Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1024to1028
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Druck per Makro

Druck per Makro
Mareike
Hallo zusammen!
Ich habe eine große Excel-Arbeitsmappe mit rd. 100 Tabellenblättern.
Nun würde ich gerne per Druck-Button über ein Makro steuern, dass der Anwender zum einen auswählen kann, welche Tabellenblätter er ausdrucken kann dann im zweiten Step soll er sich seinen Drucker auswählen können (spirch wie das normale Druckmenü).
Am besten wäre es für den Anwender, wenn man quasi Häkchen setzen könnte, für die Blätter, welche man ausdrucken kann und er bei der Auswahl die Registernamen sieht. Geht sowas?
Danke fü+r eure Hilfe.
Mareike

42
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
Teil 1
Reinhard
Hi Mareike,

Sub DruckseiteErstellen()
Dim wks As Worksheet, T As Long, L As Long, W As Long, H As Long, Box As Object
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 = "Wählen sie die zu druckenden Blätter aus."
Range("A1").Font.Bold = True
Range("E1").Select
ActiveWindow.DisplayGridlines = False
L = 10
T = 20
For Each wks In ThisWorkbook.Worksheets
Set Box = ActiveSheet.CheckBoxes.Add(L, T, W, H)
With Box
.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
Application.ScreenUpdating = True
End Sub
Sub Nix()
End Sub

Gruß
Reinhard

Anzeige
AW: Teil 1
Mareike
Das sieht ja schon mal sehr gut aus mit der Auswahlmöglichkeit. Klasse.
Fast fertig
Reinhard
Hallo Mareike,
mit gemopstem Code von Nepumuk habe ich da was gebastelt. Es fehlr nur noch das eigentliche Drucken in der Prozedur Drucken. Ich muß/will jetzt aber weg. Vielleicht bastelt ja jmd. anders den fehlen ode teil, irgendwas mit Activeprinter und Printout...

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:B100").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
.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()
If Range("D1")  "Druckerauswahl:" Then
MsgBox "Ich drucke jetzt"
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)
'        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


Gruß
Reinhard

Anzeige
AW: Fast fertig
Mareike
Wow - kurz reingeschaut. Das ja schon ziemlich genial! Vielen Dank! Hoffe, den Rest kriegt hier noch jmd. hin. Nochmals danke. Total super eure Hilfe hier!
feddisch *glaub* :-)
Reinhard
Hallo Mareike,
ich habe nur einen Drucker, also nur eingeschränkte Testmöglichkeiten. Teste es mal und gib bitte Rückmeldung ob es bei dir läuft und auch bei anderen PCs. Getestet auf XL2000.
Insbesondere interessiert mich, ob es klappt, daß nach dem Ausdruck der X Blätter auf Drucker Y wieder korrekt der Standarddrucker eingestellt wird.
Wenn du es testen willst, es langt ja auch eine neue mappe mit 3 Blättern zum Testen. Unbedingt in jedes Blatt z.B. in A1 was reinschreiben, denn leere Blätter druckt Excel nicht (*fluch* hat mich viel verlorene zeit gekostet dies rauszufinden weil ich immer dachte mein Code stimmt nicht)
Die Rückstellung auf den Standarddrucker kannst du prüfen mit:
Sub tt
msgbox application.activeprinter
end sub

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


Gruß
Reinhard

