Printing on XPS Printer

[BrendanDixon]

Hi All,

I have been trying to create a macro where I can print my Workbook as an XPS file using the XPS document Writer Driver.

This is my code so far:

Sub PRINT_UNKNOWN_Ne()
    Dim PrinterName As String
    Dim PortNumber As Integer
    Dim PrinterPort As String
    Dim PrinterFullName As String
    Dim PrinterFound As Boolean
    Dim STDprinter As String

    STDprinter = Application.ActivePrinter
    PrinterName = "Microsoft XPS Document Writer"
    PrinterFound = False
    On Error Resume Next
    For PortNumber = 0 To 12
        PrinterPort = "Ne" & Format(PortNumber, "00") & ":"
        PrinterFullName = PrinterName & PrinterNumber & " on " & PrinterPort
        Application.ActivePrinter = PrinterFullName
    Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
        ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
        If Err.Number = 0 Then
            PrinterFound = True
            Exit For
        Else
            Err.Clear
        End If
    
    Next PortNumber
    
    If PrinterFound = False Then
        MsgBox (PrinterName & vbCr & "Printer not found")
    End If
    
    Application.ActivePrinter = STDprinter
End Sub

The problems I am having is that it is also printing to my default printer on my computer. I noticed that without the STDprinter code the quickprint button from the menu would default to the XPS printer where I would like the default printer to change back to my computers default printer afterwards, and not print it on the default printer as well.

I would also like to set the filename automatically in the XPS document Does anyone know how I can do this ?

Thanks

 

[BrendanDixon]

Ok I was looking and my code and realised the I had it wrong.

With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
            For lCount = 1 To .SelectedItems.Count
            GetFolderName = .SelectedItems(lCount)
        Next lCount
        End With

I moved this code up further before the loop for the printer checking section.

I would just like to know. If I cancel the dialog it continues to print.
How change the code so that if I click on cancel it will goto end sub?

Thanks

 

[xenou]

You want to find out what it "gives" you when you cancel ... Test for that return value (maybe its an empty string "" or maybe its False) ... Possibly you'd just have an empty set of selected Items. According to the article below the dialog associated a value with the action button (0 or -1).

It bothers me that you could pick more than one folder (apparently). Though I doubt your user would do that ... especially if you are the only user. Sorry I don't have my usual tools with me - there are several versions of folder pickers out there. Did I suggest this one? I have a slightly different code that I usually use myself but its not with me ... its really trial and error. Step through the code and see what its doing, what its giving back to you at each step when you engage the object (hit buttons, select files, etc.)

Something like:

GetFolderName = ""
With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    If .Show = -1 Then
        If .SelectedItems.Count = 1 Then
            GetFolderName = .SelectedItems(1)
        End If
    End If
End With
If GetFolderName = "" Then Exit Sub '//No folder

FileDialog
http://msdn.microsoft.com/en-us/library/aa163948(office.10).aspx

Debug hints:
http://krgreenlee.blogspot.com/2006/04/programming-excel-vba-debugging-for.html

 

[xenou]

Here's another shot at it, using a custom function (you'd put the function in the same module as your sub, then call it as any other function would be called):
From:
http://www.eggheadcafe.com/software/aspnet/33659856/filedialog-mso-folder-pic.aspx

Sub Foo()

'//some code from my sub ...

GetFolderName = Get_Directory()
If GetFolderName = "" Then Exit Sub

'//More code ....

End Sub
'-------------------------------------------------------------------------------------------
Function Get_Directory(ByRef strMessage As String) As String
On Error GoTo BadDirections
Dim objFF As Object
Set objFF = CreateObject("Shell.Application").BrowseForFolder _
(0, strMessage, &H4000, "c:\")
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

 

[xenou]

This seems helpful on the filedialog:
http://www.instantpages.ltd.uk/Office_FileDialog.htm

Its seems strange to me...I'll have to test it out when I'm home.

 

[BrendanDixon]

Brilliant!!!!!!


Thank you so much Xenou!

It is Working Perfectly now

I used the If Getfoldername = "" Then Exit Sub

At the end of the file picker and everything works perfectly now.

I an not sure what that function that you posted does just happy that it is working now.

Here is the Code for everyones Reference

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
    '-------------------------------------------------------------------------
    STDprinter = Application.ActivePrinter
    GetFolderName = vbNullString
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
            For lCount = 1 To .SelectedItems.Count
            GetFolderName = .SelectedItems(lCount)
        Next lCount
        End With
        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
    '------------------------------------------------------------------------

 

[xenou]

Great. Even a blind squirrel finds a nut every now and then

 

[BrendanDixon]

Hi Xenou,

I just realised there is a slight problem with the Folder picker code in that if I select a folder and then click on save it works fine.

But if I the run the code a second time it will have the correct directory already, but if I just click on the save button it does not save it o the correct directory.

Any Idea how I could fix this ?

Thanks

 

[xenou]

I've never used the filedialog much and after 30 minutes pulling my hair out I'm stuck - I'm not getting your behavior, but I do find that if it opens to a directory (such as the last one I used), and I click OK (i.e., that's the right directory), then nothing happens - its treats it as nothing selected. I guess you also should set multi-select to False as you'd never want multiple files chosen. But why its doing what its doing ... no idea.

You could use the other picker for now (that's what I'd do, anyway). Change the initial directory to something besides C:\ if there's a better default place to start:

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
[COLOR="Blue"]    Dim GetFolderName As String
    Dim PrinterNumber[/COLOR]
    '-------------------------------------------------------------------------
    STDprinter = Application.ActivePrinter
[COLOR="blue"]    GetFolderName = Get_Directory("Select Folder", "C:\")
    If GetFolderName = "" Then Exit Sub[/COLOR]
        
    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
'--------------------------------------------------------------------------------------
[COLOR="blue"]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[/COLOR]

 

[BrendanDixon]

Hi Xenou,

That is exactly what was happening with me. But I did find that it does write the file, just not to the correct directory. Do a search for the file. I found that it was storing it in my users folder. (Windows 7) Will look into it

Thanks