رنگارنگ

چند برنامه سورس کد بازی پازل را برای شما قرار داده بودم اما این بازی تفاوتی با بقیه بازیها دارد و آنهم اینکه این قابلیت را دارد که شما میتوانید هر تصویر مورد نظرتان را به بازی آورده و از آن برای بازی استفاده کنید . سورس کد برنامه را به همراه کل ساختار برنامه برای دانلود قرار داده ام که میتوانید دانلود نمایید .

پسورد فایل زیپ : www.pcmoj.com

دانلود سورس کد - 18 کیلوبایت  

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)

Option Explicit

    Private numSwaps As Long    '// Number of swaps

Private Sub Form_Load()
    '// Load the help file
    App.HelpFile = App.Path & "\puzzles.hlp"
End Sub

Private Sub mnuGameExit_Click()
    '// End the program
    End
End Sub

Public Sub mnuGameNew_Click()
    '// If options are not defined, then show Options form
    If Not mvarOptionsDefined Then
        frmOptions.Show
    '// The options are defined
    Else
        PicClip.ROWS = mvarRows     '// Set number of rows of the PicClip
        PicClip.Cols = mvarColumns  '// Set number of columns of the PicClip
        PicClip.Picture = LoadPicture(mvarPicture)      '// Set picture of the PicClip
       
            LoadArray               '// Initialize array
            ScrambleArray           '// Scramble puzzle pieces
            DisplayArray            '// Display array/pieces
            sbStatus.Panels.Item(3).Text = "Correct " & inPlace & " out of 25"
    End If
   
    '// Initialize the values used for the new Game
    mvarOptionsDefined = False
    numSwaps = 0
   
    '// Initialize values in the Status bar
    sbStatus.Panels.Item(1).Text = ""
    sbStatus.Panels.Item(2).Text = "Number of swaps: 0"
End Sub

Private Sub mnuHelpAbout_Click()
    frmAbout.Show     '// Show about form
End Sub

Private Function PieceWidth() As Long
    '// Determine width of a single puzzle - piece
    PieceWidth = PicClip.Width / mvarColumns
End Function

Private Function PieceHeight() As Long
    '// Determine height of a single puzzle - piece
    PieceHeight = PicClip.Height / mvarRows
End Function

Private Function LoadArray()
    Dim i   As Integer      '// Iterator for pieces
   
    While i < UBound(mvarPictures)
        '// Set picture, and determine its final position
        Set mvarPictures(i).thePicture = PicClip.GraphicCell(i)
        mvarPictures(i).position = i + 1
        i = i + 1           '// Next piece
    Wend
End Function

Private Function ScrambleArray()
'// This function scrambles the puzzle pieces by
'// randomly swapping values in the array

    Dim aPiece As Piece     '// Temporary value; for swapping
    Dim i       As Integer  '// iterator for "for" loop
    Dim j       As Integer  '// iterator for "for" loop
   
    '// Use random number generator to swap values
    For i = 0 To 1000 - Int((Rnd * 500))
       
        For j = 0 To 25 - (Int(Rnd * 25)) - 1
            Dim rndVal  As Integer      '// Rendomly generated value
            rndVal = Int(Rnd * 25)      '// initialize value
           
            '// perform swapping
            aPiece = mvarPictures(j)
            mvarPictures(j) = mvarPictures(rndVal)
            mvarPictures(rndVal) = aPiece
       
        Next j
    Next i
   
End Function

Private Function DisplayArray()
'// This function displays the pictures/pieces of the
'// puzzle.  The position of the pictures is determined
'// by the mvarColumns and mvarRows (fixed = 5) and
'// pieces' width and height.

    Dim i               As Integer  '// iterator
    Dim j               As Integer  '// iterator
    Dim mvarClipWidth   As Long     '// Width of a piece
    Dim mvarClipHeight  As Long     '// height of a piece
    Dim x, y                        '// x & y positions of a piece

    '// Find values of the widht and height for a single piece
    mvarClipWidth = PieceWidth
    mvarClipHeight = PieceHeight
   
    i = 1
    y = 5   '// Start at 5 pixels from the top of frmMain
    x = 5   '// Start at 5 pixels from the left of frmMain
   
    '// Keep displaying pictures until all are displayed
    While i <= mvarColumns * mvarRows
       
        '// Set postions x and y and then assign picture
        picPiece.Item(i - 1).Top = y
        picPiece.Item(i - 1).Left = x
        picPiece.Item(i - 1).Picture = mvarPictures(i - 1).thePicture
       
        '// increment position x
        x = x + mvarClipWidth
       
        '// if there are 5 columns displayed
        If i Mod mvarColumns = 0 Then
            y = y + mvarClipHeight  '// Increment y
            x = 5                   '// start at first column
        End If
       
        i = i + 1   '// next piece
       
    Wend
   
End Function

Private Sub mnuHelpHelp_Click()
    Dim nRet As Integer
    'if there is no helpfile for this project display a message to the user
    'you can set the HelpFile for your application in the
    'Project Properties dialog
    If Len(App.HelpFile) = 0 Then
        MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 3, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If
End Sub

Private Sub picPiece_Click(Index As Integer)
    '// perform swapping of the pieces if the first piece
    '// has already been selected; otherwise set clicked
    '// to first selected piece
    If sbStatus.Panels.Item(1).Text = "" Then
        sbStatus.Panels.Item(1).Text = Index
    Else
        swap sbStatus.Panels.Item(1).Text, Index
        numSwaps = numSwaps + 1
        sbStatus.Panels.Item(1).Text = ""
        sbStatus.Panels.Item(2).Text = "Number of swaps: " & numSwaps
        sbStatus.Panels.Item(3).Text = "Correct " & inPlace & " out of  25"
    End If
End Sub

Private Function swap(ByVal cell1 As Integer, ByVal cell2 As Integer)
'// This function performs the swapping of the two pictures/pieces
'// and determines whether all the pieces are in correct postion.
    On Error GoTo ErrHandler
    Dim temp  As Piece
    '// Swap
    temp = mvarPictures(cell1)
    mvarPictures(cell1) = mvarPictures(cell2)
    mvarPictures(cell2) = temp
   
    DisplayArray
   
    If inPlace = 25 Then
        Dim answer As Integer
        answer = MsgBox("Congratulations! You win!" & vbCrLf _
        & "Would you like to play again?", vbYesNo)
            If answer = vbYes Then
                mnuGameNew_Click
            Else
                mnuGameExit_Click
            End If
    End If
   
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description
        Err.Clear
        mnuGameNew_Click
        Exit Function
    End If
End Function

Private Function inPlace() As Integer
'// This function determines how many pieces of the
'// puzzle are in in their place.
'// the function returns the number of the pieces in
'// correct position
    Dim i           As Integer
    Dim correct     As Integer
   
    While i < UBound(mvarPictures)
        If (mvarPictures(i).position = i + 1) Then correct = correct + 1
        i = i + 1
    Wend
   
    inPlace = correct
   
End Function