Anzeige
AW: feddisch *glaub* :-)
Mareike
Hallo.
So, bei mir erscheint beim Ausführen des Drucken Button leider eine Fehlermeldung "Fehler ebim komplilieren" -
Application.ActivePrinter = Range("D1") & " auf " & Application.VLookup(Range("D1"), Range(" _
B:C"), 2, 0)
Das markiert er mir dann rot. Woran kann dies liegen?
AW: feddisch *glaub* :-)
Reinhard
Hallo Mareike,
bei Antworten hier hast du oben rechts die Möglichkeit die Frage auf noch offen zu stellen, so wie ich es hier mache. Sie wird dann mehr gelesen.
Vielleicht ging was beim Kopieren schief, schreib mal die Feherlzeile in eine Zeile, also daß sie hinten so aussieht:
...Application.VLookup(Standarddrucker, Range("B:C"), 2, 0)
Bei mir kam der Fehler nicht, also weiß ich grad nix.
Gruß
Reinhard
Anzeige
AW: feddisch *glaub* :-)
Mareike
Danke für den Tipp @noch offen.
Also im Sub Drucken markiert er mir diese Zeile:
"Application.ActivePrinter = Range("D1") & " auf " & Application.VLookup(Range("D1"), Range(" _
B:C"), 2, 0)" und es kommt der Fehler, dass es einen Syntaxfehler gibt - Fehler beim kompilieren. Was auch immer das heißt? - bin doch blond :-)
In Zelle D ließt er mir brav alle meine Drucker aus und egal, welchen ich auswähle. Immer erscheint dieser Fehler.
AW: feddisch *glaub* :-)
Hajo_Zi
Hallo Mareike,
hast Du mal die 2 Zeilen zu einer Zeile zusammengefast. Das Forum bricht die Zeilen mal an den umöglichen Stellen um.

Anzeige
AW: feddisch *glaub* :-)
Dieter
Ich glaube das soll so sein.
AW: feddisch *glaub* :-)
Reinhard
Hallo Mareike,
blond ist doch kein Problem, meine beiden Schwestern sind blond, komme mit Ihnen bestens klar :-)
Schau dir mal die nächsten 10 Sätze an, es langt ja wenn du einen davon umsetzt *schwergrins*
Mach das was ich und Hajo dir geraten haben.
Mach das was ich und Hajo dir geraten haben.
Mach das was ich und Hajo dir geraten haben.
Mach das was ich und Hajo dir geraten haben.
Mach das was ich und Hajo dir geraten haben.
Mach das was ich und Hajo dir geraten haben.
Mach das was ich und Hajo dir geraten haben.
Mach das was ich und Hajo dir geraten haben.
Mach das was ich und Hajo dir geraten haben.
Mach das was ich und Hajo dir geraten haben.
:-)
Gruß
Reinhard
Anzeige
AW: feddisch *glaub* :-)
Mareike
ich werd mal versuchen alle umzusetzen... :-)
AW: feddisch *glaub* :-)
Mareike
OK, jetzt habe ich verstanden. Mache ich sofort mal.
AW: feddisch *glaub* :-)
Mareike
OK, daran lag es . Sorry, wusste ich leider nicht. Er druckt jetzt brav die ausgewählten Blätter und es ist auch weiterhin mein Standarddrucker aktiviert nach dem Druck. Ich habe u.a. auch einen PDF Drucker "Free-PDF" - hier druckt er mir leider immer nur eine 1 Seite rein.
Erst einmal ein riesen DANKESCHÖN für deine/eure Mühen. KLasse!
AW: feddisch *glaub* :-)
Reinhard
Hallo Mareike,
freut mich daß mein Code funktioniert hat *stolzschau*
Das mit dem PDF, soweit ich unklar weiß installiert man sich da Software die einen nicht realen Drucker darstellt. Wenn man dann auf diesem Drucker drucken will, wird die xls in pdf umgewandelt und dann mit dem Standarddrucker ausgedruckt.
Egal ob ich mit dieser Einschäzung richtig liege oder nicht, ich hab nicht so PDF-Zeugs, kann also nix testen um herauszufiden wie man denn da den tatsächlichen Drucker auswählt.
Deshalb Frage noch offen.
Gruß
Reinhard
Anzeige
AW: feddisch *glaub* :-)
Hajo_Zi
Hallo Reinhard,
soweit mir bekannt wird bei Drucken auf PDF nur die Date erzeugt und nicht gedruckt.
Gruß Hajo
Druck in PDF
Mareike
So, das Makro funzt super. Nur beim Druck in PDF (über Free.pdf) gibt es ein Problem. Normaler DRuck über PDF ist ok - dabei macht er aber aus jeder Seite ein PDF. Daher nutzen wir free.pdf und drucken normal ein Multidoc. Hier druckt er jetzt aber nicht brav alles Seiten in ein PDF, sondern leider nur die 1 Seite. Kennt sich jmd. damit aus?
Druckauswahl erweitern
Mareike
Hallo Reinhard!
Sag einmal, kann man das ganze ev. so erweitern, dass als erstes ein Kästchen ist, bei dem man alles auswählen kann? Sind in der Praxis doch so um die 100 Tabellenblättern und manche wollen vielleicht auch alles haben. Nur, wenn es nicht zu viel Arbeit macht. Danke schon einmal.
Mareike
Anzeige
AW: Druckauswahl erweitern
Reinhard
Hallo Mareike,
am Anfang haben doch alle Blätter einen Haken, außer dem Blatt Druck !?
Ansonsten ist es schon machbar noch zwei Checkboxen einzubauen wo man a) alle Blätter aktivieren kann und b) all Blätter deaktivieren kann.
Gruß
Reinhard
AW: Druckauswahl erweitern
Mareike
Ja, richtig. Zu Beginn haben die Blätter alle ein Häkchen. Aber ich kenne die Anwender ja :-)... die klicken erst einmal und hinterher wollen sie dann doch wieder alle auswählen/deaktivieren. Wenn es ohne großen Umstand möglich ist, wäre ich dir sehr dankbar. Schönen Sonntag noch! Mareike
Kleine Erweiterung im Makro
Mareike
Hallo Reinhard!
Guten Morgen erst einmal. Ich habe da noch eine kleine Bitte.
Zum einen wäre es toll, wenn du das Makro erweitern könntest, dass es als erste Option die Möglkichkeit gibt, alle Blätter zu markieren oder dies zu deaktivieren.
Zudem sind einige Tabellenblätter in der Arbeitsmappe eher informativ und zur Steuerung gedacht, d.h. es wäre super, wenn ich diese gar nicht erst in der Druckauswahl sehen würde. Kann man z.B. an einer Stelle dann direkt Tabellenblätter über den Registernamen an sprechen, dass sie nicht berücksichtigt werden? Eines heißt "Basisblatt" und das andere "Erläuterungen".
Und die dritte Sache - es werden bei mir jetzt immer (habe es bisher an einem Beispiel mit 3 Tabellenblättern getestet) 20 Kästchen gesetzt und dann geht es in der Breite so weiter. Eleganter wäre es, wenn alle untereinander erscheinen würden? Ist das ebenfalls machbar.
Ich weiß, wir Frauen haben immer Sonderwünsche - sorry. Vielen Dank nochmals für deine Hilfe.
Mareike
Anzeige
AW: Kleine Erweiterung im Makro
Reinhard
Hi Mareike,
wie kommen bei 3 Blättern 20 Kästchen zusammen *staun*
Teste doch mal richtig, mit 100 Bättern, rufe dazu in einer neuen leeren Mappe die prozedur
TestBlätterErzeugen
auf. Nicht in der eigentlichen Mappe starten, denn die Prozedur löschte alle Blätter außer den ersten drei Blättern ! Es werden dann 97 Blätter hinten angefügt.
Blatt4 hat dann den namen "Basisblatt", Blatt5 den Namen "Erläuterungen".
Beide Blätter und das Blatt "Druck" werden bei der Druckblattauswahl nicht aufgelistet.
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 TestBlätterErzeugen()
Dim N As Long, wks As Worksheet
Application.ScreenUpdating = False
Call Loeschen
For Each wks In Worksheets
wks.Range("A1") = "jgkfjd"
Next wks
For N = 4 To 100
Worksheets.Add after:=Worksheets(Worksheets.Count)
Range("A1") = "jgkfjd"
ActiveSheet.Name = "Blatt" & N
Next N
Worksheets("Blatt4").Name = "Basisblatt"
Worksheets("Blatt5").Name = "Erläuterungen"
Worksheets(1).Activate
Call DruckseiteErstellen
Application.ScreenUpdating = True
End Sub
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 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 Worksheets
If wks.Name  "Druck" And wks.Name  "Basisblatt" And wks.Name  "Erläuterungen" Then
Set Box = ActiveSheet.CheckBoxes.Add(L, T, W, H)
With Box
.Name = wks.Name
.Value = 1
.OnAction = "Nix"
.Characters.Text = wks.Name
End With
T = T + 20
If T Mod 420 = 0 Then
L = L + 90
T = 20
End If
End If
Next wks
Set Knopp = ActiveSheet.Buttons.Add(L + 90, 20, 160, 30)
Knopp.OnAction = "Drucken"
Knopp.Characters.Text = "Drucken der ausgewählten Blätter"
Application.ScreenUpdating = True
Set Box = ActiveSheet.CheckBoxes.Add(L + 90, 60, 130, 15)
Box.Name = "Alle"
Box.Characters.Text = "Alle Blätter aktivieren"
Box.OnAction = "Alle"
Set Box = ActiveSheet.CheckBoxes.Add(L + 90, 80, 130, 15)
Box.Name = "Keine"
Box.Characters.Text = "Alle Blätter DEaktivieren"
Box.OnAction = "Keine"
End Sub
Sub Loeschen()
Dim W As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For W = Worksheets.Count To 4 Step -1
Worksheets(W).Delete
Next W
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub Nix()
ActiveSheet.Shapes("Keine").ControlFormat.Value = -4146
ActiveSheet.Shapes("Alle").ControlFormat.Value = -4146
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 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
Sub Alle()
Dim wks As Worksheet
ActiveSheet.Shapes("Keine").ControlFormat.Value = -4146
For Each wks In Worksheets
If wks.Name  "Druck" And wks.Name  "Basisblatt" And wks.Name  "Erläuterungen" Then
ActiveSheet.Shapes(wks.Name).ControlFormat.Value = 1
End If
Next wks
End Sub
Sub Keine()
Dim wks As Worksheet
ActiveSheet.Shapes("Alle").ControlFormat.Value = -4146
For Each wks In Worksheets
If wks.Name  "Druck" And wks.Name  "Basisblatt" And wks.Name  "Erläuterungen" Then
ActiveSheet.Shapes(wks.Name).ControlFormat.Value = -4146
End If
Next wks
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


