Page tree

Welcome to FreeSoftwareServers Confluence Wiki

Skip to end of metadata
Go to start of metadata
Sub HTMLTesting()  Sub TEsting()
  Dim URLStr As String
  URLStr = "URL"
 
  Dim HTMLDoc As MSHTML.HTMLDocument
  Set HTMLDoc = New MSHTML.HTMLDocument
  Set HTMLDoc = Get_HTMLDocument(URLStr)

  Dim TableSTR As String
  TableSTR = "datatable"
  URLStr = "http://webview/cs/EditHeader/FolderSamples.asp?WO=" & WONum
    
  Dim doc As MSHTML.HTMLDocument
  Set doc = New MSHTML.HTMLDocument
  Dim tableCells As MSHTML.IHTMLElementCollection
  Set tableCells = Get_IHTMLElementCollection(URLStr, TableSTR, doc)
End Sub
Public Function Get_IHTMLElementCollection(URLStr As String, TableSTR As String, ByRef doc As HTMLDocument) As MSHTML.IHTMLElementCollection
 '< VBE > Tools > References > Microsoft Scripting Runtime & Microsoft XML, V6.0
 Set doc = Get_HTMLDocument(URLStr)
 Dim table As MSHTML.HTMLTable
 Set table = doc.getElementById(TableSTR)
 Set Get_IHTMLElementCollection = table.getElementsByTagName("tr")
End Function
Public Function Get_HTMLDocument(URLStr As String) As HTMLDocument
'<  VBE > Tools > References > Microsoft Scripting Runtime & Microsoft XML, V6.0
    Dim xhr As MSXML2.XMLHTTP60

    Set xhr = New MSXML2.XMLHTTP60

        With xhr

            .Open "GET", URLStr, False
            .send

            If .readyState = 4 And .status = 200 Then
                Set Get_HTMLDocument = New MSHTML.HTMLDocument
                Get_HTMLDocument.body.innerHTML = .responseText
            Else
                Debug.Print "Error" & vbNewLine & "Ready state: " & .readyState & vbNewLine & "HTTP request status: " & .status
            End If

        End With

End Function
Public Function Get_HTMLTable(URLStr As String, TableSTR As String, TestSTR As String) As MSHTML.HTMLTable
 Call OPENIEURL(URLStr, False)

 Do Until InStr(1, IEObj.document.getElementById(TableSTR).innerHTML, TestSTR) > 0
  DoEvents
 Loop

 Set Get_HTMLTable = IEObj.document.getElementById(TableSTR)

End Function
Public Sub CopyHTMLTable(URLStr As String, DestWS As Worksheet, TableSTR As String, TestSTR As String)
  
 Dim table As MSHTML.HTMLTable
 Set table = Get_HTMLTable(URLStr, TableSTR, TestSTR)

 Set ClipBoard = New MSForms.DataObject
 ClipBoard.SetText table.outerHTML
 ClipBoard.PutInClipboard
 
 Dim TempWS As Worksheet
 Call WorksheetCreateDelIfExists("TempSheet")
 Set TempWS = Worksheets("TempSheet")
 TempWS.Activate
 Range("A1").Select
 ActiveSheet.Paste
 Dim UsedRng As Range
 Set UsedRng = GetUsedRange(TempWS)
 UsedRng.Copy
 DestWS.Activate
 Range("A1").Select
 DestWS.Paste
 Call CloseIEObj
 Call WorksheetDelete(TempWS)
  
End Sub
  • No labels