表结构要求为 ID 文本  Picture  图像   Type  文本在ImagList中显示   strID 为ID号,imgSource为imgList名称,strTable为表格名
Sub ShowPicture(strID As String, imgSource As image, strTable As String)
    On Error Resume Next
    Dim i As Integer
    Dim intFile As Integer
    Dim Chunks As Integer
    Dim Fragment As Integer
    Dim lngTotalSize As Long
    Dim lngOffset As Long
    Dim lngTemp As Long
    Dim strTempFile As String
    Dim Chunk() As Byte
    Dim recPicture As ADODB.Recordset
    Dim ChunkSize As Integer
    lngTemp = 16384
    ChunkSize = 16384
    Set recPicture = rsOpen("Select Id,Picture,Type From " & strTable & " Where Id='" & Trim(strID) & "'")
    If recPicture.RecordCount = 0 Then
        Set imgSource.Picture = LoadPicture("")
    Else
        If Trim(recPicture.Fields("Type")) <> "" Then
            strTempFile = App.Path & "\$temp" & Format(Minute(Now), "00") & Format(Second(Now), "00") & Int(Left(Rnd * 10000, 2)) & "." & recPicture.Fields("Type")
        Else
            strTempFile = App.Path & "\$temp" & Format(Minute(Now), "00") & Format(Second(Now), "00") & Int(Left(Rnd * 10000, 2))
        End If
        intFile = FreeFile
        Open strTempFile For Binary Access Write As intFile
        If Err.Number = 70 Then
            MsgBox "系统在读取该产品的图片资料时出错,该产品的图片资料可能已被损坏!", vbOKOnly + vbInformation, gstrInfTitle
            Err.Clear
            recPicture.Close
            Set recPicture = Nothing
            Exit Sub
        End If
        lngTotalSize = recPicture.Fields("Picture").ActualSize
        Chunks = lngTotalSize \ ChunkSize
        Fragment = lngTotalSize Mod ChunkSize
        ReDim Chunk(ChunkSize)
        Chunk() = recPicture.Fields("Picture").GetChunk(lngTemp)
        Put intFile, , Chunk()
        lngOffset = lngOffset + ChunkSize
        Do While lngOffset < lngTotalSize
            Chunk() = recPicture.Fields("Picture").GetChunk(lngTemp)
            Put intFile, , Chunk()
            lngOffset = lngOffset + lngTemp
        Loop
        Close intFile
        Set imgSource.Picture = LoadPicture(strTempFile)
        Kill strTempFile
    End If
    If Err.Number = 481 Then
        MsgBox "该员工的相片资料出错!", vbOKOnly + vbInformation, gstrInfTitle
        Err.Clear
    End If
End Sub保存   strID 为ID号,strTable为表格名
Sub SavePicture(strID As String, strFileName As String, strTable)
    On Error Resume Next
    Dim i As Integer
    Dim lngFileLen As Long
    Dim intFile As Integer
    Dim Chunks As Integer
    Dim Fragment As Integer
    Dim Chunk() As Byte
    Dim recPicture As ADODB.Recordset
    Dim ChunkSize As Integer
    ChunkSize = 16384
    Set recPicture = rsOpen("Select Id,Picture,Type From " & strTable & " Where Id='" & Trim(strID) & "' Order By Id")
    If recPicture.RecordCount = 0 Then
        recPicture.AddNew
        recPicture.Fields("Id") = Trim(strID)
    End If
    If strFileName <> "" And Dir(strFileName) <> "" Then
        i = InStrRev(strFileName, ".")
        If i <> 0 Then
            recPicture.Fields("Type") = Mid(strFileName, i + 1)
        Else
            recPicture.Fields("Type") = ""
        End If
        intFile = FreeFile
        Open strFileName For Binary Access Read As intFile
        lngFileLen = LOF(intFile)    ' 文件中数据长度
        If lngFileLen = 0 Then
            Close intFile
            Exit Sub
        End If
        Chunks = lngFileLen \ ChunkSize
        Fragment = lngFileLen Mod ChunkSize
        ReDim Chunk(Fragment)
        Get intFile, , Chunk()
        recPicture.Fields("Picture").AppendChunk Chunk()
        ReDim Chunk(ChunkSize)
        For i = 1 To Chunks
            Get intFile, , Chunk()
            recPicture.Fields("Picture").AppendChunk Chunk()
        Next i
        Close intFile
        recPicture.Update
        Set recPicture = Nothing
    End If
End Sub导出
Function ExportPicture(strID As String, strTable As String, Optional strFileName As String) As Boolean
    On Error Resume Next
    Dim i As Integer
    Dim intFile As Integer
    Dim Chunks As Integer
    Dim Fragment As Integer
    Dim lngTotalSize As Long
    Dim lngOffset As Long
    Dim lngTemp As Long
    Dim strTempFile As String
    Dim Chunk() As Byte
    Dim recPicture As ADODB.Recordset
    Dim ChunkSize As Integer
    lngTemp = 16384
    ChunkSize = 16384
    Set recPicture = rsOpen("Select Id,Picture,Type From " & strTable & " Where Id='" & Trim(strID) & "'")
    If recPicture.RecordCount = 0 Then
        ExportPicture = False
        Exit Function
    Else
        If Trim(strFileName) = "" Then
            strFileName = App.Path & "\" & Trim(strID)
            strTempFile = strFileName
        End If
        If Trim(recPicture.Fields("Type")) <> "" Then
            strTempFile = strFileName & "." & recPicture.Fields("Type")
        Else
            strTempFile = strFileName
        End If
        intFile = FreeFile
        Open strTempFile For Binary Access Write As intFile
        If Err.Number = 70 Then
            MsgBox "系统在读取该产品的图片资料时出错,该产品的图片资料可能已被损坏!", vbOKOnly + vbInformation, gstrInfTitle
            Err.Clear
            recPicture.Close
            Set recPicture = Nothing
            Exit Function
        End If
        lngTotalSize = recPicture.Fields("Picture").ActualSize
        Chunks = lngTotalSize \ ChunkSize
        Fragment = lngTotalSize Mod ChunkSize
        ReDim Chunk(ChunkSize)
        Chunk() = recPicture.Fields("Picture").GetChunk(lngTemp)
        Put intFile, , Chunk()
        lngOffset = lngOffset + ChunkSize
        Do While lngOffset < lngTotalSize
            Chunk() = recPicture.Fields("Picture").GetChunk(lngTemp)
            Put intFile, , Chunk()
            lngOffset = lngOffset + lngTemp
        Loop
        Close intFile
        ShellExecute 0, "open", strTempFile, vbNullString, vbNullString, SW_SHOW
        If Err.Number = 0 Then
            ExportPicture = True
        Else
            MsgBox "产品图片信息导出不成功!" & vbCrLf & "错误信息:" & Err.Description, vbOKOnly + vbInformation, gstrInfTitle
            ExportPicture = False
        End If
    End If
End Function