AW: Kleine Erweiterung im Makro
Mareike
Da hast du mich missverstanden :-)... am WE habe ich nur mit 3 Tabellen gestetest und heute dann in der richtigen Arbeitsmappe (diese hat über 100 Tabellenblätter) und da ist es mir dann erst aufgefallen. Sonst wäre es in der Tat erstaunlich... aber so blond bin ich dann auch noch nicht :-)
Also der Test geht. Das mit dem Häkchen setzen läuft und die 2 Blätter werden nicht mit ausgewiesen.
AW: Kleine Erweiterung im Makro
Reinhard
Hallo Mareike,
also ist alles erledigt bis auf das mit dem FreePDF?
Nimm bitte sicherheitshalber die Prozeduren "Loeschen" und "testblätterErzeugen" aus dem Modul heraus, damit ausgeschlossen ist, daß sie mal in der originalmappe gestartet werden.
Am besten Einfügen--Modul, sie dorthinein verschieben, dann dieses neue Modul exportieren (wird als .bas gespeichert) und denn entfernen.
(Rechtsklick auf den Modulnamen...)
Bei Bedarf kannst du das Modul wieder fix per Importieren einbauen in eine Mappe.
An gleicher Stelle, also Rechtsklick auf den namen kannst du mit "Eigenschaften des projektes---Schutz eine Kennwort vergeben, sodaß man nur mit Kennwort den Code sehen kann.
Empfiehlt sich wenn du die Mappe verschicken willst.
Gruß
Reinhard
AW: Kleine Erweiterung im Makro
Mareike
Habe die beiden Prozeduren raus genommen und die Druckseite wird auch sauber erzeugt. Aber wenn ich nun auf drucken klicke, kommt eine Fehlermeldung "Laufzeitfehler" - Das Element mit dem angegebenen Namen wurde nicht gefunden.
Was habe ich nun falsch gemacht? Gott, ich weiß, es ist schlimm mit mir. Verzeih mir...
AW: Kleine Erweiterung im Makro
Mareike
ach ja, dies wird markiert:
If ActiveSheet.Shapes(wks.Name).ControlFormat.Value = 1 Then wks.PrintOut
AW: Kleine Erweiterung im Makro
Reinhard
Hallo Mareike,
der Fehler mit dem nicht gefunden müßte mit dem nachstehenden Code weg sein, Problem ist imm noch das PDFs zeugs. Da habe ich was eingebaut, scheint aber nicht recht zu klappen wie ich mir das wünsche.
Zum Hintergrund, da kommt ja dieses Fenster wo man Multidoc anklicken kann, anstatt Anklicken kann man auch Alt+m drücken.
Dieses Drücken von Alt+m simuliere ich im Code durch Sendkeys:
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys IIf(A = Anz, "%a", "%m")
Die 2 im Wait bedeutet, warte 2 Sekunden im Codeausführen (damit auch das Fensterchen da ist),danach wird mit Sendkeys quasi die tastenkombination Alt+m an das Fensterchen geschickt.
Nun ist Sendkeys deshalb in Verruf, weilman nicht kontrollieren kann wohin es denn nun Alt+m sendet. Sendkeys sendet es stur an das Fenster was für Sendkeys in dem Augenblick das aktive Fenster ist.
Und dasmuß halt nicht das Auswahlfensterchen von FreePDF sein, sondern kann ein Popup-Fenster von der Fireawall sein,von Zonealarm, von sonstwas.
Das mal jetzt so gesagt zur Fehleranfälligkeit des Codes bzw. Sendkeys.
Wie auch immer, probiere mal den neuen Code. Danach probiere ihn mal indem du die Sendkeyszeile durch
Application.SendKeys "%m"
ersetzt.
Anschließend druckst du manuell eine beliebige Seite aus mit FreePDF, dabei wählst du aus: Abspeichern in dem Fenster.
Wenn dann die erzeugte PDF so ist wie du das willst sind wir schon mal einen Schritt weiter :-)
Und, danke für deine Erläuterung, ich habe jetzt kapiert wie ich eine pdf mittels multidoc erzeuge :-)
Nachfolgend der Code
Achja, wenn beim Codeablauf der Curser einfriert und sich scheinbar nix mehr tut, keine Panik, macht er jedesmal, weiß nicht warum, aber dauert nur so 2-3 Minuten.
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 TestBlätterErzeugen()
Dim N As Long, wks As Worksheet
Application.ScreenUpdating = False
Call Loeschen
For Each wks In Worksheets
wks.Range("A1") = "jgkfjd"
Next wks
For N = 4 To 100
Worksheets.Add after:=Worksheets(Worksheets.Count)
Range("A1") = "jgkfjd"
ActiveSheet.Name = "Blatt" & N
Next N
Worksheets("Blatt4").Name = "Basisblatt"
Worksheets("Blatt5").Name = "Erläuterungen"
Worksheets(1).Activate
Call DruckseiteErstellen
Application.ScreenUpdating = True
End Sub
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 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 Worksheets
If wks.Name  "Druck" And wks.Name  "Basisblatt" And wks.Name  "Erläuterungen" Then
Set Box = ActiveSheet.CheckBoxes.Add(L, T, W, H)
With Box
.Name = wks.Name
.Value = 1
.OnAction = "Nix"
.Characters.Text = wks.Name
End With
T = T + 20
If T Mod 420 = 0 Then
L = L + 90
T = 20
End If
End If
Next wks
Set Knopp = ActiveSheet.Buttons.Add(L + 90, 20, 160, 30)
Knopp.OnAction = "Drucken"
Knopp.Characters.Text = "Drucken der ausgewählten Blätter"
Application.ScreenUpdating = True
Set Box = ActiveSheet.CheckBoxes.Add(L + 90, 60, 130, 15)
Box.Name = "Alle"
Box.Characters.Text = "Alle Blätter aktivieren"
Box.OnAction = "Alle"
Set Box = ActiveSheet.CheckBoxes.Add(L + 90, 80, 130, 15)
Box.Name = "Keine"
Box.Characters.Text = "Alle Blätter DEaktivieren"
Box.OnAction = "Keine"
End Sub
Sub Loeschen()
Dim W As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For W = Worksheets.Count To 4 Step -1
Worksheets(W).Delete
Next W
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub Nix()
ActiveSheet.Shapes("Keine").ControlFormat.Value = -4146
ActiveSheet.Shapes("Alle").ControlFormat.Value = -4146
End Sub
Sub Drucken()
Dim S As Shape, Anz As Long, A As Long
If Range("D1")  "Druckerauswahl:" Then
Application.ActivePrinter = Range("D1") & " auf " & Application.VLookup(Range("D1"), Range(" _
B:C"), 2, 0)
For Each S In ActiveSheet.Shapes
If S.Name Like "Drop*" Or S.Name Like "Button*" Then
Else
If S.Name  "Druck" And S.Name  "Basisblatt" And S.Name  "Erläuterungen" Then
If S.ControlFormat.Value = 1 Then Anz = Anz + 1
End If
End If
Next S
If Anz = 0 Then Exit Sub
For Each S In ActiveSheet.Shapes
If S.Name Like "Drop*" Or S.Name Like "Button*" Then
Else
If S.Name  "Druck" And S.Name  "Basisblatt" And S.Name  "Erläuterungen" Then
If S.ControlFormat.Value = 1 Then Worksheets(S.Name).PrintOut
A = A + 1
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys IIf(A = Anz, "%a", "%m")
End If
End If
Next S
Application.ActivePrinter = Standarddrucker & " auf " & Application.VLookup(Standarddrucker,  _
Range("B:C"), 2, 0)
Else
MsgBox "Kein Drucker ausgewählt!", vbCritical
End If
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 Worksheets
'      If wks.Name  "Druck" And wks.Name  "Basisblatt" And wks.Name  "Erläuterungen" Then
'         If ActiveSheet.Shapes(wks.Name).ControlFormat.Value = 1 Then wks.PrintOut
'         Application.Wait (Now + TimeValue("0:00:02"))
'         Application.SendKeys "%m"
'      End If
'   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
Sub Alle()
Dim wks As Worksheet
ActiveSheet.Shapes("Keine").ControlFormat.Value = -4146
For Each wks In Worksheets
If wks.Name  "Druck" And wks.Name  "Basisblatt" And wks.Name  "Erläuterungen" Then
ActiveSheet.Shapes(wks.Name).ControlFormat.Value = 1
End If
Next wks
End Sub
Sub Keine()
Dim wks As Worksheet
ActiveSheet.Shapes("Alle").ControlFormat.Value = -4146
For Each wks In Worksheets
If wks.Name  "Druck" And wks.Name  "Basisblatt" And wks.Name  "Erläuterungen" Then
ActiveSheet.Shapes(wks.Name).ControlFormat.Value = -4146
End If
Next wks
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


AW: Kleine Erweiterung im Makro
Mareike
Nicht wundern. Kann es erst morgen früh testen.
Super - fast fertig! :-)
Mareike
Guten Morgen.
Also, ich habe deinen neuen Code genommen. Die beiden Prozeduren wieder rausgenommen und es gestestet. Sowohl auf dem normalen Drucker als auch mit Free-PDF hat alles wie gewünscht geklappt. Vielen Dank auch für die ausführlichen Infos - das hilft euch, um ein Verständnis zu bekommen. Super!
Den Test mit Application.SendKeys "%m" habe ich jetzt nicht gemacht. Wofür ist der notwendig? Bzw. brauche ich den noch, wenn alles läuft?
Eine Frage habe ich nun natürlich noch... :-)...die Registernamen sind bei mir sehr lang (alle Zeichen ausgereizt; Frau verschenkt ja nix). D.h. aktuell sind die Namen dann nicht komplett lesbar in der Druckseite.
Wenn ich bei Dim Knop W = 70 auf mehr als 70 setze erweiter ich das Feld und es wird lesbar. Das habe ich ja erkannt, aber wie verbreitere ich den Abstand in der Breite, bis das nächste Feld kommt? Sonst sitzen die ja übereinander? An welcher Stelle definierst du dies?
Ansonsten ist alles so wunderbar - du bist echt ein Genie! Total toll, wie einem hier geholfen wird.
In der Tat dauert friert nach Ausführen des Druckens erst einmal alles für locker 3 Minuten ein. Das ist nicht elegant, aber du hast schon so viel für mich gemacht. Aber vielleicht hat ja jmd. einen Tipp, woran es liegen kann? Danke, danke, danke...
Mareike
AW: Super - fast fertig! :-)
Reinhard
Hallo Mareike,
in der Prozedur "DruckseiteErstellen" füge ich ja die Checkboxen ein mit
Set Box = ActiveSheet.CheckBoxes.Add(L, T, W, H)
wobei gilt:
L=left
T=top
W=widht
H=height
W hast du richtig erkannt und vergrößert.
Mit L legt man fest welchen Anstand die Checkboxen nach links haben
Startwert vor der Schleife ist L=10, in der Schleife wird L erhöht durch
L=L+90
an der Stelle mußt du die 90 vergrößern.
Zeitdelay kann kommen durch .printout, also den eigentlichen Druckbefehl, der ist immer langsam, okay, weiß ich jetzt nicht bei FreePDF.
Weiterhin steht ja in der Prozedur "Drucken"
Application.Wait (Now + TimeValue("0:00:02"))
Die 2 bedeutet warte zwei Sekunden an dieser Stelle.
100 Blätter a 2 Sekunden ergeben 200 Sekunden, also schon mal locker 3 Minuten reine Wartezeit.
Lösche diese Zeile und ersetze sie durch
Sleep 800
Bei Sleep kannst du hinten die Schlafzeit in Millisekunden angeben, also viel genauer vorgehen wie bei Wait, was nur ganze Sekunden kennt.
Damit das auch funktioniert mußt du ganz oben im Modul, unter Option Explcit folgendes reinkopieren:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMS As Long)
Probiere das halt mal mit mehreren Zahlen bei Sleep aus.
Letztlich braucht man ja nur so lange zu warten bis das Fensterchen mit dem Multidoc usw. erscheint.
Dessen Erscheinungszeit kann sich aber verzögern, wenn genau in diesem Moment deine Firewall, irgendein Updater, sonstwas, viel vom Prozessor in Beschlag nimmt.
Bedenke auch, deine Datei kann ja auch mal auf einem Rechner laufen der nur halb so schnell wie deiner ist,dann dauert das Fensterchen ggfs.auch länger bis man es sieht.
Gruß
Reinhard
AW: Super - fast fertig! :-)
Mareike
Perfekt. Nun kann ich auch alle Register lesen. Die Application-Zeile (komplett) ... nur durch Sleep 800 ersetzen und da mit der Zahl verschiedene Angaben testen? Und die andere Zeile vor oder statt
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" ( _
Danke noch mal. Ach ja, ich hatte diese lange Wartezeit aber auch schon beim Druck nur einer Seite...
AW: Super - fast fertig! :-)
Mareike
Hallo Reinhard,
kann es sein, dass durch das Sleep und Umstellen jetzt das mit dem PDF nicht mehr sauber läuft? Habe jetzt beim Testen leider wieder einzelne PDF's. Ich weiß, ich bring dich gleich zum Verzweifeln :-)
Mareike
AW: Super - fast fertig! :-)
Reinhard
Hallo Mareike,
auch mit
Sleep 2000
?
Gruß
Reinhard
AW: Super - fast fertig! :-)
Mareike
Hallo Reinhard,
habe es auf 2000 geändert. Leider dauert es zum einen echt immer noch super lange bis es durch ist und zum anderen ist es hinterher wieder einzelne Seiten. Es ging ja schon, dass es durchlief und am Ende nur noch abgelegt werden musste. Verstehe ich nicht...
AW: Druck per Makro
Rocky
Hallo Mareike,
da haben schon andere etwas erfunden.
http://www.add-in-world.com/katalog/xldruckertools/
da kannst du kostenfrei anmelden. (kann es empfehlen)
Es wird dann ein Addin installiert. Das hat alles was du suchst.

