Lookup First URL From Google Search Result Using VBA

[SirJB7]

Hi, joparo!
There's a new enhanced version at the same previous link of my first comment.
Regards!

[joparo]

Permission to use object denied? any help to fix this error?

[joparo]

hi all, the code stops working as i get a pop up "permission to use the object denied"
it runs for a while like copies few links and error message 419

things i tried:

removed all the add-ins

logged in as administrator

stopped using anti virus

found xlstart folder empty

error still there, any help?

[joparo]

Hi Lalit i have been using your code, it works fine after few minutes i get this crazy error "permission to use the object denied" error 419. i tried few things altering the code, didn't work, so the best person to ask is the creator, any help?

[superspike711]

Excel Fox,
The macro you created no longer works. I think the html page formatting has changed since you wrote it.
I am definitely no expert but I rewrote It anyway. It's messy but seems much faster and did not crap out during 4200 entry search.
Regards
Spike

File attached:

[Excel Fox]

SirJB7,

May I request you to remove the second last post from the thread you've posted above. We don't offer a Black Amex or any money for helping the MS-Office online community. You must have noted that we give help not just in Excel, but also most of the other applications in the MS-Office Suite.

We have no disregard for the site you're associated with. We'd expect the same in return. The way I look at it, OP has received three different solutions to the problem, and as solution providers, it should be considered as a win for yourself and us here.

PS: OP posted the query here at least 4 hours before posting it at the thread you mentioned above. And since most of us are at +5.30 GMT, we were only able to provide a solution in the morning.

The reasons why we expect someone to register is just for the sake of a figure, that may give us a sense of pride to have X registered members. If you look at Rick Rothstein's Corner, you'd notice that one doesn't need to register to read the thread. We have our own ways of doing things, and I am sure you have your own. You are free to give a thumbs down to what you deem should be 'thumbs-downed', but as a fellow Excellian or as a fellow online help volunteer, we'd expect you to maintain a sense of respect for other communities that are only trying to help others.

Kris (Admin), and I, we are two different people. Both of us are part of many other forums, and have been helping the online community for many years, having well over 15000 posts between us. Most of the solution providers here are our friends and volunteers who we've come across at different forums and work places. Admonishing someone not to post a cross-post link doesn't come from 'greatness' or even from 'keeping forum sanity in check', but it comes from a sense of contempt and highhandedness.

On a more regular note, we (and I personally) welcome you to the ExcelFox community. Glad to have you here. Feel free to post MS-Office related suggestions / posts whenever you feel like. Even with your vast experience and knowledge, I am sure there may be fractions of a percentage that we can add to your knowledge.

Happy helping.

Regards,
EF

[SirJB7]

Hi, Excel Fox!

I sincerely apologize for the misunderstanding. As soon as I received the email notice of this message I proceeded to edit the related post trying to clarify and added a link to this thread.

Absolutely nothing farther from my intentions than starting at a new forum in this way, so I thank you very much for your welcome words. I don't agree with the knowledge flow that may arise. If you could have read my Interest section of my profile at Chandoo's forums there it says: "Technical? Improve and apply". Despite of this I strongly believe in a phrase from Albert Einstein, please forgive if my non-native English play a trick on me: "We are all very ignorant, what happens is that not all ignore the same things".

Regarding your request of removing the related post I hope that the explanations given were suitable for you. Towards the future I wish that both sides of the scale get balanced, either suggesting solutions or incorporating knowledge.

Lastly I must say that I completely disagree about your words about crossposting and following actions, but I'll play with the house rules, if I play, so don't expect reading me here alike.

Best regards.

[Excel Fox]

SirJB7,

We respect your thoughts. No offense taken. And the clarification you've given over there has been taken in the right earnest.

Regarding cross posting, we here also are in lines with all other forums, including Chandoo and we ask people to inform the forum if the same thread is started elsewhere. My only specific comment above was basis this specific case only. So yes, we agree and feel the same way as you and all other forum volunteers feel about cross posting.

Would appreciate you helping the online community here as well, as you're doing for other communities.

Regards from this forum again.

Thanks,
EF

[Excel Fox]

You haven't mentioned which version of the code you are facing problem with. If you facing problem with all the codes, then there must be some administrative problems (can't tell for sure). If it's a specific code from this thread, or from the one from the other link, mention which one.

[joparo]

Option Explicit

Sub lm_GetGooleFirstSearchAddres()


    Dim strHtml                 As String
    Dim lngLoop                 As Long
    Dim rngRange                As Range
    Dim rngCell                 As Range
    
    With ThisWorkbook.Worksheets("Sheet1")
        Set rngCell = .Range("A1").CurrentRegion.Resize(, 1)
        Set rngRange = Nothing
        On Error Resume Next
        Set rngRange = Intersect(rngCell, rngCell.Offset(1))
        On Error GoTo -1: On Error GoTo 0: Err.Clear
        If Not rngRange Is Nothing Then
            For Each rngCell In rngRange
                With CreateObject("MSXML2.XMLHTTP")
                    .Open "get", URLEncode(rngCell.Value), False
                    .send
                    strHtml = .responseText
                    strHtml = Mid(strHtml, InStr(1, strHtml, "<div id=""ires"">"))
                    strHtml = Mid(strHtml, 1, InStr(1, strHtml, "<div class=""s"">"))
                    strHtml = Mid(strHtml, InStr(1, strHtml, "<a href="))
                    strHtml = Mid(strHtml, InStr(1, strHtml, "<a href="), InStr(1, strHtml, """ onmousedown="""))
                    strHtml = Mid(strHtml, InStr(1, strHtml, """"), Len(strHtml) - 1)
                    rngCell.Offset(, 1).Value = Mid(Trim(strHtml), 2, Len(Trim(strHtml)) - 2)
                End With
            Next rngCell
            MsgBox "Search completed.", vbInformation, "Google Search..."
        Else
            MsgBox "No data found to search.", vbCritical, "Google Search..."
        End If
    End With
    
    strHtml = vbNullString
    lngLoop = Empty
    Set rngRange = Nothing
    Set rngCell = Nothing
    
End Sub


Function URLEncode(EncodeStr As String) As String
    
    Dim i As Integer
    Dim erg As String
    
    Const strGogSrchUrl         As String = " http://www.google.co.in/search?output=search&sclient=psy-ab&q=|||&btnK="
    Const strConcatDelima       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 = Replace(strGogSrchUrl, strConcatDelima, erg)
    'URLEncode = strGogSrchUrl & erg
    
    i = Empty
    erg = vbNullString
    
End Function