VBA code - Print a PDF document in corresponding Cell

Ben171

Board Regular
Joined
Jul 2, 2021
Messages
88
I have a database which stores entries from user.

in Cells D2:D100 are Works Order Numbers,
in Cells R2:R100 are hyperlinks to a PDF that is corresponding to that works order number.

I would like to write some code in which users enters a works order number in cell C3 of the "print documents sheet"

It will then search the "Database" sheet for that works order number, and then when it has found it, it prints the PDF which is in Cell R at the end of the row in which the works order number is in.

I have started writing some code to do this, I have written some code that loops through the rows and finds the work order number. However i am not sure how to do the inbetween bit, which is to print the pdf at the end of the row.

any help would be greatly appreciated, see starter code below

VBA Code:
Dim iRow As Long 'Variable to hold the starting row and loop through all records in database
Dim sh As Worksheet 'worksheet variable to refer  to where database is stored
Dim myValue As Variant
Dim WorksOrder As String
Dim Found As Boolean



'Get user entered WorksOrder Number

WorksOrder = ThisWorkbook.Sheets("PrintDocuments").Range("C3").Value


'Set worksheet

Set sh = ThisWorkbook.Sheets("Database")

iRow = 2 'row in which data starts from in database

Found = False

Do While sh.Range("A" & iRow).Value <> ""  'loop through until no data is found (last row of database)
 
If WorksOrder = sh.Range("D" & iRow).Value Then

Found = True

'Insert print PDF code here











Exit Do

End If

iRow = iRow + 1

Loop



If Found = True Then
MsgBox ("Document Printed")
Else
MsgBox ("Works Order Number Not Found")
End If

End Sub
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Try this macro, which prints the PDF on the default printer or a named printer (the 2nd argument on the ShellExecute_Print call, currently commented out).
VBA Code:
Option Explicit
 
#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
    Private Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Private Const SW_HIDE As Long = 0&


Public Sub Print_Works_Order_PDF()

    Dim WorksOrder As String
    Dim foundRow As Variant

    With ThisWorkbook.Sheets("PrintDocuments")
        WorksOrder = .Range("C3").Value
        foundRow = Application.Match(WorksOrder, .Columns(4), 0)
        If IsError(foundRow) Then foundRow = Application.Match(CLng(WorksOrder), .Columns(4), 0)
        If Not IsError(foundRow) Then
            ShellExecute_Print .Cells(foundRow, "R").Hyperlinks(1).Address
            MsgBox "Printed " & .Cells(foundRow, "R").Hyperlinks(1).Address & " for Works Order Number " & WorksOrder, vbInformation
        Else
            MsgBox "Works Order Number " & WorksOrder & " not found", vbExclamation
        End If
    End With
    
End Sub


Private Sub ShellExecute_Print(file As String, Optional printerName As String)
    If printerName = "" Then
        ShellExecute Application.hWnd, "PrintTo", file, vbNullString, 0&, SW_HIDE
    Else
        ShellExecute Application.hWnd, "PrintTo", file, Chr(34) & printerName & Chr(34), 0&, SW_HIDE
    End If
End Sub
The macro leaves an empty Adobe/Acrobat window open - more code is needed to close it.
 
Upvote 0
Try this macro, which prints the PDF on the default printer or a named printer (the 2nd argument on the ShellExecute_Print call, currently commented out).
VBA Code:
Option Explicit
 
#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
    Private Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Private Const SW_HIDE As Long = 0&


Public Sub Print_Works_Order_PDF()

    Dim WorksOrder As String
    Dim foundRow As Variant

    With ThisWorkbook.Sheets("PrintDocuments")
        WorksOrder = .Range("C3").Value
        foundRow = Application.Match(WorksOrder, .Columns(4), 0)
        If IsError(foundRow) Then foundRow = Application.Match(CLng(WorksOrder), .Columns(4), 0)
        If Not IsError(foundRow) Then
            ShellExecute_Print .Cells(foundRow, "R").Hyperlinks(1).Address
            MsgBox "Printed " & .Cells(foundRow, "R").Hyperlinks(1).Address & " for Works Order Number " & WorksOrder, vbInformation
        Else
            MsgBox "Works Order Number " & WorksOrder & " not found", vbExclamation
        End If
    End With
   
End Sub


Private Sub ShellExecute_Print(file As String, Optional printerName As String)
    If printerName = "" Then
        ShellExecute Application.hWnd, "PrintTo", file, vbNullString, 0&, SW_HIDE
    Else
        ShellExecute Application.hWnd, "PrintTo", file, Chr(34) & printerName & Chr(34), 0&, SW_HIDE
    End If
End Sub
The macro leaves an empty Adobe/Acrobat window open - more code is needed to close it.
HI, thank you so much for getting back to me, have really been struggling with this!

I think this is nearly there but there are a couple of changes. You are using the sheet "PrintDocuments" to find the entered works order number. This is correct. See below sheet. This is the PrintDocuments sheet, a user enters a order number in C3 and then can press the "Print Cert" button to print off this hyperlink.

1625594434210.png


