请教：ADP+SQL 如何存储、显示照片【已解决】

yhf

数据库ADP+SQL:表中有一" image"类型的字段"照片"，请教在窗体显示、添加、删除照片的代码，谢谢！
以前在网上找到过以下代码，在MDB中没问题，但在ADP中显示“类型不匹配”：

Option Compare Database
Option Explicit

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 "JPEG", "*.jpg"
       ' .Filters.Add "位图文件", "*.bmp"
        .FilterIndex = 1
        .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

yhf

zhuyiwen 发表于 2012-9-4 06:39
SaveBImage / DisplayBImage / DeleteBImage 三函数中使用 Dim ObjRst As DAO.Recordset 来引用 窗体记录集 ...

谢谢管理员指教！ 已按您的方法测试，但出错“编译错误:方法和数据成员未找到”。再请教！

zhuyiwen

SaveBImage / DisplayBImage / DeleteBImage 三函数中使用 Dim ObjRst As DAO.Recordset 来引用 窗体记录集 Set ObjRst = NewForm.Recordset，这肯定会类型不正确，因为 ADP 窗体的记录集只能是 ADO 记录集，而不能是 DAO 记录集。你改成：

1. 
   
2. Dim ObjRst As ADODB.Recordset
   

复制代码

试试

zhuyiwen

友情提示：抄代码没有错，但要正确理解代码，才能真正地使用代码，节省时间。

liangshu-fu

值得学习。

yhf

根据网络资料自己捣鼓的：
Dim filename As String

Sub deleteImage()
On Error GoTo erro1:

    Dim rs As New ADODB.Recordset
    Dim Istm As ADODB.Stream
    rs.Open "储存图片的表名称", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    Set Istm = New ADODB.Stream

    rs("图片") = ""
    rs.Update
    rs.Close
    Istm.Close
    Set rs = Nothing
    Set Istm = Nothing

erro1:
End Sub


Private Sub 删除_Click()
deleteImage
Me.Image1.Picture = ""
End Sub

Sub SaveImage()
On Error GoTo erro1:

    Dim rs As New ADODB.Recordset
    Dim Istm As ADODB.Stream
    rs.Open "储存图片的表名称", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    Set Istm = New ADODB.Stream
    If Not IsNull(filename) Then
        With Istm
            .Type = adTypeBinary
            .Open
            .LoadFromFile filename
        End With
    End If

    rs("图片") = Istm.Read
    rs.Update
    rs.Close
    Istm.Close
    Set rs = Nothing
    Set Istm = Nothing
erro1:
End Sub

Sub GetImgName()
On Error GoTo erro1:

    Dim Result As Integer
    With Application.FileDialog(1)
        .Title = "选择照片"
        .Filters.Clear
        .Filters.Add "JPEGs", "*.jpg"
        .Filters.Add "位图文件", "*.bmp"
        .FilterIndex = 1
        .AllowMultiSelect = False
        .InitialFileName = "" ' CurrentProject.Path
        Result = .Show
        filename = Trim(.SelectedItems.Item(1))
        Image1.Picture = filename
    End With
erro1:
End Sub

Private Sub Form_Open(Cancel As Integer)
If IsNull(Me.图片) Then
   Me.Image1.Picture = ""
Else
   Me.Image1.PictureData = Me.图片
End If
End Sub


Private Sub 更新_Click()
    'Me.Image1.Picture = ""
    GetImgName
    SaveImage
    Me.Refresh
End Sub

Private Sub 下载_Click()
    Dim strNewFile As String
    Dim stm As ADODB.Stream
   
    '下载时通过另存为文件对话框选择另存为路径名
    With Application.FileDialog(2) 'msoFileDialogSaveAs
        .InitialFileName = 6786786 & ".jpg"
        If .Show Then
            strNewFile = .SelectedItems(1)
            '将保存在数据库中的二进制文件保存到流对象，再通过流对象另存为文件
            Set stm = New ADODB.Stream
            stm.Mode = adModeReadWrite
            stm.Type = adTypeBinary
            stm.Open
            stm.Write Me.图片
            '如果文件已存在，则先删除已存在的文件，以达到替换目的
            If Dir(strNewFile) <> "" Then Kill strNewFile
            stm.SaveToFile strNewFile
            stm.Close
            MsgBox "下载完成。", vbInformation, "提示信息"
        End If
    End With
    Set stm = Nothing
End Sub


说明： “图片”为 储存图片的表 内储存图片的字段(image)
           image1 为 窗体上 图像控件

            窗体命令按钮：删除、更新、下载