VBA Printen naar XPS printer

oceanrace · 20 sep 2010

Hallo forummers,

Weet iemand hoe je een excel bestand via een macro kunt laten printen naar Microsoft Office Document Image Writer?
Ik heb al de hele dag gezocht maar kan niet echt een oplossing vinden....
Deze had ik gevonden, maar bij mij kan hij de driver niet vinden....
(Driver not found krijg ik als melding)

Code:

Sub f00()
    Dim PrinterName As String
    Dim PortNumber As Integer
    Dim PrinterPort As String
    Dim PrinterFullName As String
    Dim PrinterFound As Boolean
    Dim STDprinter As String
    Dim lCount As Long
    Dim GetFolderName As String
    Dim PrinterNumber
    '-------------------------------------------------------------------------
    STDprinter = Application.ActivePrinter
    GetFolderName = Get_Directory("Select Folder", "")
    If GetFolderName = "" Then Exit Sub
        
    PrinterName = "Microsoft XPS Document Writer"
    PrinterFound = False
    On Error Resume Next       ' SET ERROR TRAPPING
    '-------------------------------------------------------------------------
    '- LOOP Ne: NUMBERS
    For PortNumber = 0 To 12
        PrinterPort = "Ne" & Format(PortNumber, "00") & ":"
        PrinterFullName = PrinterName & PrinterNumber & " on " & PrinterPort
        '---------------------------------------------------------------------
        '- TRY TO SET ACTIVEPRINTER
        Application.ActivePrinter = PrinterFullName
        '---------------------------------------------------------------------
        '- IF ERROR TRY NEXT PRINTER
        If Err.Number = 0 Then
            Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
            ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, PrintToFile:=True, PrToFileName:=(Sheets("Sheet1").Range("A1").Value & ".xps")
            PrinterFound = True
            Sheets(Array("Sheet1")).Select
            Exit For
        Else
            Err.Clear   ' clear for next error
        End If
        '---------------------------------------------------------------------
    Next PortNumber
    '-------------------------------------------------------------------------
    '- RESULT
    If PrinterFound Then
     '   MsgBox ("Successfully Saved With" & vbCr & PrinterFullName)
    Else
        MsgBox (PrinterName & vbCr & "Driver not found")
    End If
    Application.ActivePrinter = STDprinter
    '------------------------------------------------------------------------

End Sub
'--------------------------------------------------------------------------------------
Function Get_Directory(ByRef strMessage As String, ByRef strInitialDirectory) As String
On Error GoTo BadDirections
Dim objFF As Object
Set objFF = CreateObject("Shell.Application").BrowseForFolder _
(0, strMessage, &H4000, strInitialDirectory)
If Not objFF Is Nothing Then
Get_Directory = objFF.items.Item.Path
Else
Get_Directory = vbNullString
End If
Set objFF = Nothing
Exit Function

BadDirections:
Set objFF = Nothing
Get_Directory = vbNullString
End Function

danny147 · 20 sep 2010

Beste oceanrace

Werk je met Excel 2007 ?
Zoja, dan kan je deze Opslaan Als PDF of XPS.

Voor Excel 2003 een converter zoeken op het internet.

groetjes Danny. :thumb:

oceanrace · 20 sep 2010

Hoi Danny,

Ik gaat om een beveiligd werkblad die alleen via macro opgeslagen mag worden.
Ik wil alleen blad1 als xps bestand opslaan.
Omdat ik veelal bij bedrijven werk met alleen excel 2003 en geen pdf kan maken lijkt me xps een goed alternatief.

oceanrace · 20 sep 2010

Ik heb de fout gevonden:

Code:

PrinterFullName = PrinterName & PrinterNumber & " on " & PrinterPort

moet zijn

Code:

PrinterFullName = PrinterName & PrinterNumber & " op " & PrinterPort

het woordje "on" moet in eigen taal.... dus "op" zijn.

Hij slaat alleen niet op de goede plaats op en ik wil graag de bestandsnaam kunnen wijzigen.
Daarna wil ik graag op papier printen via Msgbox en een keuze.
Weet iemand raad?

oceanrace · 20 sep 2010

Het printen op papier is inmiddels ook ingebouwd:

Code:

