Question

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

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＆gt; 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

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

1 个答案: