将用户窗体保存为PDF

Private Type RECT
 Left As Long
 Top As Long
 Right As Long
 Bottom As Long
End Type

Private Declare PtrSafe Function _
 GetActiveWindow& Lib "user32" ()
Private Declare PtrSafe Sub GetWindowRect Lib _
 "user32" (ByVal hwnd&, lpRect As RECT)
Private Declare PtrSafe Function _
 GetDesktopWindow& Lib "user32" ()
'剪贴板操作
Private Declare PtrSafe Function _
 OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function _
 CloseClipboard& Lib "user32" ()
Private Declare PtrSafe Function SetClipboardData& _
 Lib "user32" (ByVal wFormat&, ByVal hMem&)
Private Declare PtrSafe Function _
 EmptyClipboard& Lib "user32" ()
'创建Bitmap
Private Declare PtrSafe Function GetDC& _
 Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function _
 CreateCompatibleDC& Lib "gdi32" (ByVal hDC&)
Private Declare PtrSafe Function CreateCompatibleBitmap& _
 Lib "gdi32" (ByVal hDC&, ByVal nWidth& _
 , ByVal nHeight&)
Private Declare PtrSafe Function SelectObject& _
 Lib "gdi32" (ByVal hDC&, ByVal hObject&)
Private Declare PtrSafe Function BitBlt& Lib "gdi32" _
 (ByVal hDestDC&, ByVal X&, ByVal Y& _
 , ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC& _
 , ByVal XSrc&, ByVal YSrc&, ByVal dwRop&)
Private Declare PtrSafe Function ReleaseDC& _
 Lib "user32" (ByVal hwnd&, ByVal hDC&)
Private Declare PtrSafe Function DeleteDC& _
 Lib "gdi32" (ByVal hDC&)
'创建图片
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 Declare PtrSafe Function OleCreatePictureIndirect _
 Lib "olepro32.dll" (PicDesc As PicBmp _
 , RefIID As Guid, ByVal fPictureOwnsHandle As Long _
 , IPic As IPicture) As Long
 
' 对象(UserForm, FullScreen, etc.):
Sub ScreenObjectCopy()
 Dim hPtr&, r As RECT
 Call GetWindowRect(GetActiveWindow, r)
 hPtr = CreateBitmap(r.Right - r.Left _
 , r.Bottom - r.Top, r.Left, r.Top)
 If hPtr = 0 Then Exit Sub
 '在硬盘中保存图像
 'SavePicture CreatePicture(hPtr), "C:\Documents and Settings\Administrator\My Documents.bmp"
 SavePicture CreatePicture(hPtr), "C:\temp\My Documents.bmp"
 ActiveSheet.Paste
End Sub

Sub ScreenPartCopy()
 Dim hPtr&  ' 像素坐标(Width, Height, Left, Top)
 hPtr = CreateBitmap(186, 60, 102, 432)
 If hPtr = 0 Then Exit Sub
 ' 在硬盘中保存图像
 SavePicture CreatePicture(hPtr),  "C:\Documents and Settings\Administrator\My Documents.bmp"
 ActiveSheet.Paste
End Sub

Private Function CreateBitmap&(ByVal W& _
 , ByVal H&, Optional L& = 0, Optional T& = 0)
 Dim hwnd&, hBitmap&, hDC&, hDCMem&
 hwnd = GetDesktopWindow()
 '获取桌面设备内容和分配内存
 hDC = GetDC(hwnd)
 hDCMem = CreateCompatibleDC(hDC)
 hBitmap = CreateCompatibleBitmap(hDC, W, H)
 If hBitmap Then
   Call SelectObject(hDCMem, hBitmap)
   ' 基于对象坐标复制桌面图片到内存位置
   Call BitBlt(hDCMem, 0, 0, W, H, hDC, L, T, &HCC0020)
   ' 设置剪贴板并复制图片
   Call OpenClipboard(hwnd)
   Call EmptyClipboard
   CreateBitmap = SetClipboardData(2, hBitmap)
   Call CloseClipboard
 End If
 ' 清理句柄
 Call DeleteDC(hDCMem)
 Call ReleaseDC(hwnd, hDC)
End Function

Private Function CreatePicture(ByVal hBmp&) As IPicture
 Dim Ret&, Pic As PicBmp, IPic As IPicture, IID As Guid
 With IID
   .Data1 = &H20400
   .Data4(0) = &HC0
   .Data4(7) = &H46
 End With
 With Pic
   .Size = Len(Pic)
   .Type = 1
   .hBmp = hBmp
 End With
 Ret = OleCreatePictureIndirect(Pic, IID, 1, IPic)
 Set CreatePicture = IPic
End Function

' 对象(UserForm, FullScreen, etc.):
Sub SOC(pasteRange As Range, Optional bmpPath As String = "")
 Dim hPtr&, r As RECT, ac As Range
 Set ac = ActiveCell
 Call GetWindowRect(GetActiveWindow, r)
 hPtr = CreateBitmap(r.Right - r.Left _
   , r.Bottom - r.Top, r.Left, r.Top)
 If hPtr = 0 Then Exit Sub
 ' 在硬盘上保存图像
 If bmpPath <> "" Then SavePicture CreatePicture(hPtr), bmpPath
 With pasteRange
      .Parent.Activate
      .Select
      .Parent.Paste
 End With
 ac.Parent.Activate
 ac.Select
End Sub

Sub ScreenObjectCopyToClipboard()
 Dim hPtr&, r As RECT
 Call GetWindowRect(GetActiveWindow, r)
 hPtr = CreateBitmap(r.Right - r.Left _
   , r.Bottom - r.Top, r.Left, r.Top)
 If hPtr = 0 Then Exit Sub
End Sub

Private Sub CommandButton2_Click()
 Dim pdf As String, s As Shape
 
 With Sheet1
   '清除工作表Sheet1中的内容
   .UsedRange.Clear
   For Each s In .Shapes
     s.Delete
   Next s
 
   Me.Repaint
   '复制并粘贴用户窗体到工作表Sheet1单元格A1.
   SOC .[A1]
   .Activate
   .[A1].Select
 
   '创建PDF文件
   pdf = ThisWorkbook.Path & "\CopyToPicture.pdf"
   .ExportAsFixedFormat xlTypePDF, pdf
 End With
 
 Unload Me
End Sub