如何将MS Access窗体Web浏览器控件中的二维码保存为位图/PNG

错误原因 #

你遇到的ActiveX component can't create object错误，核心原因有两个：

1. System.Drawing.Bitmap是.NET类，无法通过VBA的CreateObject直接实例化：.NET类默认不暴露为COM对象，即使添加了system.drawing.dll引用，VBA也无法直接创建其实例。
2. HTML元素无DrawToBitmap方法：DrawToBitmap是Windows Forms控件的专属方法，Web浏览器控件中的HTMLbody对象不支持该方法，这部分逻辑从根本上不成立。

以下是两种可行的解决方案：

方案一：通过JavaScript生成Base64图片，VBA解码保存 #

利用二维码库（如qrcode.js）生成的Canvas/Img元素，将其转为Base64编码的PNG，再通过VBA解码并保存为文件。

修改后的VBA代码 #

Private Sub cmd_GenQRCode_Click()
    Dim sCmd As String
    Dim qrBase64 As String
    Dim savePath As String
    
    ' 生成二维码并获取Base64格式的PNG数据
    ' 假设二维码生成在id为"qrcode"的元素内，且包含Canvas标签
    sCmd = "var qrCanvas = document.getElementById('qrcode').querySelector('canvas'); qrCanvas.toDataURL('image/png');"
    qrBase64 = oWebBrowserObject.Document.parentWindow.execScript(sCmd, "JavaScript")
    
    ' 移除Base64前缀（格式为"data:image/png;base64,"）
    qrBase64 = Mid(qrBase64, InStr(qrBase64, ",") + 1)
    
    ' 设置保存路径
    savePath = "C:\Documents\example.png"
    
    ' 解码Base64并保存文件
    SaveBase64ToFile qrBase64, savePath
    
    MsgBox "二维码已保存！"
End Sub

' Base64解码并保存为文件的辅助函数
Private Sub SaveBase64ToFile(base64Str As String, filePath As String)
    Dim objXML As Object
    Dim objStream As Object
    
    Set objXML = CreateObject("MSXML2.DOMDocument.6.0")
    Set objStream = CreateObject("ADODB.Stream")
    
    ' 利用XML解析Base64
    objXML.LoadXML "<root><data>" & base64Str & "</data></root>"
    objStream.Type = 1 ' 二进制模式
    objStream.Open
    objStream.Write objXML.DocumentElement.Data
    objStream.SaveToFile filePath, 2 ' 覆盖现有文件
    objStream.Close
    
    Set objStream = Nothing
    Set objXML = Nothing
End Sub

注意事项 #

• 需根据你使用的二维码库调整JS代码，确保能正确获取到二维码对应的Canvas/Img元素。
• 若二维码生成的是Img标签（而非Canvas），可将JS代码改为读取Img的src属性（若本身就是Base64格式）。

方案二：通过Windows API截图Web控件区域 #

直接对Web浏览器控件的显示区域进行截图，无需修改JavaScript逻辑。

步骤1：声明Windows API函数 #

在模块中添加以下API声明（适配64位Access）：

Private Declare PtrSafe Function BitBlt Lib "gdi32.dll" ( _
    ByVal hDestDC As LongPtr, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hSrcDC As LongPtr, _
    ByVal xSrc As Long, _
    ByVal ySrc As Long, _
    ByVal dwRop As Long _
) As Long

Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32.dll" ( _
    ByVal hdc As LongPtr _
) As LongPtr

Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" ( _
    ByVal hdc As LongPtr, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long _
) As LongPtr

Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" ( _
    ByVal hdc As LongPtr, _
    ByVal hObject As LongPtr _
) As LongPtr

Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" ( _
    ByVal hdc As LongPtr _
) As Long

Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" ( _
    ByVal hObject As LongPtr _
) As Long

Private Declare PtrSafe Function GetDC Lib "user32.dll" ( _
    ByVal hwnd As LongPtr _
) As LongPtr

Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" ( _
    ByVal hwnd As LongPtr, _
    ByVal hdc As LongPtr _
) As Long

Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
    ByRef picdesc As PICTDESC, _
    ByRef riid As GUID, _
    ByVal fPictureOwnsHandle As Long, _
    ByRef ppvObj As IPicture _
) As Long

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type PICTDESC
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
End Type

Private Const SRCCOPY = &HCC0020
Private Const PICTYPE_BITMAP = 1

步骤2：截图保存函数 #

Private Sub SaveWebControlScreenshot(webCtrl As Control, savePath As String)
    Dim hDC As LongPtr
    Dim memDC As LongPtr
    Dim hBitmap As LongPtr
    Dim oldBitmap As LongPtr
    Dim pic As IPicture
    Dim picDesc As PICTDESC
    Dim iidIPicture As GUID
    
    ' 获取Web控件的设备上下文
    hDC = GetDC(webCtrl.hwnd)
    ' 创建兼容设备上下文
    memDC = CreateCompatibleDC(hDC)
    ' 将Access缇单位转为像素（1缇=1/15像素）
    Dim ctrlWidth As Long, ctrlHeight As Long
    ctrlWidth = webCtrl.Width / 15
    ctrlHeight = webCtrl.Height / 15
    ' 创建兼容位图
    hBitmap = CreateCompatibleBitmap(hDC, ctrlWidth, ctrlHeight)
    ' 将位图选入兼容DC
    oldBitmap = SelectObject(memDC, hBitmap)
    
    ' 复制Web控件图像到兼容DC
    BitBlt memDC, 0, 0, ctrlWidth, ctrlHeight, hDC, 0, 0, SRCCOPY
    
    ' 释放资源
    SelectObject memDC, oldBitmap
    ReleaseDC webCtrl.hwnd, hDC
    DeleteDC memDC
    
    ' 创建IPicture对象
    With iidIPicture
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    
    With picDesc
        .Size = Len(picDesc)
        .Type = PICTYPE_BITMAP
        .hPic = hBitmap
        .hPal = 0
    End With
    
    OleCreatePictureIndirect picDesc, iidIPicture, True, pic
    
    ' 保存图片
    Dim stdPic As StdPicture
    Set stdPic = pic
    SavePicture stdPic, savePath
    
    ' 释放位图资源
    DeleteObject hBitmap
End Sub

步骤3：修改按钮点击事件 #

Private Sub cmd_GenQRCode_Click()
    ' 生成二维码
    Dim sCmd As String
    sCmd = "qrcode.makeCode('" & Me.txt_QRCodeContent & "');"
    oWebBrowserObject.Document.parentWindow.execScript (sCmd)
    
    ' 等待二维码渲染完成（根据实际情况调整延迟）
    Application.Wait Now + TimeValue("00:00:01")
    
    ' 截图并保存
    SaveWebControlScreenshot Me.WebBrowser0, "C:\Documents\example.png"
    
    MsgBox "二维码已保存！"
End Sub

注意事项 #

• 需确保Access窗体处于激活状态，否则截图可能为空。
• 延迟时间可根据二维码生成速度调整，避免截图时二维码尚未渲染完成。

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