Extracting Microsoft Access OLE Object Field Items

I created a Microsoft Access database for a small set of data (<1000 rows). Access was a perfect database for this particular problem, allowing easy input and good reporting, and the Access accdb database format allows easy installation on different computer that have Access. However, I made a mistake in storing bitmaps in an OLE object column. Access still has a limit of two gigabytes for its native database format. Bitmaps don't compress and quickly consume all of that limit. I had entered several hundred items before running into that limit. The two gigabyte limit was reasonable in the 1990s when a 1 gigabyte drive cost over $1000 (I have a receipt!), but is ridiculously small by today's standard.

The VBA code below works on the table tblExample. It extracts the bitmap from an OLE Object column (olePicture) and writes it to a file on the disk. It then updates another column (strPicture) with the name of the file it wrote. The filename is constructed by the name of the primary key field (ID) followed by .bmp, thus ID of 1 becomes 1.bmp in the same directory as the database.

An OLE Object field has a Package Header, an OLE header, the actual data of the bitmap, some optional other stuff, and an OLE footer. The problem is that the headers are variable length with sizes embedded into them, so the actual bitmap has to be located within the data before it can be extracted. So this code extracts the sizes and skips to the appropriate place and extracts the data. It uses a helper function that constructs a long from the first four bytes of an array of bytes (although it will break if a size is over 2^31 as it would try to convert an unsigned count to a signed count, which should never happen here).

After running this code successfully (use the Windows File Explorer to view the bitmaps), the OLE Object column can be deleted. Other VBA code will be necessary to display the picture in the external file, which is beyond the scope of what I want to show here. The code is not very fast as it writes the file one byte at a time, but it should be a one-time thing, at least for my purpose. It also probably has some boundary conditions related to some kinds of OLE objects that break it under some conditions, but it worked for what I needed.

Option Compare Database
Option Explicit

Public Sub ExtractImages()
    ' Need a reference to the Microsoft ActiveX Data Objects 6.1 Library
    Dim rst As ADODB.Recordset
    Dim varByte As Variant
    Dim i As Long
    Dim lngLength As Long
    Dim byteVal As Byte
    Dim strFileName As String
    Dim strFilePath As String
    
    Set rst = New ADODB.Recordset
    rst.Open "tblExample", CurrentProject.Connection, adOpenDynamic, adLockOptimistic
    Do While Not rst.EOF
        If Not IsNull(rst.Fields.Item("olePicture").Value) Then
            ' Create the filename from the primary key ID field.
            strFileName = rst.Fields.Item("ID").Value & ".bmp"
            
            ' Fill strPicture with the filename
            rst.Fields.Item("strPicture").Value = strFileName
            rst.Update
            
            strFilePath = Application.CurrentProject.Path & "\" & strFileName
            If Dir(strFilePath) = "" Then
                ' Read the package header the package header, the second byte is the size
                varByte = rst.Fields.Item("olePicture").GetChunk(3)
                
                'Extract the offset to the start of the OLE header
                varByte = rst.Fields.Item("olePicture").GetChunk(varByte(2) + 5)
                
                'Get the first four bytes which holds the OLE size
                varByte = rst.Fields.Item("olePicture").GetChunk(4)
                
                ' Use to size to of the header to move to the end of the header
                varByte = rst.Fields.Item("olePicture").GetChunk(GetLong(varByte))
                
                ' Skip the next eight bytes
                varByte = rst.Fields.Item("olePicture").GetChunk(8)
                
                ' The next four bytes retrieves the size of the Bitmap
                varByte = rst.Fields.Item("olePicture").GetChunk(4)
                
                ' Turn those bytes into a length
                lngLength = GetLong(varByte)
                
                ' Get the bitmap
                varByte = rst.Fields.Item("olePicture").GetChunk(lngLength)
                
                ' Write the bitmap to the file
                Open strFilePath For Binary As #1
                For i = 0 To lngLength - 1
                    byteVal = varByte(i)
                    Put #1, , byteVal
                Next i
                Close #1
            End If
        End If
        rst.MoveNext
    Loop
    rst.Close
    Set rst = Nothing
    MsgBox "Done"
End Sub

Public Function GetLong(ByRef varByte As Variant) As Long
    ' Convert the first four bytes of varByte into a long
    Dim i As Long
    Dim lngResult As Long
    
    For i = 3 To 0 Step -1
        lngResult = lngResult * 256 + varByte(i)
    Next i
    GetLong = lngResult
End Function