标签：VBA，用户窗体
在网上看到的一段程序，能够将用户窗体保存为PDF文件，特辑录于此，供查阅或方便有兴趣的朋友参考。
首先，插入一个标准模块，输入下面的代码：
代码语言：javascript复制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 SettingsAdministratorMy Documents.bmp"
SavePicture CreatePicture(hPtr), "C:tempMy 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 SettingsAdministratorMy 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在要保存为PDF的用户窗体中，放置一个按钮，并编写该按钮的执行代码：
代码语言：javascript复制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这样，当单击该按钮时，此用户窗体会作为图像显示在工作表Sheet1的单元格A1位置，并在该工作簿文件夹中保存为名为CopyToPicture的PDF文件。