Gruß Rocky



Wenn unter den Blinden der Einäugige König ist, dann findet man hier die Herren der Ringe!


AW: Druck per Makro
Rocky
Hallo Mareike,
da haben schon andere etwas erfunden.
http://www.add-in-world.com/katalog/xldruckertools/
da kannst du kostenfrei anmelden. (kann es empfehlen)
Es wird dann ein Addin installiert. Das hat alles was du suchst.

Gruß Rocky



Wenn unter den Blinden der Einäugige König ist, dann findet man hier die Herren der Ringe!


ups, doppelt wie peinlich.
Rocky
PS: die Registrierung und auch der Code sind kostenlos.

Gruß Rocky



Wenn unter den Blinden der Einäugige König ist, dann findet man hier die Herren der Ringe!


AW: ups, doppelt wie peinlich.
Mareike
Danke für denm Hinweis. Frage vorab - wenn es über AddIn ist, ist es eine Lösung für den jeweiligen PC, oder? Wenn ich die Mappe anderen zur Verfügung stelle und die dieses AddIn nicht installiert haben, steht denen die Funktion nict zur Verfügung, oder? Darum mein Gedabke mitttels Makro. Und der erste Part von Reinhard sieht ja schon super aus.
AW: ups, doppelt wie peinlich.
Rocky
Ja das stimmt. Aber man muss das Rad nicht zweimal erfinden. Das addin ist sehr umfangreich. _ Hab es selbst du bin begeistert. Das alles selbst zu programmieren ist mir zu mühsehlig gewesen. Aber wenn du das dir zutraust, dann wünsche ich dir viel Erfolg. Die Lösungen des Mitposters sind super. Danke für die Rückmeldung.

