AW: Druckseiten festlegen
14.04.2018 11:37:38
fcs
Hallo Ambros,
in der Druckanweisung können als Parameter neben dem Drucker auch die Seiten angeben, die gedruckt werden sollen.
Seitenumbrüche zu ermitteln und abzuarbeiten ist etwas komplizierter.
Die Prüfung des Druckernamens kannst du weglassen - wenn der Drucker nicht vorhanden ist, dann wird auf dem aktiven Drucker in Excel gedruckt. Dann ist die Fuction "fncPrinter_plus_Port" nicht erforderlich, die den Druckernamen inkl. Prot ermittelt.
Gruß
Franz
'##############################################################
'# Windows Vista - Excel 2010 - VBA 7.0.1628 #
'# F. Sielck 2018-04-14 #
'# Modul: Allgemeines Modul #
'# Druckbereich setzen auf Seiten wechsel, Drucker setzen #
'# Makros sollten auch unter Excel 2003 lauffähig sein #
'###### Druckbereiche für Seiten 1 bis x setzen #####
Sub Druckbereich_Seite_1_bis_1()
Call Druckbereich_Seiten(1)
End Sub
Sub Druckbereich_Seite_1_bis_2()
Call Druckbereich_Seiten(2)
End Sub
Sub Druckbereich_Seite_1_bis_3()
Call Druckbereich_Seiten(3)
End Sub
Sub Druckbereich_Seiten(bis As Integer, Optional wks As Worksheet)
Dim objHPB As HPageBreak
Dim lngView As Long
Dim intHPB As Integer
Dim Zeile_L As Long, Zeile_von As Long, Zeile_bis As Long
If wks Is Nothing Then Set wks = ActiveSheet
With ActiveWindow
lngView = .View
If .View xlPageBreakPreview Then
.View = xlPageBreakPreview
End If
End With
With wks
'vorhandene manuelle Seitenumbrüche zurücksetzen
.ResetAllPageBreaks
.PageSetup.PrintArea = "A:F"
.Calculate
Zeile_von = 1
'letzte sichtbare Zeile mit Inhalt in Spalten A:F
Zeile_L = .Range("A:F").Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Zeile_bis = Zeile_L
For intHPB = 1 To .HPageBreaks.Count
If intHPB = bis Then
Zeile_bis = .HPageBreaks(intHPB).Location.Row - 1
Exit For
End If
Next
.PageSetup.PrintArea = _
.Range(.Cells(Zeile_von, 1), .Cells(Zeile_bis, 6)).AddressLocal(True, True, xlA1)
End With
With ActiveWindow
If .View lngView Then
.View = lngView
End If
End With
End Sub
Sub Drucken()
Dim sPrinter As String
Dim wks As Worksheet
Set wks = ActiveSheet
sPrinter = "Brother MFC-J6710DW Printer"
If fncPrinter_plus_Port(sPrinter) = "" Then
MsgBox "Drucker """ & sPrinter & """ nicht gefunden"
Else
wks.PrintOut from:=Seite_von, to:=Seite_bis, ActivePrinter:=sPrinter
End If
End Sub
'###### Seiten direkt drucken #####
Sub Druck_Seite_1_bis_1()
Call Drucken_2(1, 1)
End Sub
Sub Druck_Seite_1_bis_2()
Call Drucken_2(1, 2)
End Sub
Sub Druck_Seite_1_bis_3()
Call Drucken_2(1, 3)
End Sub
Sub Drucken_2(Seite_von, Seite_bis, Optional sPrinter As String)
Dim wks As Worksheet
Set wks = ActiveSheet
If sPrinter = "" Then sPrinter = "Brother MFC-J6710DW Printer"
If fncPrinter_plus_Port(sPrinter) = "" Then
MsgBox "Drucker """ & sPrinter & """ nicht gefunden"
Else
wks.PageSetup.PrintArea = "A:F" 'kann man weglassen, wenn schon manuel gesetzt
wks.PrintOut from:=Seite_von, to:=Seite_bis, ActivePrinter:=sPrinter
End If
End Sub
Function fncPrinter_plus_Port(strPrinter) As String
'gibt Druckername inklusive Port zurück
'muss für neuere Windows-Versionen oder 64-bit-Systeme evtl angepasst werden
Dim WSHShell As Object
Dim objWMI As Object, objItem As Object
Dim sKEY As String
Set WSHShell = CreateObject("WScript.Shell")
Select Case Environ("OS")
Case "Windows_NT"
Set objWMI = GetObject("winmgmts:\\.\root\cimv2").ExecQuery( _
"Select * from Win32_Printer")
Case Else
MsgBox "Set objWMI in Function """ & fncPrinter_plus_Port _
& """ muss bezüglich Betriebssystem angepasst werden!"
Exit Function
End Select
For Each objItem In objWMI
Select Case Environ("OS")
Case "Windows_NT"
sKEY = "HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Devices\" _
& objItem.Name
Case Else
MsgBox "sKEY in Function """ & fncPrinter_plus_Port _
& """ muss bezüglich Betriebssystem angepasst werden!"
Exit Function
End Select
If LCase(objItem.Name) = LCase(strPrinter) Then
fncPrinter_plus_Port = objItem.Name & " " _
& Replace(WSHShell.RegRead(sKEY), "winspool,", "auf ")
Exit For
End If
Next objItem
Set WSHShell = Nothing: Set objWMI = Nothing: Set objItem = Nothing
End Function