Saving and Extracting Image to Recordset

jhai_salvador 1 827 Views

Add the snippet in your module.

Requirements:

  • Make sure you have reference to M$ ActiveX Data Objects Library (ADODB)
  • A table field with OLE Object / BLOB as datatype
  • A recordset that is already oppened and ready to be use

To save Image on your table field, call SetRSBlob function

Make sure that your recordset is already loaded or openned

Lets assume that our recordset rs is already oppened and ready to be updated.

Dim ret as Boolean
ret = SetRSBlob("C:\image1.jpg", rs, "image")

TRUE will be returned if image was set to the recordset field.

All you have to do is call recordset rs.update function to save it permanently to the table.

To extract the image, just call the ExtractBlob function

Again, make sure that your recordset is already openned.

Dim ret as Boolean
ret = ExtractBlob(rs, "image", "c:\extracted_image.jpg")

It will return true if image was extracted successfully.

Code is not that clean but I hope anyone can enjoy and learn something on it.

I used this code on my church management software which you can download on my website http://silentprojectsoftwares.com/ :) (I hope I will not get banned for posting my site.. haha)

Anyway, enjoy and have a happy coding..

Peace out.. :)

Function SetRSBlob(strFileName As String, dbRecordSet As ADODB.Recordset, OLEFieldName As String) As Boolean
   On Error GoTo hErr
   Dim fH      As Integer
   Dim fLen    As Long
   Dim bytes() As Byte
   fH = FreeFile()
   '* Get File bytes
   Open strFileName For Binary As #fH
      fLen = LOF(fH) - 1
      bytes = InputB(fLen, #fH)
   Close #fH
   '* Set recordset value
   dbRecordSet.Fields(OLEFieldName).Value = bytes
   SetRSBlob = True
   Exit Function
hErr:
   SetRSBlob = False
   Debug.Print Err.Description
End Function

Public Function ExtractBlob(dbRecordSet As ADODB.Recordset, _
                            OLEFieldName As String, _
                            mvarSaveToFileName As String) As Boolean
   Dim fH      As Integer
   Dim bytes() As Byte
   Dim fLen    As Long
   '* if null, exit
   If IsNull2(dbRecordSet.Fields(OLEFieldName).Value) Then
      Exit Function
   End If
   '* check size, if 0 exit
   fLen = dbRecordSet.Fields(OLEFieldName).ActualSize ' Length of data in file
   If fLen = 0 Then
      Exit Function
   End If
   fH = FreeFile()
   '* Get bytes
   bytes = dbRecordSet.Fields(OLEFieldName).Value
   '* If file exist, delete it
   If FileExist(mvarSaveToFileName) Then
      Call Kill2(mvarSaveToFileName)
   End If
   '* Save binary file
   Open mvarSaveToFileName For Binary As #fH
      Put #fH, , bytes
   Close #fH
   '* If file exist, return true
   If FileExist(mvarSaveToFileName) Then
      ExtractBlob = True
   End If
   FileSystem.Reset
End Function

'* Additional codes

'Custom null check, return true if null or string is blank
'tested with string
'tested with recordset field
Private Function IsNull2(Var As Variant) As Boolean
   Dim ret As Boolean
   ret = True
   If Not IsNull(Var) Then
      If CStr(Var) <> "" Then
         ret = False
      End If
   End If
   IsNull2 = ret
End Function

'* check file if exist
Private Function FileExist(FilePath As String) As Boolean
   On Error GoTo ErrorHandler
   Call FileLen(FilePath)
   FileExist = True
   Exit Function
ErrorHandler:
   FileExist = False
End Function

'* Delete file
Public Function Kill2(strFileName As String) As Boolean
   On Error GoTo hErr
   Call Kill(strFileName)
   Kill2 = True
   Exit Function
hErr:
   Kill2 = False
End Function
Be a part of the DaniWeb community

We're a friendly, industry-focused community of developers, IT pros, digital marketers, and technology enthusiasts meeting, networking, learning, and sharing knowledge.

Edit Preview