Frage zu einem Fehler in meinem Makro

Moin an alle,
ich benötige mal wieder Eure Unterstützung. Ich habe eine Datei, in der ich es auch ermöglichen möchte, das Blätter als PDF Dokument erstellt werden sollen. Da ich im Vorfeld aber nicht weiß, ob auf jedem Rechner das dafür vorgesehene Freewareprogramm vorhanden ist, wollte ich es ermöglichen, dieses dann aus Excel heraus installieren zu lassen. Das funktioniert soweit. Nun habe ich aber festgestellt, dass wenn die Software installiert ist, scheinbar nicht immer die gleichen Einstellungen vorhanden sind, wenn es um den Druckanschluss geht. Auf einem Rechner belegt der Drucker scheinbar die Einstellung N01, auf einem anderen Ne03. Da es dadurch zu einem Fehler kommt, wurde mir immer, da ich mit einem Errorhandler arbeite, immer die Installationsroutine aufgerufen, obwohl die Software ja installiert war. Nun hatte ich mir gedacht, dass ich mehrer On Error Resume Next Anweisungen einbaue, aber das funktioniert leider nicht. Ich hatte das eben so gedacht, mal als Beispiel, der Drucker wird auf Ne04 installiert, dass in dem Makro bei Ne01 angefangen wird. Es wird festgestellt, dass es den Drucker da nicht gibt, und der Code soll zur zweiten Anweisung in dem Makro springen. Dort gibt es ebenfalls eine Fehlermeldung, da ebenfalls nicht vorhanden, also weiter zum Dritten und dann zum Vierten. Nur leider funktioniert das so, wie ich es mache leider nicht. Es kommt zu einem Fehler 1004 mit der Meldung, Die Methode ActivePrinter für das Objekt Application ist fehlgeschlagen und es wird mir bei der Sprungmarke Drucker2 die Zeile
Application.ActivePrinter = "FreePDF XP auf Ne02:"
gelb markiert.
Kann sich mal jemand das nachfolgende Makro ansehen und mir sagen, wo da der Hase im Pfeffer liegt.

Sub Kalender_als_PDF() Dim Pfad As String 'Wenn ein Fehler auftritt, dann zur Sprungmarke "Drucker_2" springen On Error GoTo Drucker_2 'Aktuellen Pfad ausleden und in Variable "Pfad" speichern Pfad = ThisWorkbook.Path 'Blatt an FreePDF übergeben Application.ActivePrinter = "FreePDF XP auf Ne01:" ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _ "FreePDF XP auf Ne01:", Collate:=True Exit Sub Drucker_2: 'Blatt an FreePDF übergeben On Error GoTo Drucker_3 Application.ActivePrinter = "FreePDF XP auf Ne02:" ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _ "FreePDF XP auf Ne02:", Collate:=True Exit Sub Drucker_3: 'Blatt an FreePDF übergeben On Error GoTo Drucker_4 Application.ActivePrinter = "FreePDF XP auf Ne03:" ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _ "FreePDF XP auf Ne03:", Collate:=True Exit Sub Drucker_4: 'Blatt an FreePDF übergeben On Error GoTo Drucker_5 Application.ActivePrinter = "FreePDF XP auf Ne04:" ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _ "FreePDF XP auf Ne04:", Collate:=True Exit Sub Drucker_5: 'Blatt an FreePDF übergeben On Error GoTo Drucker_6 Application.ActivePrinter = "FreePDF XP auf Ne05:" ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _ "FreePDF XP auf Ne05:", Collate:=True Exit Sub Drucker_6: 'Blatt an FreePDF übergeben On Error GoTo Drucker_7 Application.ActivePrinter = "FreePDF XP auf Ne06:" ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _ "FreePDF XP auf Ne06:", Collate:=True Exit Sub Drucker_7: 'Blatt an FreePDF übergeben On Error GoTo Drucker_8 Application.ActivePrinter = "FreePDF XP auf Ne07:" ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _ "FreePDF XP auf Ne07:", Collate:=True Exit Sub Drucker_8: 'Blatt an FreePDF übergeben On Error GoTo Drucker_9 Application.ActivePrinter = "FreePDF XP auf Ne08:" ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _ "FreePDF XP auf Ne08:", Collate:=True Exit Sub Drucker_9: 'Blatt an FreePDF übergeben On Error GoTo errorhandler Application.ActivePrinter = "FreePDF XP auf Ne09:" ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _ "FreePDF XP auf Ne09:", Collate:=True Exit Sub 'Sprungmarke "errorhandler" errorhandler: 'Wenn ein Fehler auftritt Select Case Err 'Wenn der Laufzeitfehler 1004 auftritt Case 1004 'Meldung am Bildschrim ausgeben Select Case MsgBox("Für diese Funktion muss das Freewareprogramm 'FreePDF' von Stefan Heinz im Zusammenhang mit 'AFPL GhostScript 8.51' installiert sein. Erst nach erfolgreicher Installation steht diese Funktion zur Verfügung." & Chr(13) & Chr(13) _ & "Möchten Sie die Programme jetzt installieren?", vbYesNo, "Fehler") 'Wenn die Meldung mit dem Button Ja angeklickt wird Case 6 'Die Datei "gs814w32.exe" ausführen Shell (Pfad & "\FreePDF\gs814w32.exe"), 1 'Pause von 10 Sekunden einlegen Application.Wait (Now + TimeValue("0:00:10")) 'Die Datei "FreePDFXP1.6.EXE" ausführen Shell (Pfad & "\FreePDF\FreePDFXP1.6.EXE"), 1 End Select 'Bei jedem anderen Fehler eine andere Fehlermeldung am Bildschirm 'ausgeben Case Else MsgBox "Es ist ein unerwarteter Fehler aufgetretren" End Select End Sub

Ich hoffe, es hat überhaupt jemand verstanden, was ich meine. Danke Euch jedenfalls schon mal jetzt für die Hilfe.
Schönen Mittwoch noch,
Oliver

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Oliver,
ein Beispielprogramm, wie du an die Printerports kommst:
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
Private intPrinterCount As Integer

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
        Debug.Print 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 < MAX_PRINTERS)
End Sub

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
Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Frage zu einem Fehler in meinem Makro

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread