Vbscript saving pdf from Internet Explorer

Question

I wrote a script which open an excel file which contains hyperlinks. Vbscript opens hyperlink with internet explorer, and save the page as pdf with pdf creator as default printer.It is in a loop. My issue is that the script fails each and every time in a different step. I do not know how could I rewrite this script to make it a stable one.

Dim WshShell
Dim Lastrow
Dim objFso


'#### Cleanup any left-over Excel processes ####'
Dim objProcess, colProcess, strComputer, objWMIService
Dim strProcessKill 
strComputer = "."
strProcessKill = "'excel.exe'"

Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _ 
& strComputer & "\root\cimv2") 

Set colProcess = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = " & strProcessKill )
For Each objProcess in colProcess
objProcess.Terminate()
Next 
'#### End of Cleanup any left-over Excel processes ####'


'Open excel file and start macro code
Dim ws_path
ws_path= Replace(WScript.ScriptFullName, WScript.ScriptName, "") 
Set ExcelObject  = Createobject("Excel.application")
ExcelObject.visible = True
ExcelObject.workbooks.open(ws_path & "Template.xlsm")
ExcelObject.run ("FilePreparation")



Set WshShell = WScript.CreateObject( "WScript.Shell" )
Set objFso = WScript.CreateObject("Scripting.FileSystemObject")

'Actual date for the save folder
Function TwoDigits(strParam) 
    If Len(strParam) = 1 Then 
        TwoDigits = "0" & strParam 
        Else 
        TwoDigits = strParam 
    End if 
End Function 

dtmActualTime = Date 
strActualTime = TwoDigits(Day(dtmActualTime)) &  TwoDigits(Month(dtmActualTime)) & Year(dtmActualTime)
strpath = Replace(WScript.ScriptFullName, WScript.ScriptName, "") 
folderpath= strpath & "Outputs\" 
If Not objFso.FolderExists(folderpath & strActualTime & "\") Then
    objFso.CreateFolder (folderpath & strActualTime & "\")
End If 
savepath= folderpath & strActualTime & "\"


Lastrow = ExcelObject.ActiveWorkbook.Sheets("Links").Cells(ExcelObject.ActiveWorkbook.Sheets("Links").Rows.Count, "I").End("-4162").Row

'Loop through the links in the excel file
prntname = "PDFCreator"
num = 2

do while (num <= Lastrow)
    On Error Resume next        
        ExcelObject.Activeworkbook.Sheets("Links").Cells(1, 9).Value = ExcelObject.Activeworkbook.Sheets("Links").Cells(num, 10).Value
        pdfname = ExcelObject.Activeworkbook.Sheets("Links").Cells(1, 9).Value
        urlname= ExcelObject.Activeworkbook.Sheets("Links").Cells(num, 9).Value

            'Check if this set of file has already run, if so then quit from script
            Set objFolder = objFso.GetFolder(savepath)
            Set objFiles = objFolder.Files 
                For i=0 to objFiles.Count
                    If objFso.FileExists(savepath & pdfname & ".pdf" ) Then
                        'WScript.echo  "Already run this file!"
                        ExcelObject.DisplayAlerts = False
                        ExcelObject.Quit
                        WScript.Quit 
                    End If
                Next 

            'Default printer is PDFCreator
            Dim objPrinter
            Set objPrinter = CreateObject("WScript.Network")
            objPrinter.SetDefaultPrinter prntname   

            'Open URL
            Set IE = CreateObject("InternetExplorer.Application")
            IE.Visible = True
            IE.Navigate urlname
            WScript.Sleep 5000
            While IE.Busy
                WScript.Sleep 1000
            Wend

            'Activate IExplorer and Print window pop up
            Set Processes = GetObject("winmgmts:").InstancesOf("Win32_Process")
            intProcessId = ""
            For Each Process In Processes
                If StrComp(Process.Name, "iexplore.exe", vbTextCompare) = 0 Then
                    intProcessId = Process.ProcessId
                    Exit For
                End If
            Next
            If Len(intProcessId) > 0 Then
                With CreateObject("WScript.Shell")
                    .AppActivate intProcessId 
                End With
            End if

            WScript.Sleep 3000
            IE.ExecWB 6, 1
            WScript.Sleep 5000
            WshShell.SendKeys  "{ENTER}" 
            WScript.Sleep 5000


            'Activate PDFCreator window and click on save button
            Set Processes = GetObject("winmgmts:").InstancesOf("Win32_Process")
            intProcessId = ""
            For Each Process In Processes
                If StrComp(Process.Name, "PDFCreator.exe", vbTextCompare) = 0 Then
                    intProcessId = Process.ProcessId
                    Exit For
                End If
            Next
            If Len(intProcessId) > 0 Then
                With CreateObject("WScript.Shell")
                    .AppActivate intProcessId 
                End With
            End If

            WScript.Sleep 5000
            WshShell.SendKeys  "{ENTER}" 
            WScript.Sleep 5000


            'Enter the save path and close Adobe and Internet Explorer
            WshShell.SendKeys  savepath & pdfname & ".pdf" 
            WScript.Sleep 5000
            WshShell.SendKeys  "{ENTER}" 
            WScript.Sleep 5000
            WshShell.SendKeys "(%{F4})" 'ALT + F4 
            WScript.Sleep 5000
            IE.Quit
            WScript.Sleep 5000      

            'Check if new pdf exists or not in the folder, if so then quit from script
            For i=0 to objFiles.Count
                If Not objFso.FileExists(savepath & pdfname & ".pdf" ) Then
                      num = num - 1
                End If
            Next 

    num = num + 1
Loop
WScript.Sleep 5000

ExcelObject.DisplayAlerts = False
ExcelObject.Quit
WScript.Quit

Steve Steve · Accepted Answer · 2017-01-24T03:17:27

Maybe you are running out of room. You seem to be creating ie objects but never releasing them. Perhaps add an "ie.quit", followed by a wait loop, followed by "set ie = Nothing", when you have printed each page. Or just reuse the object without createobject each loop.

Vbscript saving pdf from Internet Explorer

1 Answers