VBA截屏保存解决方法

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

[解决办法]

VB code

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中代码：

VB code
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 EnumPrivate Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPrivate Declare Function CloseClipboard Lib "user32" () As LongPrivate Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As Guid, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As LongPrivate Const CF_BITMAP = 2Private Type PicBmp    Size As Long    Type As Long    hBmp As Long    hPal As Long    Reserved As LongEnd TypePrivate Type Guid    Data1 As Long    Data2 As Integer    Data3 As Integer    Data4(0 To 7) As ByteEnd TypeFunction ApiGetClipBmp() As IPictureOn 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"    CloseClipboardEnd FunctionFunction KeyJp(Optional ByVal TheMode As JpMode = theScreen) As IPictureDisp   '版权所有，请保留作者信息.QQ：1085992075   '如需商业用途请联系作者      Call keybd_event(vbKeySnapshot, TheMode, 0, 0) '      DoEvents      'Set KeyJp = Clipboard.GetDataEnd Function'┗〓〓〓〓〓〓〓〓〓  KeyJp,end  〓〓〓〓〓〓〓〓〓┛Sub dd()  KeyJp (theScreen)  SavePicture ApiGetClipBmp, "c:\2.bmp"End Sub