• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

VBA Printen naar XPS printer

Status
Niet open voor verdere reacties.
oceanrace

oceanrace

Gebruiker
Lid geworden
14 mei 2008
Berichten
198
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
 
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:
 
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.
 
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?
 
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.
 
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 ???
 
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
 
Hoi Rudi,

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

Bedankt!
 
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.
 
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
 
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 :confused:
 
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.... :rolleyes:
 
Staat de functie GetDirectory ook in de standaardmodule van je bestand ? Ik heb de macro nog eens 2x getest en geen problemen gehad
 
De hele code staat in een standaardmodule.
Ik volg je niet helemaal denk ik...
 
Hij doet het weer, de macrobeveiliging "toegang tot visual basic-project vertrouwen"was niet aangevinkt :rolleyes:
 
Laatst bewerkt:
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 :confused:
 
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
 
Kan met de XPS printer ook een logo mee worden geprint naar PDF?
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan