AW: Schaltfläche und Druckbereich per Makro
26.06.2010 11:11:54
fcs
Moin Tom,
Problem 1:
Siehe nachfolgendes Makro SchaltflaecheKopieren
Problem 2:
Die Einrichtung des Druckbereichs und ggf. setzen des Seitenwechsels solltest du in das Druckmakro integrieren. Dann ist sichergestellt, dass es passt, auch wenn jemand die Einstellungen geändert hat.
Beispiel: siehe nachfolgendes Makro.
Falls die Wahrscheinlichkeit gering ist, das Anwender die Einstellungen für den Druckbereich ändern, dann kannst du einmal das Makro "DruckbereichAnpassen" für die Datei ausführen.
Gruß
Franz
'Druckmakro in einem allgemeinen Modul speichern
Sub Drucken_Monatsblatt()
Dim wks As Worksheet, sDruckerAktuell As String
Set wks = ActiveSheet
'aktuellen Drucker merken
sDruckerAktuell = Application.ActivePrinter
'Zieldrucker setzen
Application.ActivePrinter = "hp LaserJet 1000 (Kopie 1) auf Ne02:"
'Blatt drucken
With wks
'Druckbereich(e) anpassen
With .PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
.PrintArea = "$A$1:$Z$60"
End With
.ResetAllPageBreaks
'Zeilenwechsel vor Zeile 31
.HPageBreaks.Add .Cells(31, 1)
'Drucken
.PrintOut
End With
'gemerkten Drucker wieder setzen
Application.ActivePrinter = sDruckerAktuell
End Sub
Sub SchaltflaecheKopieren()
'vor der Ausführung dieses Makros
' - in einem Blatt die Schaltfläche aus der Symbolleiste Formular erstellen/formatieren
' - Namen der Schaltfläche ändern von "Schaltfläche X" in "Button_Drucken"
' - der Schaltfläche das Makro zum Drucken zuweisen
' - das Blatt mit der Schaltfläche aktivieren
Dim oShape As Shape, sShapeName As String, oShapeOrig As Shape
Dim wks As Worksheet, wksAktiv As Worksheet
Set wksAktiv = ActiveSheet
sShapeName = "Button_Drucken" 'Name der zu kopierenden Schaltfläche - ggf. anpassen
Set oShapeOrig = wksAktiv.Shapes(sShapeName)
For Each wks In ActiveWorkbook.Worksheets
Select Case wks.Name
Case wksAktiv.Name, "TabelleXYZ" 'ggf. weitere Blattnamen getrennt durch Komma ergänzen
'do nothing - Shape-Objekt nicht in diese Blätter kopieren
Case Else
'Shape-Objekt kopieren und einfügen
oShapeOrig.Copy
wks.Paste
'Kopiertes Objekt positionieren
Set oShape = wks.Shapes(wks.Shapes.Count)
With oShape
.Top = oShapeOrig.Top
.Left = oShapeOrig.Left
End With
End Select
Next
End Sub
Sub DruckbereichAnpassen()
Dim wks As Worksheet
For Each wks In ActiveWorkbook.Worksheets
Select Case wks.Name
Case "TabelleXYZ" 'ggf. weitere Blattnamen getrennt durch Komma ergänzen
'In diesen Blättern Druckbereich nicht anpassen
Case Else
With wks
'Druckbereich(e) anpassen
With .PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
.PrintArea = "$A$1:$Z$60"
End With
.ResetAllPageBreaks
'Zeilenwechsel vor Zeile 31
.HPageBreaks.Add .Cells(31, 1)
End With
End Select
Next
End Sub