Extracting from webpage using vbs and writing into excel cell

Hi there,

the number can be done with a regular expression. Is there only going to be 1 such span?

Can you give a bit more info on the excel you want to write?

combining examples found on

http://msdn.microsoft.com/en-us/library/xk0ecsf3(VS.85).aspx 
and http://msdn.microsoft.com/en-us/library/y27d2s18(VS.85).aspx 

gives this code to match for example the whole string including the html comment before it, or just the amount by using SubMatches(0)

Option Explicit

Dim t
t = _
	"<!-- Account Number Label -->" & vbCrLf & _
	"" & vbCrLf & _
	"  <span id=""DisplayExpressTopNav1_LabelAccountNumber"" " & _
		"class=""LoginBarText"">Account: 1100214</span>" & vbCrLf & _
	"  <!-- | -->" & vbCrLf & _
	"  <span id=""DisplayExpressTopNav1_LabelPipe5"" " & _
		"class=""LoginBarPipeNarrow"">|</span>" & vbCrLf & _
	"  <!-- Balance -->" & vbCrLf & _
	"  <span id=""DisplayExpressTopNav1_LabelBalance"" " & _
		"class=""LoginBarText"">Balance: $40.00</span>" & vbCrLf & _
	"  <input type=""hidden"" name=""DisplayExpressTopNav1$GetAccountBalanceFromCam"" " & _
		"id=""DisplayExpressTopNav1_GetAccountBalanceFromCam"" value=""false"" />" & vbCrLf & _
	"  <!-- Balance Time -->" & vbCrLf & _
	"  <span id=""DisplayExpressTopNav1_LabelBalanceTime"" " & _
		"class=""LoginBarText"">at <span style=""text-decoration:none"" >3:09 PM</span></span>" & vbCrLf & _
	"   <span id=""DisplayExpressTopNav1_LabelPipe1"" " & _
		"class=""LoginBarPipe"">|</span>" & vbCrLf & _
	"				                <a id=""DisplayExpressTopNav1_LinkHideShowAccountBalance"" " & _
		"class=""LoginBarText"" href=""javascript:ToggleAccountBalanceView();"">Hide</a>" & vbCrLf & _
	"  <!-- | -->" & vbCrLf & _
	"  <span id=""DisplayExpressTopNav1_LabelPipe6"" " & _
		"class=""LoginBarPipeNarrow"">|</span>" & vbCrLf & _
	"  <!-- Refresh -->" & vbCrLf & _
	"  <a onclick=""DoPrefreshActions();"" id=""DisplayExpressTopNav1_ButtonRefreshLink"" " & _
		"class=""LoginBarLinkDefault"" onmouseover=""this.className='LoginBarMouseOver'"" " & _
		"onmouseout=""this.className='LoginBarLinkDefault'"" " & _
		"href=""javascript:__doPostBack('DisplayExpressTopNav1$ButtonRefreshLink','')"">Refresh</a>" & vbCrLf & _
	"  <img id=""DisplayExpressTopNav1_AjaxLoaderRefresh"" class=""ExpressImageRefresh"" " & _
		"src=""/shared/images/AccountManagement/en-au/refresh2.gif"" style=""border-width:0px;display:none"" />" & vbCrLf

Dim re
Set re = New RegExp
re.pattern = _
	"<!-- Balance -->\s*<span id=""DisplayExpressTopNav1_LabelBalance"" " & _
		"class=""LoginBarText"">Balance: \$(\d+\.\d+)</span>"

Dim Matches, Match, RetStr
Set Matches = re.Execute(t)
For Each Match in Matches
	RetStr = RetStr & "Match found at position "
	RetStr = RetStr & Match.FirstIndex & ". Match Value is '"
	RetStr = RetStr & Match.Value & "'." & vbCRLF
	If Match.Submatches.Count > 0 Then
		Dim sm
		For sm = 0 To Match.Submatches.Count - 1
			RetStr = RetStr & "submatch " & sm & " = " & _
				Match.Submatches(sm) & vbCrLf
		Next
	End If
Next
MsgBox RetStr

Select allOpen in new window

note the first part is just replicating the html you're getting from the page.

