Hallo Tom,
im Modul des Userforms:
Option Explicit
Private Declare PtrSafe Function GetWindowRect Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByRef lpRect As RECT) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Const GC_CLASSNAME_USERFORM = "ThunderDFrame"
Private Sub CommandButton1_Click()
Dim lngptrHwnd As LongPtr
Dim udtRectangularForm As RECT
lngptrHwnd = FindWindowA(GC_CLASSNAME_USERFORM, Caption)
Call GetWindowRect(lngptrHwnd, udtRectangularForm)
With udtRectangularForm
.Bottom = .Bottom - 5
.Left = .Left + 5
.Right = .Right - 5
.Top = .Top + 5
End With
Call PrintUserForm(udtRectangularForm)
End Sub
In einem Standardmodul:
Option Explicit
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32.dll" ( _
ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetSystemPaletteEntries Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal wStartIndex As Long, _
ByVal wNumEntries As Long, _
ByRef lpPaletteEntries As PALETTEENTRY) As Long
Private Declare PtrSafe Function CreatePalette Lib "gdi32.dll" ( _
ByRef lpLogPalette As LOGPALETTE) As LongPtr
Private Declare PtrSafe Function SelectPalette Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal hPalette As LongPtr, _
ByVal bForceBackground As Long) As LongPtr
Private Declare PtrSafe Function RealizePalette Lib "gdi32.dll" ( _
ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function BitBlt Lib "gdi32.dll" ( _
ByVal hDestDC As LongPtr, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As LongPtr, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" ( _
ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" ( _
ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Long, _
ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" ( _
ByVal wFormat As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
Private Const HWND_DESKTOP As LongPtr = 0
Private Const RASTERCAPS As Long = 38&
Private Const RC_PALETTE As Long = &H100&
Private Const SIZEPALETTE As Long = 104&
Private Const SRCCOPY As Long = &HCC0020
Private Const CF_BITMAP As Long = 2&
Public Sub PrintUserForm(ByRef prudtRectangle As RECT)
Dim objWorksheet As Worksheet
Dim objPicture As Picture
Dim strAddress As String
If Application.Dialogs(xlDialogPrinterSetup).Show Then
Call OpenClipboard(0)
Call EmptyClipboard
Call SetClipboardData(CF_BITMAP, DC_To_Picture(prudtRectangle))
Call CloseClipboard
If IsClipboardFormatAvailable(CF_BITMAP) = 1 Then
Set objWorksheet = ThisWorkbook.Worksheets.Add
With objWorksheet
On Error Resume Next
Do
Set objPicture = .Pictures.Paste(Link:=False)
If Err.Number = 0 Then Exit Do
Err.Clear
DoEvents
Loop
On Error GoTo 0
strAddress = .Range(.Cells(1, 1), objPicture.BottomRightCell).Address
With .PageSetup
.PrintArea = strAddress
.Orientation = IIf(objPicture.Width > objPicture.Height, xlLandscape, xlPortrait)
.LeftMargin = Application.CentimetersToPoints(0.5)
.RightMargin = Application.CentimetersToPoints(0.5)
.TopMargin = Application.CentimetersToPoints(0.5)
.BottomMargin = Application.CentimetersToPoints(0.5)
.CenterVertically = True
.CenterHorizontally = True
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
End With
Call .PrintOut
Application.DisplayAlerts = False
Call .Delete
Application.DisplayAlerts = True
End With
Set objPicture = Nothing
Set objWorksheet = Nothing
Else
Call Err.Raise(Number:=vbObjectError & 1004&, _
Description:="Auslesen des Bereichs fehlgeschlagen.")
End If
End If
End Sub
Private Function DC_To_Picture( _
ByRef prudtRect As RECT) As LongPtr
Dim lngLeftSrc As Long, lngTopSrc As Long, lngWidthSrc As Long, lngHeightSrc As Long
Dim lngptrhDCMemory As LongPtr, lngptrhBmp As LongPtr, lngptrhDCScr As LongPtr
Dim lngptrhPal As LongPtr, lngptrhPalPrev As LongPtr, lngptrhBmpPrev As LongPtr
Dim lngRasterCapsScrn As Long
Dim lngHasPaletteScrn As Long, lngPaletteSizeScrn As Long
Dim udtLogPal As LOGPALETTE
lngLeftSrc = prudtRect.Left
lngTopSrc = prudtRect.Top
lngWidthSrc = prudtRect.Right - prudtRect.Left
lngHeightSrc = prudtRect.Bottom - prudtRect.Top
lngptrhDCScr = GetDC(HWND_DESKTOP)
lngptrhDCMemory = CreateCompatibleDC(lngptrhDCScr)
lngptrhBmp = CreateCompatibleBitmap(lngptrhDCScr, lngWidthSrc, lngHeightSrc)
lngptrhBmpPrev = SelectObject(lngptrhDCMemory, lngptrhBmp)
lngRasterCapsScrn = GetDeviceCaps(lngptrhDCScr, RASTERCAPS)
lngHasPaletteScrn = lngRasterCapsScrn And RC_PALETTE
lngPaletteSizeScrn = GetDeviceCaps(lngptrhDCScr, SIZEPALETTE)
If lngHasPaletteScrn And (lngPaletteSizeScrn = &H100&) Then
udtLogPal.palVersion = &H300&
udtLogPal.palNumEntries = &H100&
Call GetSystemPaletteEntries(lngptrhDCScr, 0&, _
&H100&, udtLogPal.palPalEntry(0&))
lngptrhPal = CreatePalette(udtLogPal)
lngptrhPalPrev = SelectPalette(lngptrhDCMemory, lngptrhPal, 0&)
Call RealizePalette(lngptrhDCMemory)
End If
Call BitBlt(lngptrhDCMemory, 0&, 0&, lngWidthSrc, lngHeightSrc, _
lngptrhDCScr, lngLeftSrc, lngTopSrc, SRCCOPY)
lngptrhBmp = SelectObject(lngptrhDCMemory, lngptrhBmpPrev)
If lngHasPaletteScrn And (lngPaletteSizeScrn = 256&) Then _
lngptrhPal = SelectPalette(lngptrhDCMemory, lngptrhPalPrev, 0&)
Call DeleteDC(lngptrhDCMemory)
DC_To_Picture = lngptrhBmp
End Function
Hoch- oder Querformt stellt sich automatisch ein, je nachdem wie die Abmessungen des Userforms sind.
Gruß
Nepumuk