通用模块:读取图片文件并保存到OLE字段中

duomu

带示例文件,请各位朋友多多指正


Public ImgPath As String
Public Function LoadBImage(ByVal NewForm As Form, _
                           ByVal NewID As String, _
                           ByVal NewIDValue As Variant, _
                           ByVal NewField As String, _
                           ByVal NewImage As Image)
'===============================================================================
'-函数名称:     LoadBImage
'-功能描述:     以二进制数据格式加载图片,并保存于数据库,一般为当前数据库,
'               若窗体引用记录集为外部ACCESS数据库,同样适用,调用函数SaveImage
'-输入参数说明: 参数1: 必选 应用显示图片的窗体,[对象变量]
'               参数2: 必选 窗体记录集的主键名,[文本变量]
'               参数3: 必选 窗体某一记录的主键值,一般为当前记录,[未定义变量]
'               参数4: 必选 图片所在的字段名,[文本变量]
'               参数5: 必选 应用显示的图片控件,[对象变量]
'-返回参数说明: 无
'-使用语法示例: Call LoadBImage(Me, "id", me.id, "图片", me.image1)
'-参考:
'-使用注意:     NewForm, NewImage 为对象，使用时不能加引号
'               因为要使用文本流对象,请使用前引用 Microsoft ActiveX Objects 2.5以上
'-兼容性:       2000,XP,2003 compatible
'-作者:         duomu
'-更新日期：    2007-09-6
'===============================================================================
    Dim result As Integer
    Dim FileName As String
    On Error GoTo HandleErr
    If Len(ImgPath) = 0 Then ImgPath = CurrentProject.Path
    With Application.FileDialog(1)
        .Title = "选择照片"
        .Filters.Clear
        .Filters.Add "所有文件", "*.*"
        .Filters.Add "JPEGs", "*.jpg"
        .Filters.Add "位图文件", "*.bmp"
        .FilterIndex = 2
        .AllowMultiSelect = False
        .InitialFileName = ImgPath
        result = .Show
        If result = -1 Then
            FileName = Trim(.SelectedItems.Item(1))
            Call SaveBImage(FileName, NewForm, NewID, NewIDValue, NewField, NewImage)
        Else
            LoadBImage = 1
            Exit Function
        End If
        ImgPath = FileName
        NewImage.Picture = FileName
    End With
ExitHere:
    Exit Function
HandleErr:
    MsgBox Err.Description
    Resume ExitHere
End Function
Public Function SaveBImage(ByVal FileName As String, _
                           ByVal NewForm As Form, _
                           ByVal NewID As String, _
                           ByVal NewIDValue As Variant, _
                           ByVal NewField As String, _
                           ByVal NewImage As Image)
'===============================================================================
'-函数名称:     SaveBImage
'-功能描述:     以二进制数据格式加载图片,并保存于数据库,一般为当前数据库,
'               若窗体引用记录集为外部ACCESS数据库,同样适用,调用函数SaveImage
'-输入参数说明: 参数1: 必选 图片路径,[文本变量]
'               参数2: 必选 应用显示图片的窗体,[对象变量]
'               参数3: 必选 窗体记录集的主键名,[文本变量]
'               参数4: 必选 窗体某一记录的主键值,一般为当前记录,[未定义变量]
'               参数5: 必选 图片所在的字段名,[文本变量]
'               参数6: 必选 应用显示的图片控件,[对象变量]
'-返回参数说明: 无
'-使用语法示例: 略
'-参考:         LoadBImage()过程
'-使用注意:     NewForm, NewImage 为对象，使用时不能加引号
'               因为要使用文本流对象,请使用前引用 Microsoft ActiveX Objects 2.5以上
'-兼容性:       2000,XP,2003 compatible
'-作者:         duomu
'-更新日期：    2007-09-6
'===============================================================================
    Dim ObjRst As DAO.Recordset
    Dim ObjStream As ADODB.Stream

    On Error GoTo HandleErr
    Set ObjRst = NewForm.Recordset
    Set ObjStream = New ADODB.Stream
    If Not IsNull(FileName) Then
        With ObjStream
            .Type = adTypeBinary
            .Open
            .LoadFromFile FileName
        End With
    End If
    If ObjRst.Fields(NewID).Type = dbText Then
        ObjRst.FindFirst "[" & NewID & "]" & " = '" & NewIDValue & "'"
    Else
        ObjRst.FindFirst "[" & NewID & "]" & " = " & NewIDValue
    End If
    If Not ObjRst.NoMatch Then
        ObjRst.Edit
        ObjRst(NewField) = ObjStream.Read
        ObjRst.Update
    End If
    ObjStream.Close
    Set ObjStream = Nothing
ExitHere:
    Exit Function
HandleErr:
    MsgBox Err.Description
    Resume ExitHere
