Téléchargement:
DBImage.zip
(84Ko)

Chargement d'images depuis une base de données
sans passer par l'intermédiaire d'un fichier temporaire

Le problème de l'archivage d'images dans des bases de données est connu.
Avec VB, il existe 2 façons de placer des images dans une BD et 3 façons de les récupérer pour les afficher dans un PictureBox.

Dans le sens Fichier image (bmp, jpg, gif, wmf, emf, ...) --> Base de données :

Dans le sens Base de données --> PictureBox :

Préliminaire :

Le projet présenté comporte une base de données Access 97 avec une table "IMAGES" qui contient à son tour le champ "BLOB" de type ObjetOLE, c'est-à-dire binaire. Les 4 enregistrements contiennent des images de type WMF (métafile), BMP, JPG et GIF.
Ce projet ne gère pas l'écriture des images dans la base de données, se référer au besoin aux divers exemples d'utilisation de AppendChunk abondants sur le web.
Le chargement de l'image dans le PictureBox se fait en 3 opérations :

  1. Lecture des données avec GetChunk par petits morceaux de 32 Ko, et écriture dans la variable binaire m_Pict
  2. Ajout d'un préfixe de 8 octets au tout début de m_Pict. En effet, ce préfixe est nécessaire lors de la création de l'objet StdPicture.
    A noter que si l'image a été placée dans la BD avec la méthode du PictureBox lié à un Control Data, ce préfixe existe déjà. 
    En revanche, si l'image a été placée dans la BD avec AppendChunk, ce préfixe n'y est pas.
    Dans le doute, on le rajoute (ça n'est pas grave s'il est écrit 2 fois).
  3. Création d'un nouvel objet StdPicture et chargement à partir de la variable m_Pict.

La 3ème opération nécessite l'implémentation de l'interface IStream qui n'est pas disponible par défaut sous VB. C'est pourquoi il est nécessaire de charger la librairie ISTRM.TLB (ou bibliothèque de type). Cette librairie a été écrite par Eduardo Morcillo (http://www.domaindlx.com/e_morcillo) pour son projet CJPGRes dont je me suis inspiré (Le projet d'Eduardo permet de charger des images JPG et GIF depuis les ressources sans passer par l'intermédiaire d'un fichier temporaire).
Le chargement de cette librairie se fait en cliquant sur Projet --> Références et en ajoutant le fichier ISTRM.TLB à la liste. Ce fichier n'est nécessaire que lors de la compilation, il ne doit pas être distribué avec l'exécutable.
Cette implémentation se fait grâce à l'instruction Implements dans le module de classe ResPicture
Mentionnons qu'il n'est pas nécessaire de comprendre le code de ce module de classe et l'interface IStream pour l'utiliser (remarquer la simplicité du code de la feuille seule).

Rappel : (extrait de l'aide de VB5) :
Implements : Spécifie une interface ou une classe qui sera implémentée dans le module de classe dans lequel il apparaît.
Syntaxe : Implements [InterfaceName]
L'argument InterfaceName requis est le nom d'une interface dans une bibliothèque de types dont les méthodes seront implémentées par les méthodes correspondantes dans la classe Visual Basic.
Remarques
Une interface est une collection de prototypes représentant les membres (méthodes et propriétés) que l'interface encapsule, c'est-à-dire qu'elle ne contient que la déclarations des procédures membres.
Lorsque vous implémentez une interface ou une classe, vous devez inclure toutes les procédures Public impliquées. 
L'instruction Implements ne peut apparaître dans un module standard. 

Le projet s'appelle DBImage. Il est composé 
d'une feuille
contenant un contrôle Image ou PictureBox (au choix) nommé ctlImage, 1 bouton nommé cmdLoadImage (pour charger l'image dans le PictureBox), et 2 boutons nommés cmdMoveRecord(0) et cmdMoveRecord(1) pour avancer ou reculer dans le Recordset de la base de données.
et d'un module de classe nommé ResPicture.
Note : Le projet téléchargeable est écrit en VB5, accède à la base de donnée avec DAO3.5 et MSJet3.5.
Mais il est tout aussi fonctionnel avec DAO3.6 et/ou MSJet4 et/ou VB6.
Code de la feuille

Option Explicit
Dim dbs As Database, RST As Recordset

Private Sub Form_Load()
        ' Ouverture de la base de données et création du Recordset
        Set dbs = DBEngine.OpenDatabase(App.Path & "\IMAGES.MDB", False, False, "")
        strSQL = "SELECT * FROM Images ;"
        Set RST = dbs.OpenRecordset(strSQL, dbOpenSnapshot)
End Sub

Private Sub cmdLoadImage_Click()
        ' Chargement de l'image
        If Not (RST.EOF Or RST.BOF) Then ctlImage.Picture = LoadPictureFromDB(RST, "BLOB")
End Sub

Private Function LoadPictureFromDB(RST As Recordset, strField As String) As StdPicture
    ' Cette fonction permet le chargement d'une image
    ' - depuis une base de données
    ' - vers un contrôle PictureBox ou Image

    
    ' RST : Recordset contenant l'enregistrement qui nous intéresse
    ' strField : Nom du champ contenant l'image


    Dim ResPict As New ResPicture '(création d'une instance du module de classe)
    With ResPict
        ' On récupère les données binaires
        .WriteBLOB RST, strField
        ' On ajoute les 8 octets en en-tête
        .PrefixPic
        ' On charge l'image dans LoadPicture
        Set LoadPictureFromDB = .LoadPic
    End With
    Set ResPict = Nothing
End Function

Private Sub cmdMoveRecord_Click(Index As Integer)
    On Error Resume Next
    Select Case Index
        Case 0 '(On avance d'un enregistrement)
            If Not RST.BOF Then
                RST.MovePrevious
                If Not RST.BOF Then cmdLoadImage_Click
            End If
        Case 1 '(On recule d'un enregistrement)
            If Not RST.EOF Then
                RST.MoveNext
                If Not RST.EOF Then cmdLoadImage_Click
            End If
    End Select
    On Error GoTo 0
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ' On doit fermer les objets
    RST.Close
    dbs.Close