The code needs to instead go through the rows in the "Database" sheet which is where the information is stored. It needs to go through the rows until it finds the works order number that was entered in C3 of the print page, inside column D of this database sheet, and print the hyperlink at the end of that row of the database which is located in column R. Hope that makes sense!

1625594507692.png
1625594522165.png
 
Upvote 0
Sorry, I didn't notice you were searching a different sheet.

Replace:
VBA Code:
    With ThisWorkbook.Sheets("PrintDocuments")
        WorksOrder = .Range("C3").Value
with:
VBA Code:
    WorksOrder = ThisWorkbook.Worksheets("PrintDocuments").Range("C3").Value
    With ThisWorkbook.Worksheets("Database")
 
Upvote 0
Sorry, I didn't notice you were searching a different sheet.

Replace:
VBA Code:
    With ThisWorkbook.Sheets("PrintDocuments")
        WorksOrder = .Range("C3").Value
with:
VBA Code:
    WorksOrder = ThisWorkbook.Worksheets("PrintDocuments").Range("C3").Value
    With ThisWorkbook.Worksheets("Database")

this looks like it should be exactly what i'm after!

But i am getting subscript out of range error on the following line.

1625596511587.png


is there something obvious i am doing wrong?
 
Upvote 0
The code expects the links to be created with Insert -> Link, however I guess your links are created with a cell formula which uses the HYPERLINK function instead.

See if this modified main macro works for you, although it can only parse a simple =HYPERLINK formula, such as =HYPERLINK("C:\folder\path\359848.pdf","359848").
VBA Code:
Public Sub Print_Works_Order_PDF()

    Dim WorksOrder As String
    Dim foundRow As Variant
    Dim PDFfile As String

    WorksOrder = ThisWorkbook.Worksheets("PrintDocuments").Range("C3").Value
    With ThisWorkbook.Worksheets("Database")
        foundRow = Application.Match(WorksOrder, .Columns(4), 0)
        If IsError(foundRow) Then foundRow = Application.Match(CLng(WorksOrder), .Columns(4), 0)
        If Not IsError(foundRow) Then
            PDFfile = Evaluate(Split(Mid(.Cells(foundRow, "R").Formula, Len("=HYPERLINK(") + 1), ",")(0))
            ShellExecute_Print PDFfile ', "Printer Name"
            MsgBox "Printed " & PDFfile & " for Works Order Number " & WorksOrder, vbInformation
        Else
            MsgBox "Works Order Number " & WorksOrder & " not found", vbExclamation
        End If
    End With
    
End Sub
 
Upvote 0
The code expects the links to be created with Insert -> Link, however I guess your links are created with a cell formula which uses the HYPERLINK function instead.

See if this modified main macro works for you, although it can only parse a simple =HYPERLINK formula, such as =HYPERLINK("C:\folder\path\359848.pdf","359848").
VBA Code:
Public Sub Print_Works_Order_PDF()

    Dim WorksOrder As String
    Dim foundRow As Variant
    Dim PDFfile As String

    WorksOrder = ThisWorkbook.Worksheets("PrintDocuments").Range("C3").Value
    With ThisWorkbook.Worksheets("Database")
        foundRow = Application.Match(WorksOrder, .Columns(4), 0)
        If IsError(foundRow) Then foundRow = Application.Match(CLng(WorksOrder), .Columns(4), 0)
        If Not IsError(foundRow) Then
            PDFfile = Evaluate(Split(Mid(.Cells(foundRow, "R").Formula, Len("=HYPERLINK(") + 1), ",")(0))
            ShellExecute_Print PDFfile ', "Printer Name"
            MsgBox "Printed " & PDFfile & " for Works Order Number " & WorksOrder, vbInformation
        Else
            MsgBox "Works Order Number " & WorksOrder & " not found", vbExclamation
        End If
    End With
   
End Sub

Just gave this a try and i get the same error except on the following line

1625598662955.png


I assume this is because my hyperlinks look like this:

