ACCESS 导出附件

需求: 

　　把登陆窗体中的图片,替换为数据表中的图片.

思路: 

　　1.把图片保存到本地

　　2.修改图片控件的图片路径

难点:

　　1.对附件的操作方法不熟练

　　2.不同的数据库操作方法有差异

主要用到的方法:

Field2.SaveToFile 方法 (DAO)

 

效果(左侧图片的变化):

原窗体:

 

载入表中图片后的效果:

 数据表设计:

 

实现代码:

版本一.如果图片在本地数据库(不属于外链表)

' 设置登录界面图片的子程序
Sub SetLoginPic()
    ' 定义变量：
    ' rst - 用于操作tblsystemsetting表的记录集
    ' rsA - 用于操作附件字段的记录集
    ' fld - 用于表示附件字段
    ' strFullPath - 存储临时文件完整路径的字符串
    Dim rst As DAO.Recordset2
    Dim rsA As DAO.Recordset2
    Dim fld As DAO.Field2
    Dim strFullPath As String
    
    ' 打开系统设置表,注意CurrentDB是本地数据.
    Set rst = CurrentDb.OpenRecordset("tblsystemsetting")
    ' 获取附件字段
    Set fld = rst("Attachments")
    
    ' 检查记录集是否为空
    If Not rst.EOF Then
        ' 打开附件字段中的记录集
        Set rsA = fld.value
        
        ' 检查附件记录集是否为空
        If Not rsA.EOF Then
            ' 构建临时文件路径：系统临时文件夹 + 附件文件名
            strFullPath = VBA.Environ("TEMP") & "\" & rsA("FileName")
            
            ' 忽略错误（如果临时文件已存在）
            On Error Resume Next
            ' 删除可能已存在的临时文件
            Kill strFullPath
            
            ' 将附件中的文件数据保存到临时文件
            rsA("FileData").SaveToFile strFullPath
            ' 将图片控件Image57的图片设置为临时文件
            Me.Image57.Picture = strFullPath
        End If
        
        rsA.Close
    End If        

    rst.Close
        
    ' 释放对象变量
    Set fld = Nothing
    Set rsA = Nothing
    Set rst = Nothing
End Sub

版本二.图片在其他数据库

Sub SetLoginPic(ByVal DBPath As String)
    Dim rst As DAO.Recordset2
    Dim rsA As DAO.Recordset2
    Dim fld As DAO.Field2
    Dim strFullPath As String
    Dim dbExternal As DAO.Database
    Dim strConnect As String
    
    ' 关键1：构建加密数据库连接字符串（注意密码暴露风险）
    strConnect = ";Database=" & DBPath & ";PWD=数据库密码"
    
    ' 关键2：静默打开外部数据库（不显示独占/只读提示）
    Set dbExternal = DBEngine.Workspaces(0).OpenDatabase("", False, False, strConnect)
    
    ' 关键3：从外部库读取系统设置表
    Set rst = dbExternal.OpenRecordset("tblsystemsetting")
    Set fld = rst("Attachments")
    
    If Not rst.EOF Then
        Set rsA = fld.value
        If Not rsA.EOF Then
            ' 关键4：将附件图片提取到临时目录
            strFullPath = VBA.Environ("TEMP") & "\" & rsA("FileName")
            On Error Resume Next
            Kill strFullPath  ' 强制覆盖旧文件
            rsA("FileData").SaveToFile strFullPath
            
            ' 核心功能：设置窗体图片
            Me.Image57.Picture = strFullPath
        End If
        rsA.Close
    End If
    
    ' 关键5：必须按顺序关闭对象（先记录集后数据库）
    rst.Close
    dbExternal.Close
    
    ' 显式释放对象
    Set rsA = Nothing
    Set rst = Nothing
    Set dbExternal = Nothing
End Sub

 进阶版,可以指定显示第几个附件

    Dim rst As DAO.Recordset2
    Dim rsA As DAO.Recordset2
    Dim fld As DAO.Field2
    Dim strFullPath As String
    Dim dbExternal As DAO.Database
    Dim strConnect As String
    Dim lngAttIndex As Long
    
    ' 构建带密码的连接字符串
    strConnect = ";Database=" & DBPath & ";PWD=" & GetBDBPW & ""
    
    ' 直接打开外部数据库连接
    Set dbExternal = DBEngine.Workspaces(0).OpenDatabase("", False, False, strConnect)
    Set rst = dbExternal.OpenRecordset("tblsystemsetting")
    
    If Not rst.EOF Then
        ' 获取附件索引值
        lngAttIndex = Nz(rst("AttIndex"), 1) ' 默认为1如果字段为Null
        
        Set fld = rst("Attachments")
        Set rsA = fld.value
        
        ' 移动到指定的附件索引
        If Not rsA.EOF Then
            If lngAttIndex > 1 Then
                rsA.MoveFirst
                rsA.Move lngAttIndex - 1
            End If
            
            If Not rsA.EOF Then
                strFullPath = VBA.Environ("TEMP") & "\" & rsA("FileName")
                On Error Resume Next
                Kill strFullPath
                On Error GoTo 0
                
                rsA("FileData").SaveToFile strFullPath
                Me.Image57.Picture = strFullPath
            End If
        End If
        
        rsA.Close
    End If
    
    rst.Close
    dbExternal.Close
    
    Set rsA = Nothing
    Set rst = Nothing
    Set dbExternal = Nothing
End Sub