VBA截屏保留

2013-01-01

VBA截屏保存VBA中如何实现截屏，再把截屏保存为图片。有无大虾知道的，帮帮我[解决办法]Private Sub Command1

VBA截屏保存
VBA中如何实现截屏，再把截屏保存为图片。
有无大虾知道的，帮帮我
[解决办法]


Private Sub Command1_Click()
    Dim lDesktop As Long
    Dim lDC As Long
    frmMain.AutoRedraw = True
    frmMain.ScaleMode = 1
    lDesktop = GetDesktopWindow() '取得桌面窗口
    Picture1.AutoRedraw = True
    lDC = GetDC(lDesktop) '取得桌面窗口的设备场景
    BitBlt Picture1.hDC, 0, 0, Screen.Width, Screen.Height, lDC, 0, 0, vbSrcCopy '将桌面图象绘制到窗体
    
    
    SavePicture Picture1.Image, "D:\1.bmp"
End Sub

[解决办法]
'┏〓〓〓〓〓〓〓〓   ApiGetClipBmp函数相关定义声明等 Start
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
'┗〓〓〓〓〓〓〓〓   ApiGetClipBmp函数相关定义声明等 End
'┏〓〓〓〓〓〓〓〓〓 ApiGetClipBmp,start 〓〓〓〓〓〓〓〓〓┓
'［简介］：
'API方式获取剪贴板图像，可用于VBA等方式截图保存
Function ApiGetClipBmp() As IPicture
   '[mycode_id:2042],edittime:2011-9-11 下午 01:04:32
   On Error Resume Next
       Dim Pic As PicBmp, IID_IDispatch As Guid
       OpenClipboard 0 'OpenClipboard
       With IID_IDispatch
           .Data1 = &H20400
           .Data4(0) = &HC0
           .Data4(7) = &H46
       End With

       With Pic
           .Size = Len(Pic)
           .Type = 1
           .hBmp = GetClipboardData(CF_BITMAP)
       End With

       OleCreatePictureIndirect Pic, IID_IDispatch, 1, ApiGetClipBmp
       CloseClipboard
End Function
       'stdole.SavePicture ApiGetClipBmp, "c:\clipboard.bmp",保存时可用这个方式
'┗〓〓〓〓〓〓〓〓〓  ApiGetClipBmp,end  〓〓〓〓〓〓〓〓〓┛

[解决办法]
完整vba中代码：

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Enum JpMode
      theScreen = 0 '全屏截图
      theForm = 1 '当前焦点窗口截图
End Enum

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
Function ApiGetClipBmp() As IPicture
On Error Resume Next
    Dim Pic As PicBmp, IID_IDispatch As Guid
    OpenClipboard 0 'OpenClipboard
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    With Pic
        .Size = Len(Pic)
        .Type = 1
        .hBmp = GetClipboardData(CF_BITMAP)
    End With

    OleCreatePictureIndirect Pic, IID_IDispatch, 1, ApiGetClipBmp
    'stdole.SavePicture ApiGetClipBmp, "c:\clipboard.bmp"
    CloseClipboard
End Function
Function KeyJp(Optional ByVal TheMode As JpMode = theScreen) As IPictureDisp
   '版权所有，请保留作者信息.QQ：1085992075   '如需商业用途请联系作者
      Call keybd_event(vbKeySnapshot, TheMode, 0, 0) '
      DoEvents
      'Set KeyJp = Clipboard.GetData

End Function
'┗〓〓〓〓〓〓〓〓〓  KeyJp,end  〓〓〓〓〓〓〓〓〓┛
Sub dd()
  KeyJp (theScreen)
  SavePicture ApiGetClipBmp, "c:\2.bmp"
End Sub

热点排行