Little Puzzle UserForm Game done in Excel/VBA

[Jaafar Tribak]

Hi all,

Workbook Example




sometime ago, I developped this little puzzle game in excel and I thought I would post it here ... Not much but it shows the power of VBA when combined with the windows API

1- Code in the UserForm :

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
        Size As Long
        Type As Long
    #If VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    #Else
        hPic As Long
        hPal As Long
    #End If
End Type


#If VBA7 Then
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Long, ByVal bErase As Long) As Long
    Private Declare PtrSafe Function MessageBeep Lib "user32" (ByVal wType As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As Long) As Long
    
    Private lFrmHwnd As LongPtr


#Else
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long
    Private Declare Function MessageBeep Lib "user32" (ByVal wType As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long


    Private lFrmHwnd As Long
#End If




Private Const PICTYPE_BITMAP = &H1
Private Const SRCCOPY = &HCC0020
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SND_ASYNC = &H1
Private Const SND_FILENAME = &H20000
Private Const SND_LOOP = &H8
Private Const SND_PURGE = &H40


'Module level variables
Private oCol As Collection
Private oPic As Object


Private bScore As Boolean
Private bExit As Boolean
Private bAbort As Boolean


Private InitialFormLeft As Single
Private InitialFormTop As Single


Private lCounter As Long
Private lTotalImageParts As Long
Private lColumns As Long
Private lRows As Long


Private sLevel As String
Private sUserName As String


Private vFileName As Variant




Private Sub UserForm_Initialize()
    sUserName = InputBox("Please, enter your name", "Player Name")
    If Len(sUserName) = 0 And StrPtr(sUserName) <> 0 Then MsgBox "You must enter a player name", vbInformation: End
    If StrPtr(sUserName) = 0 Then End
End Sub


Private Sub UserForm_Activate()
    StartUpPosition = 2
    InitialFormLeft = Me.Left
    InitialFormTop = Me.Top
    Set oPic = frameSourcePic.Picture
    lFrmHwnd = FindWindow(vbNullString, Me.Caption)
    frameSourcePic.BorderStyle = fmBorderStyleSingle
    frameSourcePic.BorderColor = vbYellow
    With Me.ComboLevel
        .AddItem "Easy  " & " (3x6 Parts)"
        .AddItem "low  " & " (3x8 Parts)"
        .AddItem "Medium  " & "(4x10 Parts)"
        .AddItem "High  " & "(6x13 Parts)"
        .ListIndex = 0
    End With
    lblTimer.Caption = ""
    CBtnAbort.Enabled = False
    Call EnableControls(True)
End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If MsgBox("Are you sure you want to quit ?", vbQuestion + vbYesNo) = vbNo Then
        Cancel = 1
        Exit Sub
    End If
    bExit = True
End Sub




'***************************************************************************************************
'Event handlers of form's controls
Private Sub ComboLevel_Change()
    Select Case True
        Case UCase(ComboLevel.Value) Like "EASY*"
            lRows = 3
            lColumns = 6
        Case UCase(ComboLevel.Value) Like "LOW*"
            lRows = 3
            lColumns = 8
        Case UCase(ComboLevel.Value) Like "MEDIUM*"
            lRows = 4
            lColumns = 10
        Case UCase(ComboLevel.Value) Like "HIGH*"
            lRows = 6
            lColumns = 13
    End Select
    sLevel = UCase(ComboLevel.Value)
End Sub


Private Sub CBtnAbort_Click()
    Call EnableControls(False)
    bAbort = True
End Sub


Private Sub CBtnClose_Click()
    Unload Me
End Sub


Private Sub CBtnNewPic_Click()
    On Error GoTo errHandler
    vFileName = Application.GetOpenFilename(FileFilter:="Picture Files (*.gif;*.jpg;*.jpeg;*.bmp),*.gif;*.jpg;*.jpeg;*.bmp", _
    Title:="Select Picture")
    If vFileName <> False Then
    frameSourcePic.Picture = LoadPicture(vFileName)
    Call DeletePreviousImages
    End If
    Exit Sub
errHandler:
    MsgBox Err.Description
End Sub


Private Sub CBtnStart_Click()
    Dim oImagePartCls As oImagePartCls
    Dim oTextBox  As msforms.TextBox
    Dim tRect As RECT
    Dim tPt1 As POINTAPI, tPt2 As POINTAPI
    Dim BasePicframeHwnd As Long
    Dim lImgPartWidth As Long, lImgPartHeight As Long
    Dim lImgPartLeft As Long, lImgPartTop As Long
    Dim lColumn As Long, lRow As Long
    Dim lControlCounter As Long
    
    bScore = False
    bAbort = False
    Call EnableControls(False)
    BasePicframeHwnd = frameSourcePic.[_GethWnd]
    GetWindowRect BasePicframeHwnd, tRect
    tPt1.x = tRect.Left
    tPt1.y = tRect.Top
    tPt2.x = tRect.Right
    tPt2.y = tRect.Bottom
    If IsFormClipped(tPt1, tPt2) Then
        Me.Move InitialFormLeft, InitialFormTop
        GetWindowRect BasePicframeHwnd, tRect
    DoEvents
    End If
    Call DeletePreviousImages
    'add the image parts controls
    Set oCol = New Collection
    For lColumn = 1 To lRows
        For lRow = 1 To lColumns
            lControlCounter = lControlCounter + 1
            Set oImagePartCls = New oImagePartCls
            Set oImagePartCls.GetForm = Me
            Set oImagePartCls.PicturePart = Controls.Add("Forms.Image.1", "Image" & lControlCounter)
            With oImagePartCls.PicturePart
                .PictureSizeMode = fmPictureSizeModeStretch
                .BorderStyle = fmBorderStyleSingle
                .BorderColor = vbYellow
                .MousePointer = fmMousePointerSizeAll
                .Width = frameSourcePic.Width / lRows
                .Height = frameSourcePic.Height / lColumns
                .Left = frameSourcePic.Left + (((lRow - 1) * (frameSourcePic.Width + 20) / lRows))
                .Top = 20 + (((lColumn - 1) * (frameSourcePic.Height + 20) / lColumns))
                .ZOrder 0
                .ControlTipText = "Drag the Picture down to its corresponding empty frame below"
            End With
            oCol.Add oImagePartCls
        Next
    Next
     'add the textbox holder controls
    lControlCounter = 0
    For lRow = 1 To lColumns
        For lColumn = 1 To lRows
            lControlCounter = lControlCounter + 1
            Set oTextBox = Controls.Add("Forms.TextBox.1", "TextBox" & lControlCounter)
            With oTextBox
                .Enabled = False
                .BackStyle = fmBackStyleTransparent
                .BorderStyle = fmBorderStyleSingle
                .SpecialEffect = fmSpecialEffectEtched
                .Left = frameSourcePic.Left + frameSourcePic.Width + 80 + lColumn * frameSourcePic.Width / lRows
                .Top = frameSourcePic.Top + (lRow - 1) * frameSourcePic.Height / lColumns
                .Width = oImagePartCls.PicturePart.Width
                .Height = oImagePartCls.PicturePart.Height
                .ZOrder 1
            End With
        Next
    Next
    'randomly shuffle the image part controls
    lTotalImageParts = lColumns * lRows
    Me.Tag = lTotalImageParts
    ReDim iArray(1 To lTotalImageParts) As Integer  '
    Call ShufflePictureParts(lTotalImageParts, iArray)
    'set the Pic property of each image part
    lControlCounter = 0
    For lColumn = 1 To lColumns
        For lRow = 1 To lRows
            With tRect
                lImgPartWidth = (.Right - .Left) / lRows
                lImgPartHeight = (.Bottom - .Top) / lColumns
                lImgPartLeft = .Left + ((lRow - 1) * lImgPartWidth)
                lImgPartTop = .Top + ((lColumn - 1) * lImgPartHeight)
            End With
            lControlCounter = lControlCounter + 1
            Controls("image" & iArray(lControlCounter)).Tag = Controls("TextBox" & lControlCounter).Name
            CropPic lImgPartWidth, lImgPartHeight, lImgPartLeft, lImgPartTop, Me.Controls("image" & iArray(lControlCounter))
            InvalidateRect lFrmHwnd, 0, 0
        Next
    Next
    frameSourcePic.BorderStyle = fmBorderStyleSingle
    frameSourcePic.BorderColor = vbYellow
    Call UpdateTimerLabel
End Sub




'*************************************************************************************************
' Private Supporting routines


Private Sub UpdateTimerLabel()
    Dim ss As Long
    Dim mm As Long
    Dim hh As Long
    Dim sglTimer As Single
    Const WAV_FILE As String = "C:\WINDOWS\MEDIA\tada.WAV"
    
    sglTimer = Timer
    Do
        ss = Int(Timer - sglTimer)
        If ss = 60 Then mm = mm + 1: ss = 0: sglTimer = Timer
        If mm = 60 Then hh = hh + 1:  mm = 0: sglTimer = Timer
        lblTimer.Caption = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs"
        DoEvents
    Loop Until bExit Or bScore Or bAbort
    If bScore Then
        PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_LOOP Or SND_ASYNC
        If MsgBox("Congratulations " & sUserName & "  !!" & vbCrLf & vbCrLf & _
        "You scored in : " & Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" & vbCrLf & _
        "Do you want to save this score to your scores history  ?", vbQuestion + vbYesNo) = vbYes Then
            Call SaveTheScore(hh, mm, ss)
        End If
        PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_PURGE
    End If
    lblTimer.Caption = ""
    Call EnableControls(True)
    Call DeletePreviousImages
    Set frameSourcePic.Picture = oPic
End Sub


Private Sub SaveTheScore(ByVal hh As Long, mm As Long, ByVal ss As Long)
    Dim bProtection As Boolean
    
    bProtection = ActiveSheet.ProtectContents
    If bProtection Then
        ActiveSheet.Unprotect
    End If
    With Cells(Cells.Rows.Count, 1).End(xlUp)
        .Offset(1, 0) = sUserName
        .Offset(1, 1) = Now
        .Offset(1, 2) = IIf(vFileName = Empty, "Default Picture", vFileName)
        .Offset(1, 3) = sLevel
        .Offset(1, 4) = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs"
    End With
    If bProtection Then
        ActiveSheet.Protect
    End If
    ThisWorkbook.Save
End Sub


Private Sub CropPic(ByVal nWidth, ByVal nHeight, ByVal x, ByVal y, DestCtrl As Image)


    #If VBA7 Then
        Dim hdc, hDCMemory, hBmp, OldBMP As LongPtr
    #Else
        Dim hdc, hDCMemory, hBmp, OldBMP As Long
    #End If
       
    Dim IID_IDispatch As GUID
    Dim uPicinfo As PICTDESC
    Dim IPic As IPicture


    hdc = GetDC(0)
    hDCMemory = CreateCompatibleDC(hdc)
    hBmp = CreateCompatibleBitmap(hdc, nWidth, nHeight)
    OldBMP = SelectObject(hDCMemory, hBmp)
    Call BitBlt(hDCMemory, 0, 0, nWidth, nHeight, hdc, x, y, SRCCOPY)
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hBmp
        .hPal = 0
    End With
    OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
    Set DestCtrl.Picture = IPic
    ReleaseDC 0, hdc
    DeleteObject OldBMP
    DeleteDC hDCMemory
End Sub


Private Sub ShufflePictureParts(ByVal NumOfPics, ByRef Arr() As Integer)
     Dim i As Integer, lRandomNumber As Integer, temp As Integer


    For i = 1 To NumOfPics
        Arr(i) = i
    Next i
    Randomize Timer
    For i = 1 To NumOfPics
        lRandomNumber = Int(Rnd * (UBound(Arr) - LBound(Arr) + 1) + LBound(Arr))
        temp = Arr(i)
        Arr(i) = Arr(lRandomNumber)
        Arr(lRandomNumber) = temp
    Next i
End Sub


Private Sub DeletePreviousImages()
    Dim i As Long
    Dim oCtl As Control
    
    On Error Resume Next
    If Not oCol Is Nothing Then
        For i = 1 To oCol.Count
            Controls.Remove Controls("Image" & i).Name
        Next
        For Each oCtl In Me.Controls
            If TypeName(oCtl) = "TextBox" Then
                Controls.Remove oCtl.Name
            End If
            If TypeName(oCtl) = "Image" Then
                Controls.Remove oCtl.Name
            End If
        Next
    End If
End Sub


Private Function IsFormClipped(tLeftTop As POINTAPI, tRightBottom As POINTAPI) As Boolean
    IsFormClipped = _
    tLeftTop.x <= 1 Or tLeftTop.y <= 1 Or tRightBottom.x >= GetSystemMetrics(SM_CXSCREEN) - 1 Or _
    tRightBottom.y >= GetSystemMetrics(SM_CYSCREEN) - 1
End Function


Private Sub EnableControls(ByVal Bool As Boolean)
    CBtnAbort.Enabled = Not Bool
    CBtnNewPic.Enabled = Bool
    CBtnStart.Enabled = Bool
    ComboLevel.Enabled = Bool
End Sub


'*****************************************************************
' Public  Methods


Public Sub MsgbBeep()
    MessageBeep &H40&
End Sub


Public Sub FlashImagePart(ByVal Img As Image, ByVal ct As msforms.TextBox)
    Dim i As Long
    Dim t As Single
    
    For i = 0 To 1
        Img.BorderStyle = fmBorderStyleSingle
        Img.BorderColor = vbRed
        t = Timer
        Do
            DoEvents
        Loop Until Timer - t >= 0.1
        Img.BorderStyle = fmBorderStyleNone
    Next
End Sub


Public Sub CheckIfSuccess()
    Dim oCtrl As Control
    Dim lCounter As Long
    
     For Each oCtrl In Me.Controls
        If TypeName(oCtrl) = "Image" Then
            If InStr(1, oCtrl.Tag, "Success") Then
                lCounter = lCounter + 1
                If lCounter = lTotalImageParts Then
                    bScore = True
                End If
            End If
        End If
    Next
End Sub

2- Code in the Class module named (oImagePartCls) :

Option Explicit


Public WithEvents PicturePart As msforms.Image
Private initialY As Single, initialX As Single
Private oUForm As Object


Public Property Set GetForm(ByVal vNewValue As Object)
    Set oUForm = vNewValue
End Property


Private Sub PicturePart_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    initialX = x: initialY = y
    PicturePart.ZOrder 0
End Sub


Private Sub PicturePart_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Dim oCtrl As Control
    Static oPrevCtrl As Control


    If Button = 1 Then
        With PicturePart
            .Move .Left + (x - initialX), .Top + (y - initialY)
            For Each oCtrl In oUForm.Controls
                If TypeName(oCtrl) = "TextBox" Then
                    If Not oPrevCtrl Is Nothing Then
                        oPrevCtrl.Enabled = False
                        oPrevCtrl.BackStyle = fmBackStyleTransparent
                        oPrevCtrl.SpecialEffect = fmSpecialEffectEtched
                    End If
                    If .Left + .Width / 2 > oCtrl.Left And .Left + .Width / 2 < oCtrl.Left + oCtrl.Width _
                    And .Top + .Height / 2 > oCtrl.Top And .Top + .Height / 2 < oCtrl.Top + oCtrl.Height Then
                        oCtrl.Enabled = True
                        oCtrl.BackStyle = fmBackStyleOpaque
                        oCtrl.SpecialEffect = 6
                        oCtrl.BackColor = vbWhite
                        Set oPrevCtrl = oCtrl
                        Exit For
                    End If
                End If
            Next
        End With
    End If
End Sub


Private Sub PicturePart_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Dim oCtrl As Control
    
    For Each oCtrl In oUForm.Controls
        If TypeName(oCtrl) = "TextBox" Then
            With PicturePart
                If .Left + .Width / 2 > oCtrl.Left And .Left + .Width / 2 < oCtrl.Left + oCtrl.Width _
                And .Top + .Height / 2 > oCtrl.Top And .Top + .Height / 2 < oCtrl.Top + oCtrl.Height Then
                    .Move oCtrl.Left, oCtrl.Top
                    PicturePart.BorderStyle = fmBorderStyleNone
                    Call oUForm.FlashImagePart(PicturePart, oCtrl)
                    If InStr(1, PicturePart.Tag, oCtrl.Name) Then
                        PicturePart.Tag = PicturePart.Tag & "Success"
                    Else
                    If Right(PicturePart.Tag, 7) = "Success" Then
                            PicturePart.Tag = Mid(PicturePart.Tag, 1, Len(PicturePart.Tag) - 7)
                        End If
                    End If
                    Call oUForm.MsgbBeep
                    Call oUForm.CheckIfSuccess
                    Exit For
                End If
            End With
        End If
    Next
End Sub

Regards