I need help scraping the tags onto my excel from an internal company website.
This is the source code.
<br />
<span class="RptTitle"><input id="chkPromisDataLog" type="checkbox" name="chkPromisDataLog" checked="checked" onclick="showOnOffPromisLog();" /><label for="chkPromisDataLog">Promis Processing data log [83508442.1].</label></span>
<div id="divPromisDataLog" style="display: none;">
<table id="tblPromisDataLog" cellspacing="0" cellpadding="0" width="100%" border="0" class="table">
<tr>
<td width="60%"></td>
<td>
<a class="textnormal" href="javascript:popwnd=window.open('../Tools/ExportExcel.aspx?KEY=LOT_GEN_PROMIS','popwnd','status=no,toolbar=Yes,menubar=Yes,location=no,scrollbars=yes,resizable=Yes');popwnd.focus()">
Export to Excel
</a>
</td>
</tr>
<tr>
<td colspan="2">
<table cellspacing="0" rules="all" border="1" id="dgPromisDataLog" style="border-color: Black; border-collapse: collapse;">
<tr class="rptDetailsHeaderMgt" align="center">
<td>LotID</td>
<td>Hist Stage</td>
<td>Datein</td>
<td>Dateout</td>
<td>Qtyin</td>
<td>Qtyout</td>
<td>M/C ID</td>
<td>Emp TrackOut</td>
<td>Hold Code</td>
<td>Hold Reason</td>
<td>Staging (Hrs)</td>
</tr>
<tr class="rptDetailsItemMgt" align="center" style="white-space: nowrap;">
<td>83508442.1</td>
<td>
<a
href="javascript:popwnd=window.open('LotGen_Dtl.aspx?iDate=04/09/2021 09:07:07 PM&oDate=04/10/2021 03:47:59 PM&oLotid=83508442.1&oStage=C-WFRPROCS&oLastRow=N','popwnd','width=900,height=600,status=no,toolbar=no,menubar=no,location=no,scrollbars=yes,top=100,right=50,left=50');popwnd.focus();"
>
C-WFRPROCS
</a>
</td>
<td>4/9/2021 9:07:07 PM</td>
<td>4/10/2021 3:47:59 PM</td>
<td>0</td>
<td>9</td>
<td></td>
<td>10911700</td>
<td> </td>
<td> </td>
<td>18.68</td>
</tr>
</table>
</td>
</tr>
</table>
</div>
This is roughly my code
Sub Lotsearch()
Dim ie As InternetExplorer
Dim htmlEle As IHTMLElement
Dim i As Integer
Set ie = New InternetExplorer 'start new IE page
ie.Visible = True 'View what is happening in IE
ie.navigate "www.internalcompanywebsite.aspx" 'Open link in IE
While ie.readyState <> 4 'Waits for IE to finish loading
DoEvents
Wend
i = 1
'ie.document.getElementById("tblPromisDataLog") = Cells(2, 1).Value
'ie.document.getElementsByTagName("td").Value = Cells(5, 1).Value
'Set Data = ie.document.getElementByTagName("rptDetailsItemMgt")
'Dim myValue As String
'myValue = allRowOfData.Cells(0).innerHTML
'Cells(3, 13) = myValue
'Range("L1").Value = myValue
'For Each htmlEle In ie.document.getElementById("tblPromisDataLog")(0).getElementsByClassName("rptDetailsItemMgt")
With ActiveSheet
.Range("A" & i).Value = htmlEle.Children(0).textContent
' .Range("B" & i).Value = htmlEle.Children(1).textContent
' .Range("C" & i).Value = htmlEle.Children(2).textContent
' .Range("D" & i).Value = htmlEle.Children(3).textContent
' .Range("E" & i).Value = htmlEle.Children(4).textContent
' .Range("F" & i).Value = htmlEle.Children(5).textContent
' .Range("G" & i).Value = htmlEle.Children(6).textContent
' .Range("H" & i).Value = htmlEle.Children(7).textContent
' .Range("I" & i).Value = htmlEle.Children(8).textContent
' .Range("J" & i).Value = htmlEle.Children(9).textContent
' .Range("K" & i).Value = htmlEle.Children(10).textContent
' .Range("L" & i).Value = htmlEle.Children(11).textContent
End With
i = i + 1
Next htmlEle
ie.Quit
End Sub
As you can see, I have tried various methods but to no avail.
getElementbyID not working
getElementsbyTagName not working
getElementsByClassName not working
Any help would be appreciated. Thanks.
it may not actually be the most efficient way to deal with HTML extraction, but you might consider using Regex matching.. Raw Coding on youtube just made a killer regex tutorial, and I remembered seeing this question, and thought it might be a good alternative if you didn't like dealing with html explicitly.
Regex Tutorial for Beginners from Raw Coding on Youtube
like, if you only wanted normal text between td tags, you could regex search for
(?<OpenTag>[\<]+td[\>]+)(?<Contents>[\w\/\(\)\[\]\.\&\:\;\s]*?)(?<CloseTag>[\<]+[\/]+[td]+[\>]+)
here's an example at Regex101
Regex101 example using your html
Dim ht As HTMLDocument
Dim i As Integer
Dim htmltable As MSHTML.htmltable
Set htmltable = ht.getElementById("dgPromisDataLog")
myValue = htmltable.getElementsByClassName("rptDetailsItemMgt")(0).getElementsByTagName("td")(0).innerText
After messing with it for a few days, I found that the code works if I split up the getElementbyId from the other 'getElements'.
Changed htmlEle As IHTMLElement into ht As HTMLDocument. Also added htmltable As MSHTML.htmltable
For some reason the code returns an error if I chain the entire 'getelement' together. Hope this helps someone else with the same problem.
Snippet:
<table>
<tbody>
<tr>
<td valign="top" align="left">
<nobr>FILENAME</nobr>
</td>
<td valign="center" align="left">
<b>
<font size="2px">
<nobr>FILENUMBER0311</nobr>
</font>
</b>
<font size="2px"> </font>
</td>
<td valign="top" align="right"></td>
<tr>
<td valign="top" align="left">Date</td>
<td colspan="2" valign="center" align="left">
<font color="#C00000">
<b>
CANCELED
</b>
</tr>
…
<tr>
<td valign="top" align="left">
<nobr>FILENAME</nobr>
</td>
<td valign="center" align="left">
<b>
<font size="2px">
<nobr>FILENUMBER0345</nobr>
</font>
</b>
<font size="2px"> </font>
</td>
<td valign="top" align="right"></td>
<tr>
<td valign="top" align="left">Date</td>
<td colspan="2" valign="center" align="left">
<font color="#C00000">
<b>
CONFIRMED
</b>
</tr>
The website-html has a table with several tr-tags. In each tr-tag there is either the entry CONFIRMED between b-tags or the entry CANCELED. I need a code that returns the value of FILENUMBERxxxx in the case of CONFIRMED. I have no idea how to combine a "selector", "instr" and possible other operations with each other in this case.
My Code: (nothing happens!). Does anyone know a solution? THX
Sub GetData()
Const url = "https://www.zvg-portal.de/index.php?button=Suchen&all=1"
Dim Html As MSHTML.HTMLDocument
Dim xhr As Object, elm As Object
Dim I As Long
Set Html = New MSHTML.HTMLDocument
Set xhr = CreateObject("MSXML2.ServerXMLHTTP.6.0")
With xhr
.Open "POST", url, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send "ger_name=--" & " " & "Alle" & " " & "Amtsgerichte" & " " & "--&" & "order_by=2&land_abk=ni&ger_id=0"
Html.body.innerHTML = .responseText
End With
With Html.querySelectorAll("tr")
Set elm = Html.querySelectorAll("tr")
For I = 0 To 500
'right now I do not know how to set the number of repeats, therefore 0 to 500
If InStr(elm.Item(I).innerText, "Termin") > 0 Then
ActiveSheet.Cells(I + 2, 3) = elm.Item(I).ParentNode.PreviousSibling.FirstChild.NextSibling.innerText
'need the numeric value of Aktenzeichen
Exit For
End If
Next I
End With
End Sub
The following processes the rows and when it sees a listing separator (tr with only 1 child td), it increments the row counter for the output array.
It uses an Instr test, for aufgehoben, to determine if the row with termin indicates a cancellation and returns a True/False value in the output array.
During the loop, the Aktenzeichen value is extracted; this is written out in the first column of the output array, before the True/False for cancelled.
Option Explicit
Public Sub GetData()
Const url = "https://www.zvg-portal.de/index.php?button=Suchen&all=1"
Dim html As MSHTML.HTMLDocument, xhr As Object
Set html = New MSHTML.HTMLDocument
Set xhr = CreateObject("MSXML2.XMLHTTP")
With xhr
.Open "POST", url, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send "ger_name=--" & " " & "Alle" & " " & "Amtsgerichte" & " " & "--&" & "order_by=2&land_abk=ni&ger_id=0"
html.body.innerHTML = .responseText
End With
Dim table As MSHTML.HTMLTable
Set table = html.querySelector("table[border='0']")
Dim row As MSHTML.HTMLTableRow, newBlock As Boolean
Dim r As Long, cancellations(), aktenzeichen As String
ReDim cancellations(1 To 1000, 1 To 2)
r = 1
For Each row In table.Rows
If newBlock Then r = r + 1
If InStr(1, row.innerHTML, "Aktenzeichen", vbTextCompare) > 0 Then
aktenzeichen = Replace$(row.Children(1).getElementsByTagName("nobr")(0).innerText, " (Detailansicht)", vbNullString)
cancellations(r, 1) = aktenzeichen
End If
If Trim$(row.Children(0).innerText) = "Termin" Then
cancellations(r, 2) = (InStr(1, row.Children(1).innerText, "aufgehoben", vbTextCompare) > 0)
End If
newBlock = (row.Children.Length = 1)
Next
cancellations = Application.Transpose(cancellations)
Dim headers()
headers = Array(" Aktenzeichen", "Cancelled")
ReDim Preserve cancellations(1 To UBound(headers) + 1, 1 To r)
cancellations = Application.Transpose(cancellations)
With ActiveSheet
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 1).Resize(UBound(cancellations, 1), UBound(cancellations, 2)) = cancellations
End With
End Sub
I have a problem applying CSS3 and pretty round buttons to my HTA app.
As soon as I enable <meta http-equiv="x-ua-compatible" content="ie=9"> tag to turn CSS3 on the code goes straight to hell.
Counting doesn't work right and it looks like it operates on a copy of values from arrays arrX. I tested it with msgbox and once clicked it counts right but then goes back to 0.
When I remove meta tag and parenthesis in last two subs sub SaveData() and sub ExitWindow() and remove parenthesis from all onclick script works like charm.
Damn CSS3 breakes it.
Can you help me out and tell why it doesn't work and operates on a copy of arguments from arrays?
Thanks. :)
<!--DOCTYPE html-->
<html>
<head>
<meta http-equiv="x-ua-compatible" content="ie=9">
<style type="text/css">
body {
background-color:white;}
table, th, td {
border: 1px black;
color: black;
font-family:"Lucida Console";
font-size:100%;}
table {
width:500px;}
th {
text-align:left;}
td {
text-align:center;}
#maintd {
color:blue;
text-align:left;}
<!--#arrowtd {
width:100px;}-->
#runbutton {
border: 2px solid #a1a1a1;
background: #dddddd;
border-radius: 25px;}
</style>
<title>KPI reporting tool</title>
<HTA:APPLICATION
APPLICATIONNAME="KPI reporting tool"
CAPTION="yes"
SYSMENU="no"
SCROLL="no"
BORDER="thin"
SINGLEINSTANCE="yes"
WINDOWSTATE="normal"
>
</head>
<Script language="VBscript">
'==============================================================================================================
'KPI weights - EDIT HERE | KPI weights - EDIT HERE | KPI weights - EDIT HERE | KPI weights - EDIT HERE
'==============================================================================================================
Sinc = 12
Rtask = 7
Reassignment = 2
Update = 2
Transfer = 5
Assisted = 3
PassingBack = 3
'==============================================================================================================
'SCRIPT - DO NOT EDIT !!!
'==============================================================================================================
'==============================================================================================================
'ON LOAD SCRIPT TO SHOW KPI WEIGHTS
'==============================================================================================================
Sub Window_OnLoad
window.resizeTo 550,280
UserValue1.InnerHTML = Sinc
UserValue2.InnerHTML = Rtask
UserValue3.InnerHTML = Reassignment
UserValue4.InnerHTML = Update
UserValue5.InnerHTML = Transfer
UserValue6.InnerHTML = Assisted
UserValue7.InnerHTML = Passingback
End Sub
'==============================================================================================================
'REPORTING ARRAY
'==============================================================================================================
Dim arr0,arr1,arr2,arr3,arr4,arr5,arr6,arr7,arr8
arr0 = Array("Action", "Weight", "No. of times", "Points")
arr1 = Array("Incidents", Sinc, 0, 0)
arr2 = Array("Requests", Rtask, 0, 0)
arr3 = Array("Reassignments",Reassignment, 0, 0)
arr4 = Array("Updates", Update, 0, 0)
arr5 = Array("Transfers", Transfer, 0, 0)
arr6 = Array("Assists", Assisted, 0, 0)
arr7 = Array("Passing back",Passingback, 0, 0)
arr8 = Array()
'msgbox(arr1(1)) 'TEST MSGBOX
'==============================================================================================================
'SUB FOR COUNTING DOWN WITH FAIL-SAFE FOR NUMBERS BELOW ZERO
'==============================================================================================================
Sub RunScriptDown(DataAreaXa,DataAreaXb,arrX)
If arrX(2)>0 And arrx(3)>0 Then 'No. of times >0 AND Sum cannot be <0
arrx(2) = arrX(2) - 1
arrx(3) = arrX(3) - arrX(1) 'Sum = Sum - Weight
Else MsgBox "Value cannot be less than 0!",48,"ERROR"
End If
DataAreaXa.InnerHTML = arrX(2) 'No. of times
DataAreaXb.InnerHTML = arrX(1)*arrX(2) 'Weight*No. of times
DataAreaSum.InnerHTML = arr1(3)+arr2(3)+arr3(3)+arr4(3)+arr5(3)+arr6(3)+arr7(3)
msgbox(arrX(0) &" | " & "No.of times: " & arrX(2) & " | " & "total: " & arrX(3)) 'TEST MSGBOX
End Sub
'==============================================================================================================
'SUB FOR COUNTING UP
'==============================================================================================================
Sub RunScriptUp(DataAreaXa,DataAreaXb,arrX)
arrX(2) = arrX(2) + 1
arrx(3) = arrX(3) + arrX(1)
DataAreaXa.InnerHTML = arrX(2)
DataAreaXb.InnerHTML = arrX(1)*arrX(2)
DataAreaSum.InnerHTML = arr1(3)+arr2(3)+arr3(3)+arr4(3)+arr5(3)+arr6(3)+arr7(3)
msgbox(arrX(0) &" | " & "No.of times: " & arrX(2) & " | " & "total: " & arrX(3)) 'TEST MSGBOX
End Sub
'==============================================================================================================
'SUB FOR SAVING STATS TO A FILE
'==============================================================================================================
Sub SaveData()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
relativePath = wshShell.CurrentDirectory
path = relativePath & "\KPI_STATS\"
statDate = Now
statFile = Month(statDate) & "-" & Day(statDate) & "-" & Year(statDate) & ".tsv"
Set objNetwork = CreateObject("WScript.Network")
statUser = objNetwork.UserDomain & "\" & objNetwork.UserName
If objFSO.FolderExists(path) Then
'DO NOTHING
Else Set objFolder = objFSO.CreateFolder(path)
End If
msgbox(path & statFile)
If objFSO.FileExists (path & statFile) Then
MsgBox "File already exists!",48,"ERROR"
Else objFSO.CreateTextFile (path & statFile)
End If
Set objFile = objFSO.OpenTextFile (path & statFile, 8)
strLine = statUser & vbTab & statDate & vbCrLf & _
"--------------------------------------------------------" & vbCrLf & _
arr0(0) & vbTab & vbTab & arr0(1) & vbTab & arr0(2) & vbTab & arr0(3) & vbCrLf & _
arr1(0) & vbTab & arr1(1) & vbTab & arr1(2) & vbTab & vbTab & arr1(3) & vbCrLf & _
arr2(0) & vbTab & arr2(1) & vbTab & arr2(2) & vbTab & vbTab & arr2(3) & vbCrLf & _
arr3(0) & vbTab & arr3(1) & vbTab & arr3(2) & vbTab & vbTab & arr3(3) & vbCrLf & _
arr4(0) & vbTab & vbTab & arr4(1) & vbTab & arr4(2) & vbTab & vbTab & arr4(3) & vbCrLf & _
arr5(0) & vbTab & arr5(1) & vbTab & arr5(2) & vbTab & vbTab & arr5(3) & vbCrLf & _
arr6(0) & vbTab & vbTab & arr6(1) & vbTab & arr6(2) & vbTab & vbTab & arr6(3) & vbCrLf & _
arr7(0) & vbTab & arr7(1) & vbTab & arr7(2) & vbTab & vbTab & arr7(3) & vbCrLf & _
"--------------------------------------------------------" & vbCrLf & _
vbTab & vbTab & vbTab & vbTab & vbTab & arr1(3)+arr2(3)+arr3(3)+arr4(3)+arr5(3)+arr6(3)+arr7(3) & " TOTAL points"
objFile.WriteLine strLine
objFile.Close
End Sub
'==============================================================================================================
'EXIT SUB
'==============================================================================================================
Sub ExitWindow()
usrExit = MsgBox("Do you really want to exit?" & vbCrLf & "All unsaved data will be lost!",52,"WARNING!")
If usrExit = vbYes Then
self.close()
Else
End If
End Sub
</Script>
<!--HTML PART OF THE SCRIPT. WAY THE WINDOW LOOKS-->
<body>
<table>
<tr>
<th>Event</th>
<th></th>
<th>Weight</th>
<th>Times done</th>
<th>TOTAL</th>
</tr>
<tr>
<td id="maintd">INCIDENTS:</td>
<td id="arrowtd"><input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea1a,DataArea1b,arr1)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea1a,DataArea1b,arr1)"></td>
<td><span id=UserValue1></span></td>
<td><span id=DataArea1a name=a></span></td>
<td><span id=DataArea1b name=a></span></td>
</tr>
<tr>
<td id="maintd">REQUESTS:</td>
<td id="arrowtd"><input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea2a,DataArea2b,arr2)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea2a,DataArea2b,arr2)"></td>
<td><span id=UserValue2></span></td>
<td><span id=DataArea2a name=b></span></td>
<td><span id=DataArea2b name=a></span></td>
</tr>
<tr>
<td id="maintd">REASSIGNMENTS:</td>
<td id="arrowtd"><input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea3a,DataArea3b,arr3)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea3a,DataArea3b,arr3)"></td>
<td><span id=UserValue3></span></td>
<td><span id=DataArea3a name=c></span></td>
<td><span id=DataArea3b name=a></span></td>
</tr>
<tr>
<td id="maintd">UPDATES:</td>
<td id="arrowtd"><input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea4a,DataArea4b,arr4)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea4a,DataArea4b,arr4)"></td>
<td><span id=UserValue4></span></td>
<td><span id=DataArea4a name=d></span></td>
<td><span id=DataArea4b name=a></span></td>
</tr>
<tr>
<td id="maintd">TRANSFERS:</td>
<td id="arrowtd"><input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea5a,DataArea5b,arr5)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea5a,DataArea5b,arr5)"></td>
<td><span id=UserValue5></span></td>
<td><span id=DataArea5a name=e></span></td>
<td><span id=DataArea5b name=a></span></td>
</tr>
<tr>
<td id="maintd">ASSISTS:</td>
<td id="arrowtd"><input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea6a,DataArea6b,arr6)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea6a,DataArea6b,arr6)"></td>
<td><span id=UserValue6></span></td>
<td><span id=DataArea6a name=f></span></td>
<td><span id=DataArea6b name=a></span></td>
</tr>
<tr>
<td id="maintd">PASSINGS:</td>
<td id="arrowtd"><input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea7a,DataArea7b,arr7)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea7a,DataArea7b,arr7)"></td>
<td><span id=UserValue7></span></td>
<td><span id=DataArea7a name=g></span></td>
<td><span id=DataArea7b name=a></span></td>
</tr>
<tr>
<td><input id=runbutton type="button" value="Exit" onClick="ExitWindow"></td>
<td><input id=runbutton type="button" value="Show Report" onClick="RunReport"></td>
<td><input id=runbutton type="button" value="Save Data" onClick="SaveData"></td>
<td><span id=DataAreaSum name=Sum></span></td>
</tr>
</table>
</body>
</html>
I can't say my answer could be considered well-documented. However, we do find a culprit in passing parameters by reference, undoubtedly. Times change, none the less (being nearly 50 years in programming) I dare say that all the implementation variety of the pass by reference concept seems to keep equivocalness eternally. Not only in different programming languages...
VBScript, for instance: the same script gives different results with Windows script host, or (to keep in topic) with HTA and different meta http-equiv tags, e.g.
<meta http-equiv="x-ua-compatible" content="IE=9">
<!-- or <meta http-equiv="x-ua-compatible" content="IE=edge"> -->
<!-- or <meta http-equiv="content-type" content="text/html"> -->
<!-- or ... -->
I can offer working version of your HTA
Main change: your arrays arrX (i.e. arr0(y), arr1(y), … arr7(y)) combined in one quasi-matrix die2d(X)(y) and accordant passing ByRef arrX replaced with ByVal X. More explanation in code comments.
Additional button Test Array with corresponding onClick procedure Sub TestArray to demonstrate ByRef passed parameters treatment and behaviour (array type). Click it more than once to see in-sub local changes versus script public changes. Cf. also comments in code.
Additional (alike) button Test Scalar, procedure Sub TestScalar to show ByRef passed parameters behaviour (not array type).
Absolutely unsuccessful attempt to trap and inhibit Esc, F5 and Alt+F4 keys. For instance, the refresh F5 key clears the form and data at all...
Crucial changes with comments in code.
Some minor cosmetic mutations.
Some minor debugging leavings, e.g. Option Explicit etc.
Untouched some inconsistency in logic, e.g. in DataAreaXb.InnerHTML displayed another value than computed (and saved) arrX(3) Points.
Here's the code:
<!-- <!DOCTYPE html> -->
<html>
<title>KPI reporting tool</title>
<HTA:APPLICATION
ID="KPI"
APPLICATIONNAME="KPI reporting tool"
CAPTION="yes"
SYSMENU="no"
SCROLL="auto"
BORDER="thin"
SINGLEINSTANCE="yes"
WINDOWSTATE="normal"
>
<head>
<meta http-equiv="x-ua-compatible" content="ie=9">
<style type="text/css">
body {
background-color:white;
}
table, th, td {
border: 1px black;
color: black;
font-family:"Lucida Console";
font-size:100%;
}
table {
width:550px;
}
th {
text-align:left;
}
td {
text-align:center;
}
#maintd {
color:blue;
text-align:left;
}
/*
#arrowtd {
width:100px;}
*/
#runbutton {
border: 2px solid #a1a1a1;
background: #dddddd;
border-radius: 25px;
}
</style>
<Script type="text/vbscript"> ' language="VBscript">
'=============================================================================
'KPI weights - EDIT HERE | KPI weights - EDIT HERE | KPI weights - EDIT HERE
'KPI weights - EDIT HERE | KPI weights - EDIT HERE | KPI weights - EDIT HERE
'KPI weights - EDIT HERE | KPI weights - EDIT HERE | KPI weights - EDIT HERE
'=============================================================================
Option Explicit
Dim Sinc, Rtask, Reassignment, Update, Transfer, Assisted, PassingBack
Sinc = 12
Rtask = 7
Reassignment = 2
Update = 2
Transfer = 5
Assisted = 3
PassingBack = 3
'=============================================================================
'SCRIPT - DO NOT EDIT !!!
'=============================================================================
'=============================================================================
'REPORTING ARRAY
'=============================================================================
Dim die2d
die2d = Array _
( Array("Action _ _ _", "Weight", "times#","Points") _
, Array("Incidents _ _", Sinc, 0,0) _
, Array("Requests _ _", Rtask, 0,0) _
, Array("Reassignments", Reassignment,0,0) _
, Array("Updates _ _ _", Update, 0,0) _
, Array("Transfers _ _", Transfer, 0,0) _
, Array("Assists _ _ _", Assisted, 0,0) _
, Array("Passing back", PassingBack, 0,0) _
)
' In fact, die2d is not a matrix, i.e. a two-dimensional array
' It's a one-dimensional array in which every element
' is a one-dimensional array as well. Therefore use
' die2d(row)(col) reference instead of 2D matrices' die2d(row,col)
'msgbox Join(die2d(0),";") & vbNewLine & UBound(die2d) & vbTab & UBound(die2d(0)) 'TEST MSGBOX
'=============================================================================
'ON LOAD SCRIPT TO SHOW KPI WEIGHTS
'=============================================================================
Sub Window_OnLoad
window.resizeTo 550,280
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' astonishing (note procedure name initial letter capitalization):
'
' Window_OnLoad (uppercase) then resizeTo succeeds
' but .InnerHTML= fails
' window_OnLoad (lowercase) then resizeTo fails
' but .InnerHTML= succeeds
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub
Sub ShowWeights
UserValue1.InnerHTML = Sinc
UserValue2.InnerHTML = Rtask
UserValue3.InnerHTML = Reassignment
UserValue4.InnerHTML = Update
UserValue5.InnerHTML = Transfer
UserValue6.InnerHTML = Assisted
UserValue7.InnerHTML = PassingBack
End Sub
'=============================================================================
'SUB FOR COUNTING DOWN WITH FAIL-SAFE FOR NUMBERS BELOW ZERO
'=============================================================================
Sub RunScriptDown(DataAreaXa,DataAreaXb,byVal arrIDX)
If die2d(arrIDX)(2)>0 And die2d(arrIDX)(3)>0 Then 'No. of times >0 AND Sum cannot be <0
die2d(arrIDX)(2) = die2d(arrIDX)(2) - 1
die2d(arrIDX)(3) = die2d(arrIDX)(3) - die2d(arrIDX)(1) 'Sum = Sum - Weight
Else 'MsgBox "Value cannot be less than 0!",48,"ERROR"
End If
DataAreaXa.InnerHTML = die2d(arrIDX)(2) 'No. of times
DataAreaXb.InnerHTML = die2d(arrIDX)(1)*die2d(arrIDX)(2) 'Weight*No. of times
''' ??? why not DataAreaXb.InnerHTML = die2d(arrIDX)(3)
DataAreaFoo.InnerHTML = SumColumn(2)
DataAreaSum.InnerHTML = SumColumn(3)
End Sub
'=============================================================================
'SUB FOR COUNTING UP
'=============================================================================
Sub RunScriptUp(DataAreaXa,DataAreaXb,byVal arrIDX)
die2d(arrIDX)(2) = die2d(arrIDX)(2) + 1
die2d(arrIDX)(3) = die2d(arrIDX)(3) + die2d(arrIDX)(1)
DataAreaXa.InnerHTML = die2d(arrIDX)(2)
DataAreaXb.InnerHTML = die2d(arrIDX)(1)*die2d(arrIDX)(2)
''' ??? why not DataAreaXb.InnerHTML = die2d(arrIDX)(3)
DataAreaFoo.InnerHTML = SumColumn(2)
DataAreaSum.InnerHTML = SumColumn(3)
End Sub
'=============================================================================
'SUB FOR SAVING STATS TO A FILE
'=============================================================================
Sub SaveData()
Dim objFSO, WshShell, objFolder, objNetwork, objFile
Dim relativePath, path, statDate, statFile, statUser, strLine
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
relativePath = wshShell.CurrentDirectory
path = relativePath & "\KPI_STATS\"
statDate = Now
statFile = Month(statDate) & "-" & Day(statDate) & "-" & Year(statDate) & ".tsv"
Set objNetwork = CreateObject("WScript.Network")
statUser = objNetwork.UserDomain & "\" & objNetwork.UserName
If objFSO.FolderExists(path) Then
'DO NOTHING
Else Set objFolder = objFSO.CreateFolder(path)
End If
msgbox(path & statFile)
If objFSO.FileExists (path & statFile) Then
MsgBox "File already exists!",48,"ERROR"
Else objFSO.CreateTextFile (path & statFile)
End If
Set objFile = objFSO.OpenTextFile (path & statFile, 8)
strLine = statUser & vbTab & statDate & vbCrLf & _
String( 52, "-") & vbCrLf & _
Join(die2d(0), vbTab) & vbCrLf & _
Join(die2d(1), vbTab) & vbCrLf & _
Join(die2d(2), vbTab) & vbCrLf & _
Join(die2d(3), vbTab) & vbCrLf & _
Join(die2d(4), vbTab) & vbCrLf & _
Join(die2d(5), vbTab) & vbCrLf & _
Join(die2d(6), vbTab) & vbCrLf & _
Join(die2d(7), vbTab) & vbCrLf & _
String( 52, "-") & vbCrLf & _
vbTab & vbTab & vbTab & vbTab & SumColumn(3) & " TOTAL points"
objFile.WriteLine strLine
objFile.Close
End Sub
'=============================================================================
'EXIT SUB
'=============================================================================
Sub ExitWindow()
Dim usrExit
usrExit = vbYes
'usrExit = MsgBox("Do you really want to exit?" & vbCrLf & "All unsaved data will be lost!",52,"WARNING!")
If usrExit = vbYes Then
self.close()
Else
End If
End Sub
'=============================================================================
'SUB FOR showing STATS
'=============================================================================
Sub RunReport()
Dim objNetwork
Dim strLine, statDate, statUser
statDate = Now
Set objNetwork = CreateObject("WScript.Network")
statUser = objNetwork.UserDomain & "\" & objNetwork.UserName
Set objNetwork = Nothing
strLine = statUser & vbTab & statDate & vbCrLf & _
String( 52, "-") & vbCrLf & _
Join(die2d(0), vbTab) & vbCrLf & _
Join(die2d(1), vbTab) & vbCrLf & _
Join(die2d(2), vbTab) & vbCrLf & _
Join(die2d(3), vbTab) & vbCrLf & _
Join(die2d(4), vbTab) & vbCrLf & _
Join(die2d(5), vbTab) & vbCrLf & _
Join(die2d(6), vbTab) & vbCrLf & _
Join(die2d(7), vbTab) & vbCrLf & _
vbCrLf & _
vbTab & vbTab & vbTab & vbTab & SumColumn(3) & " TOTAL points"
msgbox( strLine)
End Sub
'=============================================================================
' TestArray SUB
'=============================================================================
Sub TestArray(byRef dieAd)
dieAd(1)(2)=dieAd(1)(2)+100 ' this change is "in SUB" local
' even thought the dieAd == die2d passed by reference
die2d(7)(2)=die2d(7)(2)+100 ' this change is "script" global
Sinc=Sinc+1 ' this change is "script" global
Dim strLine
strLine = "TestArray SUB" & vbCrLf & _
String( 52, "-") & vbCrLf & _
Join(dieAd(0), vbTab) & vbCrLf & _
Join(dieAd(1), vbTab) & vbCrLf & _
Join(dieAd(2), vbTab) & vbCrLf & _
Join(dieAd(3), vbTab) & vbCrLf & _
Join(dieAd(4), vbTab) & vbCrLf & _
String( 52, "-") & vbCrLf & _
Join(die2d(5), vbTab) & vbCrLf & _
Join(die2d(6), vbTab) & vbCrLf & _
Join(die2d(7), vbTab) & vbCrLf & _
vbCrLf & _
vbTab & vbTab & vbTab & vbTab & SumColumn(3) & " TOTAL points" _
& vbCrLf & Sinc
msgbox( strLine)
End Sub
'=============================================================================
' TestScalar SUB
'=============================================================================
Sub TestScalar(byRef nmbrS, byRef nmbrR)
die2d(7)(2)=die2d(7)(2)+50 ' this change is "script" global
Rtask = Rtask + 1 ' this change is "script" global
' but nmbrR stays unchanged (!!!)
' even thought the nmbrR == Rtask passed by reference
nmbrS = nmbrS + 1 ' this change is "in SUB" local
' even thought the nmbrS == Sinc passed by reference
Dim strLine
strLine = "TestScalar SUB" & vbCrLf & _
String( 52, "-") & vbCrLf & _
Join(die2d(0), vbTab) & vbCrLf & _
Join(die2d(1), vbTab) & vbCrLf & _
Join(die2d(2), vbTab) & vbCrLf & _
Join(die2d(3), vbTab) & vbCrLf & _
Join(die2d(4), vbTab) & vbCrLf & _
String( 52, "-") & vbCrLf & _
Join(die2d(5), vbTab) & vbCrLf & _
Join(die2d(6), vbTab) & vbCrLf & _
Join(die2d(7), vbTab) & vbCrLf & _
vbCrLf & _
vbTab & vbTab & vbTab & vbTab & SumColumn(3) & " TOTAL points" _
& vbCrLf & "nmbrS" & vbTab & "Sinc" & vbTab & "Rtask" & vbTab & "nmbrR" _
& vbCrLf & nmbrS & vbTab & Sinc & vbTab & Rtask & vbTab & nmbrR
msgbox( strLine)
End Sub
'=============================================================================
' SumColumn FUNCTION
'=============================================================================
Function SumColumn(byVal col)
Dim ii
SumColumn = 0
For ii = 1 To UBound(die2d)
SumColumn = SumColumn + die2d(ii)(col)
Next
End Function
'=============================================================================
' KeyCheck FUNCTION
'=============================================================================
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Absolutely unsuccessful attempt:
' Escape, F5 and Alt+F4 keys should be trapped to ensure
' no HTA window refreshes occur & proper exit-code runs
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function KeyCheck(byRef myEvent)
Dim kk
'kk=myEvent.KeyCode
kk=myEvent.Key
If kk = "F5" _
Or kk = "Esc" Then
KeyCheck = False
Else
KeyCheck = True
End If
'msgbox (VarType(kk) & " " & TypeName(kk) & " '" & kk & "' " & myEvent.keyCode)
End Function
</Script>
</head>
<!--HTML PART OF THE SCRIPT. WAY THE WINDOW LOOKS-->
<body onKeyUp="self.event.returnValue=KeyCheck(event)" onload=ShowWeights()>
<table>
<tr>
<th>Event</th>
<th></th>
<th>Weight</th>
<th>Times done</th>
<th>TOTAL</th>
</tr>
<tr>
<td id="maintd">INCIDENTS:</td>
<td id="arrowtd">
<input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea1a,DataArea1b,1)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea1a,DataArea1b,1)">
</td>
<td><span id=UserValue1 name=UserValue1 value=Sinc></span></td>
<td><span id=DataArea1a name=1a></span></td>
<td><span id=DataArea1b name=1b></span></td>
</tr>
<tr>
<td id="maintd">REQUESTS:</td>
<td id="arrowtd">
<input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea2a,DataArea2b,2)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea2a,DataArea2b,2)">
</td>
<td><span id=UserValue2 value=Rtask></span></td>
<td><span id=DataArea2a name=2a></span></td>
<td><span id=DataArea2b name=2b></span></td>
</tr>
<tr>
<td id="maintd">REASSIGNMENTS:</td>
<td id="arrowtd">
<input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea3a,DataArea3b,3)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea3a,DataArea3b,3)"></td>
<td><span id=UserValue3 value=Reassignment></span></td>
<td><span id=DataArea3a name=3a></span></td>
<td><span id=DataArea3b name=3b></span></td>
</tr>
<tr>
<td id="maintd">UPDATES:</td>
<td id="arrowtd">
<input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea4a,DataArea4b,4)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea4a,DataArea4b,4)"></td>
<td><span id=UserValue4 value=Update></span></td>
<td><span id=DataArea4a name=4a></span></td>
<td><span id=DataArea4b name=4b></span></td>
</tr>
<tr>
<td id="maintd">TRANSFERS:</td>
<td id="arrowtd">
<input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea5a,DataArea5b,5)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea5a,DataArea5b,5)"></td>
<td><span id=UserValue5></span></td>
<td><span id=DataArea5a name=5a></span></td>
<td><span id=DataArea5b name=5b></span></td>
</tr>
<tr>
<td id="maintd">ASSISTS:</td>
<td id="arrowtd">
<input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea6a,DataArea6b,6)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea6a,DataArea6b,6)"></td>
<td><span id=UserValue6></span></td>
<td><span id=DataArea6a name=6a></span></td>
<td><span id=DataArea6b name=6b></span></td>
</tr>
<tr>
<td id="maintd">PASSINGS:</td>
<td id="arrowtd">
<input id=runbutton type="button" value="←" onClick="RunScriptDown(DataArea7a,DataArea7b,7)">
<input id=runbutton type="button" value="→" onClick="RunScriptUp(DataArea7a,DataArea7b,7)"></td>
<td><span id=UserValue7></span></td>
<td><span id=DataArea7a name=7a></span></td>
<td><span id=DataArea7b name=7b></span></td>
</tr>
<tr>
<td><input id=runbutton type="button" value="Exit" onClick="ExitWindow()"></td>
<td><input id=runbutton type="button" value="Show Report" onClick="RunReport()"></td>
<td><input id=runbutton type="button" value="Save Data" onClick="SaveData()"></td>
<td><span id=DataAreaFoo name=DataAreaFoo></span></td>
<td><span id=DataAreaSum name=DataAreaSum></span></td>
</tr>
<tr>
<td><input id=runbutton type="button" value="Test Array" onClick="TestArray(die2d)"></td>
<td><input id=runbutton type="button" value="Test Scalar" onClick="TestScalar(Sinc, Rtask)"></td>
</tr>
</table>
</body>
</html>
I'm stumped. I don't want to use a WebBrowser in my application, and I want to get a specific element by id. my code is:
Dim request As System.Net.HttpWebRequest = System.Net.HttpWebRequest.Create("http://www.google.com/finance?q=NASDAQ:GOOG")
Dim response As System.Net.HttpWebResponse = request.getresponse()
Dim sr As System.IO.StreamReader = New System.IO.StreamReader(response.GetResponseStream())
Dim sourcecode As String = sr.ReadToEnd()
TextBox1.Text = sourcecode
This gets me the source code. But how do I get a specific element? I would think that there is an easy way to do this... Btw I don't want to use Regex, or download HTML Agility Pack.
You can make a parse table to recognize html tags, and search for id=elementname (plus possible whitespace characters) inside the tags. It's not the impossible task it may seem, because you can ignore most tags and you don't have to validate the html. Just consider <>, and ignore the contents of quotes, scripts, etc. There are lots more details and it takes a little work, but it's fun programming.
The alternative would be to download something like html agility pack, use a browser, or use a regex, which you'd like to avoid.
Heres a very rough idea and it does not work for BLOCK elements that need a SEPARATE closing tag (like ) but it works fine for self closing elements like
also i noted that some of tag id's are enclosed in speech marks and some are not, so you would have to tweak that possibly...
I just roughed this code up and copy pasted the routine to detect unenclosed id tags but it still needs work on it and could be shortened too.
<script runat="server">
Dim sourcecode As String
Dim bodycode As String
Dim RetVal As String
Protected Sub Page_Load(sender As Object, e As System.EventArgs)
'
LoadHttpStuff()
If Request.Form("Button1") = "Submit" Then
RetVal = MyGetElementById(Request("Text1"))
End If
End Sub
Private Sub LoadHttpStuff()
Dim request As System.Net.HttpWebRequest
Dim response As System.Net.HttpWebResponse
Dim sr As System.IO.StreamReader
Dim finishat As Long
Dim startat As Long
request = System.Net.HttpWebRequest.Create("http://www.google.com/finance?q=NASDAQ:GOOG")
response = request.GetResponse()
sr = New System.IO.StreamReader(response.GetResponseStream())
sourcecode = sr.ReadToEnd()
startat = InStr(sourcecode, "<body>")
finishat = InStr(sourcecode, "</body>") + 7
bodycode = Mid(sourcecode, startat, finishat - startat)
bodycode = LCase(bodycode)
End Sub
Private Function MyGetElementById(Id As String) As String
Dim tagstart As Long
Dim tagend As Long
Dim posx As Long
Dim item As System.Web.UI.HtmlControls.HtmlGenericControl
Dim test As Boolean
Dim letter As Char
Dim text As String
item = Nothing
test = False
text = ""
If Trim(Id) <> "" Then
'-> with SPEECHMARKS
posx = InStr(bodycode, LCase("id=" & Chr(34) & Id & Chr(34)))
If posx > 0 Then
'find start of tag
Do
posx = posx - 1
letter = Mid(bodycode, posx, 1)
If letter = "<" Then
'found tag start
tagstart = posx
Exit Do
End If
Loop Until posx < 1
If tagstart > 0 Then
posx = InStr(bodycode, LCase("id=" & Chr(34) & Id & Chr(34)))
Do
posx = posx + 1
letter = Mid(bodycode, posx, 1)
If letter = ">" Then
tagend = posx + 1
Exit Do
End If
Loop Until posx >= Len(bodycode)
If tagend > 0 Then
text = Mid(bodycode, tagstart, tagend - tagstart)
test = True
End If
End If
Else
posx = InStr(bodycode, LCase("id=" & Id))
If posx > 0 Then
'find start of tag
Do
posx = posx - 1
letter = Mid(bodycode, posx, 1)
If letter = "<" Then
'found tag start
tagstart = posx
Exit Do
End If
Loop Until posx < 1
If tagstart > 0 Then
posx = InStr(bodycode, LCase("id=" & Id))
Do
posx = posx + 1
letter = Mid(bodycode, posx, 1)
If letter = ">" Then
tagend = posx + 1
End If
Loop Until posx >= Len(bodycode)
If tagend > 0 Then
text = Mid(bodycode, tagstart, tagend - tagstart)
test = True
End If
End If
End If
End If
End If
Return Text
End Function
</script>
<html xmlns="http://www.w3.org/1999/xhtml">
<head runat="server">
<title></title>
</head>
<body>
<form id="form1" runat="server">
<table style="width: 100%;">
<tr>
<td style="text-align:left; vertical-align: top; width: 75%;"><textarea rows="20" cols="80" style="width: 90%;" disabled="disabled"><%=sourcecode%></textarea></td>
<td style="width: 25%; text-align: left; vertical-align: top;">
<table style="width:100%;">
<tr>
<td>Element Id <input id="Text1" name="Text1" type="text" /></td>
</tr><tr>
<td> </td>
</tr><tr>
<td> </td>
</tr><tr>
<td><input id="Button1" type="Submit" value="Submit" name="Button1" /></td>
</tr><tr>
<td> </td>
</tr><tr>
<td> </td>
</tr>
</table>
</td>
</tr><tr>
<td style="width: 75%;"> </td>
<td style="width: 25%;"> </td>
</tr><tr>
<td style="width: 100%;" colspan="2"><textarea rows="20" cols="80" style="width: 75%;" disabled="disabled"><%=RetVal%></textarea></td>
<td style="width: 25%;"> </td>
</tr>
</table>
</form>
</body>
</html>
Hope it helps a little