Save webpage hyperlink in excel to PDF

[Indieswirl]

Hi all,
Please note I am very new to VBA.
I have a list of hyperlinks in Column D and I found the below VBA code. It opens a web browser and give me a pop up to save the PDF. But it seems to have just googled the text in the cell rather than opening the link itself.

What i am really after is a way to:
1. Use the first link D2 which is to a webpage,
2. Save as PDF
3. Saved in location on my computer , hopefully a way to setup by the code,
3. Go to next row down D3 in same column and repeat. (I imagine this would be something like "D2:D63") and a loop of some sort.

Thanks in advance.

Sub print_PDF()

    Dim Explorer As Object
    Dim eQuery As Long ' return value
    Dim i As Integer
    Dim fTime As Single
    
    Set Explorer = CreateObject("InternetExplorer.Application") ' Connect to Explorer
    Dim url As String
    url = ThisWorkbook.ActiveSheet.Range("D2").Value
    Explorer.Navigate url ' Open document from local or web!

TryAgain:

        'Wait 2 seconds to let IE load

        fTime = Timer

        Do While fTime > Timer - 2

            DoEvents

        Loop

        eQuery = Explorer.QueryStatusWB(6)  ' print command

        If eQuery And 2 Then

            Explorer.ExecWB 6, 2, "", ""   ' Print (6), displaying dialog (2)

            'Wait for 2 seconds while IE prints

            fTime = Timer

            Do While fTime > Timer - 2

                DoEvents

            Loop

        Else

            GoTo TryAgain

        End If

 

End Sub

 

[Dan_W]

I was going to suggest that perhaps you might want to pause the code for a bit and see if that helps, but seems you've solved it yourself. Awesome job!

 

[Indieswirl]

One final query? Is there a way to name the File as per text found in another column, instead of "SnapShot_" code line below? I am using the full code above which works great, but would be just that bit better if i could name them as per the text in Column E (so column 5).

 Filename = DoubleQuote(OutputPath & "SnapShot_" & Format(Now, "yyyymmdd-hhmmssmss") & Extension, True)

 

[Indieswirl]

Fixed it myself again - Thanks for all your help @Dan_W

    Option Explicit
    
    Enum SnapShotType
        ScreenShotPNG
        FullPagePDF
    End Enum
    
    Enum PreferredBrowser
        MSEdge
        Chrome
        Brave
    End Enum

    #If VBA7 Then
        Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Long
    #Else
        Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Long
    #End If

   
   

    Function GetSnapShot(ByVal TargetURL As String, _
                         ByVal OutputPath As String, _
                         ByVal Name As String, _
                         Optional ByVal Snap As SnapShotType = ScreenShotPNG, _
                         Optional ByVal BrowserName As PreferredBrowser = Chrome)
                         

        Const ARGUMENT = " --headless --disable-gpu --blink-settings=scriptEnabled=true --window-size=768,1280 "
        
        Dim BrowserPath As String, Browser As String, Filename As String, Extension As String, Ret As Long, PID As Long
        Dim CommandLine As String, CLArguments As String, AdditionalParameter As String

        Browser = Switch(BrowserName = MSEdge, "msedge.exe", BrowserName = Chrome, "chrome.exe", BrowserName = Brave, "brave.exe")
        BrowserPath = DoubleQuote(GetProgramLocation(Browser))
        
        If Len(Trim(BrowserPath)) <= 2 Then
            MsgBox "Unable to locate the designated browser." & vbNewLine & "Exiting the procedure.", _
            vbCritical Or vbOKOnly, "Cannot locate browser."
            Exit Function
        End If
        
        ' The MakeSureDirectoryPathExists API will check whether a given path exists, and if not, will create the necessary directories.
        Ret = MakeSureDirectoryPathExists(OutputPath)
        Extension = IIf(Snap = FullPagePDF, ".pdf", ".png")
        AdditionalParameter = IIf(Snap = FullPagePDF, "--print-to-pdf=", " --screenshot=")
        Filename = DoubleQuote(OutputPath & Name & Format(Now, "yyyymmdd-hhmmssmss") & Extension, True)
        CLArguments = ARGUMENT & AdditionalParameter & Filename & TargetURL
        CommandLine = BrowserPath & CLArguments
    
        Application.Wait (Now + TimeValue("0:00:01"))
        
        ' Execute the instructions in a minimised window - other options include: vbHide, vbNormalFocus
        Debug.Print "Executing: " & CommandLine
        Shell CommandLine, vbMinimizedNoFocus
        
        GetSnapShot = Mid(Trim(Filename), 2, Len(Trim(Filename)) - 2)
        
    End Function

    Function DoubleQuote(Optional ByVal SourceText As String, Optional ByVal TrailingSpace As Boolean = False)

        DoubleQuote = Chr(34) & SourceText & Chr(34) & IIf(TrailingSpace, Chr(32), vbNullString)

    End Function

    Function GetProgramLocation(ByVal ExeFilename As String)
        
        ' This function will check the registry for any registered applications with the given filename;
        ' it will return the full path if successful.
        Const REGISTRYADDRESS = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\"
        
        On Error Resume Next
        GetProgramLocation = CreateObject("WScript.Shell").RegRead(REGISTRYADDRESS & ExeFilename & "\")

    End Function

Sub DownloadPDFFiles()

Dim TargetURL As String
Dim TargetRow As Long
Dim Name As String

 'Update number for how many rows
For TargetRow = 2 To 6
 

    TargetURL = Cells(TargetRow, 4).Hyperlinks(1).Address
    Name = Cells(TargetRow, 5).Value
    Cells(TargetRow, 7).Value = GetSnapShot(TargetURL, "C:\Users\SHart\Documents\VBA_Prints\New folder\", Name, FullPagePDF)

Next TargetRow

End Sub