Gruß Rocky



Wenn unter den Blinden der Einäugige König ist, dann findet man hier die Herren der Ringe!


weiter an Makrolösung interessiert
Mareike
Ja, grundsätzlich hast du Recht. Ist verdammt schwer und darum brauche ich hier auch die Hilfe. Da es bei mir Arbeitsmappen sind, die vielen Anwender zur Verfügung gestellt werden ist die Lösung mit dem AddIn nur meine B-Lösung. Genial wäre der Ansatz über Makro. Vielleicht gibt es ja noch Hilfe für den 2. Teil. Danke erst einmal allen!
Fast geschafft - Activeprinter und Printout
Mareike
Der Code von reinhard ist schon super - es fehlt nur noch das eigentliche Drucken in der Prozedur Drucken. Vielleicht bastelt ja jmd. anders den fehlenden Teil, irgendwas mit Activeprinter und Printout... DANKE für eure Hilfe.
Letzte Hilfe für Activeprinter und Printout
Mareike
Schafft es einer, mir beim Rest behilflich zu sein? DANKE!
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:B100").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
.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()
If Range("D1") "Druckerauswahl:" Then
MsgBox "Ich drucke jetzt"
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)
'        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 



Private Sub prcGetPrinterPorts()
Dim strBuffer As String
Dim intIndex As Integer
For intIndex = 0 To intPrinterCount - 1
strBuffer = Space$(1024)
GetProfileString "PrinterPorts", strPrinterNames(intIndex), "", _
strBuffer, Len(strBuffer)
prcGetDriverAndPort strBuffer, strPrinterDrivers(intIndex), _
strPrinterPorts(intIndex)
Next
End Sub



Private Sub prcGetDriverAndPort(ByVal Buffer As String, _
DriverName As String, PrinterPort As String)
Dim intDriver As Integer
Dim intPort As Integer
DriverName = ""
PrinterPort = ""
intDriver = InStr(Buffer, ",")
If intDriver > 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


Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige