Update VB Code to Print a list of Word Documents

[GazNicki]

Hi

I have the following code:

Function FnPrint()

    Dim objWord
    Dim objDoc
    
    Set objWord = CreateObject("Word.Application")
    
    Set objDoc = objWord.Documents.Open("\\DC0\Bakery2\TECHSPEC\Technical\Manuals\29. Training\Training\Training Documents\Training Instructions\TI-53 - Pest Awareness.docx")
    
    objWord.Visible = True
    
    objDoc.PrintOut
    
    objWord.Quit
    
End Function

This currently works fine at printing the specified document out, and works well as the default printer is the only printer.

I would like to update this to work with a list of documents starting in cell A1. The list will go down the cells until the list of documents will end, this could be added to or documents removed.

The list of documents is the full path, which is a network location, as per the example above.

Is it possible to update the code to go through the list of documents, and print them all in the specified order?
Is it also possible to have a cell where the number can be changed for the number of copies of the documents? Such the number 3 in cell B2 would repeat the process 3 times?

 

[Trevor G]

Try out this code. First you will need to set the References in the Excel VBA screen to use Microsoft Word XX (XX being the version number)
In the VBA Screen go to the Tools Menu and References and search down the list for Microsoft Word.

Document names start in A1 copies required starts in B1

A1	One	1
A2	Two	3
A3	Three	6

This has been tested as far as the print option but it should work

Change the path to your own path include the last backslash.

Sub WrdDocOpen()
'Requires you to set the Reference to Microsoft Word via Tools Menu and References
Dim wrdApp As Word.Application
Dim strPath As String
strPath = "Enter the path in full here"
Set wrdApp = CreateObject("Word.Application")
'First file name in Cell A1
Range("A1").Select
'Continue down the rows until no more entries
Do Until IsEmpty(ActiveCell)
'Open word and then all doucments and print them based on cell content to the right of file name
With wrdApp
.Visible = True
.Documents.Open strPath & ActiveCell & ".docx"
.ActiveDocument.PrintOut , , , , , , , ActiveCell.Offset(0, 1).Value
.ActiveDocument.Close
End With
ActiveCell.Offset(1).Select
Loop
wrdApp.Quit
End Sub

 

[GazNicki]

Hi

Thank you for this.

I have had a play and got this to work, thank you very much.

Just on the number of copies, is it possible to loop the process of printing according to a cell number.

Lets say Cell C1 contains a number, 10, it would go through the list from cell A1:END and then repeat the process according to how many times the cell C1 determines?

That way, the printing comes out as a number of packs, rather than copies of the same document that then need manually organising.

 

[Trevor G]

You can add a For and Next to do this. Example code here is calling the first macro I wrote so you can then either change the number of print copies as per column B or adjust the original code and the print line

Sub RepeatCode()
Dim i As Long
For i = 1 To Range("c1")
Call wrdDocOpen
Next i
End Sub

 

[GazNicki]

Hi

I have the following code now:

Private Sub CommandButton1_Click()

'Requires you to set the Reference to Microsoft Word via Tools Menu and References
    Dim i As Long
    Dim wrdApp As Word.Application
    Dim strPath As String
    strPath = "\\DC0\Bakery2\TECHSPEC\Technical\Manuals\"
    Set wrdApp = CreateObject("Word.Application")

    For i = 1 To Range("D4")
        'First file name in Cell A1
        Range("A1").Select
        'Continue down the rows until no more entries
        Do Until IsEmpty(ActiveCell)

        'Open word and then all doucments and print them based on cell content to the right of file name
        With wrdApp
            .Visible = True
            .Documents.Open strPath & ActiveCell & ".docx"
            .ActiveDocument.PrintOut , , , , , , , ActiveCell.Offset(0, 1).Value
            .ActiveDocument.Close
            Application.Wait (Now + TimeValue("00:00:03")) 'wait 3 seconds from now to ensure print order is correct
        End With

        ActiveCell.Offset(1).Select

        Loop
        wrdApp.Quit
        Application.Wait (Now + TimeValue("00:00:10")) 'wait 10 seconds from now, to ensure that printing has been completed before restarting
    Next i

End Sub

However, this fails with the following error: Runtime Error 462.

When I debug, it highlights the ".Visible = True". It fails on the second print run, the first operates correctly.

 

[GazNicki]

I managed to fix this my moving the following line:

For i = 1 to Range ("D4")

To the line after declaring i as Long. I guess I had the loop in the wrong place.

Thanks again @Trevor G for all your help on this one. Your code has allowed me to look at alternatives which my team can use to be more productive too on other tasks.

 

[Trevor G]

Your welcome and when I can I am happy to help. Thank you for letting me know you have a solution