VBScript Extracting HTML Tables

P

preludeofme

New Member
Joined
Dec 4, 2008
Messages
34
I'm working on some code that i found from:http://www.excelhero.com/blog/2010/05/multi-threaded-vba.html
(which for those that haven't read the article, it is pretty cool stuff)

but what i'm trying to do is get the vbscript "bees" to read the sourcecode for the website i'm pulling from by using the MSHTML objects. below is what i've got so far, but it keeps erroring out at the "HTMLBody.innerHTML = oXML.responseText".

i was trying to avoid having to parse out the sourcecode line by line
and just use the html objects but i'm guessing vbscript doesn't have
that functionality... any ideas?


Code: 
Set oXL = GetObject(, "Excel.Application")
Set oXML = Wscript.CreateObject("MSXML2.<WBR>XMLHTTP")
Set HtmlDoc = Wscript.CreateObject("<WBR>htmlfile")
Set HTMLBody = HtmlDoc.body
 
 
' Navigate to property page
oXML.Open "GET", URL,False
Wscript.Sleep 50
oXML.send
Wscript.Sleep 50
 
' Get html ////ERROR HAPPENS HERE////
HTMLBody.innerHTML = oXML.responseText
 
 
Set Ach = HTMLBody.document.<WBR>getElementById("<WBR>InformationGrid2")
 
 
              If Ach Is Nothing Then
              Else
 
                  For Each Row In Ach.Rows
                          If
Ach.Rows(Row.RowIndex).Cells(<WBR>0).innerText <> "Type" Then
                              If
Ach.Rows(Row.RowIndex).Cells(<WBR>0).innerText <> "No Requests found for
this Account " Then
                                  Debug.Print
Ach.Rows(Row.RowIndex).Cells(<WBR>9).innerText
                                  If
Ach.Rows(Row.RowIndex).Cells(<WBR>9).innerText = "Edit " Then
                                      vResults(0) = Acct
                                      vResults(1) =
Ach.Rows(Row.RowIndex).Cells(<WBR>0).innerText
                                      vResults(2) =
Ach.Rows(Row.RowIndex).Cells(<WBR>1).innerText
                                      vResults(3) =
Ach.Rows(Row.RowIndex).Cells(<WBR>2).innerText
                                      vResults(4) =
Ach.Rows(Row.RowIndex).Cells(<WBR>3).innerText
                                      vResults(5) =
Ach.Rows(Row.RowIndex).Cells(<WBR>4).innerText
                                      vResults(6) =
Ach.Rows(Row.RowIndex).Cells(<WBR>5).innerText
                                      vResults(7) =
Ach.Rows(Row.RowIndex).Cells(<WBR>6).innerText
                                      vResults(8) =
Ach.Rows(Row.RowIndex).Cells(<WBR>7).innerText
                                      vResults(9) =
Ach.Rows(Row.RowIndex).Cells(<WBR>8).innerText
                                      vResults(10) =
Ach.Rows(Row.RowIndex).Cells(<WBR>9).innerText
 
Sort by date Sort by votes
If it is being developed in VBA then you can add watches.
 
Upvote 0

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Norie said:
So is this code in the VBA Editor or are you using other code to create the VB script in a file and then running the script?
Click to expand...

correct

John_W said:
which references the currently running Excel application. You don't need this line in VBA. You will also need to reference an open workbook if you are writing values to cells.

For the error, try
Code:
Set HTMLdoc = CreateObject("HTMLFile")
HTMLdoc.body.innerHTML = .responseText
Set Ach = HTMLdoc.getElementById("InformationGrid2")
Click to expand...

i'll give that a shot, i haven't gotten an error on the excel part of it as the code hasn't gotten that far, but i'll change it up to see if i can avoid the problem :)

Norie said:
If it is being developed in VBA then you can add watches.
Click to expand...

Thanks i'll do some research and find out how

again thanks everyone for your help, will see if i can get it to work
 
Upvote 0
Just select the variable, right click and you should have the Add Watch... option.
 
Upvote 0
when trying the:

Code: 
Set HTMLdoc = CreateObject("HTMLFile")
HTMLdoc.body.innerHTML = .responseText
Set Ach = HTMLdoc.getElementById("InformationGrid2")

i get the following error:

Error: Object required: 'Body'
code: 800A01A8
Source: Microsoft VBScript runtime error

I also tried to put a watch on the code but not doing anything that i can tell. I don't think it will work because the code that is causing the errors is running outside of excel/VBE.
 