End Function
Public Function DisplayBImage(ByVal NewForm As Form, _
                              ByVal NewID As String, _
                              ByVal NewIDValue As Variant, _
                              ByVal NewField As String, _
                              ByVal NewImage As Image)
'===============================================================================
'-函数名称:     DisplayBImage
'-功能描述:     显示以二进制数据格式保存在数据库内的图片
'-输入参数说明: 参数1: 必选 应用显示图片的窗体,[对象变量]
'               参数2: 必选 窗体记录集的主键名,[文本变量]
'               参数3: 必选 窗体某一记录的主键值,一般为当前记录,[未定义变量]
'               参数4: 必选 图片所在的字段名,[文本变量]
'               参数5: 必选 应用显示的图片控件,[对象变量]
'-返回参数说明: 无
'-使用语法示例: Call DisplayBImage(Me, "id", me.id, "图片", me.image1)
'-参考:
'-使用注意:     NewForm, NewImage 为对象，使用时不能加引号
'               因为要使用文本流对象,请使用前引用 Microsoft ActiveX Objects 2.5以上
'-兼容性:       2000,XP,2003 compatible
'-作者:         duomu
'-更新日期：    2007-09-6
'===============================================================================
    Dim ObjRst As DAO.Recordset
    Dim ObjStream As ADODB.Stream
    On Error GoTo HandleErr
    Set ObjRst = NewForm.Recordset
    Set ObjStream = New ADODB.Stream
    If IsNull(NewIDValue) Then NewImage.Picture = "": Exit Function
    If ObjRst.Fields(NewID).Type = dbText Then
        ObjRst.FindFirst "[" & NewID & "]" & " = '" & NewIDValue & "'"
    Else
        ObjRst.FindFirst "[" & NewID & "]" & " = " & NewIDValue
    End If
    If Not ObjRst.NoMatch Then
        If Len(ObjRst(NewField)) > 0 Then
            With ObjStream
                .Mode = adModeReadWrite
                .Type = adTypeBinary
                .Open
                .Write ObjRst(NewField)
                .SaveToFile CurrentProject.Path & "\image.jpg", adSaveCreateOverWrite
            End With
        Else
            NewImage.Picture = ""
            Exit Function
        End If
    End If
    NewImage.Picture = CurrentProject.Path & "\image.jpg"
    NewImage.SizeMode = acOLESizeZoom
    ObjStream.Close
    Kill CurrentProject.Path & "\image.jpg"
    Set ObjStream = Nothing
ExitHere:
    Exit Function
HandleErr:
    MsgBox Err.Description
    Resume ExitHere
End Function
Public Function DeleteBImage(ByVal NewForm As Form, _
                             ByVal NewID As String, _
                             ByVal NewIDValue As Variant, _
                             ByVal NewField As String, _
                             ByVal NewImage As Image)
'===============================================================================
'-函数名称:     LoadImage
'-功能描述:     删除以二进制数据格式保存在数据库内的图片
'-输入参数说明: 参数1: 必选 应用显示图片的窗体,[对象变量]
'               参数2: 必选 窗体记录集的主键名,[文本变量]
'               参数3: 必选 窗体某一记录的主键值,一般为当前记录,[未定义变量]
'               参数4: 必选 图片所在的字段名,[文本变量]
'               参数5: 必选 应用显示的图片控件,[对象变量]
'-返回参数说明: 无
'-使用语法示例: Call LoadImage(Me, "id", me.id, "图片", me.image1)
'-参考:
'-使用注意:     NewForm, NewImage 为对象，使用时不能加引号
'               因为要使用文本流对象,请使用前引用 Microsoft ActiveX Objects 2.5以上
'-兼容性:       2000,XP,2003 compatible
'-作者:         duomu
'-更新日期：    2007-09-6
'===============================================================================
    Dim ObjRst As DAO.Recordset
    On Error GoTo HandleErr
    Set ObjRst = NewForm.Recordset
    If ObjRst.Fields(NewID).Type = dbText Then
        ObjRst.FindFirst "[" & NewID & "]" & " = '" & NewIDValue & "'"
    Else
        ObjRst.FindFirst "[" & NewID & "]" & " = " & NewIDValue
    End If
    If Not ObjRst.NoMatch Then
        ObjRst.Edit
        ObjRst(NewField) = ""
        ObjRst.Update
    End If
    NewImage.Picture = ""
ExitHere:
    Exit Function
HandleErr:
    MsgBox Err.Description
    Resume ExitHere
End Function

游客，如果您要查看本帖隐藏内容请回复

灰太郎

123456

f105f104

找了好久终于找到了

f105f104

非常感谢

toadandswan

谢谢分享，好东西

年年轻狂

众里寻你千百度！

zpy2

谢谢分享。

zxclen

SEEe

gdjdyyj

学习学习

ahdyxlc

学习一下  谢谢分享