VBA Access: Run-time Error '2176'-The setting for this property is too long

Question

There is an access database table called DemoImageT with a field called Image to store images (using OLE Objects). It has another field called ID which is a text field. It has values 1,2,3..etc. I have an Image holder called ImageBox1 in an Access form. When a button is clicked I want to display the image stored in the table in the image holder on the form. I executed a query and stored the results in a recordset. Then I set the picture property to the retrieved image. My code was:

Dim myConnection1 As ADODB.Connection
Dim myRecordSet1 As New ADODB.Recordset
Set myConnection1 = CurrentProject.AccessConnection
Set myRecordSet1.ActiveConnection = myConnection1

myRecordSet1.Open "SELECT * FROM DemoImageT WHERE ID = '1'"

If IsNull(myRecordSet1.Fields(1)) = False Then
  MsgBox ("Image present")
  ImageBox1.Visible = True
  ImageBox1.Picture = myRecordSet1.Fields(1)
Else
  MsgBox ("No image")
End If

I get the message box Image present. But then I get:

run time error 2176- The setting for this property is too long. 

The error occurs in the line:

Me.ImageBox1.Picture=myRecordSet1.Fields(1)

Is there something wrong with the code? Is there any other way to retrieve images stored in an Access database using VBA and display it on a form? If the above method is correct, what might be wrong?

Answer 1

It's kind of a hassle, but you have to write the binary contents of the database field to a temporary file, and set Me.ImageBox1.Picture to the path to that file, like this:

If IsNull(myRecordSet1.Fields(1)) = False Then
  MsgBox ("Image present")
  ImageBox1.Visible = True
  Module1.BlobToFile myRecordSet1.Fields(1), "c:\temp\temppic.jpg"
  Me.Image1.Picture = "c:\temp\temppic.jpg"
Else
  MsgBox ("No image")
End If

Here's the code you need for Module1 that does the actual writing out of the binary data. I cribbed this from http://support.microsoft.com/kb/194975/en-us, but I'm putting it here in case MS ever removes it. All you have to do is right-click the Modules folder and select Insert>Module, which will create a new module with the default name of Module1, then paste all code below into there.

  Option Explicit

  Const BLOCK_SIZE = 16384

  Sub BlobToFile(fld As ADODB.Field, ByVal FName As String, _
                 Optional FieldSize As Long = -1, _
                 Optional Threshold As Long = 1048576)
  '
  ' Assumes file does not exist
  ' Data cannot exceed approx. 2Gb in size
  '
  Dim F As Long, bData() As Byte, sData As String
    F = FreeFile
    Open FName For Binary As #F
    Select Case fld.Type
      Case adLongVarBinary
        If FieldSize = -1 Then   ' blob field is of unknown size
          WriteFromUnsizedBinary F, fld
        Else                     ' blob field is of known size
          If FieldSize > Threshold Then   ' very large actual data
            WriteFromBinary F, fld, FieldSize
          Else                            ' smallish actual data
            bData = fld.Value
            Put #F, , bData  ' PUT tacks on overhead if use fld.Value
          End If
        End If
      Case adLongVarChar, adLongVarWChar
        If FieldSize = -1 Then
          WriteFromUnsizedText F, fld
        Else
          If FieldSize > Threshold Then
            WriteFromText F, fld, FieldSize
          Else
            sData = fld.Value
            Put #F, , sData  ' PUT tacks on overhead if use fld.Value
          End If
        End If
    End Select
    Close #F
  End Sub

  Sub WriteFromBinary(ByVal F As Long, fld As ADODB.Field, _
                      ByVal FieldSize As Long)
  Dim Data() As Byte, BytesRead As Long
    Do While FieldSize <> BytesRead
      If FieldSize - BytesRead < BLOCK_SIZE Then
        Data = fld.GetChunk(FieldSize - BLOCK_SIZE)
        BytesRead = FieldSize
      Else
        Data = fld.GetChunk(BLOCK_SIZE)
        BytesRead = BytesRead + BLOCK_SIZE
      End If
      Put #F, , Data
    Loop
  End Sub

  Sub WriteFromUnsizedBinary(ByVal F As Long, fld As ADODB.Field)
  Dim Data() As Byte, Temp As Variant
    Do
      Temp = fld.GetChunk(BLOCK_SIZE)
      If IsNull(Temp) Then Exit Do
      Data = Temp
      Put #F, , Data
    Loop While LenB(Temp) = BLOCK_SIZE
  End Sub

  Sub WriteFromText(ByVal F As Long, fld As ADODB.Field, _
                    ByVal FieldSize As Long)
  Dim Data As String, CharsRead As Long
    Do While FieldSize <> CharsRead
      If FieldSize - CharsRead < BLOCK_SIZE Then
        Data = fld.GetChunk(FieldSize - BLOCK_SIZE)
        CharsRead = FieldSize
      Else
        Data = fld.GetChunk(BLOCK_SIZE)
        CharsRead = CharsRead + BLOCK_SIZE
      End If
      Put #F, , Data
    Loop
  End Sub

  Sub WriteFromUnsizedText(ByVal F As Long, fld As ADODB.Field)
  Dim Data As String, Temp As Variant
    Do
      Temp = fld.GetChunk(BLOCK_SIZE)
      If IsNull(Temp) Then Exit Do
      Data = Temp
      Put #F, , Data
    Loop While Len(Temp) = BLOCK_SIZE
  End Sub

  Sub FileToBlob(ByVal FName As String, fld As ADODB.Field, _
                 Optional Threshold As Long = 1048576)
  '
  ' Assumes file exists
  ' Assumes calling routine does the UPDATE
  ' File cannot exceed approx. 2Gb in size
  '
  Dim F As Long, Data() As Byte, FileSize As Long
    F = FreeFile
    Open FName For Binary As #F
    FileSize = LOF(F)
    Select Case fld.Type
      Case adLongVarBinary
        If FileSize > Threshold Then
          ReadToBinary F, fld, FileSize
        Else
          Data = InputB(FileSize, F)
          fld.Value = Data
        End If
      Case adLongVarChar, adLongVarWChar
        If FileSize > Threshold Then
          ReadToText F, fld, FileSize
        Else
          fld.Value = Input(FileSize, F)
        End If
    End Select
    Close #F
  End Sub

  Sub ReadToBinary(ByVal F As Long, fld As ADODB.Field, _
                   ByVal FileSize As Long)
  Dim Data() As Byte, BytesRead As Long
    Do While FileSize <> BytesRead
      If FileSize - BytesRead < BLOCK_SIZE Then
        Data = InputB(FileSize - BytesRead, F)
        BytesRead = FileSize
      Else
        Data = InputB(BLOCK_SIZE, F)
        BytesRead = BytesRead + BLOCK_SIZE
      End If
      fld.AppendChunk Data
    Loop
  End Sub

  Sub ReadToText(ByVal F As Long, fld As ADODB.Field, _
                 ByVal FileSize As Long)
  Dim Data As String, CharsRead As Long
    Do While FileSize <> CharsRead
      If FileSize - CharsRead < BLOCK_SIZE Then
        Data = Input(FileSize - CharsRead, F)
        CharsRead = FileSize
      Else
        Data = Input(BLOCK_SIZE, F)
        CharsRead = CharsRead + BLOCK_SIZE
      End If
      fld.AppendChunk Data
    Loop
  End Sub