home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / VB_Same_Ga2075587152007.psc / FGAME.frm < prev    next >
Text File  |  2007-07-15  |  12KB  |  400 lines
  1. VERSION 5.00
  2. Begin VB.Form FGAME 
  3.    BorderStyle     =   1  'Fixed Single
  4.    Caption         =   "VBSame Game"
  5.    ClientHeight    =   5295
  6.    ClientLeft      =   150
  7.    ClientTop       =   540
  8.    ClientWidth     =   5535
  9.    LinkTopic       =   "Form1"
  10.    MaxButton       =   0   'False
  11.    ScaleHeight     =   5295
  12.    ScaleWidth      =   5535
  13.    StartUpPosition =   2  'CenterScreen
  14.    Begin VB.PictureBox Picture1 
  15.       Align           =   2  'Align Bottom
  16.       BackColor       =   &H80000010&
  17.       BorderStyle     =   0  'None
  18.       Height          =   345
  19.       Left            =   0
  20.       ScaleHeight     =   345
  21.       ScaleWidth      =   5535
  22.       TabIndex        =   3
  23.       Top             =   4950
  24.       Width           =   5535
  25.       Begin VB.Label Label3 
  26.          Alignment       =   2  'Center
  27.          AutoSize        =   -1  'True
  28.          BackStyle       =   0  'Transparent
  29.          Caption         =   "Label3"
  30.          ForeColor       =   &H00000000&
  31.          Height          =   195
  32.          Left            =   2565
  33.          TabIndex        =   6
  34.          Top             =   75
  35.          Width           =   480
  36.       End
  37.       Begin VB.Label Label2 
  38.          AutoSize        =   -1  'True
  39.          BackStyle       =   0  'Transparent
  40.          Caption         =   "Label2"
  41.          ForeColor       =   &H00000000&
  42.          Height          =   195
  43.          Left            =   75
  44.          TabIndex        =   5
  45.          Top             =   75
  46.          Width           =   480
  47.       End
  48.       Begin VB.Label Label4 
  49.          Alignment       =   1  'Right Justify
  50.          AutoSize        =   -1  'True
  51.          BackStyle       =   0  'Transparent
  52.          Caption         =   "Label4"
  53.          ForeColor       =   &H00000000&
  54.          Height          =   195
  55.          Left            =   4950
  56.          TabIndex        =   4
  57.          Top             =   75
  58.          Width           =   480
  59.       End
  60.    End
  61.    Begin VB.PictureBox PT 
  62.       Appearance      =   0  'Flat
  63.       AutoRedraw      =   -1  'True
  64.       BackColor       =   &H00000000&
  65.       BorderStyle     =   0  'None
  66.       DrawWidth       =   3
  67.       FillColor       =   &H00FFFFFF&
  68.       FillStyle       =   0  'Solid
  69.       ForeColor       =   &H00000000&
  70.       Height          =   4815
  71.       Left            =   5700
  72.       ScaleHeight     =   321
  73.       ScaleMode       =   3  'Pixel
  74.       ScaleWidth      =   321
  75.       TabIndex        =   1
  76.       Top             =   75
  77.       Width           =   4815
  78.    End
  79.    Begin VB.PictureBox P 
  80.       Appearance      =   0  'Flat
  81.       AutoRedraw      =   -1  'True
  82.       BackColor       =   &H00808080&
  83.       BorderStyle     =   0  'None
  84.       BeginProperty Font 
  85.          Name            =   "Palatino Linotype"
  86.          Size            =   12
  87.          Charset         =   0
  88.          Weight          =   700
  89.          Underline       =   0   'False
  90.          Italic          =   0   'False
  91.          Strikethrough   =   0   'False
  92.       EndProperty
  93.       ForeColor       =   &H80000008&
  94.       Height          =   4815
  95.       Left            =   75
  96.       ScaleHeight     =   321
  97.       ScaleMode       =   3  'Pixel
  98.       ScaleWidth      =   321
  99.       TabIndex        =   0
  100.       Top             =   75
  101.       Width           =   4815
  102.       Begin VB.Image IMG 
  103.          Height          =   480
  104.          Index           =   0
  105.          Left            =   75
  106.          Picture         =   "FGAME.frx":0000
  107.          Top             =   75
  108.          Visible         =   0   'False
  109.          Width           =   480
  110.       End
  111.       Begin VB.Image IMG 
  112.          Height          =   480
  113.          Index           =   3
  114.          Left            =   75
  115.          Picture         =   "FGAME.frx":0C42
  116.          Top             =   1650
  117.          Visible         =   0   'False
  118.          Width           =   480
  119.       End
  120.       Begin VB.Image IMG 
  121.          Height          =   480
  122.          Index           =   4
  123.          Left            =   75
  124.          Picture         =   "FGAME.frx":1884
  125.          Top             =   2175
  126.          Visible         =   0   'False
  127.          Width           =   480
  128.       End
  129.       Begin VB.Image IMG 
  130.          Height          =   480
  131.          Index           =   5
  132.          Left            =   75
  133.          Picture         =   "FGAME.frx":24C6
  134.          Top             =   2700
  135.          Visible         =   0   'False
  136.          Width           =   480
  137.       End
  138.       Begin VB.Image IMG 
  139.          Height          =   480
  140.          Index           =   2
  141.          Left            =   75
  142.          Picture         =   "FGAME.frx":3108
  143.          Top             =   1125
  144.          Visible         =   0   'False
  145.          Width           =   480
  146.       End
  147.       Begin VB.Image IMG 
  148.          Height          =   480
  149.          Index           =   1
  150.          Left            =   75
  151.          Picture         =   "FGAME.frx":3D4A
  152.          Top             =   600
  153.          Visible         =   0   'False
  154.          Width           =   480
  155.       End
  156.       Begin VB.Image IMG 
  157.          Height          =   480
  158.          Index           =   6
  159.          Left            =   75
  160.          Picture         =   "FGAME.frx":498C
  161.          Top             =   3225
  162.          Visible         =   0   'False
  163.          Width           =   480
  164.       End
  165.    End
  166.    Begin VB.Label Label1 
  167.       AutoSize        =   -1  'True
  168.       BackStyle       =   0  'Transparent
  169.       Caption         =   "Info:"
  170.       Height          =   195
  171.       Left            =   4950
  172.       TabIndex        =   2
  173.       Top             =   75
  174.       Width           =   315
  175.    End
  176.    Begin VB.Menu mnuGame 
  177.       Caption         =   "Game"
  178.       Begin VB.Menu mgNEW 
  179.          Caption         =   "New Game"
  180.       End
  181.       Begin VB.Menu mgRES 
  182.          Caption         =   "Restart Game"
  183.       End
  184.       Begin VB.Menu mgLET 
  185.          Caption         =   "Letters"
  186.       End
  187.    End
  188. End
  189. Attribute VB_Name = "FGAME"
  190. Attribute VB_GlobalNameSpace = False
  191. Attribute VB_Creatable = False
  192. Attribute VB_PredeclaredId = True
  193. Attribute VB_Exposed = False
  194. Private Declare Function ExtFloodFill Lib "GDI32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal colorCode As Long, ByVal fillType As Long) As Long
  195.  
  196. Public LEV As String
  197. Public FLev As String
  198. Public fx As Single, fy As Single
  199. Public SelCount
  200. Public TotalP As Double
  201. Public NOL
  202.  
  203. Private Sub Form_Load()
  204. NOL = 3
  205. NewLev
  206. End Sub
  207.  
  208. Function GetColor(ByVal n As Integer) As Long
  209. Select Case n
  210. Case 1: GetColor = vbRed
  211. Case 2: GetColor = vbYellow
  212. Case 3: GetColor = vbGreen
  213. Case 4: GetColor = vbCyan
  214. Case 5: GetColor = vbBlue
  215. Case 6: GetColor = vbMagenta
  216. End Select
  217. End Function
  218.  
  219. Private Sub ResLev()
  220. On Error Resume Next
  221. TotalP = 0
  222. SelCount = 0
  223. fx = -1
  224. fy = -1
  225. LEV = FLev
  226. P.Enabled = True
  227. PN
  228. End Sub
  229.  
  230. Private Sub NewLev()
  231. On Error Resume Next
  232. TotalP = 0
  233. SelCount = 0
  234. fx = -1
  235. fy = -1
  236. Randomize
  237. FLev = ""
  238. For X = 0 To 9
  239. For Y = 9 To 0 Step -1
  240. Randomize
  241. FLev = FLev & "|" & Int(1 + (Rnd * NOL)) & "," & X & "," & Y
  242. Next Y
  243. Next X
  244. LEV = FLev
  245. P.Enabled = True
  246. PN
  247. End Sub
  248.  
  249. Private Sub GetInfo()
  250. Dim gi() As String
  251. Label1.Caption = "Info:"
  252. For i = 1 To NOL
  253. gi = Split("|" & LEV, "|" & i & ",")
  254. Label1.Caption = Label1.Caption & vbCrLf & UCase(Chr(96 + i)) & " = " & UBound(gi)
  255. Next i
  256. End Sub
  257.  
  258. Private Sub PN(Optional ByVal dx As Double = -1, Optional ByVal dy As Double = -1)
  259. On Error Resume Next
  260. Dim f() As String
  261. Dim g() As String
  262. Dim Col As Long
  263. Dim ADX As Single
  264. Dim ADY As Single
  265. Dim SMX As Integer
  266. Dim cx As Single
  267. f = Split(LEV, "|")
  268. P.Cls
  269. PT.Cls
  270. ADX = 0
  271. cx = 0
  272. SMX = -1
  273. For i = 1 To UBound(f)
  274. g = Split(f(i), ",")
  275. If cx = 10 Then
  276.     If Val(g(1)) <> SMX Then
  277.         ADX = ADX + 1
  278.     End If
  279. End If
  280. If Val(g(1)) <> SMX Then ADY = 0: SMX = Val(g(1)): cx = 0
  281. If Val(g(0)) = 0 Then
  282. ADY = ADY + 1
  283. cx = cx + 1
  284. Else
  285. Col = GetColor(Val(g(0)))
  286. g(1) = (Val(g(1)) - ADX)
  287. g(2) = (Val(g(2)) + ADY)
  288. PT.Line (Val(g(1)) * 32, 16 + Val(g(2)) * 32)-(32 + Val(g(1)) * 32, 16 + Val(g(2)) * 32), Col
  289. PT.Line (16 + Val(g(1)) * 32, Val(g(2)) * 32)-(16 + Val(g(1)) * 32, 32 + Val(g(2)) * 32), Col
  290. End If
  291. Next i
  292. PT.FillStyle = 1
  293. PT.Line (0, 0)-(PT.ScaleWidth - 1, PT.ScaleHeight - 1), vbBlack, B
  294. PT.FillStyle = 0
  295. If dx <> -1 And (dy) <> -1 Then ExtFloodFill PT.hDC, (dx * 32) + 16, ((dy) * 32) + 16, PT.Point((dx * 32) + 16, ((dy) * 32) + 16), 1
  296.  
  297. SelCount = 0
  298. numlets = 0
  299. ADX = 0
  300. cx = 0
  301. SMX = -1
  302. For i = 1 To UBound(f)
  303. g = Split(f(i), ",")
  304. If cx = 10 Then
  305.     If Val(g(1)) <> SMX Then
  306.         ADX = ADX + 1
  307.     End If
  308. End If
  309. If Val(g(1)) <> SMX Then ADY = 0: SMX = Val(g(1)): cx = 0
  310. If Val(g(0)) = 0 Then
  311. ADY = ADY + 1
  312. cx = cx + 1
  313. Else
  314. numlets = 1
  315. g(1) = (Val(g(1)) - ADX)
  316. g(2) = (Val(g(2)) + ADY)
  317. Col = IIf(Int(PT.Point((Val(g(1)) * 32) + 16, (Val(g(2)) * 32) + 16)) = Int(vbWhite), 6, Val(g(0)) - 1)
  318. SelCount = SelCount + IIf(PT.Point((Val(g(1)) * 32) + 16, (Val(g(2)) * 32) + 16) = vbWhite, 1, 0)
  319. P.PaintPicture IMG(Col), Val(g(1)) * 32, Val(g(2)) * 32
  320. P.Line (Val(g(1)) * 32, Val(g(2)) * 32)-(32 + Val(g(1)) * 32, 32 + Val(g(2)) * 32), vbBlack, B
  321. P.CurrentX = ((Val(g(1)) * 32 + 16) - P.TextWidth(Val(g(1))) / 2) - 2
  322. P.CurrentY = ((Val(g(2)) * 32 + 16) - P.TextHeight(Val(g(2))) / 2) - 1
  323. P.Print UCase(Chr(96 + Val(g(0))))
  324. End If
  325. Next i
  326. P.Line (0, 0)-(P.ScaleWidth - 1, P.ScaleHeight - 1), vbBlack, B
  327. If numlets = 0 Then MsgBox "Good Job! You get an extra 500 Points for clearing the screen!": TotalP = TotalP + 500: P.Enabled = False
  328. If SelCount = 1 Then
  329. If fx <> -1 Then
  330. If fx <> -1 Then
  331. fx = -1
  332. fy = -1
  333. PN
  334. End If
  335. End If
  336. End If
  337. Label2.Caption = "Selected: " & SelCount
  338. Label3.Caption = "Points: " & (SelCount ^ 2)
  339. Label4.Caption = "Score: " & TotalP
  340. GetInfo
  341. End Sub
  342.  
  343.  
  344. Private Sub mgLet_Click()
  345. f = Int(Val(InputBox("How many letters?", "Letters?")))
  346. If f <> "" Then NOL = IIf(IIf(Int(Val(f)) > 6, 6, Int(Val(f))) < 2, 2, IIf(Int(Val(f)) > 6, 6, Int(Val(f)))): NewLev
  347. End Sub
  348.  
  349. Private Sub mgNEW_Click()
  350. NewLev
  351. End Sub
  352.  
  353. Private Sub mgRes_Click()
  354. ResLev
  355. End Sub
  356.  
  357. Private Sub P_DblClick()
  358. On Error Resume Next
  359. If fx = -1 Then Exit Sub
  360. Dim g() As String
  361. Dim f() As String
  362. Dim h As String
  363. Dim j As String
  364. Dim SMX As Single
  365. Dim ADY As Single
  366. Dim ADX As Single
  367. Dim cx As Single
  368. f = Split(LEV, "|")
  369. h = ""
  370. ADX = 0
  371. cx = 0
  372. For i = 1 To UBound(f)
  373. g = Split(f(i), ",")
  374. If cx = 10 Then
  375.     If Val(g(1)) <> Val(SMX) Then
  376.         ADX = ADX + 1
  377.         cx = 0
  378.     End If
  379. End If
  380. If Val(g(1)) <> Val(SMX) Then ADY = 0: SMX = Val(g(1)): cx = 0
  381. If Val(g(0)) = 0 Then ADY = ADY + 1: cx = cx + 1
  382. j = IIf(Int(PT.Point(((Val(g(1)) - ADX) * 32) + 16, ((Val(g(2)) + ADY) * 32) + 16)) = Int(vbWhite), "|0," & g(1) & "," & g(2), "|" & g(0) & "," & g(1) & "," & g(2))
  383. h = h & j
  384. Next i
  385. LEV = h
  386. TotalP = TotalP + (SelCount ^ 2)
  387. GetInfo
  388. fx = -1
  389. fy = -1
  390. PN
  391. End Sub
  392.  
  393. Private Sub P_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  394. If Int(PT.Point(16 + Int((IIf(X < 1, 1, X) - 1) / 32) * 32, 16 + Int((IIf(Y < 1, 1, Y) - 1) / 32) * 32)) = Int(vbWhite) Then P_DblClick: Exit Sub
  395. If Int(PT.Point(16 + Int((IIf(X < 1, 1, X) - 1) / 32) * 32, 16 + Int((IIf(Y < 1, 1, Y) - 1) / 32) * 32)) = Int(vbBlack) Then fx = -1: fy = -1: PN: Exit Sub
  396. fx = Int((IIf(X < 1, 1, X) - 1) / 32)
  397. fy = Int((IIf(Y < 1, 1, Y) - 1) / 32)
  398. PN fx, fy
  399. End Sub
  400.