API/COM/系统相关
VBA保存剪贴板为Bmp(加PrtScrn截屏)
2011-10-08 23:29:39

截屏只是模拟了键盘的 {PrtScrn} 及 %{PrntScrn} 未能做到范围的!

不过保存 bmp 是异常的快! 值得保留,学习的! 尤其是要做些逐个像素处理的工作,  例如 破解登入图像的验证码, 十字绣转换软件, excel的电影播放器等! bmp 无疑是最好的选择! 正 文:

 

Private Declare Sub keybd_event Lib "user32" _ (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long     Private Const CF_BITMAP = 2     Private Type PicBmp     Size As Long     type As Long     hBmp As Long     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 Sub My_Screen_1()     Call keybd_event(vbKeySnapshot, 0, 0, 0)     DoEvents End Sub    Private Sub My_Screen_2()     Call keybd_event(vbKeySnapshot, 1, 1, 1)     DoEvents End Sub    Sub Scheduled_Snapshot()     Dim Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID          Call My_Screen_2     oTime = Now()          OpenClipboard 0

    With Pic         .Size = Len(Pic)         .type = 1         .hBmp = GetClipboardData(CF_BITMAP)     End With          OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic     stdole.SavePicture IPic, "d:\snapshot_" & Format(Now(), "yyyy-mm-dd hhnnss") & ".bmp"     CloseClipboard          End Sub