VBA code - Print a PDF document in corresponding Cell

[Ben171]

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

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

 

[John_w]

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).

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.

 

[Ben171]

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).

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.

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!

 

[John_w]

Sorry, I didn't notice you were searching a different sheet.

Replace:

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

with:

    WorksOrder = ThisWorkbook.Worksheets("PrintDocuments").Range("C3").Value
    With ThisWorkbook.Worksheets("Database")

 

[Ben171]

Sorry, I didn't notice you were searching a different sheet.

Replace:

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

with:

    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.

is there something obvious i am doing wrong?

 

[Ben171]

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

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

View attachment 42283

is there something obvious i am doing wrong?

Seem to only get this error when i have sheet as "Database" with just "PrintDocument" sheet the code runs

 

[John_w]

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").

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

 

[Ben171]

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").

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

I assume this is because my hyperlinks look like this:

=HYPERLINK(CONCATENATE("T:\pe_projects\Engineering\Receiver Mounted Stationary Screw Compressors\9_RM Database\Safety Valve Certs\",L2,".pdf"),L2)

 

[John_w]

I assume this is because my hyperlinks look like this:

=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.

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

 

[Ben171]

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.

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?