iOpus


Home		Products		Purchase		Service & Support		Partner Programs		Contact Us

iMacros


Product Information

	Success Stories

	Compare Editions

	Web Image Recognition

	Press Reviews

	System Requirements

	Online User Manual

	Product Flyer (PDF)

Support

	Online Demos

	Code Samples

	Tutorials

	iMacros User Forum

FAQ

Buy iMacros

Customer Login

Support Ticket

Home > iMacros > Support > Generate Macros

Tutorial: Generate Macros with Excel VB

Example code for the Overture Management Tutorial

1. The Excel Example Code (VBA, Visual Basic for Application(listing.vbs

Simply click inside the window below, use your cursor to highlight the script, and copy (type Control-c) it into the Excel VBA Editor.

Sub fab()

' init
Dbg = True
Dim NewsBody As String
Application.DefaultWebOptions.UpdateLinksOnSave = False
Application.DisplayAlerts = False
Application.ScreenUpdating = True
fabDir = Left(Application.ActiveWorkbook.FullName, InStrRev(Application.ActiveWorkbook.FullName, "\"))
ChDir fabDir

' Determine week # relative to start of this season
NFLWeek = DateDiff("ww", "9/5/2002", Date, vbWednesday)
If NFLWeek < 0 Then
    NFLWeek = "p" & Abs(NFLWeek)
Else
    NFLWeek = Format(NFLWeek, "00")
End If

fabWorkbook = fabDir & "fab" & NFLWeek & ".xls"

If Not Dbg Then
    Workbooks.Add
    ActiveSheet.Name = "Standings"
    ActiveWorkbook.SaveAs fabWorkbook

Workbooks.Open "http://football2126.fantasy.sportsline.com/mp/standings-overall?league=tjltjl&owner=12771&period=Current&"
    Range("A:B").Delete
    Range("A1").Select
    While Left(ActiveCell, 18) <> "Standings for Week"
        If ActiveCell.Row = 999 Then Exit Sub
        ActiveCell.Offset(1, 0).Select
    Wend
    ActiveCell.Offset(1, 0).Select
    For i = 1 To 14
        ActiveCell.Offset(1, 0).Select
        Workbooks(fabWorkbook).Sheets("Standings").Range("A" & i) = ActiveCell.Offset(0, 0)
        Workbooks(fabWorkbook).Sheets("Standings").Range("B" & i) = ActiveCell.Offset(0, 4)
        Workbooks(fabWorkbook).Sheets("Standings").Range("C" & i) = ActiveCell.Offset(0, 0).Hyperlinks(1)
    Next i
    ActiveWorkbook.Close
End If

' Get add/drop requests
Workbooks.Open "http://football2126.fantasy.sportsline.com/mp/frontoffice/transaction-requests?league=tjltjl&owner=12771&"
fabRequests = ActiveSheet.Name
Sheets(fabRequests).Move Before:=Workbooks("fab" & NFLWeek & ".xls").Sheets("Standings")

' Add sheet where bids will be consolidated into easy to manipulate table
Worksheets.Add
ActiveSheet.Name = "FAB " & NFLWeek
Cells.Font.Size = 8

Dim ColNames As Variant
ColNames = Split("Team,Points,Add,AddID,Drop,DropID,BidTime,Bid,Price,Action,BidID,Comments,NTC", ",")

For i = LBound(ColNames) To UBound(ColNames)
    ActiveWorkbook.Names.Add Name:=ColNames(i), RefersToR1C1:="=R1C" & i + 1
    Range(ColNames(i)) = ColNames(i)
Next i

Range("BidTime").EntireColumn.NumberFormat = "m/d/yy h:mm AM/PM"
Range("AddID").EntireColumn.NumberFormat = "0"
Range("DropID").EntireColumn.NumberFormat = "0"

' consolidate web-requests into easy to manage "work" table
i = 0
For Each obj In Worksheets(fabRequests).OLEObjects      ' Loop thru all OLE Object in this worksheet
    If Len(obj.Object.HTMLName) = 10 Then               ' Accept/Drop radio boxes have HTML NAME length of 10 ...
        If obj.Object.Value = "deny" Then               ' ... and the "deny" button is on the bottom
            
            i = i + 1
            
            TLCol = obj.TopLeftCell.Column
            TLRow = obj.TopLeftCell.Row
            
            Range("Team").Offset(i) = Worksheets(fabRequests).Range(Chr(TLCol + 60) & TLRow - 2)
            Range("Add").Offset(i) = Worksheets(fabRequests).Range(Chr(TLCol + 61) & TLRow - 2)
            Range("Drop").Offset(i) = Worksheets(fabRequests).Range(Chr(TLCol + 62) & TLRow - 2)
            If Range("Drop").Offset(i) = "*" Then Range("Drop").Offset(i) = ""
            
            Range("AddID").Offset(i) = Worksheets(fabRequests).Range(Chr(TLCol + 61) & TLRow - 2).Hyperlinks.Item(1).Address
            Range("AddID").Offset(i) = Mid(Range("AddID").Offset(i), InStr(Range("AddID").Offset(i), "key="))
            Range("AddID").Offset(i) = Mid(Range("AddID").Offset(i), 5, InStr(Range("AddID").Offset(i), "&") - 5)
            
            Range("DropID").Offset(i) = Worksheets(fabRequests).Range(Chr(TLCol + 62) & TLRow - 2).Hyperlinks.Item(1).Address
            Range("DropID").Offset(i) = Mid(Range("DropID").Offset(i), InStr(Range("DropID").Offset(i), "key="))
            Range("DropID").Offset(i) = Mid(Range("DropID").Offset(i), 5, InStr(Range("DropID").Offset(i), "&") - 5)
            
            ReqDate = Mid(Worksheets(fabRequests).Range(Chr(TLCol + 60) & TLRow - 1), 13, 99)
            Range("BidTime").Offset(i) = Left(ReqDate, Len(ReqDate) - 3)
            
            Range("NTC").Offset(i) = Worksheets(fabRequests).Range(Chr(TLCol + 60) & TLRow - 0)
            Range("Bid").Offset(i) = OnlyN(Worksheets(fabRequests).Range(Chr(TLCol + 60) & TLRow - 0))
            Range("Points").Offset(i) = "=VLOOKUP(RC[-1],'Standings'!R1C1:R14C2, 2,FALSE)"
            
            If Range("AddID").Offset(i) <> "" _
            And Range("Bid").Offset(i) < 5 Then
                Range("Action").Offset(i) = "deny"
                Range("Comments").Offset(i) = "Less than minimum"
                Range("Comments").Offset(i).Font.Color = vbRed
            End If
            
            Range("BidID").Offset(i) = obj.Object.HTMLName
            
            If Range("AddID").Offset(i) = "" Then
                Range("Add").Offset(i) = Range("BidID").Offset(i)
                Range("Bid").Offset(i) = 9999
            End If
            
        End If
    End If
Next

bids = i                                                                        ' Record the number of bids
Sheets(fabRequests).Delete

' deny adds which an owner changed later (i.e., DaBoyz bid $5 for Warner on Tue but then DaBoyz bid $7 for Warner on Wed)
' NOTE: Since HTMLNAME appears to be a calculation based on the bid time, I'm using it as the bid time for more accuracy (hundredths)
Selection.Sort Key1:=Range("BidID"), Order1:=xlAscending, Header:=xlYes
Selection.Sort Key1:=Range("AddID"), Order1:=xlAscending, Header:=xlYes
Selection.Sort Key1:=Range("Team"), Order1:=xlAscending, Header:=xlYes
For i = 1 To bids
    If Range("AddID").Offset(i) <> "" _
    And Range("Team").Offset(i) = Range("Team").Offset(i + 1) And Range("AddID").Offset(i) = Range("AddID").Offset(i + 1) Then
        Range("Action").Offset(i) = "deny"
        Range("Comments").Offset(i) = "Modified later by owner (BID: " & Range("BidID").Offset(i + 1) & ")"
        Range("Comments").Offset(i).Font.Color = vbBlue
    End If
Next i

' Because of conditional bids, adds are nominated in order ... sort by time only
' for each non-denied bid...
'    look for highest bid for this add besides this one
'    is this the highest bid for this add?
'        deny all other bids for same drop (this will handle conditional bids)
'        deny all other non-denied bids for same add and record the 2nd highest non-denied bid
'        accept at 2nd highest price (if tied, use actual bid) (if no 2nd highest, price = $5)
'    no
'        deny
' next non-denied bid

Selection.Sort Key1:=Range("BidID"), Order1:=xlAscending, Header:=xlYes
Selection.Sort Key1:=Range("Drop"), Order1:=xlAscending, Header:=xlYes

For i = 1 To bids                                                               ' For each bid ...
If Range("Action").Offset(i) = "" Then                                          ' ... which has not already been denied
    
    HiBidRow = 9999                                                             ' Set HiBid to one less than default
    
    ' Loop through all bids following this one that are (a) non-denied, (b) same add player, (c) record higher bid
    For J = i + 1 To bids
        If Range("Action").Offset(J) = "" _
        And Range("Add").Offset(J) = Range("Add").Offset(i) _
        And Range("AddID").Offset(J) = Range("AddID").Offset(i) _
        And Range("Bid").Offset(J) >= Range("Bid").Offset(HiBidRow) Then HiBidRow = J
    Next J

' Another Bid exceeds this one
    If (Range("Bid").Offset(HiBidRow) > Range("Bid").Offset(i)) _
    Or (Range("Bid").Offset(HiBidRow) = Range("Bid").Offset(i) And Range("Points").Offset(HiBidRow) < Range("Points").Offset(i)) Then
        Range("Action").Offset(i) = "deny"                                  ' DENY
        Range("Comments").Offset(i) = "Exceeded by higher bid (BID: " & Range("BidID").Offset(HiBidRow) & ")"
        Range("Comments").Offset(i).Font.Color = vbGreen
        Range("Price").Offset(HiBidRow) = Range("Bid").Offset(i) + 1
        If Range("Bid").Offset(HiBidRow) = Range("Bid").Offset(i) Then Range("Price").Offset(HiBidRow) = Range("Bid").Offset(i)
    Else                                                                    ' No other Bid exceeds this one
        Range("Action").Offset(i) = "accept"                                ' ACCEPT
        If Range("Add").Offset(i) = Range("BidID").Offset(i) Then Range("Comments").Offset(i) = "Simple drop (no added player)"                      ' Change comment if simple drop
        
        If Range("Price").Offset(i) = "" Then
            Range("Price").Offset(i) = Range("Bid").Offset(HiBidRow) + 1                                ' Adjust accepted bid to 2nd highest +1
            If Range("Bid").Offset(HiBidRow) = Range("Bid").Offset(i) Then Range("Price").Offset(i) = Range("Bid").Offset(i)    ' Unless HiBid is same
            If Range("Price").Offset(i) < 5 Then Range("Price").Offset(i) = 5
        End If
        Range("Comments").Offset(i) = "Awarded at $" & Range("Price").Offset(i)
        
        ' deny all other bids with same add and drop which have not already been denied
        For J = i + 1 To bids
        If Range("Action").Offset(J) = "" And Range("AddID").Offset(J) <> "" Then
            If Range("AddID").Offset(J) = Range("AddID").Offset(i) And Range("Add").Offset(J) = Range("Add").Offset(i) Then             ' same add
                Range("Action").Offset(J) = "deny"
                Range("Comments").Offset(J) = "Exceeded by higher bid (BID: " & Range("BidID").Offset(i) & ")"
                Range("Comments").Offset(J).Font.Color = vbMagenta
            End If
            If Range("Drop").Offset(J) = Range("Drop").Offset(i) And Range("Drop").Offset(i) <> "" Then                                            ' same drop
                Range("Action").Offset(J) = "deny"
                Range("Comments").Offset(J) = "Previous condition already accepted (BID: " & Range("BidID").Offset(i) & ")"
                Range("Comments").Offset(J).Font.Color = vbCyan
            End If
        End If
        Next J
    
    End If

End If
Next i

Selection.Sort Key1:=Range("BidID"), Order1:=xlAscending, Header:=xlYes
Cells.Columns.AutoFit
ActiveWorkbook.SaveAs Filename:=fabWorkbook, FileFormat:=xlText, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False

' Produce .IMM file
Worksheets.Add
ActiveSheet.Name = "IIM " & NFLWeek
Cells.Font.Size = 8
Range("A:A").ColumnWidth = 255
Range("A:A").NumberFormat = "@"

' IMM portion which processes requests
' Start with the URL, loop through the accepted or denied bids, and finish by pressing the OK button
Range("A" & ActiveSheet.UsedRange.Rows.Count) = "URL GOTO=http://football2126.fantasy.sportsline.com/mp/frontoffice/transaction-requests?league=tjltjl&owner=12771&"
For i = 1 To bids
    Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "TAG POS=1 TYPE=INPUT:RADIO FORM=ACTION:/mp/frontoffice/transaction-requests ATTR=NAME:" & Range("BidID").Offset(i) & "&&VALUE:" & Range("Action").Offset(i) & " CONTENT=" & Range("Action").Offset(i)
Next i
Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "TAG POS=1 TYPE=INPUT:IMAGE FORM=ACTION:/mp/frontoffice/transaction-requests ATTR=NAME:okay&&VALUE:"

' Allow free-for-all
Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "URL GOTO=http://football2126.fantasy.sportsline.com/mp/frontoffice/edit-league-permissions?league=tjltjl&owner=12771&random=2315&"
Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "TAG POS=1 TYPE=INPUT:RADIO FORM=ACTION:edit-league-permissions ATTR=NAME:add_drop_policy&&VALUE:free_for_all CONTENT=free_for_all"
Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "TAG POS=1 TYPE=INPUT:IMAGE FORM=ACTION:edit-league-permissions ATTR=NAME:okay&&VALUE:"

' IMM portion which adjusts salaries
' For each accepted player ... start with the URL, modify salary, and press OK (3 IMM lines per player)
' While we're here, build body of news item...
For i = 1 To bids
    If Range("action").Offset(i) = "accept" And Range("AddID").Offset(i) <> "" Then
        Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "URL GOTO=http://football2126.fantasy.sportsline.com/mp/frontoffice/edit-lineups?league=tjltjl&owner=12771&team_name=" & fabSP(Range("Team").Offset(i)) & "&player_ids=" & Range("AddID").Offset(i) & "&"
        Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "TAG POS=1 TYPE=INPUT:TEXT FORM=ACTION:/mp/frontoffice/edit-lineups ATTR=NAME:" & Range("AddID").Offset(i) & ":w1 CONTENT=" & Range("Price").Offset(i)
        Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "TAG POS=1 TYPE=INPUT:IMAGE FORM=ACTION:/mp/frontoffice/edit-lineups ATTR=NAME:okay&&VALUE:"
    End If
    NewsBody = NewsBody & fabSP("<br /><LF>" _
        & fStr(15, Range("BidID").Offset(i)) _
        & fStr(20, Range("BidTime").Offset(i)) _
        & fStr(20, Range("Team").Offset(i)) _
        & fStr(15, Range("Bid").Offset(i)) _
        & fStr(15, Range("Add").Offset(i)) _
        & fStr(15, Range("Drop").Offset(i)) _
        & fStr(10, Range("Action").Offset(i)) _
        & fStr(60, Range("Comments").Offset(i)) _
        & Range("NTC").Offset(i))
    x = Len(NewsBody)
Next i

' Add the News Item for audit purposes
Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "URL GOTO=http://football2126.fantasy.sportsline.com/mp/news-add?league=tjltjl&owner=12771&"
Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "TAG POS=1 TYPE=INPUT:CHECKBOX FORM=ACTION:news-add ATTR=NAME:pre&&VALUE:on CONTENT=YES"
Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "TAG POS=1 TYPE=INPUT:TEXT FORM=ACTION:news-add ATTR=NAME:subject CONTENT=FAB<SP>week<SP>" & NFLWeek & "<SP>results"
Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "TAG POS=1 TYPE=TEXTAREA FORM=ACTION:news-add ATTR=NAME:contents CONTENT=" & NewsBody
Range("A" & ActiveSheet.UsedRange.Rows.Count + 1) = "TAG POS=1 TYPE=INPUT:IMAGE FORM=ACTION:news-add ATTR=NAME:okay&&VALUE:"

' Save IIM file as text in the iOpus MACROS directory
ActiveWorkbook.SaveAs Filename:="C:\PROGRA~1\INTERN~2\MACROS\fab" & NFLWeek & ".iim", FileFormat:=xlTextMSDOS, CreateBackup:=False

' Invoke iOpus with the FAB IMM file
If Not Dbg Then Shell "C:\PROGRA~1\INTERN~2\iimpro.exe -macro merge-data-example -datasource fab", vbHide

End Sub
Function fabSP(ValT As Variant)

Dim J As Integer
    
    On Error GoTo fabSPerror
    
    fabSP = Mid(ValT, 1, 1)
    For J = 2 To Len(ValT)
        If Mid(ValT, J, 1) = " " Then
            fabSP = fabSP & "<SP>"
        Else
            fabSP = fabSP & Mid(ValT, J, 1)
        End If
    Next J
    
    Exit Function

fabSPerror:
    fabSP = ValT

End Function
Function OnlyN(ValT As Variant)

Dim OnlyI As Integer
    Dim OnlyJ As Integer
    Dim OnlyStr As String
    
    On Error GoTo OnlyNerror
    
    For OnlyJ = 1 To Len(ValT)
        If Not IsEmpty(OnlyStr) And Mid(ValT, OnlyJ, 1) = "." Then Exit For
        If IsNumeric(Mid(ValT, OnlyJ, 1)) Then OnlyStr = OnlyStr & Mid(ValT, OnlyJ, 1)
    Next OnlyJ
    
    OnlyN = Int(OnlyStr)
    Exit Function

OnlyNerror:
    OnlyN = 0

End Function

Public Function fStr(iQty As Integer, xStr As String) As String

fStr = Left(xStr, iQty)
If Len(fStr) < iQty Then fStr = fStr & Space$(iQty - Len(fStr))

End Function

Back to the tutorial.

Purchase

Community

Subscribe To Newsletter:

The availability and performance of this website is monitored by iMacros Web Testing