AW: Drucken einer UserForm
05.02.2020 16:47:54
Nepumuk
Hallo Andreas,
teste mal:
Option Explicit
Option Private Module
Private Declare Function OpenClipboard Lib "user32.dll" ( _
ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Sub keybd_event Lib "user32.dll" ( _
ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long)
Private Declare Function MapVirtualKeyA Lib "user32.dll" ( _
ByVal wCode As Long, _
ByVal wMapType As Long) As Long
Private Const KEYEVENTF_KEYUP As Long = &H2
Public Sub PrintUserform()
Dim objWorksheet As Worksheet
Dim objShape As Shape
Dim lngColumn As Long, lngRow As Long
Dim strAddress As String
Dim lngAltScan As Long
Call OpenClipboard(Application.hwnd)
Call EmptyClipboard
Call CloseClipboard
lngAltScan = MapVirtualKeyA(vbKeyMenu, 0)
Call keybd_event(vbKeyMenu, lngAltScan, 0, 0)
DoEvents
Call keybd_event(vbKeySnapshot, 0&, 0&, 0&)
DoEvents
Call keybd_event(vbKeyMenu, lngAltScan, KEYEVENTF_KEYUP, 0)
DoEvents
Set objWorksheet = ThisWorkbook.Worksheets.Add
With objWorksheet
On Error Resume Next
Do
Call .Paste
If Err.Number = 0 Then Exit Do
Err.Clear
DoEvents
Loop
On Error GoTo 0
Set objShape = .Shapes(1)
For lngColumn = 1 To .Columns.Count
If .Range(.Cells(1, 1), .Cells(1, lngColumn)).Width > objShape.Width Then Exit For
Next
For lngRow = 1 To .Rows.Count
If .Range(.Cells(1, 1), .Cells(lngRow, 1)).Height > objShape.Height Then Exit For
Next
strAddress = .Range(.Cells(1, 1), .Cells(lngRow, lngColumn)).Address
With .PageSetup
.PrintArea = strAddress
.Orientation = xlLandscape
.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 objShape = Nothing
Set objWorksheet = Nothing
End Sub
Der Aufruf aus dem Userform:
Private Sub CommandButton1_Click()
Call PrintUserform
End Sub
Gruß
Nepumuk
