VBA屏幕捕获并保存到桌面

Option Explicit

Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As LongPtr, ByVal dwExtraInfo As LongPtr)
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As LongPtr, ByVal nHeight As LongPtr) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hdcDest As LongPtr, ByVal nXDest As LongPtr, ByVal nYDest As LongPtr, ByVal nWidth As LongPtr, ByVal nHeight As LongPtr, ByVal hdcSrc As LongPtr, ByVal nXSrc As LongPtr, ByVal nYSrc As LongPtr, ByVal dwRop As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As LongPtr) As LongPtr
Private Declare PtrSafe Function GetTempPath Lib "kernel32" (ByVal nBufferLength As LongPtr, ByVal lpBuffer As String) As LongPtr
Private Declare PtrSafe Function SaveBitmapToFile Lib "gdi32" (ByVal hdc As LongPtr, ByVal lpszFileName As String) As LongPtr

Sub CaptureScreenAndSaveToDesktop()
    Dim hwndDesktop As LongPtr
    Dim hdcDesktop As LongPtr
    Dim hdcMem As LongPtr
    Dim hbmScreen As LongPtr
    Dim hbmMem As LongPtr
    Dim bmpFilePath As String
    Dim screenWidth As LongPtr
    Dim screenHeight As LongPtr
    Dim desktopPath As String

    ' 获取桌面窗口句柄
    hwndDesktop = GetDesktopWindow()

    ' 获取桌面窗口的设备上下文
    hdcDesktop = GetWindowDC(hwndDesktop)

    ' 获取屏幕宽度和高度
    screenWidth = GetSystemMetrics(0)
    screenHeight = GetSystemMetrics(1)

    ' 创建与桌面窗口兼容的内存设备上下文
    hdcMem = CreateCompatibleDC(hdcDesktop)

    ' 创建与桌面窗口兼容的位图
    hbmScreen = CreateCompatibleBitmap(hdcDesktop, screenWidth, screenHeight)

    ' 将位图选入内存设备上下文
    hbmMem = SelectObject(hdcMem, hbmScreen)

    ' 将桌面窗口的内容复制到内存设备上下文中的位图
    BitBlt hdcMem, 0, 0, screenWidth, screenHeight, hdcDesktop, 0, 0, &HCC0020

    ' 获取桌面路径
    desktopPath = Environ("USERPROFILE") & "\Desktop"

    ' 创建临时文件路径
    bmpFilePath = desktopPath & "\screenshot.bmp"

    ' 保存位图到文件
    SaveBitmapToFile hdcMem, bmpFilePath

    ' 清理资源
    SelectObject hdcMem, 0
    DeleteObject hbmScreen
    DeleteDC hdcMem
    ReleaseDC hwndDesktop, hdcDesktop

    ' 显示保存文件的路径
    MsgBox "屏幕截图已保存到：" & bmpFilePath, vbInformation
End Sub