• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

macro code arrangement for title extraction and google link

I enclose a macro that no longer works hoping that someone can make it work by making the right changes.

The macro starts from the value indicated in column (a) and inserts the title of the web page found in column (b) and the link in column (c).

Thanks to everyone who will contribute.
 

Attachments

  • google_results.xlsm
    18.1 KB · Views: 19
I don't know what I'm doing, but try:
Code:
Sub XMLHTTP()

Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
Dim start_time As Date
Dim end_time As Date

lastRow = Range("A" & Rows.Count).End(xlUp).Row
   
Dim cookie As String
Dim result_cookie As String
   
start_time = Time
Debug.Print "start_time:" & start_time

For i = 2 To lastRow

  url = "https://www.google.co.in/search?q=" & Cells(i, 1) & "&rnd=" & WorksheetFunction.RandBetween(1, 10000)

  Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
  XMLHTTP.Open "GET", url, False
  XMLHTTP.setRequestHeader "Content-Type", "text/xml"
  XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
  XMLHTTP.send

  Set html = CreateObject("htmlfile")
  html.body.innerHTML = XMLHTTP.ResponseText
  Set objResultDiv = html.getelementbyid("rso")
  Set objH3 = objResultDiv.getelementsbytagname("H3")(0)
  Set link = objResultDiv.getelementsbytagname("a")(0)
  str_text = objH3.innertext

  Cells(i, 2) = str_text
  Cells(i, 3) = link.href
  DoEvents
Next
   
end_time = Time
Debug.Print "end_time:" & end_time
   
Debug.Print "done" & "Time taken : " & DateDiff("n", start_time, end_time)
MsgBox "done" & "Time taken : " & DateDiff("n", start_time, end_time)
End Sub
 
Any error message when it crashes?

When you debug, type in the Immediate Pane:
?"]" & url & "["
and press Enter.
Copy/paste the result here.
 
I can't figure out where to insert the string.
I tried again by clicking on the question mark and leaving a message saying:
certified error
internal application error when loading SSL libraries

and this web page opens:

https://docs.microsoft.com/it-it/of...and-will-stop-the-debugger?f1url=https://msdn. microsoft.com 2Fquery%%% 2Fdev11.query 3FappId% 3DDev11IDEF1% 26l% 3Dit-EN% 26k% 3DK (vblr6.chm60081)% 3BK (TargetFrameworkMoniker-Office.Version 3Dv15%)%% 26rd 3Dtrue
 
Have you had a Windows update installed recently?
Google "internal application error when loading SSL libraries".
Does the macro work in your sample file? It does here (clear columns B and C first).
 
For p45cal:
I used macro in the workp. I think the browser will be updated.

For chihiro:
Tomorrow I can see the link and figure out how to do it.



I'll let you know.

Thank you so much
 
Good morning.
I checked the windows update date and downloaded and installed the chihiro link.
Unfortunately it does not work.
 

Attachments

  • 1.JPG
    1.JPG
    23.1 KB · Views: 7
  • 2.JPG
    2.JPG
    195.8 KB · Views: 7
  • 3.JPG
    3.JPG
    47.2 KB · Views: 4
  • 4.JPG
    4.JPG
    40.3 KB · Views: 3
So you are no longer getting the SSL message. That patch did it's job.

From the looks of it, that error message is related to request being timedout... not related to SSL anymore.

I have tested @p45cal 's code on my machine. Had no issues.
 
Yes, there is no longer that kind of error, but there is always this other message I am attaching to the photos.
Why is it generated?
Thank you
 

Attachments

  • 1.JPG
    1.JPG
    21.2 KB · Views: 7
  • 2.JPG
    2.JPG
    67.9 KB · Views: 6
Add this line just before the .Send line:
Debug.print "]" & url & "["
Copy/paste the result visible in the Immediate pane here.
 
Hi Pas45cal.
I entered the line of code as you indicated. You have the same error.
First the macro was fine and it was also very fast and without limits. Sin
 
Code:
Sub XMLHTTP()

Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
Dim start_time As Date
Dim end_time As Date

lastRow = Range("A" & Rows.Count).End(xlUp).Row
  
Dim cookie As String
Dim result_cookie As String
  
start_time = Time
Debug.Print "start_time:" & start_time

For i = 2 To lastRow

  url = "https://www.google.co.in/search?q=" & Cells(i, 1) & "&rnd=" & WorksheetFunction.RandBetween(1, 10000)

  Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
  XMLHTTP.Open "GET", url, False
  XMLHTTP.setRequestHeader "Content-Type", "text/xml"
  XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
  Debug.Print "]" & url & "["
  XMLHTTP.send

  Set html = CreateObject("htmlfile")
  html.body.innerHTML = XMLHTTP.ResponseText
  Set objResultDiv = html.getelementbyid("rso")
  Set objH3 = objResultDiv.getelementsbytagname("H3")(0)
  Set link = objResultDiv.getelementsbytagname("a")(0)
  str_text = objH3.innertext

  Cells(i, 2) = str_text
  Cells(i, 3) = link.href
  DoEvents
Next
  
end_time = Time
Debug.Print "end_time:" & end_time
  
Debug.Print "done" & "Time taken : " & DateDiff("n", start_time, end_time)
MsgBox "done" & "Time taken : " & DateDiff("n", start_time, end_time)
End Sub
 
I was hoping you would "Copy/paste the result visible in the Immediate pane here."
You should find it in the Immediate pane directly below the line starting "start_time:".
Then I'll able to follow it and see it anything valid turns up.
 
The Immediate pane and what I want highlighted in green:
59441



If you can't see the Immediate pane then:
59442
 
Last edited:
What he meant, I believe, is copy the string from immediate window. Paste as is to the forum.

From image, we can't tell if there are non-printing character mixed in there or not. And it's much easier to test validity with pasted string rather than from image.
 
I've tried that same url in the macro and it works fine here, so there's no problem up to that point.
I can't help any further because I can't replicate the problem here.
 
Good morning.
I think I found a similar post in another forum.
Also in this case it is necessary to update the macro, but compared to the one that does not seem to be open the pages.
It is probably more complete than the one I attached to the forum. It seems he does the search using two browsers.
I am attaching them to you so that you can evaluate them (if you have time).
Good day

link:
http://www.excelfox.com/forum/showt...ogle-Search-Result-Using-VBA?highlight=google
 

Attachments

  • BingLookupUrl.xlsm
    51.5 KB · Views: 11
  • BingLookupUrl_superspike711.xlsm
    51.7 KB · Views: 9
  • GoogleLookupUrl.xlsm
    26.5 KB · Views: 13
Good evening.
I did try the macro with the p45cal code from a friend.
He told me it works.
Could it be that the macro need to be adapted to work on other versions of excel and / or windows?
 
Hi stefan,
I had a look around, finding that the below helped one user with the same problem:
try replacing the line:
Code:
Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
with the line:
Code:
Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP.6.0")

Stevie ^.^
 
Back
Top