如何用VBA将Access窗体剪贴板截图粘贴到新建Outlook邮件中

网上流传的Excel剪贴板粘贴方案在Access环境下失效，核心原因有两点：

• Access与Outlook分属不同COM套间，跨进程直接调用剪贴板粘贴接口会被系统权限拦截，手动Ctrl+V是前台操作不受该限制
• VBA原生SavePicture方法无法直接读取剪贴板中的DDB类型位图，会出现保存文件为空、报错的问题

直接按以下步骤实现即可，不需要调整现有截图逻辑：

实现逻辑 #

• 放弃跨进程直接读取剪贴板粘贴的方案，先将剪贴板中的窗体截图落地为临时BMP文件
• 通过Outlook内联附件接口将本地图片插入邮件正文，完全绕开剪贴板跨进程权限问题
• 邮件发送/展示后自动删除临时文件，无磁盘残留
• 截图1:1保留窗体条件格式、控件样式，和手动粘贴效果完全一致

完整实现代码 #

将以下代码放入对应窗体的模块中，兼容32位/64位全版本Office，不需要额外添加引用：

' 模块顶部API声明
#If VBA7 Then
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As LongPtr, ByVal FileName As LongPtr, ByRef clsidEncoder As Any, ByRef encoderParams As Any) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hBmp As LongPtr, ByVal hPal As LongPtr, ByRef pBitmap As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpsz As LongPtr, ByRef pclsid As Any) As Long
#Else
    Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As Long, ByVal FileName As Long, ByRef clsidEncoder As Any, ByRef encoderParams As Any) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hBmp As Long, ByVal hPal As Long, ByRef pBitmap As Long) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef pclsid As Any) As Long
#End If
Const CF_BITMAP = 2

' 按钮点击触发主逻辑
Sub SendFormWithScreenshot()
    Dim objOutlook As Object, objMail As Object
    Dim tempBmpPath As String, hBmp As LongPtr, pBmp As LongPtr
    Dim bmpClsid(0 To 15) As Byte, fileName As String
    
    ' 1. 截图当前窗体到剪贴板，可复用你现有截图逻辑
    Me.PrintForm
    
    ' 2. 从剪贴板读取位图保存到本地临时目录，解决存图失败问题
    tempBmpPath = Environ("TEMP") & "\AccessFormCap_" & Format(Now(), "YYYYMMDDHHMMSS") & ".bmp"
    fileName = Split(tempBmpPath, "\")(UBound(Split(tempBmpPath, "\")))
    OpenClipboard Me.hWnd
    hBmp = GetClipboardData(CF_BITMAP)
    CLSIDFromString StrPtr("{557CF400-1A04-11D3-9A73-0000F81EF32E}"), bmpClsid(0)
    GdipCreateBitmapFromHBITMAP hBmp, 0, pBmp
    GdipSaveImageToFile pBmp, StrPtr(tempBmpPath), bmpClsid(0), ByVal 0
    GdipDisposeImage pBmp
    CloseClipboard
    
    ' 3. 创建Outlook邮件，插入截图到正文
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    With objMail
        .To = "业务收件人邮箱"
        .Subject = "带窗体截图的业务上报邮件"
        .BodyFormat = 2 ' 固定为HTML格式，避免图片不显示
        ' 正文内容可按需拼接，保留原有业务文字即可
        .HTMLBody = "<p>各位好，以下是本次业务窗体截图：</p>"
        ' 插入本地截图为内联图片
        .Attachments.Add tempBmpPath, 1, 0
        .HTMLBody = .HTMLBody & "<p><img src='cid:" & fileName & "' width='900'></p>"
        .HTMLBody = .HTMLBody & "<p>其他业务说明文字可在此处补充</p>"
        .Display ' 替换为.Send可直接发送
    End With
    
    ' 4. 清理临时文件
    Kill tempBmpPath
    Set objMail = Nothing
    Set objOutlook = Nothing
End Sub

避坑说明 #

• 不要用MSForms.DataObject操作剪贴板存图，该对象在Access中对位图格式的支持存在已知bug，会出现空数据、保存失败问题
• 邮件格式必须设置为HTML，纯文本/RTF格式会导致内联图片显示为红叉或普通附件
• 如果截图不全，调用PrintForm前先将窗体滚动到最顶部，确保需要展示的区域处于可视范围
• 调整图片显示尺寸直接修改<img>标签的width属性即可，不需要额外处理图片文件

内容的提问来源于stack exchange，提问作者Alex D