Sub f00()
    Dim PrinterName As String
    Dim PortNumber As Integer
    Dim PrinterPort As String
    Dim PrinterFullName As String
    Dim PrinterFound As Boolean
    Dim STDprinter As String
    Dim lCount As Long
    Dim GetFolderName As String
    Dim PrinterNumber
    '-------------------------------------------------------------------------
    STDprinter = Application.ActivePrinter
    GetFolderName = Get_Directory("Select Folder", "")
    If GetFolderName = "" Then Exit Sub
        
    PrinterName = "Microsoft XPS Document Writer"
    PrinterFound = False
    On Error Resume Next       ' SET ERROR TRAPPING
    '-------------------------------------------------------------------------
    '- LOOP Ne: NUMBERS
    For PortNumber = 0 To 12
        PrinterPort = "Ne" & Format(PortNumber, "00") & ":"
        PrinterFullName = PrinterName & PrinterNumber & " op " & PrinterPort
        '---------------------------------------------------------------------
        '- TRY TO SET ACTIVEPRINTER
        Application.ActivePrinter = PrinterFullName
        '---------------------------------------------------------------------
        '- IF ERROR TRY NEXT PRINTER
        If Err.Number = 0 Then
            Sheets(Array("kaart")).Select
            ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, PrintToFile:=True, PrToFileName:=(Sheets("kaart").Range("AG2").Value & ".xps")
            PrinterFound = True
            Sheets(Array("kaart")).Select
            Exit For
        Else
            Err.Clear   ' clear for next error
        End If
        '---------------------------------------------------------------------
    Next PortNumber
    '-------------------------------------------------------------------------
    '- RESULT
    If PrinterFound Then
      A = MsgBox("Wil je de kaart printen?", vbQuestion + vbYesNo, "Gelukt, de kaart is opgeslagen!")

      If A = vbYes Then
    
          Application.Dialogs(xlDialogPrint).Show
    Else
        MsgBox (PrinterName & vbCr & "Driver not found")
    End If
    Application.ActivePrinter = STDprinter
    '------------------------------------------------------------------------
  End If
End Sub
'--------------------------------------------------------------------------------------
Function Get_Directory(ByRef strMessage As String, ByRef strInitialDirectory) As String
On Error GoTo BadDirections
Dim objFF As Object
Set objFF = CreateObject("Shell.Application").BrowseForFolder _
(0, strMessage, &H4000, strInitialDirectory)
If Not objFF Is Nothing Then
Get_Directory = objFF.items.Item.Path
Else
Get_Directory = vbNullString
End If
Set objFF = Nothing
Exit Function

BadDirections:
Set objFF = Nothing
Get_Directory = vbNullString
End Function

Hij slaat alleen op een verkeerde plaats op en ik kan ook nog geen naam bekijken / wijzigen.
Dat is wat ik nu nog mis.

Warme bakkertje · 20 sep 2010

Om de juiste locatie aan te geven vraag je de directory op aan het begin van je macro. Gebruik dan ook de naam van deze variabele

Code:

PrToFileName:=[COLOR="red"]GetFolderName & "\" &[/COLOR] (Sheets("Sheet1").Range("A1").Value & ".xps")

De bestandsnaam wordt toch opgegeven in A1 van Blad1, nietwaar ???

oceanrace · 20 sep 2010

Warme bakkertje zei:
De bestandsnaam wordt toch opgegeven in A1 van Blad1, nietwaar ???

dat klopt, ik kan hem alleen niet wijzigen als dat nodig zou zijn.
Ook slaat hij altijd op in de map mijn documenten, terwijl ik een andere map aanwijs.

Warme bakkertje · 21 sep 2010

Deze werkt voor mij feilloos. Controleer enkel nog de bladnaam (rode tekst)

Code:

Sub f00()
    Dim PrinterName As String
    Dim PortNumber As Integer
    Dim PrinterPort As String
    Dim PrinterFullName As String
    Dim PrinterFound As Boolean
    Dim STDprinter As String
    Dim lCount As Long
    Dim GetFolderName As String
    Dim PrinterNumber
    '-------------------------------------------------------------------------
    STDprinter = Application.ActivePrinter
    GetFolderName = Get_Directory("Select Folder", "")
    If GetFolderName = "" Then Exit Sub
    fName = GetFolderName & "\" & [[COLOR="red"]Blad1[/COLOR]!A1] & ".xps"
    PrinterName = "Microsoft XPS Document Writer"
    PrinterFound = False
    On Error Resume Next       ' SET ERROR TRAPPING
    '-------------------------------------------------------------------------
    '- LOOP Ne: NUMBERS
    For PortNumber = 0 To 12
        PrinterPort = "Ne" & Format(PortNumber, "00") & ":"
        PrinterFullName = PrinterName & PrinterNumber & " op " & PrinterPort
        '---------------------------------------------------------------------
        '- TRY TO SET ACTIVEPRINTER
        Application.ActivePrinter = PrinterFullName
        '---------------------------------------------------------------------
        '- IF ERROR TRY NEXT PRINTER
        If Err.Number = 0 Then
            Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
            ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, PrintToFile:=True, PrToFileName:=fName
            PrinterFound = True
            Sheets(Array("Sheet1")).Select
            Exit For
        Else
            Err.Clear   ' clear for next error
        End If
        '---------------------------------------------------------------------
    Next PortNumber
    '-------------------------------------------------------------------------
    '- RESULT
    If PrinterFound Then
     '   MsgBox ("Successfully Saved With" & vbCr & PrinterFullName)
    Else
        MsgBox (PrinterName & vbCr & "Driver not found")
    End If
    Application.ActivePrinter = STDprinter
    '------------------------------------------------------------------------

