UserForm - Drucken - xlLandscape - xlPortrait...

Frage: Ich habe verschiedene UserFormen. Diese möchte ich gerne drucken. Ist die UserForm breiter wie höher, dann im querformat drucken - sonst nicht. Wie geht das?

I have different user forms. This I would like to print. Is the UserForm wider than higher, then in landscape print - otherwise not. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
UserForm - Drucken - xlLandscape - xlPortrait...[XLS 70 KB]

' Code gehört in UserForm1 / Code is in UserForm1

Option Explicit
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 MapVirtualKey Lib "user32" _
    Alias "MapVirtualKeyA" (ByVal wCode As Long, _
    ByVal wMapType As Long) As Long
Const VK_MENU = &H12 'ALT
'--------------------------------------------------------------------------
' Module    : UserForm1
' Procedure : CommandButton1_Click
' Author    : Case (Ralf Stolzenburg)
' Date      : 12.04.2013
' Purpose   : Tasten ALT & Druck drücken...
'--------------------------------------------------------------------------
Private Sub CommandButton1_Click()
    keybd_event VK_MENU, MapVirtualKey(VK_MENU, 0), 0, 0 ' 0 = ALT drücken
    keybd_event vbKeySnapshot, 0, 0, 0
    DoEvents
    keybd_event VK_MENU, MapVirtualKey(VK_MENU, 0), 2, 0 ' 2 = ALT loslassen
    If Me.Width > Me.Height Then
        Application.OnTime Now + TimeSerial(0, 0, 2), "Main"
    Else
        Application.OnTime Now + TimeSerial(0, 0, 2), "'Main True'"
    End If
    Unload Me
End Sub

' Code gehört in UserForm2 / Code is in UserForm2

Option Explicit
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 MapVirtualKey Lib "user32" _
    Alias "MapVirtualKeyA" (ByVal wCode As Long, _
    ByVal wMapType As Long) As Long
Const VK_MENU = &H12 'ALT
'--------------------------------------------------------------------------
' Module    : UserForm2
' Procedure : CommandButton1_Click
' Author    : Case (Ralf Stolzenburg)
' Date      : 12.04.2013
' Purpose   : Tasten ALT & Druck drücken...
'--------------------------------------------------------------------------
Private Sub CommandButton1_Click()
    keybd_event VK_MENU, MapVirtualKey(VK_MENU, 0), 0, 0 ' 0 = ALT drücken
    keybd_event vbKeySnapshot, 0, 0, 0
    DoEvents
    keybd_event VK_MENU, MapVirtualKey(VK_MENU, 0), 2, 0 ' 2 = ALT loslassen
    If Me.Width > Me.Height Then
        Application.OnTime Now + TimeSerial(0, 0, 2), "Main"
    Else
        Application.OnTime Now + TimeSerial(0, 0, 2), "'Main True'"
    End If
    Unload Me
End Sub

' Code gehört in ein Modul / Code is in a module

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 12.04.2013
' Purpose   : UserForm im Querformat ausdrucken...
'--------------------------------------------------------------------------
Sub Main(Optional blnTMP As Boolean = False)
    Dim shpShape As Shape
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell"
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken
        .DisplayAlerts = False
    End With
    ' Neues Worksheet erzeugen
    ThisWorkbook.Worksheets.Add
    With ActiveSheet
        ' Bild der UserForm einfügen
        .Paste
        ' Wenn UserForm breiter als höher, dann...
        If blnTMP = False Then
            ' Horizontal und vertikal zentrieren - Querformat
            ' Hier könnten auch noch die Seitenränder verkleinert werden
            With .PageSetup
                .CenterHorizontally = True
                .CenterVertically = True
                .Orientation = xlLandscape
            End With
            ' Bildhöhe anpassen
            With .Shapes(1)
                .Height = 480
            End With
        Else
            ' Horizontal und vertikal zentrieren - Längsformat
            With .PageSetup
                .CenterHorizontally = True
                .CenterVertically = True
                .Orientation = xlPortrait
            End With
            ' Bildbreie anpassen
            With .Shapes(1)
                .Width = 400
            End With
        End If
        ' Tabellenblatt drucken
        .PrintOut
        ' Tabellenblatt löschen
        .Delete
        ' Umbruchvorschau ausschalten
        ActiveSheet.DisplayAutomaticPageBreaks = False
    End With
Fin:
    ' Die Applikation aufwecken
    With Application
        ' Bildschirmaktualisierung wieder einschalten
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Sub UF1_Show()
    UserForm1.Show
End Sub
Sub UF2_Show()
    UserForm2.Show
End Sub

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...