THEO TODMAN’S BRIDGE WEBSITES CODE PAGES



This Page provides a jumping-off point for the VBA Code that generates my Bridge Websites.

Table of Code Documentation Location 25 (6 items)

cmdMPsImport_ClickcmdPromotions_ClickCheck_VariablesHand_Deal
Hand_SaveHandicap_Calculation..

To access information, click on one of the links in the table above.

Go to top of page




Source Code of: Check_Variables
Procedure Type: Public Sub
Module: Documentation
Lines of Code: 122
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Check_Variables()
0002'Currently, this doesn't cope with:-
0003 'a) Public and Static variables
0004 'b) Variables declared without a type?
0005Dim rsTableToRead As Recordset
0006Dim rsTableToWrite As Recordset
0007Dim Procedure As String
0008Dim Code As String
0009Dim Procedure_Type As String
0010Dim Module As String
0011Dim Variable As String
0012Dim i As Long
0013Dim j As Long
0014Dim k As Long
0015Dim DIM_Found As Boolean
0016Dim strAfter As String
0017Dim strBefore As String
0018Dim strTest As String
0019Dim strCheck As String
0020Dim Reference_OK As Boolean
0021 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT Procedure_Name, Procedure_Type, Module, Code FROM Code_Table ORDER BY Procedure_Name;")
0022 DoCmd.RunSQL ("DELETE * FROM Variables_Table;")
0023 Set rsTableToWrite = CurrentDb.OpenRecordset("SELECT * FROM Variables_Table WHERE Procedure_Name = ""Zzzzz"";")
0024rsTableToRead.MoveFirst
0025Do While Not rsTableToRead.EOF
0026 Procedure = rsTableToRead.Fields(0).Value
0027 Procedure_Type = rsTableToRead.Fields(1).Value
0028 Module = rsTableToRead.Fields(2).Value
0029 Code = rsTableToRead.Fields(3).Value
0030 'Find DIMs
0031 i = 1
0032 Do While i > 0
0033 i = InStr(i, Code, "DIM ")
0034 If i > 0 Then
0035 j = InStr(i + 4, Code, " ")
0036 If j > 0 Then
0037 If Mid(Code, j + 1, 3) = "as " Then
0038 Variable = Trim(Mid(Code, i + 4, j - i - 4))
0039 'Check not a table!
0040 j = InStr(Variable, "(")
0041 If j > 0 Then
0042 Variable = Trim(Left(Variable, j - 1))
0043 End If
0044 'Update Variables_Table
0045 rsTableToWrite.AddNew
0046 rsTableToWrite.Fields(0) = Procedure
0047 rsTableToWrite.Fields(1) = Procedure_Type
0048 rsTableToWrite.Fields(2) = Module
0049 rsTableToWrite.Fields(3) = Variable
0050 rsTableToWrite.Fields(4) = 0
0051 rsTableToWrite.Update
0052 End If
0053 End If
0054 i = i + 1
0055 End If
0056 Loop
0057 rsTableToRead.MoveNext
0058Loop
0059'Check for use of variables ...
0060 Set rsTableToRead = CurrentDb.OpenRecordset("SELECT Variables_Table.Procedure_Name, Variables_Table.Variable, Variables_Table.[Used?], Code_Table.Code FROM Variables_Table INNER JOIN Code_Table ON (Variables_Table.Module = Code_Table.Module) AND (Variables_Table.Procedure_Type = Code_Table.Procedure_Type) AND (Variables_Table.Procedure_Name = Code_Table.Procedure_Name) ORDER BY Variables_Table.Procedure_Name, Variables_Table.Variable;")
0061rsTableToRead.MoveFirst
0062Do While Not rsTableToRead.EOF
0063 Procedure = rsTableToRead.Fields(0)
0064 Variable = rsTableToRead.Fields(1)
0065 Code = rsTableToRead.Fields(3)
0066 DIM_Found = False
0067 i = InStr(Code, Variable)
0068 'Check for DIM & skip over ...
0069 Do Until DIM_Found = True Or i = 0
0070 If Mid(Code, i - 4, 3) = "DIM" Then
0071 DIM_Found = True
0072 Else
0073 i = InStr(i + 1, Code, Variable)
0074 End If
0075 Loop
0076 Reference_OK = False
0077 If DIM_Found = True Then
0078 i = InStr(i + 1, Code, Variable) 'Having skipped over the DIM ...
0079 'Ignore false positives - this should be a function as it's used elsewhere
0080 Do Until i = 0 Or Reference_OK = True
0081 strAfter = Mid(Code, i + Len(Variable), 1)
0082 'Check Following character
0083 If strAfter = " " Or strAfter = ")" Or strAfter = "(" Or strAfter = Chr$(10) Or strAfter = "]" Or strAfter = "." Or strAfter = """" Or strAfter = ";" Then 'This needs to be made more sophisticated
0084 strBefore = Mid(Code, i - 1, 1)
0085 'And check preceeding character
0086 If strBefore = " " Or strBefore = "(" Or strBefore = "[" Or strBefore = """" Then 'This needs to be made more sophisticated
0087 'Now check for part of longer name ...
0088 If Not (strAfter = " " And strBefore = """") And Not (strAfter = """" And strBefore = " ") Then
0089 'Find the line number
0090 j = i - 1
0091 strTest = ""
0092 Do Until strTest = Chr$(10) Or j = 1
0093 strTest = Mid(Code, j, 1)
0094 j = j - 1
0095 Loop
0096 If j = 1 Then
0097 Else
0098 j = j + 2
0099 End If
0100 Reference_OK = True
0101 strCheck = Mid(Code, j + 4, i - j - 4)
0102 k = InStr(strCheck, "'") + InStr(strCheck, "Debug.Print") + InStr(strCheck, "MsgBox")
0103 'Exclude Comments, Debug and MsgBox items ... Any other false positives?
0104 If k > 0 Then
0105 Reference_OK = False
0106 End If
0107 End If
0108 End If
0109 End If
0110 i = InStr(i + 1, Code, Variable)
0111 Loop
0112 If Reference_OK = True Then
0113 rsTableToRead.Edit
0114 rsTableToRead.Fields(2) = vbYes
0115 rsTableToRead.Update
0116 End If
0117 End If
0118 rsTableToRead.MoveNext
0119Loop
0120Set rsTableToRead = Nothing
0121Set rsTableToWrite = Nothing
0122End Sub

Procedures Calling This Procedure (Check_Variables) Tables / Queries / Fragments Directly Used By This Procedure (Check_Variables) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page



Source Code of: cmdMPsImport_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 12

Line-No. / Ref.Code Line
0001Private Sub cmdMPsImport_Click()
0002Dim strMsg As String
0003strMsg = "Do you want to import the Annual EBU masterpoints lists?" & Chr(10)
0004strMsg = strMsg & "First, copy the YYYY data into EBU_Essex_YYYY_MasterPoints.txt, where ""YYYY"" is the (previous) year, and attach as a table. " & Chr(10)
0005 strMsg = strMsg & "Then, copy the ""All Time"" data into EBU_Essex_9999_MasterPoints.txt. "
0006If MsgBox(strMsg, vbYesNo) = vbYes Then
0007 Parse_Masterpoints (9999)
0008 Parse_Masterpoints (2016)
0009 DoCmd.OpenQuery ("EBU_Annual_Masterpoints_Missing_Players")
0010 MsgBox ("Imported OK - see the errors, if any. Fix the .txt files - usually, errors in the names. ")
0011End If
0012End Sub

Procedures Called By This Procedure (cmdMPsImport_Click) Tables / Queries / Fragments Directly Used By This Procedure (cmdMPsImport_Click) Go To Top of This Page
Link to VBA Code Control Page



Source Code of: cmdPromotions_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 58
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdPromotions_Click()
0002Dim rs As Recordset
0003Dim rs2 As Recordset
0004Dim strQuery As String
0005Dim File_Date As Date
0006Dim i As Integer
0007Dim j As Integer
0008Dim k As Integer
0009Dim New_Rank As String
0010Dim Old_Rank As String
0011If MsgBox("Do you want to output the ECBA Promotions web-pages?", vbYesNo) = vbYes Then
0012Else
0013 MsgBox ("Click another button then!")
0014 End
0015End If
0016 strQuery = "DELETE * FROM EBU_Essex_Promotions;"
0017DoCmd.RunSQL strQuery
0018 strQuery = "SELECT * FROM EBU_Essex_Members_Ranking_History_Crosstab;"
0019Set rs = CurrentDb.OpenRecordset(strQuery)
0020j = rs.Fields.Count
0021 strQuery = "SELECT * FROM EBU_Essex_Promotions;"
0022Set rs2 = CurrentDb.OpenRecordset(strQuery)
0023If Not rs.EOF Then
0024 For k = 4 To j - 2
0025 rs.MoveFirst
0026 Do Until rs.EOF
0027 New_Rank = rs.Fields(k) & ""
0028 Old_Rank = rs.Fields(k + 1) & ""
0029 If New_Rank <> "Unranked" And New_Rank <> "" Then
0030 If New_Rank <> Old_Rank Then
0031 rs2.AddNew
0032 rs2.Fields(0) = rs.Fields(2)
0033 rs2.Fields(1) = rs.Fields(k).Name
0034 rs2.Fields(2) = rs.Fields(k + 1).Name
0035 rs2.Fields(3) = rs.Fields(0)
0036 rs2.Fields(4) = rs.Fields(1)
0037 rs2.Fields(5) = rs.Fields(3)
0038 rs2.Fields(6) = New_Rank
0039 rs2.Fields(7) = Old_Rank
0040 rs2.Update
0041 i = i + 1
0042 End If
0043 End If
0044 rs.MoveNext
0045 Loop
0046 Next k
0047End If
0048'Delete non-Essex
0049 strQuery = "UPDATE EBU_Essex_Promotions INNER JOIN EBU_Clubs ON EBU_Essex_Promotions.Primary_Club = EBU_Clubs.Club_Name SET EBU_Essex_Promotions.[Essex?] = No WHERE (((EBU_Essex_Promotions.Primary_Club)<>""Alpha Bridge Club"" And (EBU_Essex_Promotions.Primary_Club)<>""Monday Bridge Club"") AND ((EBU_Clubs.[Essex?])=No));"
0050DoCmd.RunSQL strQuery
0051 strQuery = "UPDATE EBU_Essex_Promotions SET EBU_Essex_Promotions.[Essex?] = No WHERE (((EBU_Essex_Promotions.Primary_Club)=""None""));"
0052DoCmd.RunSQL strQuery
0053 strQuery = "DELETE EBU_Essex_Promotions.*, EBU_Essex_Promotions.[Essex?] FROM EBU_Essex_Promotions WHERE (((EBU_Essex_Promotions.[Essex?])=No));"
0054DoCmd.RunSQL strQuery
0055 OK = Web_Page_Control_EBU_Promotions("Date", DateSerial(2015, 12, 31), DateSerial(Year(Now()), Month(Now()), 1) - 1, "ECBA")
0056 OK = Web_Page_Control_EBU_Promotions("Club", DateSerial(2015, 12, 31), DateSerial(Year(Now()), Month(Now()), 1) - 1, "ECBA")
0057MsgBox (i & " promotions recorded.")
0058End Sub

Procedures Called By This Procedure (cmdPromotions_Click) Tables / Queries / Fragments Directly Used By This Procedure (cmdPromotions_Click) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page



Source Code of: Hand_Deal
Procedure Type: Public Sub
Module: HandDealing
Lines of Code: 238
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Hand_Deal()
0002Dim Spade As String
0003Dim Heart As String
0004Dim Diamond As String
0005Dim Club As String
0006Dim OK As String
0007Dim Spades As Integer
0008Dim Hearts As Integer
0009Dim Diamonds As Integer
0010 Dim Clubs As Integer
0011Dim Points As Integer
0012Dim i As Integer
0013Dim j As Integer
0014Dim Hand As Integer
0015Club = Chr(167)
0016Diamond = Chr(168)
0017Heart = Chr(169)
0018Spade = Chr(170)
0019N_Spades = ""
0020S_Spades = ""
0021E_Spades = ""
0022W_Spades = ""
0023N_Diamonds = ""
0024S_Diamonds = ""
0025E_Diamonds = ""
0026W_Diamonds = ""
0027N_Hearts = ""
0028S_Hearts = ""
0029E_Hearts = ""
0030W_Hearts = ""
0031N_Clubs = ""
0032S_Clubs = ""
0033E_Clubs = ""
0034W_Clubs = ""
0035'Captions
0036Forms!Bridge!HandN_Spades.Caption = ""
0037Forms!Bridge!N_Spade.Caption = Spade
0038Forms!Bridge!N_Heart.Caption = Heart
0039Forms!Bridge!N_Diamond.Caption = Diamond
0040Forms!Bridge!N_Club.Caption = Club
0041Forms!Bridge!E_Spade.Caption = Spade
0042Forms!Bridge!E_Heart.Caption = Heart
0043Forms!Bridge!E_Diamond.Caption = Diamond
0044Forms!Bridge!E_Club.Caption = Club
0045Forms!Bridge!S_Spade.Caption = Spade
0046Forms!Bridge!S_Heart.Caption = Heart
0047Forms!Bridge!S_Diamond.Caption = Diamond
0048Forms!Bridge!S_Club.Caption = Club
0049Forms!Bridge!W_Spade.Caption = Spade
0050Forms!Bridge!W_Heart.Caption = Heart
0051Forms!Bridge!W_Diamond.Caption = Diamond
0052Forms!Bridge!W_Club.Caption = Club
0053'Crude Deal
0054 Clubs = 0
0055Diamonds = 0
0056Hearts = 0
0057Spades = 0
0058For i = 1 To 52
0059 For j = 1 To 2
0060 Card(i, j) = ""
0061 Next j
0062Next i
0063'Order: S, H, D, C
0064' A, K, Q, J, 10, ..., 2.
0065Randomize
0066i = 1
0067 Do Until Spades + Hearts + Diamonds + Clubs = 52
0068 If Card(i, 2) = "" Then
0069 Hand = Int(Rnd * 4) + 1
0070 OK = "Yes"
0071 Select Case Hand
0072 Case 1
0073 If Spades < 13 Then
0074 Spades = Spades + 1
0075 Else
0076 OK = "No"
0077 End If
0078 Case 2
0079 If Hearts < 13 Then
0080 Hearts = Hearts + 1
0081 Else
0082 OK = "No"
0083 End If
0084 Case 3
0085 If Diamonds < 13 Then
0086 Diamonds = Diamonds + 1
0087 Else
0088 OK = "No"
0089 End If
0090 Case 4
0091 If Clubs < 13 Then
0092 Clubs = Clubs + 1
0093 Else
0094 OK = "No"
0095 End If
0096 End Select
0097 If OK = "No" Then
0098 Else
0099 Card(i, 1) = Hand
0100 Card(i, 2) = "Y"
0101 i = i + 7
0102 If i > 52 Then
0103 i = 1
0104 End If
0105 End If
0106 Else
0107 i = i + 7
0108 If i > 52 Then
0109 i = i - 52
0110 End If
0111 End If
0112Loop
0113'Count the hands
0114'North
0115Points = 0
0116Hand = 1
0117 OK = Count_Hand(Spades, Clubs, Diamonds, Hearts, Points, Hand)
0118N_Points = Points
0119N_Distribution_Long = "S" & Spades & "-H" & Hearts & "-D" & Diamonds & "-C" & Clubs
0120N_Distribution = Spades & "-" & Hearts & "-" & Diamonds & "-" & Clubs
0121Forms!Bridge!N_Points.Caption = "North Points = " & N_Points
0122Forms!Bridge!N_Distribution.Caption = "North Distribution = " & N_Distribution
0123'East
0124Points = 0
0125Hand = 2
0126 OK = Count_Hand(Spades, Clubs, Diamonds, Hearts, Points, Hand)
0127E_Points = Points
0128E_Distribution_Long = "S" & Spades & "-H" & Hearts & "-D" & Diamonds & "-C" & Clubs
0129E_Distribution = Spades & "-" & Hearts & "-" & Diamonds & "-" & Clubs
0130Forms!Bridge!E_Points.Caption = "East Points = " & E_Points
0131Forms!Bridge!E_Distribution.Caption = "East Distribution = " & E_Distribution
0132'South
0133Points = 0
0134Hand = 3
0135 OK = Count_Hand(Spades, Clubs, Diamonds, Hearts, Points, Hand)
0136S_Points = Points
0137S_Distribution_Long = "S" & Spades & "-H" & Hearts & "-D" & Diamonds & "-C" & Clubs
0138S_Distribution = Spades & "-" & Hearts & "-" & Diamonds & "-" & Clubs
0139Forms!Bridge!S_Points.Caption = "South Points = " & S_Points
0140Forms!Bridge!S_Distribution.Caption = "South Distribution = " & S_Distribution
0141'West
0142Points = 0
0143Hand = 4
0144 OK = Count_Hand(Spades, Clubs, Diamonds, Hearts, Points, Hand)
0145W_Points = Points
0146W_Distribution_Long = "S" & Spades & "-H" & Hearts & "-D" & Diamonds & "-C" & Clubs
0147W_Distribution = Spades & "-" & Hearts & "-" & Diamonds & "-" & Clubs
0148Forms!Bridge!W_Points.Caption = "West Points = " & W_Points
0149Forms!Bridge!W_Distribution.Caption = "West Distribution = " & W_Distribution
0150'Print North Hand
0151For i = 1 To 52
0152 If Card(i, 1) = 1 Then
0153 If i < 14 Then
0154 N_Spades = N_Spades & Card_Name(i) & " "
0155 Else
0156 If i < 27 Then
0157 N_Hearts = N_Hearts & Card_Name(i - 13) & " "
0158 Else
0159 If i < 40 Then
0160 N_Diamonds = N_Diamonds & Card_Name(i - 26) & " "
0161 Else
0162 N_Clubs = N_Clubs & Card_Name(i - 39) & " "
0163 End If
0164 End If
0165 End If
0166 Forms!Bridge!HandN_Spades.Caption = N_Spades
0167 Forms!Bridge!HandN_Hearts.Caption = N_Hearts
0168 Forms!Bridge!HandN_Diamonds.Caption = N_Diamonds
0169 Forms!Bridge!HandN_Clubs.Caption = N_Clubs
0170 End If
0171Next i
0172'Print East Hand
0173For i = 1 To 52
0174 If Card(i, 1) = 2 Then
0175 If i < 14 Then
0176 E_Spades = E_Spades & Card_Name(i) & " "
0177 Else
0178 If i < 27 Then
0179 E_Hearts = E_Hearts & Card_Name(i - 13) & " "
0180 Else
0181 If i < 40 Then
0182 E_Diamonds = E_Diamonds & Card_Name(i - 26) & " "
0183 Else
0184 E_Clubs = E_Clubs & Card_Name(i - 39) & " "
0185 End If
0186 End If
0187 End If
0188 Forms!Bridge!HandE_Spades.Caption = E_Spades
0189 Forms!Bridge!HandE_Hearts.Caption = E_Hearts
0190 Forms!Bridge!HandE_Diamonds.Caption = E_Diamonds
0191 Forms!Bridge!HandE_Clubs.Caption = E_Clubs
0192 End If
0193Next i
0194'Print South Hand
0195For i = 1 To 52
0196 If Card(i, 1) = 3 Then
0197 If i < 14 Then
0198 S_Spades = S_Spades & Card_Name(i) & " "
0199 Else
0200 If i < 27 Then
0201 S_Hearts = S_Hearts & Card_Name(i - 13) & " "
0202 Else
0203 If i < 40 Then
0204 S_Diamonds = S_Diamonds & Card_Name(i - 26) & " "
0205 Else
0206 S_Clubs = S_Clubs & Card_Name(i - 39) & " "
0207 End If
0208 End If
0209 End If
0210 Forms!Bridge!HandS_Spades.Caption = S_Spades
0211 Forms!Bridge!HandS_Hearts.Caption = S_Hearts
0212 Forms!Bridge!HandS_Diamonds.Caption = S_Diamonds
0213 Forms!Bridge!HandS_Clubs.Caption = S_Clubs
0214 End If
0215Next i
0216'Print West Hand
0217For i = 1 To 52
0218 If Card(i, 1) = 4 Then
0219 If i < 14 Then
0220 W_Spades = W_Spades & Card_Name(i) & " "
0221 Else
0222 If i < 27 Then
0223 W_Hearts = W_Hearts & Card_Name(i - 13) & " "
0224 Else
0225 If i < 40 Then
0226 W_Diamonds = W_Diamonds & Card_Name(i - 26) & " "
0227 Else
0228 W_Clubs = W_Clubs & Card_Name(i - 39) & " "
0229 End If
0230 End If
0231 End If
0232 Forms!Bridge!HandW_Spades.Caption = W_Spades
0233 Forms!Bridge!HandW_Hearts.Caption = W_Hearts
0234 Forms!Bridge!HandW_Diamonds.Caption = W_Diamonds
0235 Forms!Bridge!HandW_Clubs.Caption = W_Clubs
0236 End If
0237Next i
0238End Sub

Procedures Calling This Procedure (Hand_Deal) Procedures Called By This Procedure (Hand_Deal) Tables / Queries / Fragments Directly Used By This Procedure (Hand_Deal) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page



Source Code of: Hand_Save
Procedure Type: Public Sub
Module: HandDealing
Lines of Code: 35
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Hand_Save()
0002Dim rsTableControl As Recordset
0003'Add Database Record
0004 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Hands.* FROM Hands WHERE Hands.N_Distribution = """";")
0005rsTableControl.AddNew
0006rsTableControl.Fields(1) = N_Spades
0007rsTableControl.Fields(2) = N_Hearts
0008rsTableControl.Fields(3) = N_Clubs
0009rsTableControl.Fields(4) = N_Diamonds
0010rsTableControl.Fields(5) = E_Spades
0011rsTableControl.Fields(6) = E_Hearts
0012rsTableControl.Fields(7) = E_Clubs
0013rsTableControl.Fields(8) = E_Diamonds
0014rsTableControl.Fields(9) = S_Spades
0015rsTableControl.Fields(10) = S_Hearts
0016rsTableControl.Fields(11) = S_Clubs
0017rsTableControl.Fields(12) = S_Diamonds
0018rsTableControl.Fields(13) = W_Spades
0019rsTableControl.Fields(14) = W_Hearts
0020rsTableControl.Fields(15) = W_Clubs
0021rsTableControl.Fields(16) = W_Diamonds
0022rsTableControl.Fields(17) = N_Points
0023rsTableControl.Fields(18) = E_Points
0024rsTableControl.Fields(19) = S_Points
0025rsTableControl.Fields(20) = W_Points
0026rsTableControl.Fields(21) = N_Distribution
0027rsTableControl.Fields(22) = E_Distribution
0028rsTableControl.Fields(23) = S_Distribution
0029rsTableControl.Fields(24) = W_Distribution
0030rsTableControl.Fields(31) = N_Distribution_Long
0031rsTableControl.Fields(32) = E_Distribution_Long
0032rsTableControl.Fields(33) = S_Distribution_Long
0033rsTableControl.Fields(34) = W_Distribution_Long
0034rsTableControl.Update
0035End Sub

Procedures Calling This Procedure (Hand_Save) Tables / Queries / Fragments Directly Used By This Procedure (Hand_Save) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page



Source Code of: Handicap_Calculation
Procedure Type: Public Sub
Module: ScorebridgeConvertion
Lines of Code: 93
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Handicap_Calculation()
0002Dim rsTableControl As Recordset
0003Dim rsTableControl2 As Recordset
0004Dim iYear As Integer
0005Dim iYear_Read As Integer
0006Dim Player As String
0007Dim Player_Saved As String
0008Dim Handicap As Single
0009Dim Handicap_Found As Boolean
0010Dim Ready As Boolean
0011Dim iQualifyingSessions As Integer
0012Dim iSessions_Read As Integer
0013Dim Percentage As Single
0014Dim Percentage_Total As Single
0015Dim iSessions_Total As Integer
0016iYear = Year(Now())
0017Handicap_Found = False
0018iQualifyingSessions = 10
0019Player_Saved = ""
0020Ready = False
0021If MsgBox("Recalculate and Export Hutton Handicaps for " & iYear & "?", vbYesNo) = vbNo Then
0022 Exit Sub
0023End If
0024 DoCmd.RunSQL ("DELETE Handicaps.* FROM Handicaps WHERE Handicaps.Year = " & iYear & ";")
0025 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Handicaps.* FROM Handicaps WHERE Handicaps.Club = """";")
0026 Set rsTableControl2 = CurrentDb.OpenRecordset("SELECT Player_Stats.Player, Player_Stats.Year, Player_Stats.Sessions, Player_Stats.[Average %age] FROM Player_Stats WHERE (((Player_Stats.Club) = ""Hutton"") And ((Player_Stats.Year) < " & iYear & ")) ORDER BY Player_Stats.Player, Player_Stats.Year DESC; ")
0027rsTableControl2.MoveFirst
0028Do While Not rsTableControl2.EOF
0029 Player = rsTableControl2.Fields(0)
0030 iYear_Read = rsTableControl2.Fields(1)
0031 iSessions_Read = rsTableControl2.Fields(2)
0032 Percentage = rsTableControl2.Fields(3)
0033 If Player = Player_Saved Then
0034 If Handicap_Found = True Then
0035 'Just ignore record
0036 Else
0037 If iSessions_Read > iQualifyingSessions - iSessions_Total + 1 Then
0038 Percentage_Total = Percentage_Total + Percentage * (iQualifyingSessions - iSessions_Total)
0039 iSessions_Total = iQualifyingSessions
0040 Else
0041 iSessions_Total = iSessions_Total + iSessions_Read
0042 Percentage_Total = Percentage_Total + Percentage * iSessions_Read
0043 End If
0044 End If
0045 Else
0046 If Handicap_Found = False And Player_Saved <> "" Then
0047 Percentage_Total = Percentage_Total + 55 * (iQualifyingSessions - iSessions_Total)
0048 iSessions_Total = iQualifyingSessions
0049 Handicap = 50 - (Percentage_Total / iSessions_Total)
0050 rsTableControl.AddNew
0051 rsTableControl.Fields(0) = "Hutton"
0052 rsTableControl.Fields(1) = Player_Saved
0053 rsTableControl.Fields(2) = iYear
0054 rsTableControl.Fields(3) = Handicap
0055 rsTableControl.Update
0056 End If
0057 iSessions_Total = iSessions_Read
0058 Percentage_Total = Percentage * iSessions_Read
0059 Ready = False
0060 Handicap_Found = False
0061 End If
0062 If Ready = False Then
0063 If iSessions_Total > iQualifyingSessions - 1 Then
0064 Handicap = 50 - (Percentage_Total / iSessions_Total)
0065 Ready = True
0066 Handicap_Found = True
0067 rsTableControl.AddNew
0068 rsTableControl.Fields(0) = "Hutton"
0069 rsTableControl.Fields(1) = Player
0070 rsTableControl.Fields(2) = iYear
0071 rsTableControl.Fields(3) = Handicap
0072 rsTableControl.Update
0073 End If
0074 End If
0075 Player_Saved = Player
0076 rsTableControl2.MoveNext
0077Loop
0078'Finish last player ...
0079If Handicap_Found = False Then
0080 Percentage_Total = Percentage_Total + 55 * (iQualifyingSessions - iSessions_Total)
0081 iSessions_Total = iQualifyingSessions
0082 Handicap = 50 - (Percentage_Total / iSessions_Total)
0083 rsTableControl.AddNew
0084 rsTableControl.Fields(0) = "Hutton"
0085 rsTableControl.Fields(1) = Player_Saved
0086 rsTableControl.Fields(2) = iYear
0087 rsTableControl.Fields(3) = Handicap
0088 rsTableControl.Update
0089End If
0090Set rsTableControl = Nothing
0091Set rsTableControl2 = Nothing
0092MsgBox ("Hutton Handicaps for " & iYear & " Recalculated and Exported OK.")
0093End Sub

Procedures Calling This Procedure (Handicap_Calculation) Tables / Queries / Fragments Directly Used By This Procedure (Handicap_Calculation) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page



© Theo Todman, June 2007 - December 2019 Please address any comments on this page to theo@theotodman.com. File output:
Website Maintenance Dashboard
Return to Top of this Page Return to Theo Todman's Bridge Page Return to Theo Todman's Home Page