Form1.frm.VisualBasicSourceCode.c

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "TittyMemory"
   ClientHeight    =   5010
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6930
   Icon            =   "Form1.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   ScaleHeight     =   5010
   ScaleWidth      =   6930
   StartUpPosition =   3  'Windows Default
   Begin VB.Timer Timer2 
      Interval        =   200
      Left            =   5760
      Top             =   120
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Settings"
      Height          =   375
      Left            =   1320
      TabIndex        =   3
      Top             =   120
      Width           =   1095
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   200
      Left            =   3720
      Top             =   120
   End
   Begin VB.PictureBox Picture1 
      Height          =   4095
      Left            =   120
      ScaleHeight     =   4035
      ScaleWidth      =   6675
      TabIndex        =   1
      Top             =   840
      Width           =   6735
   End
   Begin VB.CommandButton Command1 
      Caption         =   "New Game"
      Height          =   375
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   1095
   End
   Begin VB.Image Image2 
      Height          =   615
      Left            =   4920
      Picture         =   "Form1.frx":0442
      Top             =   120
      Visible         =   0   'False
      Width           =   780
   End
   Begin VB.Label Label2 
      Caption         =   "Time:"
      Height          =   255
      Left            =   2520
      TabIndex        =   2
      Top             =   120
      Visible         =   0   'False
      Width           =   975
   End
   Begin VB.Image Image1 
      Height          =   495
      Left            =   4320
      Top             =   120
      Visible         =   0   'False
      Width           =   495
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim square() As MemoCard
Dim initOK As Boolean
Dim firstClick As Boolean
Public cardName As String
Public deckName As String
Public squareMaxX As Long
Public squareMaxY As Long
Public attempts As Long
Public elapsedTime As Long
Public dirty As Boolean
Dim startTime As Single
Dim mutexNewGame As Boolean

Private Sub Command1_Click()
    mutexNewGame = True
    firstClick = False
    newGame
    mutexNewGame = False
End Sub

Private Sub Command2_Click()
    Dim oldCardName As String
    Dim oldDeckName As String
    Dim oldMaxX As Long
    Dim oldMaxY As Long
    oldCardName = cardName
    oldDeckName = deckName
    oldMaxX = squareMaxX
    oldMaxY = squareMaxY
    If Not (mutexNewGame) Then
        Dialog.Show vbModal, Me
        DoEvents
        If (oldCardName <> cardName) Then
            Picture1.Cls
            dirty = True
            Command1_Click
        ElseIf (oldMaxX <> squareMaxX Or oldMaxY <> squareMaxY) Then
            Picture1.Cls
            dirty = True
            Command1_Click
        ElseIf (oldDeckName <> deckName) Then
            Image1.Picture = getPic(deckName, -1)
        End If
    End If
    Me.Refresh
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If (KeyCode = vbKeyF5) Then
        Form_Resize
        KeyCode = 0
    End If
End Sub

Private Sub Form_Load()
    cardName = "cardPussy"
    deckName = "deckAcorn"
    squareMaxX = 4
    squareMaxY = 4
    dirty = True
End Sub

Sub newGame()
    initOK = False
    If dirty Then
        ReDim square(squareMaxX, squareMaxY)
        makeSquare
        dirty = False
    End If
    initGame
End Sub

Sub initGame()
    clearSquare
    randomizeSquare
    rePosSquare
    drawSquare
    initOK = True
    startTime = Timer
    attempts = 0
    elapsedTime = 0
    Timer1.Enabled = True
End Sub

Sub clearSquare()
    Dim x As Long
    Dim y As Long
    For x = 0 To UBound(square, 1) - 1
        For y = 0 To UBound(square, 2) - 1
            square(x, y).isFound = False
            square(x, y).isOpen = False
        Next y
    Next x
End Sub