End Sub

Le module de classe ResPicture

Option Explicit

Implements IStream
Const BlockSize = 32768
Dim m_Pict() As Byte             ' Données du Stream
Dim m_StreamPos As Long      ' Position courante du Stream

Public Function LoadPic() As StdPicture
    ' Cette procédure convertit la variable binaire m_Pict
    ' en StdPicture, c'est-à-dire en image pouvant être chargée dans un PictureBox


    Dim hRsrc As Long, hGbl As Long
    Dim IPS As IPersistStream

    Set LoadPic = New StdPicture    ' On crée un nouvel objet StdPicture
    Set IPS = LoadPic                    ' ... et on obtient son interface  IPersistStream

    ' On appelle la méthode Load de IPersistStream en passant Me comme argument pour IStream.
    On Error Resume Next    '(Erreur si les données binaires ne correspondent pas à une image valide)
        IPS.Load Me            '(Ce qui va déclencher plusieurs fois les événements Read et Seek)
        If Err Then MsgBox Err.Description
    On Error GoTo 0

    Erase m_Pict '(libération de la mémoire)
End Function

Public Function PrefixPic()
    ' Cette procédure ajoute un préfixe de 8 octets aux données binaires de l'image
    ' Nécessaire si on a chargé l'image dans la BD avec AppendChunk
    ' Non nécessaire si on a chargé l'image par un copier-coller
    ' dans un PictureBox lié avec un Control Data.
    ' Mais même dans ce cas, ça ne fait rien si le préfixe est écrit 2 fois.


    Dim ResLen As Long
    ' On doit redimensionner la variable pour lui ajouter 8 octets supplémentaires
    ResLen = UBound(m_Pict)  
    ReDim Preserve m_Pict(0 To ResLen + 8) As Byte
    ' On déplace les données 8 octets plus loin
    MoveMemory m_Pict(8), m_Pict(0), ResLen
    ' On copie la taille de la variable m_Pict dans le 5ème octet
    MoveMemory m_Pict(4), ResLen, 4
    ' On écrit les 4 premiers octets du préfixe
    m_Pict(0) = &H6C
    m_Pict(1) = &H74
    m_Pict(2) = 0
    m_Pict(3) = 0