End Sub

oceanrace · 21 sep 2010

Hoi Rudi,

Bravo!
Het lijkt hier ook goed te werken, ik ga vandaag eens testen.
De code lijkt ook sneller te zijn nu.

Bedankt!

oceanrace · 21 sep 2010

Met de functie

Code:

GetFolderName = Get_Directory("Select Folder", "")

kun je geen recente mappen kiezen en je kunt ook niet eventueel de bestandsnaam aanpassen.
Kan dat op een andere manier?
Eerder gebruikte ik

Code:

GetSaveAsFilename

maar ik weet niet of dat hier ook mogelijk is.

Warme bakkertje · 21 sep 2010

Code:

fName = Application.GetSaveAsFilename("D:\Mijn documenten", _
    "XPS Document Writer (*.xps),*.xps", 1)
If sName = False Then Exit Sub

De map die vermeld is de standaard startmap, deze kan je naar wens aanpassen
Als je in het deelvenster geen naam invult wordt de macro gestopt

oceanrace · 21 sep 2010

Het werkte de hele dag goed maar nu opeens krijg ik een compileerfout: Sub of Function is niet gedefinieerd bij :

Code:

GetFolderName = Get_Directory(

Verder is er niets gewijzigd

oceanrace · 21 sep 2010

De code van Warme Bakkertje die vanmorgen heel goed werkte in excel 2003 en 2007, geeft nu ineens een foutmelding Sub of Function is niet gedefinieerd.

Code:

Sub f00()
    Dim PrinterName As String
    Dim PortNumber As Integer
    Dim PrinterPort As String
    Dim PrinterFullName As String
    Dim PrinterFound As Boolean
    Dim STDprinter As String
    Dim lCount As Long
    Dim GetFolderName As String
    Dim PrinterNumber
    '-------------------------------------------------------------------------
    STDprinter = Application.ActivePrinter
    GetFolderName = Get_Directory("Select Folder", "")
    If GetFolderName = "" Then Exit Sub
    fName = GetFolderName & "\" & [Blad1!A1] & ".xps"
    PrinterName = "Microsoft XPS Document Writer"
    PrinterFound = False
    On Error Resume Next       ' SET ERROR TRAPPING
    '-------------------------------------------------------------------------
    '- LOOP Ne: NUMBERS
    For PortNumber = 0 To 12
        PrinterPort = "Ne" & Format(PortNumber, "00") & ":"
        PrinterFullName = PrinterName & PrinterNumber & " op " & PrinterPort
        '---------------------------------------------------------------------
        '- TRY TO SET ACTIVEPRINTER
        Application.ActivePrinter = PrinterFullName
        '---------------------------------------------------------------------
        '- IF ERROR TRY NEXT PRINTER
        If Err.Number = 0 Then
            Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
            ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, PrintToFile:=True, PrToFileName:=fName
            PrinterFound = True
            Sheets(Array("Sheet1")).Select
            Exit For
        Else
            Err.Clear   ' clear for next error
        End If
        '---------------------------------------------------------------------
    Next PortNumber
    '-------------------------------------------------------------------------
    '- RESULT
    If PrinterFound Then
     '   MsgBox ("Successfully Saved With" & vbCr & PrinterFullName)
    Else
        MsgBox (PrinterName & vbCr & "Driver not found")
    End If
    Application.ActivePrinter = STDprinter
    '------------------------------------------------------------------------

End Sub

Misschien dat iemand dit even kan testen op zijn pc....

Warme bakkertje · 21 sep 2010

Staat de functie GetDirectory ook in de standaardmodule van je bestand ? Ik heb de macro nog eens 2x getest en geen problemen gehad

oceanrace · 21 sep 2010

De hele code staat in een standaardmodule.
Ik volg je niet helemaal denk ik...

oceanrace · 22 sep 2010

Hij doet het weer, de macrobeveiliging "toegang tot visual basic-project vertrouwen"was niet aangevinkt

oceanrace · 25 sep 2010

Ik heb de code geprobeerd aan te passen met fName = Application.GetSaveAsFilename toevoeging, de getfoldername heb ik eruit gehaald. Nu stuurt hij echter niet meer naar de printer...

Code:

    Sub opslaanxps()
    Dim PrinterName As String
    Dim PortNumber As Integer
    Dim PrinterPort As String
    Dim PrinterFullName As String
    Dim PrinterFound As Boolean
    Dim STDprinter As String
    Dim lCount As Long
    Dim PrinterNumber
    '-------------------------------------------------------------------------
    STDprinter = Application.ActivePrinter
    fName = Application.GetSaveAsFilename([AG2], _
    "XPS Document Writer (*.xps),*.xps", 1)
    If sName = False Then Exit Sub
    PrinterName = "Microsoft XPS Document Writer"
    PrinterFound = False
    On Error Resume Next
    For PortNumber = 0 To 12
        PrinterPort = "Ne" & Format(PortNumber, "00") & ":"
        PrinterFullName = PrinterName & PrinterNumber & " op " & PrinterPort

        Application.ActivePrinter = PrinterFullName

        If Err.Number = 0 Then
            Sheets(Array("kaart")).Select
            ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, PrintToFile:=True, PrToFileName:=fName
            PrinterFound = True
            Sheets(Array("kaart")).Select
            Exit For
        Else
            Err.Clear
        End If

    Next PortNumber

    If PrinterFound Then
      A = MsgBox("Wil je  printen?", vbQuestion + vbYesNo, "Gelukt, opgeslagen als Microsoft XPS Document!")

      If A = vbYes Then
    
          Application.Dialogs(xlDialogPrint).Show

    End If
    Application.ActivePrinter = STDprinter

  End If
End Sub

Wie weet raad?
De bedoeling is dat ik het bestand via xps printer op kan slaan en daarna op de standaard printer uitprint op papier.
Met getfoldername zijn de mogelijkheden wat beperkt, recente folders etc kun je daarmee niet zoeken en de bestandsnaam kun je niet wijzigen.
Dit kan wel met Application.GetSaveAsFilename. Maar dan stuurt hij weer niet naar de printer

Warme bakkertje · 25 sep 2010

Code:

Sub opslaanxps()
    Dim PrinterName As String
    Dim PortNumber As Integer
    Dim PrinterPort As String
    Dim PrinterFullName As String
    Dim PrinterFound As Boolean
    Dim STDprinter As String
    Dim lCount As Long
    Dim PrinterNumber
    '-------------------------------------------------------------------------
    STDprinter = Application.ActivePrinter
    fName = Application.GetSaveAsFilename([AG2], _
    "XPS Document Writer (*.xps),*.xps", 1)
    If fName = False Then Exit Sub
    PrinterName = "Microsoft XPS Document Writer"
    PrinterFound = False
    On Error Resume Next
    For PortNumber = 0 To 12
        PrinterPort = "Ne" & Format(PortNumber, "00") & ":"
        PrinterFullName = PrinterName & PrinterNumber & " op " & PrinterPort

        Application.ActivePrinter = PrinterFullName

        If Err.Number = 0 Then
            Sheets(Array("kaart")).Select
            ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, PrintToFile:=True, PrToFileName:=fName
            PrinterFound = True
            Sheets(Array("kaart")).Select
            Exit For
        Else
            Err.Clear
        End If

    Next PortNumber

    If PrinterFound Then
      A = MsgBox("Wil je  printen?", vbQuestion + vbYesNo, "Gelukt, opgeslagen als Microsoft XPS Document!")

      If A = vbYes Then
          Application.ActivePrinter = STDprinter
          Application.Dialogs(xlDialogPrint).Show

    End If
  End If
End Sub

oceanrace · 25 sep 2010

Het werkt!
Wederom bedankt voor je hulp...

aph · 7 okt 2010

Kan met de XPS printer ook een logo mee worden geprint naar PDF?

VBA Printen naar XPS printer

Gebruiker

Terugkerende gebruiker

Gebruiker

Gebruiker

Gebruiker

Meubilair

Gebruiker

Meubilair

Gebruiker

Gebruiker

Meubilair

Gebruiker

Gebruiker

Meubilair

Gebruiker

Gebruiker

Gebruiker

Meubilair

Gebruiker

Gebruiker

Wij waarderen jouw privacy