VBA屏幕捕获并保存到桌面

Option Explicit

Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function BitBlt Lib "gdi32" (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
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As LongPtr
Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As LongPtr
Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr

Public Sub CaptureScreen()
    Dim desktopPath As String
    Dim desktopDC As LongPtr
    Dim memoryDC As LongPtr
    Dim bitmap As LongPtr
    Dim oldBitmap As LongPtr
    Dim result As Long
    Dim width As Long
    Dim height As Long
    
    ' 获取桌面路径
    desktopPath = Environ("USERPROFILE") & "\Desktop\"
    
    ' 获取桌面设备上下文
    desktopDC = GetDC(0)
    
    ' 创建内存设备上下文
    memoryDC = CreateCompatibleDC(desktopDC)
    
    ' 获取屏幕宽度和高度
    width = GetSystemMetrics(0)
    height = GetSystemMetrics(1)
    
    ' 创建位图对象
    bitmap = CreateCompatibleBitmap(desktopDC, width, height)
    
    ' 选择位图对象到内存设备上下文
    oldBitmap = SelectObject(memoryDC, bitmap)
    
    ' 将桌面图像复制到内存设备上下文
    result = BitBlt(memoryDC, 0, 0, width, height, desktopDC, 0, 0, vbSrcCopy)
    
    ' 保存位图到文件
    result = SaveBitmapToFile(bitmap, desktopPath & "screenshot.bmp")
    
    ' 清理资源
    result = SelectObject(memoryDC, oldBitmap)
    result = DeleteObject(bitmap)
    result = DeleteDC(memoryDC)
    result = ReleaseDC(0, desktopDC)
End Sub

Private Function SaveBitmapToFile(ByVal bitmap As LongPtr, ByVal filePath As String) As Long
    Dim fileNum As Integer
    Dim fileData() As Byte
    Dim fileSize As Long
    
    ' 打开文件
    fileNum = FreeFile
    Open filePath For Binary Access Write As fileNum
    
    ' 获取位图数据
    fileSize = GetObjectData(bitmap, fileData)
    
    ' 写入文件
    Put fileNum, , fileData
    
    ' 关闭文件
    Close fileNum
    
    ' 返回文件大小
    SaveBitmapToFile = fileSize
End Function

Private Function GetObjectData(ByVal hObject As LongPtr, ByRef data() As Byte) As Long
    Dim headerInfo(0 To 3) As Long
    Dim fileSize As Long
    Dim fileHeaderSize As Long
    Dim fileDataSize As Long
    Dim result As Long
    
    ' 获取位图文件头信息
    result = SendMessage(hObject, &H7F, 0, VarPtr(headerInfo(0)))
    
    ' 计算文件大小
    fileSize = headerInfo(2) + headerInfo(3)
    
    ' 计算文件数据大小
    fileHeaderSize = 14
    fileDataSize = fileSize - fileHeaderSize
    
    ' 重新调整数据数组大小
    ReDim data(0 To fileDataSize - 1) As Byte
    
    ' 获取位图数据
    result = SendMessage(hObject, &H7E, fileDataSize, VarPtr(data(0)))
    
    ' 返回文件大小
    GetObjectData = fileSize
End Function