Upvote 0
I was wrong when I said that VBA code should work almost unchanged in VBScript. To 'load' the XML response, HTMLDocument, HTMLdoc.body.innerHTML = .responseText works in VBA, but in VBScript it fails with the error shown in your previous post. For VBScript, use instead HTMLDoc.Write .responseText and HTMLDoc.Close. Here's a complete working example which displays the Excel Questions threads (save it as Test.vbs):
Code: 
Dim HTMLDoc, XML
Dim URL, table

Set HTMLDoc = CreateObject("HTMLFile")
Set XML = CreateObject("MSXML2.XMLHTTP")

URL = "http://www.mrexcel.com/forum/forumdisplay.php?f=10&order=desc"

With XML
  .Open "GET", URL, False
  .Send
  HTMLDoc.Write .responseText
  HTMLDoc.Close
End With

Set table = HTMLDoc.getElementById("threadslist")
WScript.Echo table.innerText
 
Upvote 0
so here's the final vers:

Code: 
Public Sub Swarm_Method()
    ' Note: this method uses a number of independent VBScript files.
    '       You may need to authorize each once when they run for
    '       the first time, depending on your security settings.
    
    Dim lngCurRec As Long
    Dim lngCurAgt As Long
    Dim rngOutput As Range
    
    
    ' Setup variables
    With ThisWorkbook.Sheets("Criteria").Range("A1")
        lngRecords = .End(xlDown).Row - .Row + 1
        vAddresses = .Resize(lngRecords)
    End With
    lngAgents = 10
    lngOutputCol = ThisWorkbook.Sheets("Results").Range("B2").Column
    
    
    ' Create VBScript Agent Swarm
    For lngCurRec = 2 To UBound(vAddresses)
        
        DoEvents
            DoEvents
            
'            Debug.Print ThisWorkbook.Sheets("criteria").Range("A" & lngCurRec).Value
            
            Call CreateVBScriptAgentAndLaunch(ThisWorkbook.Sheets("criteria").Range("A" & lngCurRec).Value, ThisWorkbook.Sheets("criteria").Range("B" & lngCurRec).Value)
            lngCurAgt = lngCurAgt + 1
            If lngCurAgt = lngAgents Then Exit For
            Sleep 5
    
    
    Next lngCurRec
    ' Terminate objects
    Set rngOutput = Nothing
End Sub
Public Sub CreateVBScriptAgentAndLaunch(Acct As String, rep As String)
    Dim sFileName As String
    Dim intFileNum As Integer
    Dim shellWin As New ShellWindows
    Dim s As String
    Dim lngRow As Long, sCol As String, sPropAddr As String, sOutputRangeAddress As String
    Dim lngAgentNumber As Long
       
    ' Setup variables
    DoEvents
    
    AcctNum = Acct
    repcode = rep
    
    lngAgentNumber = lngAgents
    DoEvents
    
    ' Create string for contents of VBScript file
    DoEvents
    s = s & "Dim oXML, oXL, oXLB" & vbCrLf
    s = s & "Const xlup = -4162" & vbCrLf
    s = s & "Dim hbody" & vbCrLf
    s = s & "Dim HtmlDoc" & vbCrLf
    s = s & "Dim HTMLBody" & vbCrLf
    s = s & "Dim achRows " & vbCrLf
    s = s & "Dim Ach " & vbCrLf
    s = s & "Dim rep " & vbCrLf
    s = s & "Dim rngOutput" & vbCrLf
    s = s & "Dim crow" & vbCrLf
    s = s & vbCrLf
    s = s & vbCrLf
    s = s & vbCrLf
    s = s & "' Setup variables" & vbCrLf
    s = s & "AcctNum = """ & Acct & """" & vbCrLf
    s = s & "repcode = """ & repcode & """ " & vbCrLf
    s = s & "Set oXL = GetObject(, ""Excel.Application"")" & vbCrLf
    s = s & "Set oXML = WScript.CreateObject(""MSXML2.XMLHTTP"")" & vbCrLf
    s = s & "Set htmldoc = WScript.CreateObject(""htmlfile"")" & vbCrLf
    s = s & vbCrLf
    s = s & vbCrLf
    s = s & "' Navigate to property page" & vbCrLf
    s = s & "oXML.Open ""GET"", URL , False"
    s = s & vbCrLf
    s = s & "Wscript.Sleep 50" & vbCrLf
    s = s & "oXML.send" & vbCrLf
    s = s & "Wscript.Sleep 50" & vbCrLf
    s = s & vbCrLf
    s = s & vbCrLf
    s = s & vbCrLf
    s = s & "' Get html" & vbCrLf
    s = s & "htmldoc.write oXML.responseText" & vbCrLf
    s = s & "htmldoc.close" & vbCrLf

    s = s & "set ach = htmldoc.getelementbyid(""InformationGrid2"")' Get html" & vbCrLf
    s = s & " set oXLB = oXL.workbooks(""" & ThisWorkbook.Name & """).Sheets(""Results"")" & vbCrLf
    s = s & "On Error Resume Next" & vbCrLf
 
    s = s & "               If Ach Is Nothing Then  " & vbCrLf
    s = s & "               Else    " & vbCrLf
    s = s & "                   For y=0 to ach.rows.length-1   " & vbCrLf
    s = s & "                           If Ach.Rows(y).Cells(0).innerText <> ""Type"" Then " & vbCrLf
    s = s & "                               If Ach.Rows(y).Cells(0).innerText <> ""No Requests found "" Then  " & vbCrLf
    s = s & "                                   If Ach.Rows(y).Cells(9).innerText = ""Edit ""  Then " & vbCrLf
    s = s & "                                       crow = oXLB.Range(""A500000"").End(xlup).Offset(1, 0).row " & vbCrLf
    s = s & "                                       oXLB.cells(crow,1).value = Acctnum   " & vbCrLf
    s = s & "                                       oXLB.cells(crow,2).value = repcode " & vbCrLf
    s = s & "                                       oXLB.cells(crow,3).value = Ach.Rows(y).Cells(0).innerText  " & vbCrLf
    s = s & "                                       oXLB.cells(crow,4).value = Ach.Rows(y).Cells(2).innerText  " & vbCrLf
    s = s & "                                       oXLB.cells(crow,5).value = Ach.Rows(y).Cells(4).innerText  " & vbCrLf
    s = s & "                                       oXLB.cells(crow,6).value = Ach.Rows(y).Cells(7).innerText  " & vbCrLf
    s = s & "                                       RandomNumber = Int(Rnd * (800 + 1 - 350)) + 350" & vbCrLf
    s = s & "                                       Wscript.Sleep RandomNumber" & vbCrLf
    s = s & vbCrLf
    s = s & "                                   End If  " & vbCrLf
    s = s & "                               End If  " & vbCrLf
    s = s & "                           End If"
    s = s & vbCrLf
    s = s & "                   Next" & vbCrLf
    s = s & "On Error goto 0" & vbCrLf
    s = s & "               End If  " & vbCrLf
    Debug.Print s
    ' Write VBScript file to disk
    sFileName = ActiveWorkbook.Path & "\SwarmAgent_" & lngAgentNumber & ".vbs"
    intFileNum = FreeFile
    Open sFileName For Output As intFileNum
    Print #intFileNum, s
    Close intFileNum
    DoEvents
    ' Run VBScript file
    Set wshShell = CreateObject("Wscript.Shell")
    wshShell.Run """" & sFileName & """"
    
    DoEvents
    Set wshShell = Nothing
 
End Sub
 
Upvote 0
Hello,

Currently I am trying to read myself trough the Swarm_Method. I also managed to adjust the code to my needs, unfortunately only for one column.
The following Code runs trough Waybills in Column D and gives me a value in Column E.
But additionally I need further info out of that Waybill which I would like to display in the column F,G,H etc.(screenshot)
In the code I provided the loop for the column F (Pieces).

How to I have to change the code to get it into my Excel File? How do I optimze the code at all?

Appretiate you Help
Thanks in Advance!






Code: 
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public lngAgents As Long
Public lngOutputCol As Long

Public Sub Swarm_Method(shtData As Worksheet, sProperty_RangeAddr, Optional boolOneAgentOnly As Boolean)
    Dim lngCurRec As Long
    Dim lngCurAgt As Long
    Dim rngOutput As Range
    
'Setup variables
    With shtData.Range(sProperty_RangeAddr)
        lngRecords = .End(xlDown).Row - .Row + 1
        vAddresses = .Resize(lngRecords)
    End With
    lngAgents = [SwarmSize]
    lngOutputCol = Range(sProperty_RangeAddr).Offset(, 1).Column
    
'Create VBScript Agent Swarm
    For lngCurRec = 1 To UBound(vAddresses)
        DoEvents
        Set rngOutput = Range(sProperty_RangeAddr).Offset(lngCurRec - 1, 1)
        
        If Len(rngOutput) = 0 Then
            DoEvents
            CreateVBScriptAgentAndLaunch rngOutput
            lngCurAgt = lngCurAgt + 1
            If boolOneAgentOnly Or lngCurAgt = lngAgents Then Exit For
            Sleep 5
        End If
    Next lngCurRec
    ' Terminate objects
    Set rngOutput = Nothing
End Sub

Public Sub CreateVBScriptAgentAndLaunch(rngOutput As Range)
    Dim sFileName As String
    Dim intFileNum As Integer
    Dim shellWin As New ShellWindows
    Dim s As String
    Dim lngRow As Long, sCol As String, sPropAddr As String, LastCheckpoint, Account As String
    Dim lngAgentNumber As Long
       
' Setup variables
    lngRow = rngOutput.Row
    sCol = rngOutput.Column
    LastCheckpoint = rngOutput.Resize(, 1).Address
    Account = rngOutput.Resize(, 2).Address
    sPropAddr = rngOutput.Offset(, -1)
    DoEvents
                
' Set semaphore
    lngAgentNumber = lngRow Mod lngAgents
    rngOutput = "Agent_" & lngAgentNumber
    DoEvents
       
' Create string for contents of VBScript file
    DoEvents
    s = s & "Dim oXML, oXL, curRow, outputCol, propAddress, sHTML, i" & vbCrLf
    's = s & "Dim vResults(7)" & vbCrLf
    s = s & vbCrLf
' Setup variables" & vbCrLf
    s = s & "curRow = " & lngRow & vbCrLf
    s = s & "outputCol = """ & sCol & """" & vbCrLf
    s = s & "propAddress = """ & sPropAddr & """" & vbCrLf
    s = s & "Set oXL = GetObject(, ""Excel.Application"")" & vbCrLf
    s = s & "Set oXML = WScript.CreateObject(""MSXML2.XMLHTTP"")" & vbCrLf
    s = s & vbCrLf
' Navigate to property page
    s = s & "oXML.Open ""GET"", ""http://npts2.apis.dhl.com:6010/npts/ShipmentDataFetchServlet?action=8&shipDetFromSumm="" & propAddress, false" & vbCrLf
    s = s & "Wscript.Sleep 50" & vbCrLf
    s = s & "oXML.send" & vbCrLf
    s = s & "Wscript.Sleep 50" & vbCrLf
    s = s & vbCrLf
' Get html
    s = s & "sHTML = oXML.responseText" & vbCrLf
    s = s & vbCrLf
' Get html
s = s & "IEhtml2 = Split(sHTML, vbCrLf)" & vbCrLf
s = s & "On Error Resume Next" & vbCrLf

' Parse fields
'------------------------------------------------------------------------------------------------------------------------
'Remarks
s = s & "For a = 1 To UBound(IEhtml2)" & vbCrLf
        s = s & "If InStr(1, IEhtml2(a), ""Remarks"") Then" & vbCrLf
                s = s & "Remark = IEhtml2(a + 27)" & vbCrLf
                s = s & "Remark = Replace(Remark, chr(34), """")" & vbCrLf
                s = s & "Remark = Replace(Remark, "" "", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""<"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""="", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, "">"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""&"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, "";"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""/a"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""/td"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""("", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, "")"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""'"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""tdclassgrayTdNormalheight21nbsp"", """")" & vbCrLf
        s = s & "End If" & vbCrL
s = s & vbCrLf
s = s & "Next" & vbCrL
s = s & vbCrLf
'-----------------------------------------------------------------------------------------------------------------------
 ' Example for Column F  = Pieces
s = s & "For a = 1 To UBound(IEhtml2)" & vbCrLf
        s = s & "If InStr(1, IEhtml2(a), ""addZero"") Then" & vbCrLf
                s = s & "Piece = IEhtml2(a)" & vbCrLf
                s = s & "Piece = Replace(Piece, chr(34), """")" & vbCrLf
                s = s & "Piece = Replace(Piece, "" "", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""<"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""="", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, "">"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""&"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, "";"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""/a"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""/td"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""("", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, "")"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""'"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, propAddress, """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""tdclasswhiteTdNormalheight21aligncenternbspahrefjavascript:pieceClickedaddZero"", """")" & vbCrLf
        s = s & "End If" & vbCrL
s = s & vbCrLf
s = s & "Next" & vbCrL
s = s & vbCrLf

'Write results to Excel sheet
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""" & LastCheckpoint & """) = Remark" & vbCrLf


    
'Write VBScript file to disk
    sFileName = ActiveWorkbook.Path & "\SwarmAgent_" & lngAgentNumber & ".vbs"
    intFileNum = FreeFile
    Open sFileName For Output As intFileNum
    Print #intFileNum, s
    Close intFileNum
    DoEvents
'Run VBScript file
    Set wshShell = CreateObject("Wscript.Shell")
    wshShell.Run """" & sFileName & """"
    DoEvents
    Set wshShell = Nothing
 
End Sub
 
Upvote 0
poppi1984 said:
Currently I am trying to read myself trough the Swarm_Method. I also managed to adjust the code to my needs, unfortunately only for one column.
Click to expand...
Do you need to use this Swarm_Method (multiple VBScript parallel processes) technique? It is a very fast technique if you need to retrieve the same data from thousands of URLs, but not really necessary if a sequential retrieval does the job in a reasonable time. How many Waybills are there in column D?

If you want to use the swarm technique, I suggest you first get the data retrieval and parsing working with pure VBA code (not VBScript) using XMLhttp and HTMLDocument and related methods (not string parsing, as your code does) and then incorporate the code into the swarm technique.
 
Upvote 0
Hello,

Thanks for the quick reply, I would like to continue to use/try the Swarm technique.Because in some cases I would like to add up to 10000 Waybills.

I managed to retrieve several info's out of 1 Waybill.

But unfortunately when running the code it is not as fast as i thought. :( Could I combine the parsing fields somehow?

Do you think,putting the parsing part into the regular VBA code would speed up the code?
If Yes would you mind giving me a hint how to realise it?

Thanks in advance!



Added those Code to Write the results to Excel sheet + the Parsing Code for each Column(have a look in the entire code further below)
Code: 
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""E"" & curRow) = Account" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""F"" & curRow) = Piece" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""G"" & curRow) = weight" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""H"" & curRow) = ORG" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""I"" & curRow) = Dest" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""J"" & curRow) = ProductCode" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""K"" & curRow) = Remark" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""L"" & curRow) = LastComment" & vbCrLf


Entire Code
Code: 
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public lngAgents As Long
Public lngOutputCol As Long

Public Sub Swarm_Method(shtData As Worksheet, sProperty_RangeAddr, Optional boolOneAgentOnly As Boolean)
    Dim lngCurRec As Long
    Dim lngCurAgt As Long
    Dim rngOutput As Range
    
'Setup variables
    With shtData.Range(sProperty_RangeAddr)
        lngRecords = .End(xlDown).Row - .Row + 1
        vAddresses = .Resize(lngRecords)
    End With
    lngAgents = [SwarmSize]
    lngOutputCol = Range(sProperty_RangeAddr).Offset(, 1).Column
    
'Create VBScript Agent Swarm
    For lngCurRec = 1 To UBound(vAddresses)
        DoEvents
        Set rngOutput = Range(sProperty_RangeAddr).Offset(lngCurRec - 1, 1)
        
        If Len(rngOutput) = 0 Then
            DoEvents
            CreateVBScriptAgentAndLaunch rngOutput
            lngCurAgt = lngCurAgt + 1
            If boolOneAgentOnly Or lngCurAgt = lngAgents Then Exit For
            Sleep 5
        End If
    Next lngCurRec
    ' Terminate objects
    Set rngOutput = Nothing
End Sub

Public Sub CreateVBScriptAgentAndLaunch(rngOutput As Range)
    Dim sFileName As String
    Dim intFileNum As Integer
    Dim shellWin As New ShellWindows
    Dim s As String
    Dim lngRow As Long, sCol As String, sPropAddr As String, LastCheckpoint, Account As String
    Dim lngAgentNumber As Long
       
' Setup variables
    lngRow = rngOutput.Row
    sCol = rngOutput.Column
    LastCheckpoint = rngOutput.Resize(, 1).Address
    Account = rngOutput.Resize(, 2).Address
    sPropAddr = rngOutput.Offset(, -1)
    DoEvents
                
' Set semaphore
    lngAgentNumber = lngRow Mod lngAgents
    rngOutput = "Agent_" & lngAgentNumber
    DoEvents
       
' Create string for contents of VBScript file
    DoEvents
    s = s & "Dim oXML, oXL, curRow, outputCol, propAddress, sHTML, i" & vbCrLf
    's = s & "Dim vResults(7)" & vbCrLf
    s = s & vbCrLf
' Setup variables" & vbCrLf
    s = s & "curRow = " & lngRow & vbCrLf
    s = s & "outputCol = """ & sCol & """" & vbCrLf
    s = s & "propAddress = """ & sPropAddr & """" & vbCrLf
    s = s & "Set oXL = GetObject(, ""Excel.Application"")" & vbCrLf
    s = s & "Set oXML = WScript.CreateObject(""MSXML2.XMLHTTP"")" & vbCrLf
    s = s & vbCrLf
' Navigate to property page
    s = s & "oXML.Open ""GET"", ""http://npts2.apis.dhl.com:6010/npts/ShipmentDataFetchServlet?action=8&shipDetFromSumm="" & propAddress, false" & vbCrLf
    s = s & "Wscript.Sleep 50" & vbCrLf
    s = s & "oXML.send" & vbCrLf
    s = s & "Wscript.Sleep 50" & vbCrLf
    s = s & vbCrLf
' Get html
    s = s & "sHTML = oXML.responseText" & vbCrLf
    s = s & vbCrLf
' Get html
s = s & "IEhtml2 = Split(sHTML, vbCrLf)" & vbCrLf
s = s & "On Error Resume Next" & vbCrLf

' Parse fields
'------------------------------------------------------------------------------------------------------------------------
'Remarks
s = s & "For a = 1 To UBound(IEhtml2)" & vbCrLf
        s = s & "If InStr(1, IEhtml2(a), ""Remarks"") Then" & vbCrLf
                s = s & "Remark = IEhtml2(a + 27)" & vbCrLf
                s = s & "Remark = Replace(Remark, chr(34), """")" & vbCrLf
                s = s & "Remark = Replace(Remark, "" "", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""<"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""="", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, "">"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""&"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, "";"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""/a"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""/td"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""("", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, "")"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""'"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""tdclassgrayTdNormalheight21nbsp"", """")" & vbCrLf
        s = s & "End If" & vbCrL
