Excel Hyperlinks to Open to Specific Pages in a PDF

[legalhustler]

I want to create various hyperlinks in a Excel sheet that open to specific pages in a PDF. The PDF is saved in a folder on my desktop. I cannot use Power Query in my version of Excel to connect to the PDF, since PDF source has not yet been added. I cannot use Power BI. Ideally, I would like to use the HYPERLINK or some other Excel function, otherwise I need to have a custom function/macro that allows each of my hyperlinks to open to specific pages in a PDF. Is this do-able?

Appreciate any help. TIA!

 

[John_w]

This macro works with hyperlinks created with inserted Links, not HYPERLINK function formulas. The former type of hyperlink triggers the Worksheet_FollowHyperlink which opens the PDF at page 1. Windows API functions are then called to close the PDF and reopen it at the specified page.

You can specify the page number in the hyperlink in 2 ways:

1. After the # character at the end of the file path, e.g. "C:\path\to\file.pdf#page". This is a standard Excel convention.
2. After the # character at the end of the text to display, e.g. "Data file#page". This is a convention I've invented and could be changed.

Put this code in the worksheet module of the worksheet containing the hyperlinks:

Option Explicit

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    
    If Target.SubAddress <> "" Then
        'Page number is specified in the subaddress part of the address, in the format "C:\folder\file.pdf#p", where #p is the page number subaddress
        Open_PDF_At_Page Target.Address, Target.SubAddress
    Else
        'Page number is specified in the text to display, in the format "text#p", where #p is the page number
        Open_PDF_At_Page Target.Address, CStr(Split(Target.TextToDisplay, "#")(1))
    End If
    
End Sub

Put this code in a standard module:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As LongPtr
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal wCmd As Long) As LongPtr
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare PtrSafe Function IsWindow Lib "user32.dll" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32.dll" () As Long
#Else
    Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
    Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function IsWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
    Private Declare Function WaitMessage Lib "user32.dll" () As Long
#End If


Private Const WM_CLOSE = &H10
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5


'This is called from Sheet's Worksheet_FollowHyperlink

Public Sub Open_PDF_At_Page(PDFfullName As String, Optional page As String = "1")

    Dim PDFexe As String
    Dim AdobeCommand As String
    Dim PDFfile As String, p As Long
        
    If Dir(PDFfullName) <> vbNullString Then
    
        PDFexe = Get_ExePath(PDFfullName)
        
        AdobeCommand = " /a ""page=" & page & "=Open Actions"" "
        
        p = InStrRev(PDFfullName, "\")
        PDFfile = Mid(PDFfullName, p + 1)
        
        'Worksheet_FollowHyperlink opens the PDF automatically at page 1, if not already open.  The PDF must be closed before opening it at the specified page,
        'otherwise it will stay open at the current page
        
        'Find and close the PDF's window using Windows API functions
    
        Find_and_Close_Window PDFfile
        
        'Open the PDF at the specified page

        Shell Chr(34) & PDFexe & Chr(34) & AdobeCommand & Chr(34) & PDFfullName & Chr(34), vbNormal
        
    Else
    
        MsgBox PDFfullName & " doesn't exist", vbExclamation
        
    End If

End Sub


Private Function Get_ExePath(lpFile As String) As String
    Dim lpDirectory As String, sExePath As String, rc As Long
    lpDirectory = "\"
    sExePath = Space(255)
    rc = FindExecutable(lpFile, lpDirectory, sExePath)
    Get_ExePath = Left$(sExePath, InStr(sExePath, Chr$(0)) - 1)
End Function

Private Sub Find_and_Close_Window(windowTitle As String)

    #If VBA7 Then
        Dim hWnd As LongPtr
    #Else
        Dim hWnd As Long
    #End If
    Dim thisWindowTitle As String, thisClassName As String
    Dim textLen As Long
    Dim foundWindow As Boolean
    Dim n As Long
    
    Const AcrobatClassName = "AcrobatSDIWindow"
    
    'Loop through all open windows
    
    foundWindow = False
    
    hWnd = GetWindow(GetDesktopWindow(), GW_CHILD)
    n = 0
    Do Until hWnd = 0 Or foundWindow
    
        n = n + 1
        thisWindowTitle = Space(256)
        textLen = GetWindowText(hWnd, thisWindowTitle, Len(thisWindowTitle))
        
        If textLen Then
                      
            'Close the window if its title matches the one being sought and is an Acrobat window
            
            thisWindowTitle = Left(thisWindowTitle, textLen)
            
            thisClassName = Space(256)
            textLen = GetClassName(hWnd, thisClassName, Len(thisClassName))
            thisClassName = Left(thisClassName, textLen)
            
            If InStr(1, thisWindowTitle, windowTitle, vbTextCompare) And thisClassName = AcrobatClassName Then

                PostMessage hWnd, WM_CLOSE, 0, 0
                
                'Wait until the window has closed
                
                While IsWindow(hWnd)
                    WaitMessage
                    DoEvents
                    Sleep 20
                Wend
            
                foundWindow = True

            End If
            
        End If
        
        hWnd = GetWindow(hWnd, GW_HWNDNEXT)
    
    Loop
    
End Sub