求VBA截取屏幕区域代码修改

lsggjie

在豆包上提问回复了vba截取屏幕的代码，但是运行时提示“子过程或函数未定义”，怎么回事，请大佬们看看，给修改一下，谢谢！


Option Explicit


Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SaveBitmapToFile Lib "gdi32" (ByVal hBitmap As Long, ByVal lpFileName As String) As Long


'定义vbSrcCopy常量
Private Const vbSrcCopy As Long = &HCC0020
Sub CaptureScreenArea()
'    On Error Resume Next
    Dim leftPos As Long, topPos As Long, width As Long, height As Long
    leftPos = 100 ' 截取区域的左边界
    topPos = 100 ' 截取区域的上边界
    width = 400  ' 截取区域的宽度
    height = 300 ' 截取区域的高度


    Dim hWnd As Long
    hWnd = GetDesktopWindow()
    Dim hDC As Long
    hDC = GetDC(hWnd)


    Dim memDC As Long
    memDC = CreateCompatibleDC(hDC)


    Dim hBitmap As Long
    hBitmap = CreateCompatibleBitmap(hDC, width, height)


    Dim oldBitmap As Long
    oldBitmap = SelectObject(memDC, hBitmap)


    BitBlt memDC, 0, 0, width, height, hDC, leftPos, topPos, vbSrcCopy


    SelectObject(memDC, oldBitmap)


    SaveBitmapToFile hBitmap, ThisWorkbook.Path & "\screenshot.bmp"


    DeleteObject hBitmap
    DeleteDC memDC
    ReleaseDC hWnd, hDC
End Sub

lsggjie

有哪位大佬高手给解决一下吗？

lss001

lsggjie 发表于 2024-12-27 08:46
有哪位大佬高手给解决一下吗？

Private Type PicBmp
    Size As Long
    type As Long
    hbmp As LongPtr
    hPal As Long
    Reserved As Long
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Declare PtrSafe Function GetDesktopWindow _
    Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetDC Lib "user32" ( _
    ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" ( _
    ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As LongPtr
Private 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
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 Long, _
    ByVal nHeight As Long) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" ( _
    ByVal hDC As LongPtr, ByVal hObject 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
'office32位："olepro32.dll"
Private Declare PtrSafe Function OleCreatePictureIndirect _
    Lib "oleaut32.dll" (PicDesc As PicBmp, RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, Ipic As IPicture) As Long
   
'定义vbSrcCopy常量
Private Const vbSrcCopy As Long = &HCC0020

Sub CaptureScreenArea()
'    On Error Resume Next
    Dim leftPos As Long, topPos As Long
    Dim width As Long, height As Long
    leftPos = 100 ' 截取区域的左边界
    topPos = 100 ' 截取区域的上边界
    width = 400  ' 截取区域的宽度
    height = 300 ' 截取区域的高度

    Dim hWnd As LongPtr
    hWnd = GetDesktopWindow()
    Dim hDC As LongPtr
    hDC = GetDC(hWnd)

    Dim memDC As LongPtr
    memDC = CreateCompatibleDC(hDC)
    Dim hBitmap As LongPtr
    hBitmap = CreateCompatibleBitmap(hDC, width, height)

    Dim oldBitmap As LongPtr
    oldBitmap = SelectObject(memDC, hBitmap)
    BitBlt memDC, 0, 0, width, height, hDC, leftPos, topPos, vbSrcCopy
      
    Dim Sliid As GUID, hpic As PicBmp
    With Sliid
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With hpic
        .Size = Len(hpic)
        .type = 1
        .hbmp = hBitmap
        .hPal = 0
    End With
   
    Dim Ipic As IPictureDisp, pfile As String
    OleCreatePictureIndirect hpic, Sliid, 1, Ipic
    pfile = ThisWorkbook.Path & "\screenshot.bmp"
    SavePicture Ipic, pfile

    DeleteObject hBitmap
    DeleteDC memDC
    ReleaseDC hWnd, hDC
End Sub