当初做测试时截了一个月图,如果那时候就会这个,好像也没什么卵用 ,应该能节省-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