Sub makeSquare()
    Dim x As Long
    Dim y As Long
    Dim i As Long
    Dim picCount As Long
    If Not (FormProgress.Visible) Then FormProgress.Show
    FormProgress.setMax (UBound(square, 1) * UBound(square, 2)) / 2
    For x = 0 To UBound(square, 1) - 1
        For y = 0 To UBound(square, 2) - 1
            Set square(x, y) = New MemoCard
            If (i Mod 2 = 0) Then
                Image1.Picture = getPic(cardName, picCount)
                If (Image1.Picture = 0) Then
                    cardName = "(select new)"
                    If Not (Dialog.Visible) Then Dialog.Show vbModal, Me
                    Image1.Picture = getPic(cardName, picCount)
                End If
                picCount = picCount + 1
                FormProgress.update picCount
            End If
            Set square(x, y).pic = Image1.Picture
            square(x, y).fName = cardName & picCount
            i = i + 1
            DoEvents
        Next y
    Next x
    Image1.Picture = getPic(deckName, -1)
    If (Image1.Picture = 0) Then
        deckName = "(select new)"
        If Not (Dialog.Visible) Then Dialog.Show vbModal, Me
        Image1.Picture = getPic(deckName, -1)
    End If
    Unload FormProgress
End Sub

Function getPic(fName As String, Optional count As Long) As IPictureDisp
    On Error GoTo Hell
    Dim path As String
    If (count = -1) Then
        path = App.path & "\pics\" & fName & ".jpg"
    Else
        path = App.path & "\pics\" & fName & Format(count, "00") & ".jpg"
    End If
    If (Dir(path) = "") Then
        MsgBox "Cannot find file: " & vbNewLine & _
                path & vbNewLine & _
                "Please read the 'ReadMe.txt' file.", _
                vbCritical, "TittyMemory"
        Set getPic = Nothing
    Else
        Set getPic = LoadPicture(path)
    End If
    Exit Function
Hell:
    MsgBox "Error while loading file: " & vbNewLine & _
            path & vbNewLine & _
            "Please read the 'ReadMe.txt' file.", _
            vbCritical, "TittyMemory"
    Unload Me
End Function

Sub randomizeSquare()
    Dim swap As New MemoCard
    Dim x1 As Long
    Dim y1 As Long
    Dim x2 As Long
    Dim y2 As Long
    Dim i As Long
    Dim maxX As Long
    Dim maxY As Long
    maxX = UBound(square, 1) - 1
    maxY = UBound(square, 2) - 1
    Randomize
    For i = 1 To (maxX * maxY)
        x1 = Rnd() * maxX
        y1 = Rnd() * maxY
        x2 = Rnd() * maxX
        y2 = Rnd() * maxY
        Set swap = square(x1, y1)
        Set square(x1, y1) = square(x2, y2)
        Set square(x2, y2) = swap
    Next i
End Sub

Sub drawSquare()
    Dim x As Long
    Dim y As Long
    Picture1.Cls
    For x = 0 To UBound(square, 1) - 1
        For y = 0 To UBound(square, 2) - 1
            drawPic x, y
        Next y
    Next x
End Sub

Sub drawPic(x As Long, y As Long)
    Dim w As Long
    Dim h As Long
    w = square(x, y).x2 - square(x, y).x1
    h = square(x, y).y2 - square(x, y).y1
    If (w < 50 Or h < 50) Then Exit Sub
    If (square(x, y).isFound Or square(x, y).isOpen) Then
        If (square(x, y).pic <> 0) Then
            Picture1.PaintPicture square(x, y).pic, _
                square(x, y).x1, square(x, y).y1, _
                w, h
        Else
            Picture1.PaintPicture Image2.Picture, _
                square(x, y).x1, square(x, y).y1, _
                w, h
        End If
    Else
        If (Image1.Picture <> 0) Then
            Picture1.PaintPicture Image1.Picture, _
                square(x, y).x1, square(x, y).y1, _
                w, h
        Else
            Picture1.PaintPicture Image2.Picture, _
                square(x, y).x1, square(x, y).y1, _
                w, h
        End If
    End If
End Sub