VBA Code:
=HYPERLINK(CONCATENATE("T:\pe_projects\Engineering\Receiver Mounted Stationary Screw Compressors\9_RM Database\Safety Valve Certs\",L2,".pdf"),L2)
 
Upvote 0
I assume this is because my hyperlinks look like this:

VBA Code:
=HYPERLINK(CONCATENATE("T:\pe_projects\Engineering\Receiver Mounted Stationary Screw Compressors\9_RM Database\Safety Valve Certs\",L2,".pdf"),L2)
Yes; as I said, the macro expects only a simple =HYPERLINK( formula. Any extra functions like CONCATENATE, IF, AND, etc within the HYPERLINK function require a cleverer parser.

Try this updated macro (full code) which parses your =HYPERLINK(CONCATENATE( formula - it should be able to handle any number of CONCATENATE arguments, as long as they don't contain any embedded commas.

VBA Code:
Option Explicit
 
#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
    Private Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Private Const SW_HIDE As Long = 0&


Public Sub Print_Works_Order_PDF()

    Dim WorksOrder As String
    Dim foundRow As Variant
    Dim PDFfile As String

    WorksOrder = ThisWorkbook.Worksheets("PrintDocuments").Range("C3").Value
    With ThisWorkbook.Worksheets("Database")
        foundRow = Application.Match(WorksOrder, .Columns(4), 0)
        If IsError(foundRow) Then foundRow = Application.Match(CLng(WorksOrder), .Columns(4), 0)
        If Not IsError(foundRow) Then
            PDFfile = HyperlinkLocation(.Cells(foundRow, "R").Formula)
            ShellExecute_Print PDFfile ', "Printer Name"
            MsgBox "Printed " & PDFfile & " for Works Order Number " & WorksOrder, vbInformation
        Else
            MsgBox "Works Order Number " & WorksOrder & " not found", vbExclamation
        End If
    End With
    
End Sub


Private Sub ShellExecute_Print(file As String, Optional printerName As String)
    If printerName = "" Then
        ShellExecute Application.hWnd, "PrintTo", file, vbNullString, 0&, SW_HIDE
    Else
        ShellExecute Application.hWnd, "PrintTo", file, Chr(34) & printerName & Chr(34), 0&, SW_HIDE
    End If
End Sub

Private Function HyperlinkLocation(HyperlinkFormula As String) As String

    'Parse a =HYPERLINK(CONCATENATE( formula and return what the link_location parameter evaluates to.  Should work with 1 or more CONCATENATE arguments
    
    Dim p1 As Long, p2 As Long
    Dim concatArgs As Variant, i As Long

    HyperlinkLocation = ""
    p1 = InStr(1, HyperlinkFormula, "=HYPERLINK(CONCATENATE(", vbTextCompare)
    If p1 > 0 Then
        p1 = p1 + Len("=HYPERLINK(CONCATENATE(")
        p2 = InStrRev(HyperlinkFormula, ")", -1)
        p2 = InStrRev(HyperlinkFormula, ")", p2 - 1)
        concatArgs = Split(Mid(HyperlinkFormula, p1, p2 - p1), ",")
        For i = 0 To UBound(concatArgs)
            HyperlinkLocation = HyperlinkLocation & Evaluate(concatArgs(i))
        Next
    End If
    
End Function
 
Upvote 0
Yes; as I said, the macro expects only a simple =HYPERLINK( formula. Any extra functions like CONCATENATE, IF, AND, etc within the HYPERLINK function require a cleverer parser.

Try this updated macro (full code) which parses your =HYPERLINK(CONCATENATE( formula - it should be able to handle any number of CONCATENATE arguments, as long as they don't contain any embedded commas.

VBA Code:
Option Explicit
 
#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
    Private Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Private Const SW_HIDE As Long = 0&


Public Sub Print_Works_Order_PDF()

    Dim WorksOrder As String
    Dim foundRow As Variant
    Dim PDFfile As String

    WorksOrder = ThisWorkbook.Worksheets("PrintDocuments").Range("C3").Value
    With ThisWorkbook.Worksheets("Database")
        foundRow = Application.Match(WorksOrder, .Columns(4), 0)
        If IsError(foundRow) Then foundRow = Application.Match(CLng(WorksOrder), .Columns(4), 0)
        If Not IsError(foundRow) Then
            PDFfile = HyperlinkLocation(.Cells(foundRow, "R").Formula)
            ShellExecute_Print PDFfile ', "Printer Name"
            MsgBox "Printed " & PDFfile & " for Works Order Number " & WorksOrder, vbInformation
        Else
            MsgBox "Works Order Number " & WorksOrder & " not found", vbExclamation
        End If
    End With
   
End Sub


Private Sub ShellExecute_Print(file As String, Optional printerName As String)
    If printerName = "" Then
        ShellExecute Application.hWnd, "PrintTo", file, vbNullString, 0&, SW_HIDE
    Else
        ShellExecute Application.hWnd, "PrintTo", file, Chr(34) & printerName & Chr(34), 0&, SW_HIDE
    End If
End Sub

Private Function HyperlinkLocation(HyperlinkFormula As String) As String

    'Parse a =HYPERLINK(CONCATENATE( formula and return what the link_location parameter evaluates to.  Should work with 1 or more CONCATENATE arguments
   
    Dim p1 As Long, p2 As Long
    Dim concatArgs As Variant, i As Long

    HyperlinkLocation = ""
    p1 = InStr(1, HyperlinkFormula, "=HYPERLINK(CONCATENATE(", vbTextCompare)
    If p1 > 0 Then
        p1 = p1 + Len("=HYPERLINK(CONCATENATE(")
        p2 = InStrRev(HyperlinkFormula, ")", -1)
        p2 = InStrRev(HyperlinkFormula, ")", p2 - 1)
        concatArgs = Split(Mid(HyperlinkFormula, p1, p2 - p1), ",")
        For i = 0 To UBound(concatArgs)
            HyperlinkLocation = HyperlinkLocation & Evaluate(concatArgs(i))
        Next
    End If
   
End Function
Ahh i see, thank you!

this code runs, and i get the printed message. However it is not being sent to the printer. (I haven't specified one so i assume it would go to the default printer)?

Or do i have to tell it which printer to go to?
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,237
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top