Moderator: 2020vision
by jonn » Sun Aug 02, 2009 8:45 pm
by throwmeadisc » Mon Aug 03, 2009 10:44 am
by Norwegian Would » Mon Aug 03, 2009 1:08 pm
by throwmeadisc » Tue Aug 04, 2009 11:30 am
Sub ToExcel(msg As Outlook.MailItem)
'FOR FEEDER Sheet............
Dim i As Integer
Dim j As Integer
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim insp As Outlook.Inspector
Dim MsgDate As Date
Dim webMsg As MSHTML.HTMLDocument
Dim htable As MSHTML.HTMLTable
Dim hrow As MSHTML.HTMLTableRow
Dim hcell As MSHTML.HTMLTableCell
Dim colTables As MSHTML.IHTMLElementCollection
Dim colRows As MSHTML.IHTMLElementCollection
Dim colCells As MSHTML.IHTMLElementCollection
Dim exc As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
On Error GoTo ErrorSub:
Set exc = GetObject(, "Excel.Application")
Set wb = exc.Workbooks("Feeder.xls") 'References Workbook
Set ws = wb.Sheets("Email In") 'References Worksheet
exc.Visible = True
ws.Activate
With exc.Application
.EnableEvents = False
.ScreenUpdating = False
End With
strID = msg.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set msg = olNS.GetItemFromID(strID)
Set insp = msg.GetInspector
Set webMsg = insp.HTMLEditor
Do Until webMsg.readyState = "complete" 'Waits until Email is fully opened
DoEvents
Loop
ws.Range("A1:O1000").Clear 'Clears working area
'Extracts HTML Tables from Email
Set colTables = webMsg.getElementsByTagName("table")
i = 2 ' offset, change as needed to adjust the blank rows at the top
For Each htable In colTables
i = i + 1 ' sets blank rows between tables
Set colRows = htable.rows
For Each hrow In colRows
i = i + 1 ' increment row index
Set colCells = hrow.Cells
For Each hcell In colCells
j = hcell.cellIndex + 1
ws.Cells(i, j) = Trim(hcell.innerText)
Next
Next
Next
ws.Range("N1").Value = "Time of Extract:"
ws.Range("O1").Value = Now
ws.Range("N3").Value = "Email Date:"
ws.Range("O3").Value = msg.SentOn
ws.Range("O4").Clear
ws.Range("O4").Value = msg.Body ' This is any email text
With exc.Application
.EnableEvents = True
.ScreenUpdating = True
End With
ws.Range("O2").Value = "Changed" 'To trigger a Macro in Excel to process data
Do
Loop Until ws.Range("O2").Value = "Processed" 'Waits for Excel to finish processing the data from Outlook
ExitSub:
With exc.Application
.EnableEvents = True
.ScreenUpdating = True
End With
ErrorSub:
On Error Resume Next
Set exc = Nothing
Set wb = Nothing
Set ws = Nothing
Set msg = Nothing
Set insp = Nothing
Set olNS = Nothing
Set webMsg = Nothing
Set colCells = Nothing
End Sub
The strength of Gruss Software is that it’s been designed by one of you, a frustrated sports punter, and then developed by listening to dozens of like-minded enthusiasts.
Gruss is owned and run by brothers Gary and Mark Russell. Gary discovered Betfair in 2004 and soon realised that using bespoke software to place bets was much more efficient than merely placing them through the website.
Gary built his own software and then enhanced its features after trialling it through other Betfair users and reacting to their improvement ideas, something that still happens today.
He started making a small monthly charge so he could work on it full-time and then recruited Mark to help develop the products and Gruss Software was born.
We think it’s the best of its kind and so do a lot of our customers. But you can never stand still in this game and we’ll continue to improve the software if any more great ideas emerge.