s = s & vbCrLf
s = s & "Next" & vbCrL
s = s & vbCrLf


'-----------------------------------------------------------------------------------------------------------------------
'Piece
s = s & "For a = 1 To UBound(IEhtml2)" & vbCrLf
        s = s & "If InStr(1, IEhtml2(a), ""addZero"") Then" & vbCrLf
                s = s & "Piece = IEhtml2(a)" & vbCrLf
                s = s & "Piece = Replace(Piece, chr(34), """")" & vbCrLf
                s = s & "Piece = Replace(Piece, "" "", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""<"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""="", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, "">"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""&"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, "";"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""/a"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""/td"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""("", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, "")"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""'"", """")" & vbCrLf
                s = s & "Piece = Replace(Piece, propAddress, """")" & vbCrLf
                s = s & "Piece = Replace(Piece, ""tdclasswhiteTdNormalheight21aligncenternbspahrefjavascript:pieceClickedaddZero"", """")" & vbCrLf
        s = s & "End If" & vbCrL
s = s & vbCrLf
s = s & "Next" & vbCrL
s = s & vbCrLf


'------------------------------------------------------------------------------------------------------------------------
'Last Checkpoint
s = s & "For a = 1 To UBound(IEhtml2)" & vbCrLf
        s = s & "If InStr(1, IEhtml2(a), ""Last Checkpoint Summary"") Then" & vbCrLf
                s = s & "Remark = IEhtml2(a + 2)" & vbCrLf
                s = s & "Remark = Replace(Remark, chr(34), """")" & vbCrLf
                s = s & "Remark = Replace(Remark, "" "", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""<"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""="", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, "">"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""&"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, "";"", """")" & vbCrLf
                s = s & "Remark = Replace(Remark, ""tdclassgrayTdNormalheight21nowrapnbsp"", """")" & vbCrLf
        s = s & "End If" & vbCrL
s = s & vbCrLf
s = s & "Next" & vbCrL
s = s & vbCrLf

'------------------------------------------------------------------------------------------------------------------------
'Account
s = s & "For a = 1 To UBound(IEhtml2)" & vbCrLf
        s = s & "If InStr(1, IEhtml2(a), ""Account"") Then" & vbCrLf
                s = s & "Account = IEhtml2(a + 9)" & vbCrLf
                s = s & "Account = Replace(Account, chr(34), """")" & vbCrLf
                s = s & "Account = Replace(Account, "" "", """")" & vbCrLf
                s = s & "Account = Replace(Account, ""<"", """")" & vbCrLf
                s = s & "Account = Replace(Account, ""="", """")" & vbCrLf
                s = s & "Account = Replace(Account, "">"", """")" & vbCrLf
                s = s & "Account = Replace(Account, ""&"", """")" & vbCrLf
                s = s & "Account = Replace(Account, "";"", """")" & vbCrLf
                s = s & "Account = Replace(Account, ""/td"", """")" & vbCrLf
                s = s & "Account = Replace(Account, ""tdclassgrayTdNormalheight21nowrapnbsp"", """")" & vbCrLf
                s = s & "Account = Replace(Account, ""tdclasswhiteTdNormalheight21nbsp"", """")" & vbCrLf
                
        s = s & "End If" & vbCrL
s = s & vbCrLf
s = s & "Next" & vbCrL
s = s & vbCrLf
'-----------------------------------------------------------------------------------------------------------------------
'weight
s = s & "For a = 1 To UBound(IEhtml2)" & vbCrLf
        s = s & "If InStr(1, IEhtml2(a), ""addZero"") Then" & vbCrLf
                s = s & "weight = IEhtml2(a + 2)" & vbCrLf
                s = s & "weight = Replace(weight, chr(34), """")" & vbCrLf
                s = s & "weight = Replace(weight, "" "", """")" & vbCrLf
                s = s & "weight = Replace(weight, ""<"", """")" & vbCrLf
                s = s & "weight = Replace(weight, ""="", """")" & vbCrLf
                s = s & "weight = Replace(weight, "">"", """")" & vbCrLf
                s = s & "weight = Replace(weight, ""&"", """")" & vbCrLf
                s = s & "weight = Replace(weight, "";"", """")" & vbCrLf
                s = s & "weight = Replace(weight, ""/a"", """")" & vbCrLf
                s = s & "weight = Replace(weight, ""/td"", """")" & vbCrLf
                s = s & "weight = Replace(weight, ""("", """")" & vbCrLf
                s = s & "weight = Replace(weight, "")"", """")" & vbCrLf
                s = s & "weight = Replace(weight, ""'"", """")" & vbCrLf
                s = s & "weight = Replace(weight, ""tdclasswhiteTdNormalheight21aligncenternbsp"", """")" & vbCrLf
        s = s & "End If" & vbCrL