to save it in an excel file that contains 2 columns (account, balance) you could use:

Option Explicit

Const C_EXCEL_FILENAME = "balance.xls"

Dim t
t = _
	"<!-- Account Number Label -->" & vbCrLf & _
	"" & vbCrLf & _
	"  <span id=""DisplayExpressTopNav1_LabelAccountNumber"" " & _
		"class=""LoginBarText"">Account: 1100214</span>" & vbCrLf & _
	"  <!-- | -->" & vbCrLf & _
	"  <span id=""DisplayExpressTopNav1_LabelPipe5"" " & _
		"class=""LoginBarPipeNarrow"">|</span>" & vbCrLf & _
	"  <!-- Balance -->" & vbCrLf & _
	"  <span id=""DisplayExpressTopNav1_LabelBalance"" " & _
		"class=""LoginBarText"">Balance: $40.00</span>" & vbCrLf & _
	"  <input type=""hidden"" name=""DisplayExpressTopNav1$GetAccountBalanceFromCam"" " & _
		"id=""DisplayExpressTopNav1_GetAccountBalanceFromCam"" value=""false"" />" & vbCrLf & _
	"  <!-- Balance Time -->" & vbCrLf & _
	"  <span id=""DisplayExpressTopNav1_LabelBalanceTime"" " & _
		"class=""LoginBarText"">at <span style=""text-decoration:none"" >3:09 PM</span></span>" & vbCrLf & _
	"   <span id=""DisplayExpressTopNav1_LabelPipe1"" " & _
		"class=""LoginBarPipe"">|</span>" & vbCrLf & _
	"				                <a id=""DisplayExpressTopNav1_LinkHideShowAccountBalance"" " & _
		"class=""LoginBarText"" href=""javascript:ToggleAccountBalanceView();"">Hide</a>" & vbCrLf & _
	"  <!-- | -->" & vbCrLf & _
	"  <span id=""DisplayExpressTopNav1_LabelPipe6"" " & _
		"class=""LoginBarPipeNarrow"">|</span>" & vbCrLf & _
	"  <!-- Refresh -->" & vbCrLf & _
	"  <a onclick=""DoPrefreshActions();"" id=""DisplayExpressTopNav1_ButtonRefreshLink"" " & _
		"class=""LoginBarLinkDefault"" onmouseover=""this.className='LoginBarMouseOver'"" " & _
		"onmouseout=""this.className='LoginBarLinkDefault'"" " & _
		"href=""javascript:__doPostBack('DisplayExpressTopNav1$ButtonRefreshLink','')"">Refresh</a>" & vbCrLf & _
	"  <img id=""DisplayExpressTopNav1_AjaxLoaderRefresh"" class=""ExpressImageRefresh"" " & _
		"src=""/shared/images/AccountManagement/en-au/refresh2.gif"" style=""border-width:0px;display:none"" />" & vbCrLf

Dim re
Set re = New RegExp
re.Global = True
re.MultiLine = True
re.pattern = _
	"<!-- Account Number Label -->\s*<span id=""DisplayExpressTopNav1_LabelAccountNumber"" " & _
		"class=""LoginBarText"">Account: (\d+)</span>" & _
	"(?:\s*|.*?)*" & _
	"<!-- Balance -->\s*<span id=""DisplayExpressTopNav1_LabelBalance"" " & _
		"class=""LoginBarText"">Balance: \$(\d+\.\d+)</span>"

Dim objExcel
Set objExcel = CreateObject("Excel.Application")
objExcel.DisplayAlerts = 0
objExcel.Visible = False
objExcel.Workbooks.Open Replace(WScript.ScriptFullName, WScript.ScriptName, C_EXCEL_FILENAME)
Dim rownum, blnFound
blnFound = False

