Hallo Interessierte,
aufgrund einer Anfrage in einem anderen Forum habe ich Code gebastelt.
Der Code ist dann hilfreich wenn man viele Tabellenblätter hat und mal so mal so nur einige davon drucken will und dann noch den Drucker auswählen will auf dem sie gedruckt werden.
Noch ungeklärt ist warum es mit dem Code Probleme gibt mit PDF-Druckern, da wird wohl nur eine Seite gedruckt. Ansonsten scheint er zu funktionieren.
Um den Code in einer Mappe zu installieren, Alt+F11, Einfügen–Modul, Code reinkopieren, VB-Editor schließen.
Starten des Codes mit Alt+F8 und „DruckseiteErstellen“ ausführen lassen.
Gruß
Reinhard
Option Explicit
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" ( \_
ByVal lpAppName As String, \_
ByVal lpKeyName As String, \_
ByVal lpDefault As String, \_
ByVal lpReturnedString As String, \_
ByVal nSize As Long) As Long
Private Const MAX\_PRINTERS = 16
Private strPrinterNames(MAX\_PRINTERS) As String
Private strPrinterDrivers(MAX\_PRINTERS) As String
Private strPrinterPorts(MAX\_PRINTERS) As String
Public intPrinterCount As Integer
'
Sub DruckseiteErstellen()
Dim wks As Worksheet, T As Long, L As Long, W As Long, H As Long, Box As Object
Dim Knopp
W = 70
H = 10
Application.ScreenUpdating = False
For Each wks In ThisWorkbook.Worksheets
If wks.Name = "Druck" Then
Application.DisplayAlerts = False
wks.Delete
Application.DisplayAlerts = True
Exit For
End If
Next wks
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Druck"
Range("A1").Value = "Drucker- und Blattauswahl."
Range("A1").Font.Bold = True
Range("D1").Value = "Druckerauswahl:"
Range("D1").Font.Bold = True
Call prcGetPrinterList
Columns(2).AutoFit
Columns(4).ColumnWidth = Columns(2).ColumnWidth
Range("D1").Interior.ColorIndex = 35
With Range("D1").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= \_
xlBetween, Formula1:="=B2:B" & 1 + intPrinterCount
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Range("B2:c100").Font.ColorIndex = 2
Range("d1").Select
ActiveWindow.DisplayHeadings = False
ActiveWindow.DisplayGridlines = False
L = 10
T = 20
For Each wks In ThisWorkbook.Worksheets
Set Box = ActiveSheet.CheckBoxes.Add(L, T, W, H)
With Box
.Name = wks.Name
.Value = wks.Name "Druck"
.OnAction = "Nix"
Box.Characters.Text = wks.Name
End With
T = T + 20
If T Mod 420 = 0 Then
L = L + 90
T = 20
End If
Next wks
Set Knopp = ActiveSheet.Buttons.Add(L, T, 160, 30)
Knopp.OnAction = "Drucken"
Knopp.Characters.Text = "Drucken der ausgewählten Blätter"
Application.ScreenUpdating = True
End Sub
'
Sub Nix()
End Sub
'
Sub Drucken()
Dim wks As Worksheet, s
If Range("D1") "Druckerauswahl:" Then
Application.ActivePrinter = Range("D1") & " auf " & Application.VLookup(Range("D1"), Range("B:C"), 2, 0)
For Each wks In ThisWorkbook.Worksheets
If ActiveSheet.Shapes(wks.Name).ControlFormat.Value = 1 Then wks.PrintOut
Next wks
Application.ActivePrinter = Standarddrucker & " auf " & Application.VLookup(Standarddrucker, Range("B:C"), 2, 0)
Else
MsgBox "Kein Drucker ausgewählt!", vbCritical
End If
End Sub
'
Public Sub prcGetPrinterList()
Dim strBuffer As String
Dim intIndex As Integer
strBuffer = Space$(8192)
GetProfileString "PrinterPorts", vbNullString, "", \_
strBuffer, Len(strBuffer)
prcGetPrinterNames strBuffer
prcGetPrinterPorts
For intIndex = 0 To intPrinterCount
Worksheets("Druck").Range("B2").Offset(intIndex, 0) = strPrinterNames(intIndex)
Worksheets("Druck").Range("B2").Offset(intIndex, 1) = strPrinterPorts(intIndex)
' MsgBox strPrinterNames(intIndex) & "---" & \_
' strPrinterPorts(intIndex) & "---" & \_
' strPrinterDrivers(intIndex)
Next
End Sub
'
Private Sub prcGetPrinterNames(ByVal strBuffer As String)
Dim intIndex As Integer
Dim strName As String
intPrinterCount = 0
Do
intIndex = InStr(strBuffer, Chr(0))
If intIndex \> 0 Then
strName = Left$(strBuffer, intIndex - 1)
If Len(Trim$(strName)) \> 0 Then
strPrinterNames(intPrinterCount) = Trim$(strName)
intPrinterCount = intPrinterCount + 1
End If
strBuffer = Mid$(strBuffer, intIndex + 1)
Else
If Len(Trim$(strBuffer)) \> 0 Then
strPrinterNames(intPrinterCount) = Trim$(strBuffer)
intPrinterCount = intPrinterCount + 1
End If
strBuffer = ""
End If
Loop While (intIndex \> 0) And (intPrinterCount 0 Then
DriverName = Left$(Buffer, intDriver - 1)
intPort = InStr(intDriver + 1, Buffer, ",")
If intPort \> 0 Then
PrinterPort = Mid$(Buffer, intDriver + 1, \_
intPort - intDriver - 1)
End If
End If
End Sub
'
Function Standarddrucker() As String
Dim objWMI, objItem
Set objWMI = GetObject("winmgmts:\\.\root\cimv2"). \_
ExecQuery("Select \* from Win32\_Printer where Default = 'true'")
For Each objItem In objWMI
Standarddrucker = objItem.properties\_.Item("Name").Value
Next
End Function
Sub tt()
MsgBox Application.ActivePrinter
End Sub