有没有办法用 vba 在 MS-Access 中截屏？

Posted 2023-05-06

【中文标题】有没有办法用 vba 在 MS-Access 中截屏？

【英文标题】：Is there a way to take a screenshot in MS-Access with vba?

【发布时间】：2010-03-16 18:19:49

【问题描述】：

我想使用 vba 截取屏幕截图（然后将作为电子邮件附件发送）。理想情况下，我想只截取活动表单的屏幕截图。有没有办法做到这一点？

【问题讨论】：

您需要自动化吗？这就是你不能使用 Alt+PrintScreen 的原因吗？

是的，它必须是自动化的。我想把它放在代码中，这样当用户执行某个操作时，会截取屏幕截图并通过电子邮件发送给管理员。

或者快照可以作为 bmp 保存到错误消息表中。以及其他信息，例如活动表单名称、工作站编号、用户 ID、日期/时间等。

我在我的博客上发布了这个帖子的摘要，并收到了以下回复。我以 Stephan Lebans (OLEToDisk) 代码为例进行截图并转换为 JPG 并最终发送到电子邮件您可以在此处下载：（访问 XP）logicielappui.com/tips/AccXP_Notification.zip（法语）希望这对您有所帮助。罗伯特·西马德

【参考方案1】：

您必须使用 Windows API 调用来执行此操作。以下代码适用于 MS Access 2007。它将保存 BMP 文件。

Option Compare Database
Option Explicit

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
  bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const VK_SNAPSHOT = &H2C

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

Private Declare Function CloseClipboard Lib "user32" () As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long

'\\ Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

'\\ Declare a UDT to store the bitmap information
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type

Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1

Sub PrintScreen()
    keybd_event VK_SNAPSHOT, 1, 0, 0
End Sub

Public Sub MyPrintScreen(FilePathName As String)

    Call PrintScreen

    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Dim hPtr As Long

    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    CloseClipboard

    '\\ Create the interface GUID for the picture
    With IID_IDispatch
        .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

    '\\ Fill uPicInfo with necessary parts.
    With uPicinfo
        .Size = Len(uPicinfo) '\\ Length of structure.
        .Type = PICTYPE_BITMAP '\\ Type of Picture
        .hPic = hPtr '\\ Handle to image.
        .hPal = 0 '\\ Handle to palette (if bitmap).
    End With

   '\\ Create the Range Picture Object
   OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic

    '\\ Save Picture Object
    stdole.SavePicture IPic, FilePathName

End Sub

有一个更深入的Knowledge Base article。

【讨论】：

很抱歉让这个从死里复活，但这也适用于 Access 2003 吗？如果没有，我可以让它工作吗？

我刚刚浏览了代码。我不明白为什么只要存在 DLL，它就不能在 Access 2003 中工作。你试过了吗？

实现工作....大致。如果剪贴板内容实际上是打印屏幕，则没有检查，但这很好，因为您直接调用它。我现在留下的主要问题是由此生成的图像文件很大......完整的打印屏幕大约为 6mb。根据我在 Access 2003 中看到的情况，没有内置方法可以将 IPicture 制作成 .png 并对其进行压缩，您碰巧知道吗？

你可以从这个答案***.com/questions/12813280/…修改代码

顺便说一句，您的回答和随后的帮助帮助我构建了一个模块，该模块今天在相对紧迫的时间限制下投入生产。所以为了另外感谢你，我在这个答案上加了 100 分赏金:)

【参考方案2】：

使用 raj 的示例获取图像，然后保存

Dim oPic
On Error Resume Next
Set oPic = Clipboard.GetData
On Error GoTo 0
If oPic Is Nothing Then
  'no image in clipboard'
Else
  SavePicture oPic, "c:\temp\pic.bmp"
end if