userform im Querformat
Melanie
ich habe für mein Problem bereits eine Antwort in der Suche-Funktion gefunden (s.u.), aber ich bekomme eine Debugger-Meldung beim ausführen.
Wenn ich alle so mache, wie Nepumuk es vorgeschlagen hat, dann bleibt der Debugger in der Zeile
.Zoom = .Zoom + Choose(intIndex, 50, 10, 1)
mehrfach hängen. Ich komme zwar über 6-7 maliges "Fortfahren" zu meinem Ausdruck, aber ich möchte das natürlich bequemer haben. Gibt es eine Idee, wie ich das abstellen kann?
Gruß,
Melanie
*************************
Hallo Richard,
null Problemo. Folgenden Code in ein Standardmodul:
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(objForm As Object)
Dim intAltScan As Integer, intIndex As Integer
Application.ScreenUpdating = False
intAltScan = MapVirtualKey(VK_MENU, 0&)
keybd_event VK_MENU, intAltScan, 0&, 0&
keybd_event vbKeySnapshot, 0&, 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(objForm.Width > objForm.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
Private Sub CommandButton1_Click()
Call prcPrintForm(Me)
End Sub
Gruß
Nepumuk
Anzeige