Code:
Option Explicit
Dim var As Variant
Sub SearchBing()
Dim rng As Range
Dim lngCol As Long
Dim oXML As New MSXML2.XMLHTTP
Dim uTxt As Variant
Dim xURL As String
Dim srchString As Variant
Dim StrStart As Variant
Dim StrEnd As Variant
Dim StrOutput As Variant
Dim x As Variant
Dim OutputRowNumber As Variant
' Clear Destination Column for URL Lookup
Worksheets("Sheet1").Range("B2:B" & Rows.Count).ClearContents
' Set base search using bing instead of google because google's pages are a mess
Const strURL = "http://www.bing.com/search?q=|+|"
' Move through source cells
For Each rng In Worksheets("Sheet1").Range("A2:A5000")
' Make sure range is not empty before we start
If Not IsEmpty(rng) Then
' encode url for direct submission
xURL = Replace(strURL, "|+|", URLEncode(rng.Value))
'Debug.Print xURL
' set object parameters
oXML.Open "GET", xURL, False
oXML.setRequestHeader "Content-Type", "text/xml"
' Delay request by wait to allow catchup and to not freakout
' search firewalls
x = x + 1
If x = 6 Then
x = 0
'Slow it down a bit
DoEvents
End If
'Debug.Print "x=" & x
' if you don't have this program will crap out if it encounters weird
' formatted page
On Error Resume Next
'Send request returns page of searchable xml text to oXML object
oXML.send
'FIRST SEARCH PRIORITY
' srchstring finds unique string in the ballpark of what you want
' add more searchs if you want other information or if you want to
' get check more accurate info from page if it is available
' this section finds "website" button that sometimes appears on the right
' of bing search results
srchString = "role=""button"" href=""http"
' extract small chunk of text so you can search again without dupes
StrStart = InStr(1, oXML.responseText, srchString) + 20
StrEnd = InStr(StrStart, oXML.responseText, 60)
StrOutput = Mid(oXML.responseText, StrStart, StrEnd - StrStart - 3) & Chr(10)
' in the smaller string you extracted above drill down on the actual string
' you want - this one finds the first instance of http in the smaller string
StrStart = InStr(1, StrOutput, "http")
' this one finds the end of the url by starting 9 after http and looks for "
StrEnd = InStr(StrStart + 9, StrOutput, """")
' use start and end to isolate the web address
StrOutput = Mid(StrOutput, StrStart, StrEnd - StrStart)
'SECOND SEARCH PRIORITY
' using if-then If the first search does not find a website button it
' returns first item from search results. Note: First result is not always
' what you want
If InStr(1, StrOutput, "www.w3.org") Then
srchString = "Search Results"
StrStart = InStr(1, oXML.responseText, srchString) + 47
StrEnd = InStr(StrStart, oXML.responseText, 60)
StrOutput = Mid(oXML.responseText, StrStart, StrEnd - StrStart - 3) & Chr(10)
StrStart = InStr(1, StrOutput, "http")
StrEnd = InStr(StrStart + 9, StrOutput, """")
StrOutput = Mid(StrOutput, StrStart, StrEnd - StrStart)
End If
'Remove results that is too long (likely some sort of error)
If Len(StrOutput) > 50 Then StrOutput = "NOT FOUND"
'Cleanup Some of the Bad Addresses
If InStr(1, StrOutput, "bloomberg.com") Then StrOutput = "NOT FOUND"
If InStr(1, StrOutput, "dandb.com") Then StrOutput = "NOT FOUND"
If InStr(1, StrOutput, "bing.com") Then StrOutput = "NOT FOUND"
If InStr(1, StrOutput, "wikipedia.org") Then StrOutput = "NOT FOUND"
If InStr(1, StrOutput, "doubleclick.net") Then StrOutput = "NOT FOUND"
If InStr(1, StrOutput, "brightscope.com") Then StrOutput = "NOT FOUND"
If InStr(1, StrOutput, "usnews.com") Then StrOutput = "NOT FOUND"
If InStr(1, StrOutput, "linkedin.com") Then StrOutput = "NOT FOUND"
If InStr(1, StrOutput, "usnews.com") Then StrOutput = "NOT FOUND"
'add row numbers for debugging
'OutputRowNumber = OutputRowNumber + 1
'Debug.Print OutputRowNumber & ": " & StrOutput
'Debug.Print oXML.responseText
rng.Offset(, 1).Value = StrOutput
Else
Exit For
End If
Next rng
'set debugging row back to zero
'OutputRowNumber = 0
Set rng = Nothing
End Sub
Function URLEncode(EncodeStr As String) As String
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
Reply With Quote
Bookmarks