vba截图相关

当初做测试时截了一个月图，如果那时候就会这个，好像也没什么卵用 ，应该能节省-50%到50%的时间。

截图

原贴http://club.excelhome.net/thread-1193134-1-1.html
可以全屏截图和当前窗口截图

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

Public Sub getPicScreen()           'screen
    Call keybd_event(vbKeySnapshot, 0, 0, 0)
    DoEvents
End Sub

Public Sub getPicActiveWindow()           'active window
    Call keybd_event(vbKeySnapshot, 1, 1, 1)
    DoEvents
End Sub

'功能:运行 getPicScreen 就是截取整个屏幕，运行 getPicActiveWindow 就是仅截取当前活动窗口。
'原理: 调用API函数模拟键盘上的PrtSc键 (印屏幕)

保存剪切板的图片到文件

ClipboardPicToJPGFile(path)，path是要保存的文件的全名

• jpg/png格式都可以，其他格式未测试
• 如果path=d:/1/2.jpg，那么d:/1这个文件夹必须存在，否则不生成图片也不报错。建议在调用前(判断文件夹是否存在/生成文件夹)

'''剪贴板函数
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal Format As Long) As Long

'''OLE函数
Private Type Clsid
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Long, pclsid As Clsid) As Long

'''GDI函数
Private Type GdiplusStartupInput
   GdiplusVersion As Long
   DebugEventCallback As Long
   SuppressBackgroundThread As Long
   SuppressExternalCodecs As Long
End Type

Private Type EncoderParameter
   Guid As Clsid
   NumberOfValues As Long
   type As Long
   value As Long
End Type

Private Type EncoderParameters
   count As Long
   Parameter As EncoderParameter
End Type

Private Const CLSID_JPG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As Clsid, encoderParams As Any) As Long

Public Function ClipboardPicToJPGFile(path)         'path="d:\1\2.jpg",d:\1 must exists
    Dim hMem As Long
    Dim bitmap As Long
    Dim GDI_Token As Long
    Dim GpInput As GdiplusStartupInput
    Dim ReturnValue As Long
    Dim Params As EncoderParameters
    Dim Quality As Long
    
    '''获取剪贴板BMP数据的Handle
    OpenClipboard 0&
    hMem = GetClipboardData(2)
    CloseClipboard
    If hMem = 0 Then MsgBox "未找到截屏数据": Exit Function
    
    '''初始化GDI+
    GpInput.GdiplusVersion = 1
    ReturnValue = GdiplusStartup(GDI_Token, GpInput)
    If ReturnValue <> 0 Then MsgBox "初始化GDI+失败！": Exit Function
    
    '''创建GDI+的bitmap对象
    GdipCreateBitmapFromHBITMAP hMem, 0, bitmap
    
    '''JPG压缩参数设置
    Quality = 50
    With Params
        .count = 1
        With .Parameter
            .Guid = GetEncoderClsid(EncoderQuality)
            .NumberOfValues = 1
            .type = 4
            .value = VarPtr(Quality)
        End With
    End With

    GdipSaveImageToFile bitmap, StrPtr(path), GetEncoderClsid(CLSID_JPG), Params
    
    GdipDisposeImage bitmap
    GdiplusShutdown GDI_Token
End Function

Private Function GetEncoderClsid(CLSIDString As String) As Clsid
    CLSIDFromString StrPtr(CLSIDString), GetEncoderClsid
End Function

一些可能有用的操作

• testPaste2Mspaint：保存截图到画图。截图+paste。要等画图工具打开才paste，所以等了1s，不知道更好的方法是什么。使用DoEvents依旧会出现paste失败的情况。
• testPaste2Worksheet：保存截图到工作表指定单元格(图的左上角和单元格对齐)处。截图+ActiveSheet.Paste。Cells(i, i).Select后paste无效，可能是sendkyes要选中窗口才能用，原因不明 。
• testSaveScreen2File：保存截图成文件

Sub testPaste2Mspaint()
    For i = 1 To 3
        Call getPicScreen
        a = Shell("mspaint", 1)
        'AppActivate a
        Application.Wait (Now + TimeValue("00:00:01"))
        'DoEvents
        Application.SendKeys "^v"
    Next i
End Sub

Sub testPaste2Worksheet()
    For i = 1 To 3
        Call getPicScreen
        ThisWorkbook.Sheets(1).Activate
        Cells(i, i).Select
        'Application.Wait (Now + TimeValue("00:00:01"))
        'Application.SendKeys "^v"
        ActiveSheet.Paste
    Next i
End Sub

Sub testSaveScreen2File()
    For i = 1 To 3
        Call getPicScreen
        ClipboardPicToJPGFile ("d:\" & i & ".jpg")
    Next i
End Sub