s = s & vbCrLf
s = s & "Next" & vbCrL
s = s & vbCrLf
'-----------------------------------------------------------------------------------------------------------------------
'LastComment
s = s & "For a = 1 To UBound(IEhtml2)" & vbCrLf
        s = s & "If InStr(1, IEhtml2(a), ""Remarks"") Then" & vbCrLf
                s = s & "LastComment = IEhtml2(a + 27)" & vbCrLf
                s = s & "LastComment = Replace(LastComment, chr(34), """")" & vbCrLf
                's = s & "LastComment = Replace(LastComment, "" "", """")" & vbCrLf
                s = s & "LastComment = Replace(LastComment, ""<"", """")" & vbCrLf
                s = s & "LastComment = Replace(LastComment, ""="", """")" & vbCrLf
                s = s & "LastComment = Replace(LastComment, "">"", """")" & vbCrLf
                s = s & "LastComment = Replace(LastComment, ""&"", """")" & vbCrLf
                s = s & "LastComment = Replace(LastComment, "";"", """")" & vbCrLf
                s = s & "LastComment = Replace(LastComment, ""/a"", """")" & vbCrLf
                s = s & "LastComment = Replace(LastComment, ""/td"", """")" & vbCrLf
                s = s & "LastComment = Replace(LastComment, ""("", """")" & vbCrLf
                s = s & "LastComment = Replace(LastComment, "")"", """")" & vbCrLf
                s = s & "LastComment = Replace(LastComment, ""'"", """")" & vbCrLf
                s = s & "LastComment = Replace(LastComment, ""    td classgrayTdNormal height21nbsp"", """")" & vbCrLf
        s = s & "End If" & vbCrL
s = s & vbCrLf
s = s & "Next" & vbCrL
s = s & vbCrLf



'-----------------------------------------------------------------------------------------------------------------------
'Org + Location
s = s & "For a = 1 To UBound(IEhtml2)" & vbCrLf
        s = s & "If InStr(1, IEhtml2(a), ""Orig"") Then" & vbCrLf
                s = s & "ORG = IEhtml2(a + 17)" & vbCrLf
                s = s & "ORG = Replace(ORG, chr(34), """")" & vbCrLf
                s = s & "ORG = Replace(ORG, "" "", """")" & vbCrLf
                s = s & "ORG = Replace(ORG, ""<"", """")" & vbCrLf
                s = s & "ORG = Replace(ORG, ""="", """")" & vbCrLf
                s = s & "ORG = Replace(ORG, "">"", """")" & vbCrLf
                s = s & "ORG = Replace(ORG, ""&"", """")" & vbCrLf
                s = s & "ORG = Replace(ORG, "";"", """")" & vbCrLf
                s = s & "ORG = Replace(ORG, ""/a"", """")" & vbCrLf
                s = s & "ORG = Replace(ORG, ""/td"", """")" & vbCrLf
                s = s & "ORG = Replace(ORG, ""("", """")" & vbCrLf
                s = s & "ORG = Replace(ORG, "")"", """")" & vbCrLf
                s = s & "ORG = Replace(ORG, ""'"", """")" & vbCrLf
                s = s & "ORG = Replace(ORG, ""tdclasswhiteTdNormalheight21aligncenternbsp"", """")" & vbCrLf
        s = s & "End If" & vbCrL
