00001 VERSION 5.00
00002 Begin VB.Form Dialog1
00003 BorderStyle = 3 'Fixed Dialog
00004 Caption = "TittyMemory Hiscore"
00005 ClientHeight = 6225
00006 ClientLeft = 2760
00007 ClientTop = 3750
00008 ClientWidth = 4410
00009 Icon = "Dialog1.frx":0000
00010 LinkTopic = "Form1"
00011 MaxButton = 0 'False
00012 MinButton = 0 'False
00013 ScaleHeight = 6225
00014 ScaleWidth = 4410
00015 ShowInTaskbar = 0 'False
00016 StartUpPosition = 1 'CenterOwner
00017 Begin VB.TextBox Text1
00018 BeginProperty Font
00019 Name = "Courier New"
00020 Size = 8.25
00021 Charset = 0
00022 Weight = 400
00023 Underline = 0 'False
00024 Italic = 0 'False
00025 Strikethrough = 0 'False
00026 EndProperty
00027 Height = 285
00028 Left = 1440
00029 MaxLength = 12
00030 TabIndex = 1
00031 Top = 5880
00032 Visible = 0 'False
00033 Width = 1455
00034 End
00035 Begin VB.CommandButton OKButton
00036 Caption = "OK"
00037 Default = -1 'True
00038 BeginProperty Font
00039 Name = "Courier New"
00040 Size = 8.25
00041 Charset = 0
00042 Weight = 400
00043 Underline = 0 'False
00044 Italic = 0 'False
00045 Strikethrough = 0 'False
00046 EndProperty
00047 Height = 255
00048 Left = 3120
00049 TabIndex = 0
00050 Top = 5880
00051 Width = 1215
00052 End
00053 Begin VB.Label Label3
00054 Caption = "Label3"
00055 BeginProperty Font
00056 Name = "Courier New"
00057 Size = 8.25
00058 Charset = 0
00059 Weight = 400
00060 Underline = 0 'False
00061 Italic = 0 'False
00062 Strikethrough = 0 'False
00063 EndProperty
00064 Height = 255
00065 Left = 120
00066 TabIndex = 4
00067 Top = 5520
00068 Width = 4095
00069 End
00070 Begin VB.Label Label2
00071 Caption = "Enter name:"
00072 BeginProperty Font
00073 Name = "Courier New"
00074 Size = 8.25
00075 Charset = 0
00076 Weight = 400
00077 Underline = 0 'False
00078 Italic = 0 'False
00079 Strikethrough = 0 'False
00080 EndProperty
00081 Height = 255
00082 Left = 120
00083 TabIndex = 3
00084 Top = 5880
00085 Visible = 0 'False
00086 Width = 1335
00087 End
00088 Begin VB.Label Label1
00089 Caption = "Label1"
00090 BeginProperty Font
00091 Name = "Courier New"
00092 Size = 8.25
00093 Charset = 0
00094 Weight = 400
00095 Underline = 0 'False
00096 Italic = 0 'False
00097 Strikethrough = 0 'False
00098 EndProperty
00099 Height = 5295
00100 Left = 120
00101 TabIndex = 2
00102 Top = 0
00103 Width = 3375
00104 End
00105 End
00106 Attribute VB_Name = "Dialog1"
00107 Attribute VB_GlobalNameSpace = False
00108 Attribute VB_Creatable = False
00109 Attribute VB_PredeclaredId = True
00110 Attribute VB_Exposed = False
00111
00112 Option Explicit
00113
00114 Dim attempts As Long
00115 Dim elapsedTime As Long
00116 Dim insertPos As Long
00117 Dim section As Long
00118 Dim maxX As Long
00119 Dim maxY As Long
00120
00121 ' 4 x 4
00122 ' 5 x 4
00123 ' 6 x 4
00124 ' 6 x 5
00125 ' 6 x 6
00126
00127 ' name attempts time
00128 ' 1
00129 ' 2
00130 ' 3
00131
00132 Dim hiscore(3, 15) As String
00133
00134 Private Sub Form_Load()
00135 attempts = Form1.attempts
00136 elapsedTime = Form1.elapsedTime
00137 maxX = Form1.squareMaxX
00138 maxY = Form1.squareMaxY
00139 Label3.Caption = "You played: " & maxX & "x" & maxY & _
00140 " Att.: " & attempts & " Time: " & _
00141 elapsedTime
00142 loadHS
00143 checkHS
00144 displayHS
00145 End Sub
00146
00147 Sub checkHS()
00148 insertPos = 99
00149 If (maxX = 4 And maxY = 4) Then
00150 section = 0
00151 ElseIf (maxX = 5 And maxY = 4) Then
00152 section = 1
00153 ElseIf (maxX = 6 And maxY = 4) Then
00154 section = 2
00155 ElseIf (maxX = 6 And maxY = 5) Then
00156 section = 3
00157 ElseIf (maxX = 6 And maxY = 6) Then
00158 section = 4
00159 End If
00160 If (attempts = hiscore(1, section * 3 + 2)) Then
00161 If (elapsedTime <= hiscore(2, section * 3 + 2)) Then
00162 insertPos = 2
00163 End If
00164 End If
00165 If (attempts < hiscore(1, section * 3 + 2)) Then
00166 insertPos = 2
00167 End If
00168 If (attempts = hiscore(1, section * 3 + 1)) Then
00169 If (elapsedTime <= hiscore(2, section * 3 + 1)) Then
00170 insertPos = 1
00171 End If
00172 End If
00173 If (attempts < hiscore(1, section * 3 + 1)) Then
00174 insertPos = 1
00175 End If
00176 If (attempts = hiscore(1, section * 3 + 0)) Then
00177 If (elapsedTime <= hiscore(2, section * 3 + 0)) Then
00178 insertPos = 0
00179 End If
00180 End If
00181 If (attempts < hiscore(1, section * 3 + 0)) Then
00182 insertPos = 0
00183 End If
00184 If (insertPos < 99) Then
00185 Me.Visible = True
00186 Text1.Visible = True
00187 Label2.Visible = True
00188 Text1.SetFocus
00189 End If
00190 If (insertPos = 2) Then
00191 hiscore(0, section * 3 + 2) = "** NEW ENTRY **"
00192 hiscore(1, section * 3 + 2) = attempts
00193 hiscore(2, section * 3 + 2) = elapsedTime
00194 End If
00195 If (insertPos = 1) Then
00196 hiscore(0, section * 3 + 2) = hiscore(0, section * 3 + 1)
00197 hiscore(1, section * 3 + 2) = hiscore(1, section * 3 + 1)
00198 hiscore(2, section * 3 + 2) = hiscore(2, section * 3 + 1)
00199 hiscore(0, section * 3 + 1) = "** NEW ENTRY **"
00200 hiscore(1, section * 3 + 1) = attempts
00201 hiscore(2, section * 3 + 1) = elapsedTime
00202 End If
00203 If (insertPos = 0) Then
00204 hiscore(0, section * 3 + 2) = hiscore(0, section * 3 + 1)
00205 hiscore(1, section * 3 + 2) = hiscore(1, section * 3 + 1)
00206 hiscore(2, section * 3 + 2) = hiscore(2, section * 3 + 1)
00207 hiscore(0, section * 3 + 1) = hiscore(0, section * 3 + 0)
00208 hiscore(1, section * 3 + 1) = hiscore(1, section * 3 + 0)
00209 hiscore(2, section * 3 + 1) = hiscore(2, section * 3 + 0)
00210 hiscore(0, section * 3 + 0) = "** NEW ENTRY **"
00211 hiscore(1, section * 3 + 0) = attempts
00212 hiscore(2, section * 3 + 0) = elapsedTime
00213 End If
00214 End Sub
00215
00216 Sub displayHS()
00217 Dim y As Long
00218 Dim text As String
00219 For y = 0 To UBound(hiscore, 2) - 1
00220 If (y = 0) Then text = vbNewLine & text & " 4 x 4 Att. Time" & vbNewLine
00221 If (y = 3) Then text = text & vbNewLine & " 5 x 4 Att. Time" & vbNewLine
00222 If (y = 6) Then text = text & vbNewLine & " 6 x 4 Att. Time" & vbNewLine
00223 If (y = 9) Then text = text & vbNewLine & " 6 x 5 Att. Time" & vbNewLine
00224 If (y = 12) Then text = text & vbNewLine & " 6 x 6 Att. Time" & vbNewLine
00225 text = text & (y Mod 3) + 1 & Format(hiscore(0, y), "@@@@@@@@@@@@@@@@") & " " & _
00226 Format(hiscore(1, y), "0000") & " " & _
00227 Format(hiscore(2, y), "0000") & vbNewLine
00228 Next y
00229 Label1.Caption = text
00230 End Sub
00231
00232 Sub loadHS()
00233 On Error GoTo Hell
00234 Dim fNr As Long
00235 Dim fName As String
00236 Dim y As Long
00237 Dim inputName As String
00238 Dim inputAtt As String
00239 Dim inputTime As String
00240 fName = App.path & "\hiscore.dat"
00241 If (Dir(fName) = "") Then
00242 makeDefaultTable
00243 saveHS
00244 Exit Sub
00245 End If
00246 fNr = FreeFile
00247 Open fName For Input As #fNr
00248 For y = 0 To UBound(hiscore, 2) - 1
00249 Input #fNr, inputName, inputAtt, inputTime
00250 hiscore(0, y) = decodeStr(inputName, 1)
00251 hiscore(1, y) = decodeStr(inputAtt, 15)
00252 hiscore(2, y) = decodeStr(inputTime, 14)
00253 Next y
00254 Close #fNr
00255 Exit Sub
00256 Hell:
00257 MsgBox "Error loading file: 'hiscore.dat'", vbCritical, "TittyMemory"
00258 End Sub
00259
00260 Function decodeStr(str As String, key As Long) As String
00261 Dim i As Long
00262 Dim c As Long
00263 Dim res As String
00264 For i = 1 To Len(str)
00265 c = Asc(Mid$(str, i, 1))
00266 c = c - key
00267 res = res & Chr(c)
00268 Next i
00269 decodeStr = res
00270 End Function
00271
00272 Function encodeStr(str As String, key As Long) As String
00273 Dim i As Long
00274 Dim c As Long
00275 Dim res As String
00276 For i = 1 To Len(str)
00277 c = Asc(Mid$(str, i, 1))
00278 c = c + key
00279 res = res & Chr(c)
00280 Next i
00281 encodeStr = res
00282 End Function
00283
00284 Sub saveHS()
00285 On Error GoTo Hell
00286 Dim fNr As Long
00287 Dim fName As String
00288 Dim y As Long
00289 Dim encodeName As String
00290 Dim encodeAtt As String
00291 Dim encodeTime As String
00292 fName = App.path & "\hiscore.dat"
00293 fNr = FreeFile
00294 Open fName For Output As #fNr
00295 For y = 0 To UBound(hiscore, 2) - 1
00296 encodeName = encodeStr(hiscore(0, y), 1)
00297 encodeAtt = encodeStr(hiscore(1, y), 15)
00298 encodeTime = encodeStr(hiscore(2, y), 14)
00299 Write #fNr, encodeName; encodeAtt; encodeTime
00300 Next y
00301 Close #fNr
00302 Exit Sub
00303 Hell:
00304 MsgBox "Error writing file: 'hiscore.dat'", vbCritical, "TittyMemory"
00305 End Sub
00306
00307 Sub makeDefaultTable()
00308 hiscore(0, 0) = "Peter": hiscore(1, 0) = "30": hiscore(2, 0) = "44"
00309 hiscore(0, 1) = "Bob": hiscore(1, 1) = "32": hiscore(2, 1) = "56"
00310 hiscore(0, 2) = "Endrew": hiscore(1, 2) = "34": hiscore(2, 2) = "53"
00311
00312 hiscore(0, 3) = "DonPhilippe": hiscore(1, 3) = "44": hiscore(2, 3) = "62"
00313 hiscore(0, 4) = "Klaus": hiscore(1, 4) = "52": hiscore(2, 4) = "67"
00314 hiscore(0, 5) = "Irmi": hiscore(1, 5) = "54": hiscore(2, 5) = "66"
00315
00316 hiscore(0, 6) = "Boba Fet": hiscore(1, 6) = "62": hiscore(2, 6) = "86"
00317 hiscore(0, 7) = "Chewbacca": hiscore(1, 7) = "66": hiscore(2, 7) = "84"
00318 hiscore(0, 8) = "Pizza Mampf": hiscore(1, 8) = "70": hiscore(2, 8) = "97"
00319
00320 hiscore(0, 9) = "Karl": hiscore(1, 9) = "74": hiscore(2, 9) = "99"
00321 hiscore(0, 10) = "Heinz": hiscore(1, 10) = "80": hiscore(2, 10) = "102"
00322 hiscore(0, 11) = "Rummenige": hiscore(1, 11) = "84": hiscore(2, 11) = "110"
00323
00324 hiscore(0, 12) = "Meiling": hiscore(1, 12) = "90": hiscore(2, 12) = "140"
00325 hiscore(0, 13) = "Zedong": hiscore(1, 13) = "96": hiscore(2, 13) = "133"
00326 hiscore(0, 14) = "Jintao": hiscore(1, 14) = "100": hiscore(2, 14) = "154"
00327 End Sub
00328
00329 Private Sub OKButton_Click()
00330 If (Text1.Visible) Then
00331 If (Text1.text = "") Then Text1.text = "Nobody"
00332 hiscore(0, section * 3 + insertPos) = Text1.text
00333 hiscore(1, section * 3 + insertPos) = attempts
00334 hiscore(2, section * 3 + insertPos) = elapsedTime
00335 saveHS
00336 End If
00337 Unload Me
00338 Form1.redraw
00339 End Sub
00340
00341 Private Sub Text1_Change()
00342 hiscore(0, section * 3 + insertPos) = Text1.text
00343 If (Len(Text1.text) = 0) Then
00344 hiscore(0, section * 3 + insertPos) = "** NEW ENTRY **"
00345 End If
00346 displayHS
00347 End Sub
