Get href attribute

199 Views Asked by At

There is a program that works fine . The result of her work is the output in Excel of the table of elements (every element look like “{td class=clr width=69>{a class=bluelink href=main.php?champ=2604&f_date=201611&tour=110}06.11.2016{/a}{/td}”). I’am trying to convert a program so that it outputs the href of each element (“main.php?champ=2604&f_date=201611&tour=110”) . I changed the line data(x, y) = oRow.Cells(y).innerHTML to data(x, y) = oRow.Cells(y). getAttribute("href"). But as a result , the program did not give anything away. Probably because of the fact that there is one more tag inside the element (“a”). Then I changed the same line to data(x, y) = oRow.Cells(y). getelementsbytagname("a"). getAttribute("href").

And got an error (Run-time error ‘438’ : Object doesn’t support this property or method) .

    Function extractTable(Ssilka As String, book1 As Workbook, iLoop As Long)
    Dim oDom As Object, oTable As Object, oRow As Object
    Dim iRows As Integer, iCols As Integer
    Dim x As Integer, y As Integer
    Dim data()
    Dim oHttp As Object
    Dim oRegEx As Object
    Dim sResponse As String
    Dim oRange As Range



    ' get page
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    oHttp.Open "GET", Ssilka, False
    oHttp.Send

    ' cleanup response
    sResponse = StrConv(oHttp.responseBody, vbUnicode)
    Set oHttp = Nothing

    sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))

    Set oRegEx = CreateObject("vbscript.regexp")
    With oRegEx
    .MultiLine = True
    .Global = True
    .IgnoreCase = False
    .Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
    sResponse = .Replace(sResponse, "")
    End With
    Set oRegEx = Nothing

    ' create Document from response
    Set oDom = CreateObject("htmlFile")
    oDom.Write sResponse
    DoEvents

    ' table with results, indexes starts with zero
    Set oTable = oDom.getelementsbytagname("table")(3)

     DoEvents

    iRows = oTable.Rows.Length
    iCols = oTable.Rows(1).Cells.Length

   ' first row and first column contain no intresting data
     ReDim data(1 To iRows - 1, 1 To iCols - 1)

    ' fill in data array
    For x = 1 To iRows - 1
       Set oRow = oTable.Rows(x)

       For y = 1 To iCols - 1
          data(x, y) = oRow.Cells(y).innerHTML

 '<td class=clr width=69><a class=bluelink href=main.php?
 champ=2604&f_date=201611&tour=110>06.11.2016</a></td>
 'getAttribute("href")
 'td-table data ячейка таблицы

    Next y
    Next x

    Set oRow = Nothing
    Set oTable = Nothing
    Set oDom = Nothing


   ' put data array on worksheet

     Set oRange = book1.ActiveSheet.Cells(34, iLoop * 25).Resize(iRows - 1, iCols - 1)
    oRange.NumberFormat = "@"
    oRange.Value = data

    Set oRange = Nothing


   '<DEBUG>
   '    For x = LBound(data) To UBound(data)
   '        Debug.Print x & ":[ ";
   '        For y = LBound(data, 2) To UBound(data, 2)
   '            Debug.Print y & ":[" & data(x, y) & "] ";
   '        Next y
   '        Debug.Print "]"
   '    Next x
   '</DEBUG>



    End Function
0

There are 0 best solutions below