VBA 访问：运行时错误“2176”-此属性的设置太长

Question

有一个名为DemoImageT 的访问数据库表，其中一个名为Image 的字段用于存储图像（使用OLE 对象）。它有另一个名为ID 的字段，它是一个文本字段。它的值是 1,2,3..等。我在访问表单中有一个名为ImageBox1 的图像持有者。单击按钮时，我想在表单上的图像支架中显示存储在表格中的图像。我执行了一个查询并将结果存储在一个记录集中。然后我将图片属性设置为检索到的图像。我的代码是：

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

我收到消息框图片显示。但后来我得到：

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

错误发生在以下行：

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

代码有问题吗？有没有其他方法可以使用 VBA 检索存储在 Access 数据库中的图像并将其显示在表单上？如果上述方法是正确的，那可能有什么问题？

Answer 1

这有点麻烦，但你必须将数据库字段的二进制内容写入一个临时文件，并将Me.ImageBox1.Picture设置为该文件的路径，如下所示：

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

以下是 Module1 所需的代码，用于实际写出二进制数据。我从http://support.microsoft.com/kb/194975/en-us 抄写了这个，但我把它放在这里以防 MS 将它删除。您所要做的就是右键单击 Modules 文件夹并选择 Insert>Module，这将创建一个默认名称为 Module1 的新模块，然后将下面的所有代码粘贴到那里。

  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