Userform drucken
26.07.2006 20:55:51
Max
ich habe beim Suchen ein Makro von Nepumuk gefunden, welches auch sehr gut
funktioniert.
Allerdings macht es aus einer kleinen Userform eine ganze DinA4 Seite.
Welche Zahlen muss ich ändern, damit das Zoom kleiner wird? Meine Versuche
führen leider immer wieder zu Fehlern.... ;-))
Option Explicit
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Enum Constants
KEYEVENTF_KEYUP = &H2
VK_MENU = &H12
sngMargin = 1.5 'Breit der Seitenränder in cm
End Enum
Private Sub GetWindowSnapShot(Mode As Long)
Dim altscan%, NT As Boolean
NT = IsNT
If Not NT Then
If Mode = 0& Then Mode = 1& Else Mode = 0&
End If
If NT And Mode = 0 Then
keybd_event vbKeySnapshot, 0&, 0&, 0&
Else
altscan = MapVirtualKey(VK_MENU, 0)
keybd_event VK_MENU, altscan, 0, 0
DoEvents
keybd_event vbKeySnapshot, Mode, 0&, 0&
End If
DoEvents
keybd_event VK_MENU, altscan, KEYEVENTF_KEYUP, 0
End Sub
Private Function IsNT() As Boolean
Dim verinfo As OSVERSIONINFO
verinfo.dwOSVersionInfoSize = Len(verinfo)
If (GetVersionEx(verinfo)) = 0 Then Exit Function
IsNT = verinfo.dwPlatformId = 2
End Function
Public Sub Userform_drucken(strFrmName As String)
Dim intIndex As Integer
Application.ScreenUpdating = False
Call GetWindowSnapShot(1)
ThisWorkbook.Worksheets.Add
Rows.RowHeight = 3
Columns.ColumnWidth = 0.83
With ActiveSheet
.Paste
With .PageSetup
.Orientation = IIf(UserForms.Add(strFrmName).Width > UserForms.Add(strFrmName).Height, xlLandscape, xlPortrait)
.LeftMargin = Application.CentimetersToPoints(sngMargin)
.RightMargin = Application.CentimetersToPoints(sngMargin)
.TopMargin = Application.CentimetersToPoints(sngMargin)
.BottomMargin = Application.CentimetersToPoints(sngMargin)
.HeaderMargin = Application.CentimetersToPoints(0)
.FooterMargin = Application.CentimetersToPoints(0)
.CenterVertically = True
.CenterHorizontally = True
.Zoom = 10
For intIndex = 1 To 3
Do Until ExecuteExcel4Macro("Get.Document(50)") > 1
.Zoom = .Zoom + Choose(intIndex, 50, 10, 1)
Loop
.Zoom = .Zoom - Choose(intIndex, 50, 10, 1)
Next
End With
.PrintOut
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
End Sub
Vielen Dank für eure Mühe!
Gruss
Max