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