Sub rePosSquare()
    Dim x As Long
    Dim y As Long
    Dim w As Long
    Dim h As Long
    Dim distX As Long
    Dim distY As Long
    w = Picture1.Width
    h = Picture1.Height
    distX = w / (UBound(square, 1))
    distY = h / (UBound(square, 2))
    For x = 0 To UBound(square, 1) - 1
        For y = 0 To UBound(square, 2) - 1
            square(x, y).x1 = x * distX + 30
            square(x, y).y1 = y * distY + 30
            square(x, y).x2 = x * distX + distX - 100
            square(x, y).y2 = y * distY + distY - 100
        Next y
    Next x
End Sub

Private Sub Form_Paint()
    If (initOK) Then
        drawSquare
    End If
End Sub

Private Sub Form_Resize()
    If (WindowState <> vbMinimized) Then
        Picture1.Left = ScaleLeft
        Picture1.Top = Command1.Top + Command1.Height + 100
        Picture1.Width = ScaleWidth
        If (ScaleHeight > Picture1.Top) Then
            Picture1.Height = ScaleHeight - Picture1.Top
        End If
        If (initOK) Then
            rePosSquare
            drawSquare
        End If
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim f As Form
    For Each f In Forms
        Unload f
    Next f
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim cardX As Long
    Dim cardY As Long
    If (initOK) Then
        For cardX = 0 To UBound(square, 1) - 1
            For cardY = 0 To UBound(square, 2) - 1
                If ((x > square(cardX, cardY).x1) And _
                     (x < square(cardX, cardY).x2) And _
                     (y > square(cardX, cardY).y1) And _
                     (y < square(cardX, cardY).y2)) Then
                    checkCardClick cardX, cardY
                End If
            Next cardY
        Next cardX
    End If
End Sub

Sub checkCardClick(x As Long, y As Long)
    Static lastCardX As Long
    Static lastCardY As Long
    Dim time1 As Single
    If ((square(x, y).isFound) Or (square(x, y).isOpen)) Then
        Exit Sub
    Else
        attempts = attempts + 1
    End If
    If (firstClick) Then
        firstClick = False
        square(x, y).isOpen = True
        If (square(x, y).fName = square(lastCardX, lastCardY).fName) Then
            square(x, y).isFound = True
            square(lastCardX, lastCardY).isFound = True
            drawPic x, y
            checkGameOver
        Else
            drawPic x, y
            time1 = Timer
            Do
                '
            Loop While (Timer < time1 + 1)
            square(x, y).isOpen = False
            square(lastCardX, lastCardY).isOpen = False
            drawPic x, y
            drawPic lastCardX, lastCardY
        End If
    Else
        firstClick = True
        square(x, y).isOpen = True
        lastCardX = x
        lastCardY = y
        drawPic x, y
    End If
End Sub

Private Sub Timer1_Timer()
    Static lastTime As Single
    If (Timer > lastTime + 1) Then
        Label2.Caption = "Time: " & _
                    Format(lastTime - startTime, "00")
        elapsedTime = elapsedTime + 1
        lastTime = Timer
    End If
End Sub

Private Sub Timer2_Timer()
    Static lastBottom As Long
    If (Form1.Top + Form1.Height < lastBottom) Then
        lastBottom = Form1.Top + Form1.Height
        Form_Paint
    End If
    If (Form1.Top + Form1.Height > Screen.Height - 1000) Then
        lastBottom = Form1.Top + Form1.Height
    End If
End Sub

Sub checkGameOver()
    Dim x As Long
    Dim y As Long
    Dim res As VbMsgBoxResult
    For x = 0 To UBound(square, 1) - 1
        For y = 0 To UBound(square, 2) - 1
            If (square(x, y).isFound = False) Then Exit Sub
        Next y
    Next x
    Timer1.Enabled = False
    If Not (Dialog1.Visible) Then
        Dialog1.Show vbModal, Me
    End If
End Sub

Public Sub redraw()
    Form_Paint
End Sub

---