Web page save to PDF

[nokarukutu]

Hello comrades
There is macro which saves Web to PDF. After IE and Excel upgrade macro doesn't work correctly and offer to save Web page in html. Please advise what can do

The code:
----------------------------------------------------
Dim PDFFolder As String
Dim LastRow As Long
Dim arrSpecialChar() As String
Dim dblSpCharFound As Double
Dim PDFPath As String
Dim i As Long
Dim j As Integer

'An array with special characters that cannot be used for naming a file.
arrSpecialChar() = Split("\ / : * ? " & Chr$(34) & " < > |", " ")

'Find the last row.
With shMain
.Activate
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
End With

'Check if the PDF's folder exists.
PDFFolder = shMain.Range("B4").Value
If FolderExists(PDFFolder) = False Or PDFFolder = "" Then
MsgBox "The PDF folder's path is incorect!", vbCritical, "Wrong path"
shMain.Range("B4").Select
Exit Sub
End If

'Check if there is at least one URL.
If LastRow < 8 Then
MsgBox "You did't enter a URL!", vbCritical, "No URL"
Exit Sub
End If

'Add the backslash if not exists.
If Right(PDFFolder, 1) <> "\" Then
PDFFolder = PDFFolder & "\"
End If

' 'Set the default printer to Adobe PDF (for Adobe Professional).

'Convert the URLs to PDFs.
For i = 8 To LastRow
On Error Resume Next
PDFPath = Cells(i, 4).Value
' 'Check if the PDF name contains a special/illegal character.
For j = LBound(arrSpecialChar) To UBound(arrSpecialChar)
dblSpCharFound = WorksheetFunction.Find(arrSpecialChar(j), PDFPath)
If dblSpCharFound > 0 Then
PDFPath = WorksheetFunction.Substitute(PDFPath, arrSpecialChar(j), "-")
End If
Next j
PDFPath = PDFFolder & PDFPath
On Error GoTo 0
'Save the PDF files to the selected folder.
Call WebpageToPDF(Cells(i, 3).Value, PDFPath & ".pdf")
Next i

'Inform the user that macro finished.
MsgBox LastRow - 7 & " invoices were successfully saved as PDFs!", vbInformation, "Done"

End Sub

Sub WebpageToPDF(pageURL As String, PDFPath As String)

'Creates a new web browser object, opens a selected URL and then prints
'the web page as PDF using Adobe Professional.

'The macro needs a reference to Windows Script Host Object Model Library, as well
'as to the Microsoft Internet Controls Library in order to work.
'From VBA editor go to Tools -> References -> add the two references.
'Or you can find them at C:\Windows\system32\wshom.ocx and C:\Windows\system32\ieframe.dll.

Dim WebBrowser As InternetExplorer
Dim StartTime As Date
Dim intRet As Long
Dim Report As Variant


'Create new web browser object, make it visible,
'maximize the window and navigate to the desired url.
Set WebBrowser = New InternetExplorer
WebBrowser.Visible = True
ShowWindow WebBrowser.hwnd, SW_MAXIMIZE
WebBrowser.Navigate (pageURL)

'Wait until the web page is fully loaded.
Do
DoEvents
Loop Until WebBrowser.ReadyState = READYSTATE_COMPLETE

'Check if the internet explorer window exists.
StartTime = Now()
Do Until Now() > StartTime + TimeValue("00:00:05")
intRet = 0
DoEvents
'IEFrame is the class name for internet explorer.
intRet = FindWindow("IEFrame", vbNullString)
If intRet <> 0 Then Exit Do
Loop

Const OLECMDID_SAVEAS = 4
Const OLECMDEXECOPT_DODEFAULT = 0
Const OLECMDEXECOPT_PROMPTUSER = 2
'If the IE window exists, print the web page as PDF.
WebBrowser.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_PROMPTUSER
WebBrowser.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_PROMPTUSER
If intRet <> 0 Then

WebBrowser.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_PROMPTUSER

ShowWindow WebBrowser.hwnd, SW_MAXIMIZE
Application.Wait (Now + TimeValue("00:00:05"))

End If

If MsgBox("Invoice saved! Do you wish to proceed?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If


'Release the web browser object.
WebBrowser.Quit
Set WebBrowser = Nothing

End Sub

----------------------------------------------------------------------

Thank you in advance for your help

 

[nokarukutu]

any ideas comrades?