s = s & vbCrLf
s = s & "Next" & vbCrL
s = s & vbCrLf


'-----------------------------------------------------------------------------------------------------------------------
'Dest
s = s & "For a = 1 To UBound(IEhtml2)" & vbCrLf
        s = s & "If InStr(1, IEhtml2(a), ""Orig"") Then" & vbCrLf
                s = s & "Dest = IEhtml2(a + 19)" & vbCrLf
                s = s & "Dest = Replace(Dest, chr(34), """")" & vbCrLf
                s = s & "Dest = Replace(Dest, "" "", """")" & vbCrLf
                s = s & "Dest = Replace(Dest, ""<"", """")" & vbCrLf
                s = s & "Dest = Replace(Dest, ""="", """")" & vbCrLf
                s = s & "Dest = Replace(Dest, "">"", """")" & vbCrLf
                s = s & "Dest = Replace(Dest, ""&"", """")" & vbCrLf
                s = s & "Dest = Replace(Dest, "";"", """")" & vbCrLf
                s = s & "Dest = Replace(Dest, ""/a"", """")" & vbCrLf
                s = s & "Dest = Replace(Dest, ""/td"", """")" & vbCrLf
                s = s & "Dest = Replace(Dest, ""("", """")" & vbCrLf
                s = s & "Dest = Replace(Dest, "")"", """")" & vbCrLf
                s = s & "Dest = Replace(Dest, ""'"", """")" & vbCrLf
                s = s & "Dest = Replace(Dest, ""tdclasswhiteTdNormalheight21aligncenternbsp"", """")" & vbCrLf
        s = s & "End If" & vbCrL
s = s & vbCrLf
s = s & "Next" & vbCrL
s = s & vbCrLf


'-----------------------------------------------------------------------------------------------------------------------
'ProductCode
s = s & "For a = 1 To UBound(IEhtml2)" & vbCrLf
        s = s & "If InStr(1, IEhtml2(a), ""Orig"") Then" & vbCrLf
                s = s & "ProductCode = IEhtml2(a + 29)" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, chr(34), """")" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, "" "", """")" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, ""<"", """")" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, ""="", """")" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, "">"", """")" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, ""&"", """")" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, "";"", """")" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, ""/a"", """")" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, ""/td"", """")" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, ""("", """")" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, "")"", """")" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, ""'"", """")" & vbCrLf
                s = s & "ProductCode = Replace(ProductCode, ""tdclasswhiteTdNormalheight21aligncenternbsp"", """")" & vbCrLf
        s = s & "End If" & vbCrL
s = s & vbCrLf
s = s & "Next" & vbCrL
s = s & vbCrLf

'Write results to Excel sheet
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""E"" & curRow) = Account" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""F"" & curRow) = Piece" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""G"" & curRow) = weight" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""H"" & curRow) = ORG" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""I"" & curRow) = Dest" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""J"" & curRow) = ProductCode" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""K"" & curRow) = Remark" & vbCrLf
    s = s & "oXL.workbooks(""" & ThisWorkbook.Name & """).sheets(""Demo"").Range(""L"" & curRow) = LastComment" & vbCrLf
   
   
    
'Write VBScript file to disk
    sFileName = ActiveWorkbook.Path & "\SwarmAgent_" & lngAgentNumber & ".vbs"
    intFileNum = FreeFile
    Open sFileName For Output As intFileNum
    Print #intFileNum, s
    Close intFileNum
    DoEvents
'Run VBScript file
    Set wshShell = CreateObject("Wscript.Shell")
    wshShell.Run """" & sFileName & """"
    DoEvents
    Set wshShell = Nothing
    
    
 
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Get text from HTML table
Replies
5
Views
4K
mdo8105
M
A
  • Question Question
Extract first table of Outlook mail folder
Replies
2
Views
579
abhishukla15
A
E
  • Question Question
Extracting Tables from website
Replies
1
Views
660
ExcelStudent00
E

Forum statistics

Threads
1,223,999
Messages
6,175,882
Members
452,679
Latest member
darryl47nopra

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top