Dim Matches, Match, foundAccount, foundBalance
Set Matches = re.Execute(t)
For Each Match in Matches
	If Match.Submatches.Count = 2 Then
		foundAccount = Match.Submatches(0)
		foundBalance = Match.Submatches(1)
		With objExcel.Workbooks(C_EXCEL_FILENAME).Sheets(1).UsedRange
			For rownum = 2 To .Rows.Count '' skip header
				''MsgBox "in loop; rownum = " & rownum & " (" & .Cells(rownum, 1).Value & " / " & foundAccount & ")"
				If CStr(.Cells(rownum, 1).Value) = foundAccount Then
					.Cells(rownum, 2).Value = foundBalance
					blnFound = True
					Exit For
				End If
			Next
			'' use the fact that rownum has gone over the upper bounds of the loop...
			If Not blnFound Then
				''MsgBox "after loop; rownum = " & rownum
				.Cells(rownum, 1).Value = foundAccount
				.Cells(rownum, 2).Value = foundBalance
			End If
		End With
	End If
Next
objExcel.Workbooks(C_EXCEL_FILENAME).Save
objExcel.Quit
Set objExcel = Nothing

Select allOpen in new window

This also works if there's more than 1 of these blocks of html by the way, it will update (or add) all found accounts with their respective balances.

Maybe it's smart to add some error trapping/processing because the Excel object can hang in memory and keep the document open when the script crashes without closing it.

Here's how the excel looks after a few test runs. I put the money format on column B manually.

 

Sorry to make it easier for you

The script is a continuance of the last one.

I have a excel spread sheet which I need to run the vbs.  the vbs then login to website.  From the website it gets account info and returns the value spreadsheet cell then looks at another cell on the spreadsheet to send a string to the website

 

A bit confusing

no problem, how will you be running the code, press a button, just use Alt-F8 or something else?

Ok, for the moment I have assumed you will run the macro manually. We can always link it to a button or another function.

Now my problem is that I can't test because I don't have a login/password...

Can you test "MyMacro" in "ThisWorkbook" in the attached excel sheet?

 balance.xls

your a legend works perfect

I can put that into a function right. I am using Visual Studio to code with so things aren't in macro

Copied the code in VS module errors

yeah, there's going to be some changes for use in VB.NET, I must say I'm a bit lost now, you want to call it from excel, but develop in Visual Studio? I guess it's possible but I don't think I see the connection just now.

Changes will be along these lines: add Imports at the start or call:

* System.Threading.Thread.Sleep(100)
* System.Text.RegularExpressions.Regex (but this is different than the vbs Regexp)

Can you explain how you call this code?

Maybe my problem here is that I use Visual Studio 2010 Express and I don't have an Excel-project option?

Is this in effect VBA.NET?? at some level I hope not...

Here is the module

Imports Microsoft.VisualStudio.Tools.Applications.Runtime
Imports Office = Microsoft.Office.Core
Imports Tools = Microsoft.Office.Tools.Excel
Imports Microsoft.Office.Interop
Imports Login = BetBotv2.au.com.tab.login
Imports Racing = BetBotv2.au.com.tab.racing
Imports System
Imports System.IO
Imports System.Xml


Module Module1
    Private WithEvents myTimer As New System.Windows.Forms.Timer With {.Interval = 15000}

    Public Sub Refresh(ByVal RunTimer As Boolean)
        myTimer.Enabled = RunTimer
    End Sub

    Private Sub myTimer_Tick(ByVal sender As Object, ByVal e As System.EventArgs) Handles myTimer.Tick
        NextMeeting()
    End Sub

    Public Sub NextMeeting()

        Dim key As String
        Dim j As String
        Dim rt As String
        Dim racing As New au.com.tab.racing.Racing
        Dim root As Xml.XmlElement



        key = Globals.Sheet3.Range("B4").Value
        j = Globals.Sheet3.Range("B9").Value
        rt = "0"
        If Globals.Sheet3.Range("B8").Value = "Races" Then
            rt = "R"
        ElseIf Globals.Sheet3.Range("B8").Value = "Harness" Then
            rt = "H"
        ElseIf Globals.Sheet3.Range("B8").Value = "Greyhounds" Then
            rt = "G"
        End If


        root = racing.NextEvent(key, j, rt)
        If root.InnerXml = "" Then
            Globals.Sheet1.Range("B2").Value = "There are no more races available"

        Else

            'MeetingInfo

            Dim VenueName As XmlNode = root.SelectSingleNode("//MeetingInfo/VenueName")
            Globals.Sheet1.Range("B1").Value = VenueName.InnerXml

            Dim MeetingStatus As XmlNode = root.SelectSingleNode("//MeetingInfo/Status")
            Globals.Sheet1.Range("B2").Value = MeetingStatus.InnerXml

            Dim TrackCondition As XmlNode = root.SelectSingleNode("//MeetingInfo/TrackCondition")
            Globals.Sheet1.Range("B3").Value = TrackCondition.InnerXml

            Dim Weather As XmlNode = root.SelectSingleNode("//MeetingInfo/WeatherCondition")
            Globals.Sheet1.Range("B4").Value = Weather.InnerXml

            Dim NumRaces As XmlNode = root.SelectSingleNode("//MeetingInfo/NumberRaces")
            Globals.Sheet1.Range("B5").Value = NumRaces.InnerXml


            'RaceInfo

            Dim RaceID As XmlNode = root.SelectSingleNode("/RaceInfo/Race/@RID")
            Globals.Sheet1.Range("B12").Value = RaceID.FirstChild.InnerText

            Find_First()

            Dim RaceNum As XmlNode = root.SelectSingleNode("//RaceInfo/Race/Race")
            Globals.Sheet1.Range("B6").Value = RaceNum.InnerXml

            Dim StartTime As XmlNode = root.SelectSingleNode("//RaceInfo/Race/StartTimeAdj")
            Globals.Sheet1.Range("B7").Value = StartTime.InnerXml

            Dim JumpTime As XmlNode = root.SelectSingleNode("//RaceInfo/Race/TimeToJump")
            Globals.Sheet1.Range("B8").Value = JumpTime.InnerXml

            Dim BetStatus As XmlNode = root.SelectSingleNode("//RaceInfo/Race/Status")
            Globals.Sheet1.Range("B9").Value = BetStatus.InnerXml

            Dim RaceName As XmlNode = root.SelectSingleNode("//RaceInfo/Race/Name")
            Globals.Sheet1.Range("B10").Value = RaceName.InnerXml

            Dim Distance As XmlNode = root.SelectSingleNode("//RaceInfo/Race/Distance")
            Globals.Sheet1.Range("B11").Value = Distance.InnerXml


            'RunnerInfo

            Dim RunnerStatus As XmlNodeList = root.SelectNodes("//RunnerInfo/Race/Runners/Status")
            Dim a As Integer
            For a = 0 To RunnerStatus.Count - 1
                Globals.Sheet1.Range("B" & (16 + (a))).Value = RunnerStatus(a).InnerXml
            Next a

            Dim RunnerBox As XmlNodeList = root.SelectNodes("//RunnerInfo/Race/Runners/@Number")
            Dim b As Integer
            For b = 0 To RunnerBox.Count - 1
                Globals.Sheet1.Range("C" & (16 + (b))).Value = RunnerBox(b).InnerXml
            Next b

            Dim elemList As XmlNodeList = root.SelectNodes("//RunnerInfo/Race/Runners/Name")
            Dim c As Integer
            For c = 0 To elemList.Count - 1
                Globals.Sheet1.Range("D" & (16 + (c))).Value = elemList(c).InnerXml
            Next c

            'Approximates
            Dim ApproxWin As XmlNode = root.SelectSingleNode("//Approximates/Pool/Win")
            Dim WinResults As String

            WinResults = ApproxWin.InnerXml


            Dim toCol As String
            Dim toRow As String
            Dim inVal As String
            Dim outVal As String
            Dim commaPos As Integer

            ' Copy from column A to column B.'

            toCol = "E"
            toRow = "16"

            ' Go until no more entries in column A.'
            inVal = WinResults

            While inVal <> ""

                ' Go until all sub-entries used up.'
                While inVal <> ""
                    ' Extract each subentry.'
                    commaPos = InStr(1, inVal, ",")
                    While commaPos <> 0

                        ' and write to output column.'
                        outVal = Left(inVal, commaPos - 1)
                        Globals.Sheet1.Range(toCol + toRow).Select()
                        Globals.Sheet1.Range(toCol + toRow).Value = outVal
                        toRow = Mid(Str(Val(toRow) + 1), 2)

                        ' Remove that sub-entry.'
                        inVal = Mid(inVal, commaPos + 1)
                        While Left(inVal, 1) = " "
                            inVal = Mid(inVal, 2)
                        End While
                        commaPos = InStr(1, inVal, ",")
                    End While

                    ' Get last sub-entry (or full entry if no commas).'
                    Globals.Sheet1.Range(toCol + toRow).Select()
                    Globals.Sheet1.Range(toCol + toRow).Value = inVal
                    toRow = Mid(Str(Val(toRow) + 1), 2)
                    inVal = ""
                End While
            End While
        End If
    End Sub

    Public Sub Find_First()

        Dim FindString As String
        Dim Rng As Excel.Range
        Dim Rcount As Long
        Dim NextEmpty As String
        Dim excel As New Microsoft.Office.Interop.Excel.Application()
        FindString = Globals.Sheet1.Range("B12").Value
        Rcount = 0

        If Trim(FindString) <> "" Then
            With Globals.Sheet7.Range("A:A")
                Rng = .Find(What:=FindString, _
                After:=.Cells(.Cells.Count), _
                LookIn:=Excel.XlFindLookIn.xlValues, _
                LookAt:=Excel.XlLookAt.xlWhole, _
                SearchOrder:=Excel.XlSearchOrder.xlByColumns, _
                SearchDirection:=Excel.XlSearchDirection.xlNext, _
                MatchCase:=False)


                If Rng Is Nothing Then
                    NextEmpty = Globals.Sheet7.Range("A65536").End(Excel.XlDirection.xlUp).Row
                    NextEmpty = NextEmpty + 1
                    Globals.Sheet7.Range("A" & NextEmpty).Value = FindString
                    Excel.DisplayAlerts = False
                    Globals.Sheet7.SaveAs(filename:="C:\Betbot\ResultsDB.csv", fileFormat:=excel.XlFileFormat.xlCSVWindows)
                    Excel.DisplayAlerts = True
                End If
            End With
        End If

    End Sub


    Public Sub RunBet()
        Const C_EXCEL_FILENAME = "balance.xls"

        Dim objIE
        Dim strtext
        Dim strpasstext
        Dim strbutton

        strtext = "DisplayExpressTopNav1" & Chr(36) & "TextboxLogin"
        strpasstext = "DisplayExpressTopNav1" & Chr(36) & "TextboxPassword"
        strbutton = "DisplayExpressTopNav1" & Chr(36) & "ButtonLogin"

        objIE = CreateObject("InternetExplorer.Application")

        objIE.Navigate("http://www.tab.com.au/ExpressBet/LoginFrame.aspx?State=2&ExpressBetMode=Standard")
        objIE.Visible = True

        While objIE.Busy = True
            Sleep(100)
        End While

        objIE.Document.form1.elements(strtext).Value = ""
        objIE.Document.form1.elements(strpasstext).Value = ""

        objIE.Document.form1.elements(strbutton).Click()

        While objIE.Busy = True
            Sleep(100)
        End While

        Dim t
        t = objIE.Document.DocumentElement.outerHTML

        Dim re
        re = New RegExp
        re.Global = True
        re.MultiLine = True
        re.Pattern = _
            "<!-- Account Number Label -->\s*<span id=""DisplayExpressTopNav1_LabelAccountNumber"" " & _
                "class=""LoginBarText"">Account: (\d+)</span>" & _
            "(?:\s*|.*?)*" & _
            "<!-- Balance -->\s*<span id=""DisplayExpressTopNav1_LabelBalance"" " & _
                "class=""LoginBarText"">Balance: \$(\d+\.\d+)</span>"

        Dim Matches, Match, foundAccount, foundBalance
        Matches = re.Execute(t)
        For Each Match In Matches
            If Match.Submatches.Count = 2 Then
                foundAccount = Match.Submatches(0)
                foundBalance = Match.Submatches(1)
                ActiveSheet.Range("C5").Value = foundBalance
            End If
        Next

    End Sub

End Module

Select allOpen in new window

spreadsheet sheet 3

 

Public Class Sheet3

    Private Sub Sheet3_Startup() Handles Me.Startup
        Range("B5").Value = "Logged Out"

    End Sub

    Private Sub Sheet3_Shutdown() Handles Me.Shutdown

    End Sub

    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        'Logout

        Range("B5").Value = "Logged Out"
        Range("B2:B4").Value = ""
        Button1.Visible = False
        Button2.Visible = True

    End Sub

    Private Sub Button2_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button2.Click
        Dim user As String
        Dim pass As String
        Dim userLogin As New au.com.tab.login.Login
        Dim key As String


        user = Range("B2").Value
        pass = Range("B3").Value

        key = userLogin.GetKey(user, pass)
        Range("B4").Value = key

        If Range("B4").Value = "<Error>Your username or password is invalid. Please try again.</Error>" Then
            Range("B5").Value = "Login Error"
        ElseIf Range("B4").Value = "" Then
            Range("B5").Value = "Logged Out"
        Else
            Range("B5").Value = "Logged In"
        End If

        Button1.Visible = True
        Button2.Visible = False

    End Sub

End Class

Select allOpen in new window

Spreadsheet sheet 1

 

Imports Microsoft.VisualStudio.Tools.Applications.Runtime
Imports Office = Microsoft.Office.Core
Imports Tools = Microsoft.Office.Tools.Excel
Imports Login = BetBotv2.au.com.tab.login
Imports Racing = BetBotv2.au.com.tab.racing
Imports System
Imports System.IO
Imports System.Xml



Public Class Sheet1
    Public RunTimer As Boolean


    Private Sub Sheet1_Startup() Handles Me.Startup

    End Sub

    Private Sub Sheet1_Shutdown() Handles Me.Shutdown

    End Sub

    Private Sub Button4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button4.Click


        Button3.Visible = True
        Button4.Visible = False
        NextMeeting()
        Refresh(True)

    End Sub

    Private Sub Button3_Click_1(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.Click

        Button4.Visible = True
        Button3.Visible = False
        Refresh(False)

    End Sub

End Class

Select allOpen in new window

This is all the code for the workbook
I call some xml

I see the main thing I miss is the Visual Studio Tools for Office. But maybe we can get by without me installing that. In any case I'm guessing I couldn't run it still because I would be missing the data, for starters the login credentials.

Can you start by adding to the first Module these lines, below the other imports:

Imports System.Threading.Thread
Imports System.Text.RegularExpressions

Select allOpen in new window

Then we still have to make some changes for the Regex to work, but I need some time to test that.

Ah, I see something like:

Globals.Sheet3.Range("B4").Value

Select allOpen in new window

so you should be able to place it anywhere you like.

The only thing that needs addressing is RegExp

sorry I posted a number of times quickly, maybe you need to refresh, that part is in my post with ID: 36488636 ;)

so get rid of the old code in lines 236-255 (with Regexp) and put in the .NET code (with Regex, note the missing 'p')...

sorry

No problem, man! See I already learned something completely new from helping you! It really makes my day too if we can say at the end: we did it, it works!

With constant do I need to track it to where the xlsm file is????

 

No, you can actually delete that line, it is from the old code where the excel file was opened dynamically. Now you just use the current workbook.

your a champion works a dream

if you wont to know what this is a mate has asked me if i could build him a bet bot. I told him I would take a look
Pretty much because it would be a learning experience for me its falling together quiet well with your help thanks heaps

Just by chance you in germany???? or some where around there

There are a few more thing I am stuck with one is on this post

Saving worksheet to csv file without prompts

If you want I will raise new post for other one should be easy for you in the same function just needs to send a string to the website to lodge bet

I'm in the Netherlands as it happens, I will be around for another half an hour... but back tomorrow.

k can't do much now races have stopped for the day. 1225am here in aus tomorrow would be great

If you could look at that other post would be great the new post I will put up tomorrow

again thanks heaps

Wow, just took a look at the other question thread, I'm gonna need some more time to read that than I have now, sorry but will look later tonight or tomorrow.

Robert your a legend

Hi Robert If you can when you get a chance can you look at this post

Excel string to website textarea and submit

Thanks