Userform auf ein Blatt A4 drucken

Private Sub cmd_Druck_Click() Dim wshTemp As Worksheet DoEvents keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY, 0 keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0 keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0 keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0 DoEvents ThisWorkbook.Worksheets.Add ActiveSheet.Name = "Temp" Set wshTemp = ThisWorkbook.Worksheets("Temp") With wshTemp .Paste .PageSetup.Orientation = xlLandscape .PrintOut .DrawingObjects.Delete End With Application.DisplayAlerts = False ThisWorkbook.Worksheets("Temp").Delete Application.DisplayAlerts = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi,
so:
' **********************************************************************
' Modul: basPrint Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" ( _
    ByVal wCode As Long, _
    ByVal wMapType As Long) As Long
Private Declare Sub keybd_event Lib "user32" ( _
    ByVal bVk As Byte, _
    ByVal bScan As Byte, _
    ByVal dwFlags As Long, _
    ByVal dwExtraInfo As Long)

Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_MENU = &H12
Private Const lngMargin = 1& 'Breite der Seitenränder in cm

Public Sub prcPrintForm(strFrmName As String)
    Dim intAltScan As Integer, intIndex As Integer
    Dim lngMode As Long
    Application.ScreenUpdating = False
    intAltScan = MapVirtualKey(VK_MENU, 0)
    keybd_event VK_MENU, intAltScan, 0, 0
    keybd_event vbKeySnapshot, lngMode, 0&, 0&
    DoEvents
    keybd_event VK_MENU, intAltScan, KEYEVENTF_KEYUP, 0
    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, 2, 1)
            .LeftMargin = Application.CentimetersToPoints(lngMargin)
            .RightMargin = Application.CentimetersToPoints(lngMargin)
            .TopMargin = Application.CentimetersToPoints(lngMargin)
            .BottomMargin = Application.CentimetersToPoints(lngMargin)
            .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

Der Aufruf erfolgt mit: Call prcPrintForm(Me.Name)
Gruß
Nepumuk

Sub prcPrintForm(strFrmName As String) Dim intAltScan As Integer, intIndex As Integer Dim lngMode As Long Application.ScreenUpdating = False intAltScan = MapVirtualKey(VK_MENU, 0) keybd_event VK_MENU, intAltScan, 0, 0 keybd_event vbKeySnapshot, lngMode, 0&, 0& DoEvents keybd_event VK_MENU, intAltScan, KEYEVENTF_KEYUP, 0 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, 2, 1) .LeftMargin = Application.CentimetersToPoints(lngMargin) .RightMargin = Application.CentimetersToPoints(lngMargin) .TopMargin = Application.CentimetersToPoints(lngMargin) .BottomMargin = Application.CentimetersToPoints(lngMargin) .HeaderMargin = Application.CentimetersToPoints(0) .FooterMargin = Application.CentimetersToPoints(0) .CenterVertically = True .CenterHorizontally = True .Zoom = 160 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

Beliebteste Forumthreads (12 Monate)

Userform auf ein Blatt A4 drucken

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

143 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Userform auf ein Blatt A4 drucken

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

143 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread