I have a block of VBA code that takes names from an excel list and searches them into google, within search parameters and print screens the results. However, the code saves the print-screen as a .png file and I need it to be saved as an adobe file as I need to be able to comment/see the entirety of the first page of results.
I have tried my best to fix it myself but sadly it appears I cannot without the use of Selenium, which I can not use as I am unable to download software to my desktop.
Please see my code below; any tips/ points of reference are greatly appreciated. Thank you
Code
Option Explicit
'requires references: "Microsoft HTML Object Library" & "Microsoft Internet Controls"
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Sub screenShotWords()
Const url = "https://www.google.com/search?q="
Const imgScale = 1 ' 0.25 'scale to 25% (to create thumbnail)
Dim ie As InternetExplorer, ws As Worksheet, sz As Long
Dim img As Picture, oCht As ChartObject
Dim row, RowCount As Integer
Dim word, Query, fname As String
Set ws = ThisWorkbook.Sheets("Sheet1")
Set ie = GetIE()
RowCount = ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row 'get the last row number
With ie
Pause (2)
For row = 1 To RowCount
word = Range("A" & row)
Query = URLEncode("""" & word & """" & " + Sanction OR Charged OR Fraud OR Criminal OR Penalty OR Lawsuit OR Complaint OR Investigation")
fname = Application.ThisWorkbook.Path & "\sc_" & ReplaceIllegalCharacters(word, "_") & ".png" 'output filename (can be png/jpg/bmp/gif)
.navigate url & Query
Do: DoEvents: Loop While .busy Or .readyState <> 4 'wait for page load
ShowWindow .hwnd, 5 'activate IE window
Call keybd_event(44, 0, 0, 0) '44="VK_SNAPSHOT"
Pause (0.25) 'pause so clipboard catches up
With ws
ShowWindow Application.hwnd, 5 'back to Excel
.Activate
.Paste
Set img = Selection
With img
Set oCht = ws.ChartObjects.Add(.Left, .Top, .Left + .Width, .Top + .Height)
oCht.Width = .Width * imgScale 'scale obj to picture size
oCht.Height = .Height * imgScale
oCht.Activate
ActiveChart.Paste
ActiveChart.Export fname, Mid(fname, InStrRev(fname, ".") + 1)
oCht.Delete
.Delete
End With 'end with img
.Activate
End With 'end with ws
Next 'next row
If Dir(fname) = "" Then MsgBox fname & " Not created" 'Something went wrong (file not created)
.FullScreen = False
.Quit
End With 'ie
End Sub
Sub Pause(sec As Single)
Dim t As Single: t = Timer
Do: DoEvents: Loop Until Timer > t + sec
End Sub
Function GetIE() As Object
'requires references: "Microsoft HTML Object Library" & "Microsoft Internet Controls"
'return an object for the open Internet Explorer window, or create new one
For Each GetIE In CreateObject("Shell.Application").Windows() 'Loop to find
If (Not GetIE Is Nothing) And GetIE.Name = "Internet Explorer" Then Exit For 'Found!
Next GetIE
If GetIE Is Nothing Then Set GetIE = CreateObject("InternetExplorer.Application") 'Create
GetIE.Visible = True 'Make IE visible
GetIE.FullScreen = True
End Function
Function URLEncode(EncodeStr As String) As String
'source: https://blog.adamfurmanek.pl/2018/01/20/url-encode-in-vba/
Dim i As Integer
Dim erg As String
erg = EncodeStr
' *** First replace '%' chr
erg = Replace(erg, "%", Chr(1))
' *** then '+' chr
erg = Replace(erg, "+", Chr(2))
For i = 0 To 255
Select Case i
' *** Allowed 'regular' characters
Case 37, 43, 48 To 57, 65 To 90, 97 To 122
Case 1 ' *** Replace original %
erg = Replace(erg, Chr(i), "%25")
Case 2 ' *** Replace original +
erg = Replace(erg, Chr(i), "%2B")
Case 32
erg = Replace(erg, Chr(i), "+")
Case 3 To 15
erg = Replace(erg, Chr(i), "%0" & Hex(i))
Case Else
erg = Replace(erg, Chr(i), "%" & Hex(i))
End Select
Next
URLEncode = erg
End Function
Function ReplaceIllegalCharacters(ByVal strIn As String, strChar As String) As String
'source: https://stackoverflow.com/questions/50846340/remove-illegal-characters-while-saving-workbook-excel-vba
Dim strSpecialChars As String
Dim i As Long
strSpecialChars = "~""#%&*:<>?{|}/\[]" & Chr(10) & Chr(13)
For i = 1 To Len(strSpecialChars)
strIn = Replace(strIn, Mid$(strSpecialChars, i, 1), strChar)
Next
ReplaceIllegalCharacters = strIn
End Function
Display More