End Function

Public Function WriteBLOB(RST As Recordset, sField As String) As Long
    ' Cette procédure récupère les données binaires depuis la base de données
    ' et remplit la variable binaire m_Pict
    ' Comme ces données peuvent être volumineuses,
    ' on effectue ce remplissage par petits paquets de 32 Ko (FileDataB)

    
    ' - RST : c'est le Recordset d'intérêt
    ' - sField : c'est le nom du champ contenant les données de l'image
   
' Retourne le nombre d'octets écrits
    
    Dim NumBlocks As Integer, I As Integer
    Dim FileLength As Long, LeftOver As Long
    Dim FileDataB() As Byte
    
    On Error GoTo Err_WriteBLOB
    
    ' On obtient la taille du champ
    FileLength = RST(sField).FieldSize()
    If FileLength = 0 Then
        WriteBLOB = 0
        Exit Function
    End If

    ' On calcule le nombre de blocs à écrire (NumBlocks), et aussi le reste de la division (LeftOver)
    NumBlocks = FileLength \ BlockSize
    LeftOver = FileLength Mod BlockSize
    
    ReDim m_Pict(0 To FileLength)
    ' On commence par écrire LeftOver dans la variable binaire FileDataB
    ReDim FileDataB(LeftOver)
    FileDataB = RST(sField).GetChunk(0, LeftOver)
    ' Et on transfère dans m_Pict
    MoveMemory m_Pict(0), FileDataB(0), LeftOver

    ' On copie morceau par morceau dans la variable binaire FileDataB
    ReDim FileDataB(BlockSize)
    For I = 1 To NumBlocks
        FileDataB = RST(sField).GetChunk((I - 1) * BlockSize + LeftOver, BlockSize)
        ' Et on transfère dans m_Pict
        MoveMemory m_Pict((I - 1) * BlockSize + LeftOver), FileDataB(0), BlockSize
    Next I

    WriteBLOB = FileLength
    Erase FileDataB
Exit Function

Err_WriteBLOB:
    WriteBLOB = -Err
    MsgBox Err.Description
End Function

' Les événements implémentés sont : Read et Seek et se produisent de multiples fois au fur et à mesure du chargement de l'objet StdPicture.

Private Sub IStream_Read(ByVal pv As Long, ByVal cb As Long, ByVal pcbRead As Long)

    ' Dim m_StreamPos As Long ' Current stream position
    ' cb : taille de la lecture (en bytes)
    ' pcbRead : taille de la lecture réellement effectuée
    ' On vérifie si on ne dépasse pas la taille de m_Pict

    If (m_StreamPos + cb) > UBound(m_Pict) Then cb = UBound(m_Pict) - m_StreamPos
    ' On copie la donnée dans la mémoire de pointeur py
    MoveMemory ByVal pv, m_Pict(m_StreamPos), cb
    ' On déplace la position du stream
    m_StreamPos = m_StreamPos + cb
    ' On vérifie si pcbRead n'est pas NULL et on copie le nombre d'octets lus
    If pcbRead Then MoveMemory ByVal pcbRead, cb, 4
End Sub

Private Sub IStream_Seek(ByVal dlibMove As Currency, ByVal dwOrigin As STREAM_SEEK, ByVal plibNewPosition As Long)
    ' On vérifie dwOrgin et on définit la position selon les cas
    Select Case dwOrigin
        Case STREAM_SEEK_SET
            m_StreamPos = dlibMove
        Case STREAM_SEEK_CUR
            m_StreamPos = m_StreamPos + dlibMove
        Case STREAM_SEEK_END
            m_StreamPos = UBound(m_Pict) - dlibMove
    End Select

    ' On copie la nouvelle position si plibNewPosition n'est pas NULL
    If plibNewPosition Then MoveMemory ByVal plibNewPosition, CCur(m_StreamPos), 8
End Sub

Retour à l'accueil