dcsimg
CodeGuru Home VC++ / MFC / C++ .NET / C# Visual Basic VB Forums Developer.com
Results 1 to 3 of 3

Thread: **** Grabbing Macros

  1. #1
    Join Date
    Jul 2015
    Posts
    3

    **** Grabbing Macros

    Hello! I want to grab the urls from this http://www.****.com/sch/Motorcycles-...cat=6024&rt=nc page and extract the data from the individual tables. I have a macro, ListURls, that works perfectly,
    Code:
    Sub ListURLs()
    
        Dim Anchors As Object
        Dim HTMLdoc As Object
        Dim Rng As Range
        Dim row As Long
        Dim URL As Variant
        Dim Wks As Worksheet
        
            URL = "http://www.****.com/sch/Motorcycles-/6024/i.html?_nkw=&_dcat=6024&rt=nc"
            
            Set Wks = Worksheets("Sheet1")
            Set Rng = Wks.Range("A2")
            
            With CreateObject("MSXML2.XMLHTTP")
                .Open "GET", URL, False
                .Send
                
                While .ReadyState <> 4: DoEvents: Wend
                
                If .Status <> 200 Then
                    MsgBox "Server Error: " & .Status & " - " & .StatusText
                    Exit Sub
                End If
                
                Set HTMLdoc = CreateObject("htmlfile")
                HTMLdoc.Write .responseText
                HTMLdoc.Close
                
                   Set Anchors = HTMLdoc.getElementsByTagName("A")
                
                For Each URL In Anchors
                    If URL.className = "vip" Then
                        Rng.Offset(row, 0).Value = URL.href
                        row = row + 1
                    End If
                Next URL
            End With
            
            Set HTMLdoc = Nothing
            
    End Sub
    but it pastes the links in a format of cgi.****., which doesnt work when i run my GetData macro,
    Code:
     Global HTMLdoc As Object
    
    Function GetElemText(ByRef Elem As Object, Optional ByRef ElemText As String) As String
    
     
        
        If Elem Is Nothing Then ElemText = "~": Exit Function
        
          ' Is this element a text value?
            If Elem.NodeType = 3 Then
              ' Separate text elements with a space character.
                ElemText = ElemText & Elem.NodeValue & " "
            Else
              ' Keep parsing - Element contains other non text elements.
                For Each Elem In Elem.ChildNodes
                    Select Case UCase(Elem.NodeName)
                        Case Is = "BR": ElemText = vbLf
                        Case Is = "TD": If ElemText <> "" Then ElemText = ElemText & "|"
                        Case Is = "TR": ElemText = ElemText & vbLf
                    End Select
                    Call GetElemText(Elem, ElemText)
                Next Elem
            End If
            
        GetElemText = ElemText
        
    End Function
    
    Function GetWebDocument(ByVal URL As String) As Variant
    
        Dim Text As String
        
            Set HTMLdoc = Nothing
            Set WebPage = CreateObject("InternetExplorer.Application")
            With WebPage
                WebPage.Navigate URL
                WebPage.Visible = False
            
            
                
                While .ReadyState <> 4: DoEvents: Wend
                
                If .Status <> 200 Then
                    GetWebDocument = "Error"
                    Exit Function
                End If
                
                Text = .responseText
            End With
            
            Set HTMLdoc = CreateObject("htmlfile")
            HTMLdoc.Write Text
            HTMLdoc.Close
            
    End Function
    
    Sub GetData()
    
        Dim Data    As Variant
        Dim n       As Long
        Dim oDiv    As Object
        Dim oTable  As Object
        Dim ret     As Variant
        Dim Rng     As Range
        Dim Text    As String
        
        
            Set Rng = Range("A2")
            
            Do While Not IsEmpty(Rng)
                ret = GetWebDocument(Rng)
        
              ' Check for a web page error.
                If Not IsEmpty(ret) Then
                    Rng.Offset(0, 1).Value = ret
                    GoTo NextURL
                End If
            
                Set oDiv = HTMLdoc.getElementByID("vi-desc-maincntr")
            
                  ' Locate the Item Specifics Table.
                    For n = 0 To oDiv.Children.Length - 1
                        If oDiv.Children(n).NodeType = 1 Then
                            If oDiv.Children(n).className = "attrLabels" Then
                                On Error Resume Next
                                    Set oDiv = oDiv.Children(n)
                                    Set oDiv = oDiv.Children(0)
                                    Set oTable = oDiv.Children(2)
                                On Error GoTo 0
                                Exit For
                            End If
                        End If
                    Next n
                
                  ' Check if Table exists.
                    If oTable Is Nothing Then
                        Rng.Offset(0, 1).Value = "Item Specifics were not found on this page."
                        GoTo NextURL
                    End If
                
                    c = 1
                
                  ' Read the row data and output it to the worksheet.
                    For n = 0 To oTable.Rows.Length - 1
                        Text = ""
                        Text = GetElemText(oTable.Rows(n), Text)
                        
                      ' To avoid an error, check there is text to output.
                        If Text <> "" Then
                            Data = Split(Text, "|")
                            Rng.Offset(0, c).Resize(1, UBound(Data) + 1).Value = Data
                            c = c + UBound(Data) + 1
                        End If
                    Next n
                    
    NextURL:
                Set Rng = Rng.Offset(1, 0)
            Loop
                
    End Sub
    I get an error 438 "object doesnt support this method" when I run this macro on the If status <>200 line. I have no idea what is wrong any help is appreciated!!

  2. #2
    DataMiser is offline Super Moderator Power Poster
    Join Date
    Jul 2008
    Location
    WV
    Posts
    5,331

    Re: **** Grabbing Macros

    When talking about Macros you really should state what app you are working with. VBA varies a bit by what product you are using. I assume in this case you are using Excel VBA.

    I do not code in Excel at all but it sounds like the object
    MSXML2.XMLHTTP does not have a .Status property

    Curious though as first you say it works perfectly and then you say you get an error on a given line within the so called perfectly working sub routine.
    Always use [code][/code] tags when posting code.

  3. #3
    Join Date
    Jul 2015
    Posts
    3

    Re: **** Grabbing Macros

    Sorry, I am working in Excel VBA. When I paste links in this format http://www.****.com/itm/Harley-David...m=191623359787, the GetData Macro works, but the ListUrl pastes the links in this format : http://cgi.****.com/****motors/Harle...a46d2b&vxp=mtr. Even though they link to the same page, GetData errors out on these types of links. Sorry about the confusion.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  


Windows Mobile Development Center


Click Here to Expand Forum to Full Width




On-Demand Webinars (sponsored)