لعبة تركيب صورة للاطفال

[جعفر الطريبق]

السلام عليكم

لقد انتهيت من تصميم الفورم و الكود  .. كتبت الكود و جربته على أوفيس 2007 ويندوز XP

طبعا ينبغي تعديل ال API Declarations لكي يعمل الكود على الويندوز 64 بت

ارجو أن يعجبكم العمل

 

لقطة من اشاشة :

ملف للتحميل :

https://app.box.com/s/pn0ogngk3swhfbxbugk8f87ookrqb18b

 

الكود:

1- كود في موديول الفورم: PaintingPuzzleGame

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 uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
Private Declare Function FindWindow Lib "User32.dll" 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.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (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 OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function InvalidateRect Lib "User32.dll" (ByVal hwnd As Long, ByVal 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 Const PICTYPE_BITMAP = &H1
Private Const SRCCOPY = &HCC0020
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SND_ASYNC As Long = &H1
Private Const SND_FILENAME As Long = &H20000
Private Const SND_LOOP As Long = &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 lFrmHwnd As Long
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)
    Dim hdc As Long
    Dim hDCMemory As Long
    Dim hBmp As Long
    Dim OldBMP As Long
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    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.2
        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- الكود في الكلاس موديول : 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

 

تم تعديل سبتمبر 30, 2015 بواسطه جعفر الطريبق

[محمد حسن المحمد]

السلام عليكم ورحمة الله وبركاته أستاذنا الكريم جعفر الطريبق المحترم:

عمل رائع ومتقن ومميز ...وكل كلمة قلتها لا يمكن أن تصل إلى التعبير عن عمل مبهر كهذا...فــــــــــوق الإعجــــــــــــــــــاب.

جزاكم الله خيراً...

[الصـقر]

استاذى الفاضل

اسال الله تعالى ان يزيدك من علمه وفضله

بحق ابداع ما أروعه

تقبل تحياتى 

 

[محمد حسن المحمد]

السلام عليكم ورحمة الله وبركاته

أقترح أن يضاف عمل اﻷستاذ جعفر الطريبق إلى دليل المواضيع المثبتة..وذلك لكبر حجم العمل وإتقانه علما أنه يعمل على ال 64 بشكل طبيعي ...إذا كان دليل المواضيع المثبتة متجددا..

كما أقترح على الأستاذ جعفر المحترم أن يوجد أسلوبا تعود فيه القصاصة إلى موقعها عند الانتقاء الخطأ..مع تعبير مناسب بالصوت أو الصورة للانتقاء الصحيح أو الخاطئ.. إن لم يؤد ذلك إلى كبر أو بطء في العمل ..هذا العمل يبعث على دقة الملاحظة..وهو مهم للناشئة..وممتع..

تقبلوا تحياتي...

[ياسر خليل أبو البراء]

أخي الحبيب جعفر

يبدو أنني سأكون مصدر إزعاج لك ..

قمت بالتعديل على API Declarations لكي يعمل الكود على الويندوز 64 بت

وعند التنفيذ ظهرت لي رسالة

File not found : olepro32.dll

أعمل على ويندوز 10 64 بت ...

[جعفر الطريبق]

مشكورين على الردود

أستادي الفاضل ياسر

بدل ال olepro32.ddl ب OleAut32.dll

لتصبح كالتالي :

Private Declare Function OleCreatePictureIndirect Lib "OleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

 

[ياسر خليل أبو البراء]

ممتاز ورائع حقاً أخي الغالي جعفر

الآن .. بدأ الفورم يعمل .. عند الشروع في العمل والضغط على زر Start تظهر الضور المقطعة بشكل طبيعي ولكن عند بداية سحب الصور تظهر الصور بخلفية بيضاء وتختفي الصورة ...

[مجدى يونس]

الاخ العزيز جعفر

مجهود رائع فعلا لقد قمت بتثبيته لاهمية مجهودك

[Yasser Fathi Albanna]

أستاذى الفاضل / جعفر الطريبق

مجهود جبار وعمل أكثر من رائع

جزاك الله خيرا

وألف شكرا للأستاذ القدير / مجدى يونس لتثبيت الموضوع للإفاده للجميع

تقبلوا خالص تحياتى وتقديرى

[جعفر الطريبق]

ممتاز ورائع حقاً أخي الغالي جعفر

الآن .. بدأ الفورم يعمل .. عند الشروع في العمل والضغط على زر Start تظهر الضور المقطعة بشكل طبيعي ولكن عند بداية سحب الصور تظهر الصور بخلفية بيضاء وتختفي الصورة ...

استادي الفاضل ياسر

لقد قمت بتجريب الكود على جهاز أخر في احدى محلات الانتيرنيت تحت نظام الويندوز 08 - 64 بت  و الأفيس 2007 و اشتغل جيدا ... سأجربه لاحقا عند أحد الأصدقاء على الويندوز 64 بت اوفيس 2010 64 بت 

شكرا الأستاد الفاضل مجدي يونس على اهتمامك و على تثبيت الموضوع

تم تعديل أكتوبر 2, 2015 بواسطه جعفر الطريبق

[مجدى يونس]

الاخ ياسر

شكرا لك انا ثبته بناء على طلبكم ولمجهود الاخ جعفر

الاخ جعفر

لا شكر على واجب يستحق التثبيت وفكرت افصل الجذء الخاص بك فى موضوع منفصل فانتظرت رايك

[محمد حسن المحمد]

السلام عليكم ورحمة الله وبركاته..أستاذنا الجليل مجدي يونس...

عمل رائع يستحق الثناء ...وجهد مبذول يشكر عليه الأستاذ جعفر الطريبق المحترم...لما له من تحفيز للذاكرة وتنشيط للفكر...والتعويد على الدقة 

نشكرك جزيل الشكر على تثبيت الموضوع ...والسلام عليكم.

[مجدى يونس]

الاخ محمد حسن

لا شكر على واجب

كل مايهمنا فى المنتدى روح الإخوة والمحبة بيننا وتحقيق رغبات الجميع

[ياسر خليل أبو البراء]

أخي الكريم جعفر

أنا أعمل على نظام التشغيل ويندوز 10    64 بت

والأوفيس 2013   64 بت ...

إن شاء الله تجد الحل المناسب

[رشوان احمد]

الاخ مجدى

والاخ جعفر

جذاكم الله خير

[ياسر خليل أبو البراء]

أخي الحبيب جعفر

هل اطلعت على مشكلتي مع الملف ؟ وهل المشكلة تخصني فقط أم أن هناك من يعاني منها؟

الملف الآن يعمل بشكل جيد بدون مشاكل فيما يخص الأكواد والتعامل مع النظامين

بقي مشكلة واحدة ألا وهي التعامل مع الأجزاء المقطعة من الصورة

عند التأشير عليها أو محاولة سحبها فإنها تظهر بخلفية ذات لون أبيض .. أي أن الصورة على الجزؤ المقطع تختفي

أرجو أن تجد الحل

[جعفر الطريبق]

السلام علبكم

ملف للتحميل : https://app.box.com/s/72jzyfczsk6bvsedm57h6ycv12agxgv9

 

نسخة 64 بيت .. حربتها على Windows7 64 bit Office 2010 64 bit

- كود في موديول الفورم: PaintingPuzzleGame

 

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
    hPic As LongPtr
    hPal As LongPtr
End Type

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 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 lFrmHwnd As LongPtr
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)
    Dim hdc As LongPtr
    Dim hDCMemory As LongPtr
    Dim hBmp As LongPtr
    Dim OldBMP As LongPtr
    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

- الكود في الكلاس موديول : 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

 

[ياسر خليل أبو البراء]

أخي الحبيب جعفر

لعل غيابك عنا الفترة البسيطة اللي فاتت يكون خير

صراحة تعجز الكلمات عن وصفك ووصف الأعمال المدهشة التي تقدمها

بارك الله لنا فيك وجزيت عنا خير الجزاء

[جعفر الطريبق]

مشكور يا أستاذ ياسر خليل .. لقد اشنريت جهازا حديدا يشتغل على الويندوز 64 اوقيس 2010 و بدأئت أعدل في بعض الأكواد 

 

[ياسر خليل أبو البراء]

الحمد لله أخي الحبيب جعفر على عودتك

إن شاء الله حاول تعمل حسابك عند كتابة الأكواد النظامين معاً 32 بت و 64 بت حتى يكون الكود متكامل

وفقك الله لما يحب ويرضى

[Shereen Ahmed]

فعلا مجهود طيب

بارك الله فيك و جزاك خيرا 

 

[مجدى يونس]

شكرا لك