save & retrieve image from Ms access using VB

[amrahim]

Hi, just try to create application using VB6 for my kids, but facing problem with image on how to save & retrieve it from MS access database. could you guys please share the code. TQ in advance.

[AndreRet]

Thanks for opening your own thread amrahim, it is much appreciated.

Below should do the trick for you, just add the controls as needed.

Option Explicit

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long

'Purpose     :  Saves pictures in image boxes (or similiar) to a field in a recordset
'Inputs      :  oPictureControl                 A control containing an image
'               adoRS                           ADO recordset to add the image to
'               sFieldName                      The field name in adoRS, to add the image to
'Outputs     :  Returns True if succeeded in updating the recordset
'Notes       :  The field specified in sFieldName, must have a binary field type (ie. OLE Object in access)
'               Save the image at the currect cursor location in the recordset.
'Revisions   :

Public Function SavePictureToDB(oPictureControl As Object, adoRS As ADODB.Recordset, sFieldName As String) As Boolean
    Dim oPict As StdPicture
    Dim sDir As String, sTempFile As String
    Dim iFileNum As Integer
    Dim lFileLength As Long
    Dim abBytes() As Byte
    Dim iCtr As Integer
    
    On Error GoTo ErrHandler
    
    Set oPict = oPictureControl.Picture
    If oPict Is Nothing Then
        SavePictureToDB = False
        Exit Function
    End If

    'Save picture to temp file
    sTempFile = FileGetTempName
    SavePicture oPict, sTempFile
    
    'read file contents to byte array
    iFileNum = FreeFile
    Open sTempFile For Binary Access Read As #iFileNum
    lFileLength = LOF(iFileNum)
    ReDim abBytes(lFileLength)
    Get #iFileNum, , abBytes()
    'put byte array contents into db field
    adoRS.Fields(sFieldName).AppendChunk abBytes()
    Close #iFileNum
    
    'Don't return false if file can't be deleted
    On Error Resume Next
    Kill sTempFile
    SavePictureToDB = True
    Exit Function
    
ErrHandler:
    SavePictureToDB = False
    Debug.Print Err.Description
End Function


'Purpose     :  Loads a Picture, saved as binary data in a database, from a recordset into a picture control.
'Inputs      :  oPictureControl                 A control to load the image into
'               adoRS                           ADO recordset to add the image to
'               sFieldName                      The field name in adoRS, to add the image to
'Outputs     :  Returns True if succeeded in loading the image
'Notes       :  Loads the image at the currect cursor location in the recordset.


Public Function LoadPictureFromDB(oPictureControl As Object, adoRS As ADODB.Recordset, sFieldName As String) As Boolean
    Dim oPict As StdPicture
    Dim sDir As String
    Dim sTempFile As String
    Dim iFileNum As Integer
    Dim lFileLength As Long
    Dim abBytes() As Byte
    Dim iCtr As Integer
    
    On Error GoTo ErrHandler
    sTempFile = FileGetTempName
   
    iFileNum = FreeFile
    Open sTempFile For Binary As #iFileNum
    lFileLength = LenB(adoRS(sFieldName))
    
    abBytes = adoRS(sFieldName).GetChunk(lFileLength)
    Put #iFileNum, , abBytes()
    Close #iFileNum

    oPictureControl.Picture = LoadPicture(sTempFile)
    
    Kill sTempFile
    LoadPictureFromDB = True
    Exit Function
    
ErrHandler:
    LoadPictureFromDB = False
    Debug.Print Err.Description
End Function


'Purpose     :  The FileGetTempName function returns a name of a temporary file.
'Inputs      :  [sFilePrefix]               The prefix of the file name.
'Outputs     :  Returns the name of the next free temporary file name (and path).
'Notes       :  The filename is the concatenation of specified path and prefix strings,
'               a hexadecimal string formed from a specified integer, and the .TMP extension


Function FileGetTempName(Optional sFilePrefix As String = "TMP") As String
    Dim sTemp As String * 260, lngLen As Long
    Static ssTempPath As String
    
    If LenB(ssTempPath) = 0 Then
        'Get the temporary path
        lngLen = GetTempPath(260, sTemp)
        'strip the rest of the buffer
        ssTempPath = Left$(sTemp, lngLen)
        If Right$(ssTempPath, 1) <> "\" Then
            ssTempPath = ssTempPath & "\"
        End If
    End If
    
    'Get a temporary filename
    lngLen = GetTempFileName(ssTempPath, sFilePrefix, 0, sTemp)
    'Remove all the unnecessary chr$(0)'s
    FileGetTempName = Left$(sTemp, InStr(1, sTemp, Chr$(0)) - 1)
End Function


'SAMPLE USAGE
'NOTE : Add a PictureBox control to a form before running this code
Sub TestLoadPicture()
    Dim sConn As String
    Dim oConn As New ADODB.Connection
    Dim oRs As New ADODB.Recordset
    
    On Error GoTo ErrFailed
    sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\MyPhotoData.MDB;Persist Security Info=False"
    
    oConn.Open sConn
    oRs.Open "SELECT * FROM Copies", oConn, adOpenKeyset, adLockOptimistic
    'If oRs.EOF = False Then
        LoadPictureFromDB Picture2, oRs, "EmpPhoto"
    'End If
    oRs.Close
    Exit Sub
ErrFailed:
    MsgBox "Error " & Err.Description
End Sub

'SAMPLE USAGE
'NOTE : Add a PictureBox control to a form before running this code
Sub TestSavePicture()
    Dim sConn As String
    Dim oConn As New ADODB.Connection
    Dim oRs As New ADODB.Recordset
    
    On Error GoTo ErrFailed
    sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\MyPhotoData.MDB;Persist Security Info=False"
    
    oConn.Open sConn
    oRs.Open "SELECT * FROM Copies", oConn, adOpenKeyset, adLockOptimistic
    'If oRs.EOF = False Then
        oRs.AddNew
        SavePictureToDB Picture1, oRs, "EmpPhoto"
        oRs.Update
        MsgBox "saved"
    'End If
    oRs.Close
    Exit Sub
ErrFailed:
    MsgBox "Error " & Err.Description
End Sub

Private Sub Command1_Click()
Call TestLoadPicture
End Sub

Private Sub Command2_Click()
Call TestSavePicture
End Sub

Hope this helped.

[amrahim]

thanks. will try.

[AndreRet]

It's a pleasure. Don't forget to please mark this thread as solved if it worked for you. This way we will ensure that it is closed properly, thanks.

[amrahim]

maybe my pc or vb6 on my pc have problem. I cannot use adodb. before, I use it to retrieve image from file (image not in database) and its work. Try to do something with this PC before I mark this thread as solved, unless I'm very sure the code is working for me. Thanks.