جعفر الطريبق

الاستاد الفاضل مختار حسين شكرا على المتابعة

في بداية الماكرو  Test  توجد ال Variable eAction  و ال  Variable oTargetRange ... فالاولى تعطي الكود امكانية اختيار مجال الخلايا و الثانية اختار التلوين أو التفريغ أو الوميض .. تلك هي المرونة التي كنت أقصدها و هي مرونة على مستوى الكود و تجعله مرتبا و مرنا و سهلا

أما على مستوى المستخدم فنعم يمكن اضافة InputBox  او فورم كما تفضلت

جرب هده الفروميلة

=INDEX(A1:A20,MATCH(MIN(COUNTIF(A1:A20,A1:A20)),COUNTIF(A1:A20,A1:A20),0))

هده Array Formula فيجب ادخالها في الخلية عن طريق Shift+Control+ Enter

مشكور يا أستاد مختار حسين على الكود الجميل

السلام عليكم يا أستادي الفاضل مختار حسين

فعلا نحن كلنا هنا لنتعلم و لهدا نحاول دائما تحسين أعمالنا قدر الامكان ... أنا أعتبر كل سؤال أو مشاركة فرصة للتعلم و لتحسين خبراتنا

اليك هدا التعديل للكود فهو يتحسب مسبقا لأي أخطاء ممكن أن تحدث كما أنه أسرع و أكثر مرونة بسبب ال Enum Argument

ممكن اضافة ميزة أخرى للكود ألا و هي اعطاء المستخدم امكانية ارجاع الخلايا كما كانت قبل التفريغ أو التعديل أو التلوين

ملف للتحميل : https://app.box.com/s/3tmxv0k3xxzj3fg6616oounfugns55si

الكود في موديول عادي:

Option Explicit

Private Enum ActionToTake
    EditCells = 0
    EmptyCells = 1
    ColorCells = 2
    FlashCells = 4
End Enum

Private Declare Function sndPlaySound32 Lib "winmm.dll" _
Alias "sndPlaySoundA" (ByVal lpszSoundName _
As String, ByVal uFlags As Long) As Long


Sub test()
    Dim eAction As ActionToTake
    Dim sAction As String
    Dim oTargetRange As Range
    
    Set oTargetRange = Sheet1.Range("A1:K20")
    eAction = FlashCells
    
    Select Case eAction
        Case EditCells
            sAction = "edit"
        Case EmptyCells
            sAction = "clear"
        Case ColorCells
            sAction = "change the color of"
        Case FlashCells
            sAction = "flash"
    End Select
    If MsgBox("You are about to " & sAction & " the cells in the Range : " & vbCr & vbCr & _
    oTargetRange.Address(external:=True) & vbCr & vbCr & "Go ahead ?", vbExclamation + vbYesNo) = vbYes Then
        If CheckRangeForErrors(Target:=oTargetRange, WhichAction:=eAction) = False Then
            MsgBox Err.Description
        End If
    End If
End Sub

Private Function CheckRangeForErrors( _
    ByVal Target As Range, _
    Optional ByVal WhichAction As ActionToTake = FlashCells _
) _
    As Boolean

    Dim oCellsWithErrorFormulae As Range
    Dim oCell As Range
    Dim ar() As Long
    Dim j As Long
    Dim i As Long
    Dim t As Single
    
    On Error Resume Next
    Set oCellsWithErrorFormulae = Target.SpecialCells(xlCellTypeFormulas, 16)
    If Not oCellsWithErrorFormulae Is Nothing Then
        With oCellsWithErrorFormulae
            Select Case WhichAction
                Case EditCells
                    .Value = "Error Edited"
                Case EmptyCells
                    .ClearContents
                Case ColorCells
                    .Interior.Color = vbRed
                Case FlashCells
                    ReDim ar(1 To .Cells.Count)
                    For Each oCell In .Cells
                        i = i + 1
                        ar(i) = oCell.Interior.ColorIndex
                    Next oCell
                    For i = 1 To 4
                        Call sndPlaySound32("C:\windows\media\notify.wav", 1)
                        .Cells.Interior.ColorIndex = 3
                        t = Timer
                        Do
                            DoEvents
                        Loop Until Timer - t >= 0.2
                        j = 0
                        For Each oCell In .Cells
                            j = j + 1
                            oCell.Interior.ColorIndex = ar(j)
                        Next oCell
                        t = Timer
                        Do
                            DoEvents
                        Loop Until Timer - t >= 0.2
                    Next i
                    i = 0
                    For Each oCell In .Cells
                        i = i + 1
                        oCell.Interior.ColorIndex = ar(i)
                    Next oCell
                    Erase ar
                    Set oCellsWithErrorFormulae = Nothing
                    Set oCell = Nothing
            End Select
        End With
        CheckRangeForErrors = True
    End If
End Function

استادي الفاضل أنس دروبي

تفضل الكود في اليوزرفورم

Private Sub CommandButton1_Click()
    If MsgBox("Do you want to add this workbook to the Windows startUp ?", vbYesNo + vbQuestion) = vbYes Then
        AddToWinStartUp ThisWorkbook.FullName, True
    End If
End Sub

Private Sub AddToWinStartUp(ByVal File As String, ByVal Add As Boolean)
     CreateObject("wscript.shell").RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\", IIf(Add, File, vbNullString), "REG_SZ"
End Sub

كود جميل للاستاد الفاضل مختار حسين

عند بعض الملاحظات

1- من الأفضل اضافة  Error Handling  للكود لتفادي ال  RunTime error  في حالة عدم وجود أي خلايا تحتوي على معادلات في الصفحة

2- يمكن الاستغناء عن  Select  ليكون الكود أسرع

3- في حالة وجود أكثر من خلية حاوية لمعادلة يمكن اشغال الوميض على كل الخلايا مرة واحدة في نفس الوقت .. هدا الأمر من شانه الاسراع بالكود خصوصا لو وجدت خلايا عديدة

4- من الأحسن تغيير شكل الكود بحيث يصبح التعديل و التفريغ و التلوين و الوميض  Arguments  يتم اختيارهم من طرف المستخدم .. هدا من شأنه اعطاء للكود مرونة كبيرة

الأساتدة الافاضل ياسر و توكل

كما سبق لي أن قلت لم أجرب الكود و اعتمدت فقط على ال  ASCII MAP للحروف العربية

لكي أجرب الكود يجب أن أغير السيتينس عبر  Control Panel-Regional Settings لكن الجهاز يطلب مني ادخال سيدي الويندوز XP  الدي ضاع مني

مشكورين على الكود الجميل لكن للتدكير فقط أن هدا الكود صالح فقط للاكسيل 2003/2000/97  و لا يمنع من النسخ و اللصق من ال  Ribbon Controls  في اصدارت اكسيل 2007 و ما فوق

الأستاد الفاضل مختار حسين

جوابا على سؤالك ليس هنالك MsgBox  بدون أزرار لكن يمكن تغييرها ببرمجة ال  API و اظهارها بدون أزرار  لتختفي بدون تدخل المستخدم بعد فترة زمنية .. للأسف كتابة الكود لن يكون سهلا

لو عندي وقت سأحاول كتابة الكود لتحقيق دالك

الأستاد ياسر خليل

جرب هدا الكود .. أرجو أن يعمل لأنني أريد العديد من أكوادي أن تعمل على ال 64 بت

Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As LongLong
End Type

Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String,ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongLong, ByVal hMenu As LongLong, ByVal hInstance As LongLong, lpParam As Any) As LongLong
Private Declare PtrSafe Function DestroyWindow Lib "user32" Alias "DestroyWindow" (ByVal hwnd As LongLong) As Long
Private Declare PtrSafe Function FillRect Lib "user32" Alias "FillRect" (ByVal hdc As LongLong, lpRect As RECT, ByVal hBrush As LongLong) As Long
Private Declare PtrSafe Function GetDC Lib "user32" Alias "GetDC" (ByVal hwnd As LongLong) As LongLong
Private Declare PtrSafe Function ReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal hwnd As LongLong, ByVal hdc As LongLong) As Long
Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" Alias "CreateBrushIndirect" (lpLogBrush As LOGBRUSH) As LongLong
Private Declare PtrSafe Function DeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As LongLong) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" Alias "SetBkMode" (ByVal hdc As LongLong, ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As LongLong, ByVal lpString As String) As Long
Private Declare PtrSafe Function SetTextColor Lib "gdi32" Alias "SetTextColor" (ByVal hdc As LongLong, ByVal crColor As Long) As Long
Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As LongLong, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare PtrSafe Function SetRect Lib "user32" Alias "SetRect" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32" Alias "ShowWindow" (ByVal hwnd As LongLong, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function GetSysColor Lib "user32" Alias "GetSysColor" (ByVal nIndex As Long) As Long

Private Const WS_CHILD = &H40000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CAPTION = &HC00000
Private Const WS_EX_TOPMOST = &H8&
Private Const SW_NORMAL = 1
Private Const TRANSPARENT = 1
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const COLOR_BTNFACE = 15

Private bWindowExist As Boolean

Public Sub Test()
    If Not bWindowExist Then
        Call ShowUpdatingMessage( _
                Message:="Showing message number :  ", _
                Title:="Officena", _
                HowManyTimes:=10, MessageDelay:=1, _
                TOPMOST:=True, TextColor:=vbRed, BackColor:=vbYellow _
            )
    End If
End Sub


Private Sub ShowUpdatingMessage( _
    ByVal Message As String, _
    ByVal Title As String, _
    ByVal HowManyTimes As Single, _
    Optional ByVal MessageDelay As Single, _
    Optional ByVal TOPMOST As Boolean, _
    Optional ByVal TextColor As Long, _
    Optional ByVal BackColor As Long)
    
    Const WIDTH = 250
    Const HEIGHT = 120
    Dim tRect As RECT
    Dim tLb As LOGBRUSH
    Dim t As Single
    Dim hBrush As LongLong
    Dim hwndChild As LongLong
    Dim hwndParent As LongLong
    Dim hdc As LongLong
    Dim iCounter As Integer
    
    On Error GoTo CleanUp
'    Application.EnableCancelKey = xlErrorHandler
    hwndParent = CreateWindowEx(IIf(TOPMOST, WS_EX_TOPMOST, 0), "BUTTON", Title, WS_CAPTION + WS_CLIPCHILDREN, _
    (GetSystemMetrics(SM_CXSCREEN) - WIDTH) / 2.2, (GetSystemMetrics(SM_CYSCREEN) - HEIGHT) / 2, WIDTH, HEIGHT, 0, ByVal 0, 0, ByVal 0&)
    hwndChild = CreateWindowEx(0, "STATIC", vbNullString, WS_CHILD, 0, 0, WIDTH, HEIGHT, hwndParent, ByVal 0&, Application.Hinstance, ByVal 0&)
    If hwndChild Then
        bWindowExist = True
        Application.OnKey "%{F4}", ""
        ShowWindow hwndParent, SW_NORMAL
        ShowWindow hwndChild, SW_NORMAL
        DoEvents
        hdc = GetDC(hwndChild)
        SetBkMode hdc, TRANSPARENT
        If TextColor <> 0 Then
           SetTextColor hdc, TextColor
        End If
        SetRect tRect, 0, 0, WIDTH, HEIGHT
        tLb.lbColor = IIf(BackColor = 0, GetSysColor(COLOR_BTNFACE), BackColor)
        hBrush = CreateBrushIndirect(tLb)
        For iCounter = 1 To HowManyTimes
            FillRect hdc, tRect, hBrush
            TextOut hdc, 30, 20, Message, Len(Message)
            TextOut hdc, 115, 50, CStr(iCounter), Len(CStr(iCounter))
            t = Timer
            Do
                DoEvents
            Loop Until Timer - t >= IIf(MessageDelay = 0, 1, MessageDelay)
        Next
    End If
CleanUp:
        ReleaseDC hwndChild, 0
        DeleteObject hBrush
        DestroyWindow hwndChild
        DestroyWindow hwndParent
        bWindowExist = False
        Application.OnKey "%{F4}"
End Sub

الأستاد الفاضل محمد حسن المحمد

شكرا على الملاحظة القيمة ... أعتقد أن الحساب على أساس 28 أو 36 مرهون بارادة المستخدم  ... أنا أفضل الحساب على أساس 36 حرف لأنه أشمل  ASCII MAP

و نفس الأمر بالنسبة للفراغات فهو أمر مرتبط بما يريده طالب الكود أو المستخدم  ... يمكن تعديل الأكواد على حسب الرغبة و على حسب عدد الحروف المطلوبة

السلام عليكم

يمكن تبسيط الكود باستغلال القيمة العددية للحروف :  ASCII

 لم أجرب الكود لأنه لأنني ضيعت سيدي الويندوز المطلوب عند محاولة تغيير اللغة عن طريق ال Regional Settings

Function AlphaSum(ByVal Word As String) As Long
    Dim i As Long
    Word = Replace(Word, " ", "")
    For i = 1 To Len(Word)
        AlphaSum = AlphaSum + Asc(Mid(Word, i, 1)) - IIf(Asc(Mid(Word, i, 1)) > &H63A, &H626, &H620)
    Next
End Function

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

جرب الكود التالي في ال  ThisWorkbook Module:

Private Sub Workbook_Open()
    If MsgBox("Do you want to add this workbook to the Windows startUp ?", vbYesNo + vbQuestion) = vbYes Then
        AddToWinStartUp Me.FullName, True
    End If
End Sub

Private Sub AddToWinStartUp(ByVal File As String, ByVal Add As Boolean)
     CreateObject("wscript.shell").RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\", IIf(Add, File, vbNullString), "REG_SZ"
End Sub

للتدكير فقط ممكن أن يختلف ال (Key Path (  Microsoft\Windows\CurrentVersion  في اصدارات أخرى للويندوز .. كما أن المستخدم User ينبغي أن يتوفر على الحق Privileges في تغيير الريجيستار  Registry

لازالة الملف من قائمة البرامج عند بدء تشغيل الويندوز شغل الكود التالي :

 AddToWinStartUp Me.FullName, False

جرب هدا الكود :

Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As LongPtr
End Type

Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String,ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" Alias "DestroyWindow" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function FillRect Lib "user32" Alias "FillRect" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function GetDC Lib "user32" Alias "GetDC" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" Alias "CreateBrushIndirect" (lpLogBrush As LOGBRUSH) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" Alias "SetBkMode" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String) As Long
Private Declare PtrSafe Function SetTextColor Lib "gdi32" Alias "SetTextColor" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare PtrSafe Function SetRect Lib "user32" Alias "SetRect" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32" Alias "ShowWindow" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function GetSysColor Lib "user32" Alias "GetSysColor" (ByVal nIndex As Long) As Long

Private Const WS_CHILD = &H40000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CAPTION = &HC00000
Private Const WS_EX_TOPMOST = &H8&
Private Const SW_NORMAL = 1
Private Const TRANSPARENT = 1
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const COLOR_BTNFACE = 15

Private bWindowExist As Boolean

Public Sub Test()
    If Not bWindowExist Then
        Call ShowUpdatingMessage( _
                Message:="Showing message number :  ", _
                Title:="Officena", _
                HowManyTimes:=10, MessageDelay:=1, _
                TOPMOST:=True, TextColor:=vbRed, BackColor:=vbYellow _
            )
    End If
End Sub


Private Sub ShowUpdatingMessage( _
    ByVal Message As String, _
    ByVal Title As String, _
    ByVal HowManyTimes As Single, _
    Optional ByVal MessageDelay As Single, _
    Optional ByVal TOPMOST As Boolean, _
    Optional ByVal TextColor As Long, _
    Optional ByVal BackColor As Long)
    
    Const WIDTH = 250
    Const HEIGHT = 120
    Dim tRect As RECT
    Dim tLb As LOGBRUSH
    Dim t As Single
    Dim hBrush As LongPtr
    Dim hwndChild As LongPtr
    Dim hwndParent As LongPtr
    Dim hdc As LongPtr
    Dim iCounter As Integer
    
    On Error GoTo CleanUp
'    Application.EnableCancelKey = xlErrorHandler
    hwndParent = CreateWindowEx(IIf(TOPMOST, WS_EX_TOPMOST, 0), "BUTTON", Title, WS_CAPTION + WS_CLIPCHILDREN, _
    (GetSystemMetrics(SM_CXSCREEN) - WIDTH) / 2.2, (GetSystemMetrics(SM_CYSCREEN) - HEIGHT) / 2, WIDTH, HEIGHT, 0, ByVal 0, 0, ByVal 0&)
    hwndChild = CreateWindowEx(0, "STATIC", vbNullString, WS_CHILD, 0, 0, WIDTH, HEIGHT, hwndParent, ByVal 0&, Application.hInstance, ByVal 0&)
    If hwndChild Then
        bWindowExist = True
        Application.OnKey "%{F4}", ""
        ShowWindow hwndParent, SW_NORMAL
        ShowWindow hwndChild, SW_NORMAL
        DoEvents
        hdc = GetDC(hwndChild)
        SetBkMode hdc, TRANSPARENT
        If TextColor <> 0 Then
           SetTextColor hdc, TextColor
        End If
        SetRect tRect, 0, 0, WIDTH, HEIGHT
        tLb.lbColor = IIf(BackColor = 0, GetSysColor(COLOR_BTNFACE), BackColor)
        hBrush = CreateBrushIndirect(tLb)
        For iCounter = 1 To HowManyTimes
            FillRect hdc, tRect, hBrush
            TextOut hdc, 30, 20, Message, Len(Message)
            TextOut hdc, 115, 50, CStr(iCounter), Len(CStr(iCounter))
            t = Timer
            Do
                DoEvents
            Loop Until Timer - t >= IIf(MessageDelay = 0, 1, MessageDelay)
        Next
    End If
CleanUp:
        ReleaseDC hwndChild, 0
        DeleteObject hBrush
        DestroyWindow hwndChild
        DestroyWindow hwndParent
        bWindowExist = False
        Application.OnKey "%{F4}"
End Sub

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

تعديل ال  API كود لكي يعمل على نظام 64 بت لا يقتصر فقط على اضافة PtrSafe  بل يطال أيضا ال  Variable Types   ال  Function Parameters  مثل LongPtr ; LonogLong الى أخره .. سأحاول تعديل الكود بنفسي و لكن سأترك لك مهمة التجريب لأنه لا يمكن اي تجريب الكود على جهازي

هل هدا ما تقصده :

(غير حروف الاسم ABDEL AZIZ الى العربية )  ... لاحظ أنني غيرت الكود 

 TextOut hdc, 30, 20, Message & " " & iCounter, Len(Message & " " & iCounter)

Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type

Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) 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
Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Const WS_CHILD = &H40000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CAPTION = &HC00000
Private Const WS_EX_TOPMOST = &H8&
Private Const SW_NORMAL = 1
Private Const TRANSPARENT = 1
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const COLOR_BTNFACE = 15

Private bWindowExist As Boolean

Public Sub Test()
    If Not bWindowExist Then
        Call ShowUpdatingMessage( _
                Message:="ABDEL AZIZ", _
                Title:="Officena", _
                HowManyTimes:=10, MessageDelay:=1, _
                TOPMOST:=True, TextColor:=vbRed, BackColor:=vbYellow _
            )
    End If
End Sub

Private Sub ShowUpdatingMessage( _
    ByVal Message As String, _
    ByVal Title As String, _
    ByVal HowManyTimes As Single, _
    Optional ByVal MessageDelay As Single, _
    Optional ByVal TOPMOST As Boolean, _
    Optional ByVal TextColor As Long, _
    Optional ByVal BackColor As Long)
    
    Const WIDTH = 250
    Const HEIGHT = 120
    Dim tRect As RECT
    Dim tLb As LOGBRUSH
    Dim t As Single
    Dim hBrush As Long
    Dim hwndChild As Long
    Dim hwndParent As Long
    Dim hdc As Long
    Dim iCounter As Integer
    
    On Error GoTo CleanUp
'    Application.EnableCancelKey = xlErrorHandler
    hwndParent = CreateWindowEx(IIf(TOPMOST, WS_EX_TOPMOST, 0), "BUTTON", Title, WS_CAPTION + WS_CLIPCHILDREN, _
    (GetSystemMetrics(SM_CXSCREEN) - WIDTH) / 2.2, (GetSystemMetrics(SM_CYSCREEN) - HEIGHT) / 2, WIDTH, HEIGHT, 0, ByVal 0&, 0, ByVal 0&)
    hwndChild = CreateWindowEx(0, "STATIC", vbNullString, WS_CHILD, 0, 0, WIDTH, HEIGHT, hwndParent, ByVal 0&, Application.hInstance, ByVal 0&)
    If hwndChild Then
        bWindowExist = True
        Application.OnKey "%{F4}", ""
        ShowWindow hwndParent, SW_NORMAL
        ShowWindow hwndChild, SW_NORMAL
        DoEvents
        hdc = GetDC(hwndChild)
        SetBkMode hdc, TRANSPARENT
        If TextColor <> 0 Then
           SetTextColor hdc, TextColor
        End If
        SetRect tRect, 0, 0, WIDTH, HEIGHT
        tLb.lbColor = IIf(BackColor = 0, GetSysColor(COLOR_BTNFACE), BackColor)
        hBrush = CreateBrushIndirect(tLb)
        For iCounter = 1 To HowManyTimes
            FillRect hdc, tRect, hBrush
            TextOut hdc, 30, 20, Message & " " & iCounter, Len(Message & " " & iCounter)
'            TextOut hdc, 115, 50, CStr(iCounter), Len(CStr(iCounter))
            t = Timer
            Do
                DoEvents
            Loop Until Timer - t >= IIf(MessageDelay = 0, 1, MessageDelay)
        Next
    End If
CleanUp:
        ReleaseDC hwndChild, 0
        DeleteObject hBrush
        DestroyWindow hwndChild
        DestroyWindow hwndParent
        bWindowExist = False
        Application.OnKey "%{F4}"
End Sub

في ال الماكرو  Test  بدل :

Message:="Showing message number :  ", 

بالتاي

Message:="عبد العزيز :  ", 

 ربما تحتاج أيضا ضبط طول و عرض النافدة عن طريق تغيير ال WIDTH و  HEIGHT Constantes  الموجودة في ال  ShowUpdatingMessage Routine

السلام عليكم

تكملة و اثراء لهدا الموضوع لقد كتبت الكود التالي الدي يعرض رسالة على فترات زمنية متقطعة بدون اللجوء الى اليوزرفورم و بدون امكانية الغائها من طرف المستخدم كما هو مطلوب أعلاه

Private Sub ShowUpdatingMessage( _
    ByVal Message As String, _
    ByVal Title As String, _
    ByVal HowManyTimes As Single, _
    Optional ByVal MessageDelay As Single, _
    Optional ByVal TOPMOST As Boolean, _
    Optional ByVal TextColor As Long, _
    Optional ByVal BackColor As Long)

ال  Routine  اعلاه تعطي المستخدم مرونة  اختيار  موضوع الرسالة و عدد المرات التي سيتم فيها عرضها و مدة كل رسالة و ال  Z order  لنافدة الرسالة و لون الحروف و لون الخلفية

طبعا لو نص الرسالة طويل فعلى مستعمل الكود أن يغير طول و عرض (WIDTH and HEIGHT Constantes) النافدة لاستعاب كل النص

مرة أخرى نظرا لكتابة الكود على الويندوز 32 بت فانه لن يعمل على اويندوز و الأوفيس 64 بت

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

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

الكود في موديول عادي :

Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type

Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) 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
Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Const WS_CHILD = &H40000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CAPTION = &HC00000
Private Const WS_EX_TOPMOST = &H8&
Private Const SW_NORMAL = 1
Private Const TRANSPARENT = 1
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const COLOR_BTNFACE = 15

Private bWindowExist As Boolean

Public Sub Test()
    If Not bWindowExist Then
        Call ShowUpdatingMessage( _
                Message:="Showing message number :  ", _
                Title:="Officena", _
                HowManyTimes:=10, MessageDelay:=1, _
                TOPMOST:=True, TextColor:=vbRed, BackColor:=vbYellow _
            )
    End If
End Sub


Private Sub ShowUpdatingMessage( _
    ByVal Message As String, _
    ByVal Title As String, _
    ByVal HowManyTimes As Single, _
    Optional ByVal MessageDelay As Single, _
    Optional ByVal TOPMOST As Boolean, _
    Optional ByVal TextColor As Long, _
    Optional ByVal BackColor As Long)
    
    Const WIDTH = 250
    Const HEIGHT = 120
    Dim tRect As RECT
    Dim tLb As LOGBRUSH
    Dim t As Single
    Dim hBrush As Long
    Dim hwndChild As Long
    Dim hwndParent As Long
    Dim hdc As Long
    Dim iCounter As Integer
    
    On Error GoTo CleanUp
'    Application.EnableCancelKey = xlErrorHandler
    hwndParent = CreateWindowEx(IIf(TOPMOST, WS_EX_TOPMOST, 0), "BUTTON", Title, WS_CAPTION + WS_CLIPCHILDREN, _
    (GetSystemMetrics(SM_CXSCREEN) - WIDTH) / 2.2, (GetSystemMetrics(SM_CYSCREEN) - HEIGHT) / 2, WIDTH, HEIGHT, 0, ByVal 0&, 0, ByVal 0&)
    hwndChild = CreateWindowEx(0, "STATIC", vbNullString, WS_CHILD, 0, 0, WIDTH, HEIGHT, hwndParent, ByVal 0&, Application.hInstance, ByVal 0&)
    If hwndChild Then
        bWindowExist = True
        Application.OnKey "%{F4}", ""
        ShowWindow hwndParent, SW_NORMAL
        ShowWindow hwndChild, SW_NORMAL
        DoEvents
        hdc = GetDC(hwndChild)
        SetBkMode hdc, TRANSPARENT
        If TextColor <> 0 Then
           SetTextColor hdc, TextColor
        End If
        SetRect tRect, 0, 0, WIDTH, HEIGHT
        tLb.lbColor = IIf(BackColor = 0, GetSysColor(COLOR_BTNFACE), BackColor)
        hBrush = CreateBrushIndirect(tLb)
        For iCounter = 1 To HowManyTimes
            FillRect hdc, tRect, hBrush
            TextOut hdc, 30, 20, Message, Len(Message)
            TextOut hdc, 115, 50, CStr(iCounter), Len(CStr(iCounter))
            t = Timer
            Do
                DoEvents
            Loop Until Timer - t >= IIf(MessageDelay = 0, 1, MessageDelay)
        Next
    End If
CleanUp:
        ReleaseDC hwndChild, 0
        DeleteObject hBrush
        DestroyWindow hwndChild
        DestroyWindow hwndParent
        bWindowExist = False
        Application.OnKey "%{F4}"
End Sub

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

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

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

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

فقط عندي اقتراح أن يتم تفريغ الفورم من الداكرة ال  memory عوض اخفائه .. ايضا لا داعي لتكرار المصفوفة داخل ال  UnloadUF

Option Explicit

Dim X As Integer
Dim iuserform As Variant

Sub showUF()
' by mokhtatr 19/9/2015
     
   iuserform = Array(UserForm1, UserForm2, UserForm3, UserForm4)
   For X = LBound(iuserform) To UBound(iuserform)
          Application.OnTime Now + TimeValue("00:00:01"), "UnloadUF"
          iuserform(X).Show
   Next X
End Sub

Sub UnloadUF()
    Unload iuserform(X)
    Application.Wait Now + TimeValue("00:00:01")
End Sub

كدالك لا ينبغي نسيان أن المستخدم يمكن له أن يغلق الفورم بالضغط على الزر  x  و لهدا يجب اضافة كود داخل اليوزرفورم موديول كالتالي

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Cancel = Not CloseMode
End Sub

بالمناسبة يمكن كتابة كود  لا يستوجب استخدام عدد معين من اليوزرفورم و انما يستخدم فقط ال Standard MsgBox

الكود أكثر تعقيدا لكنه ممكن

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

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

بدل ال 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

السلام عليكم

لقد انتهيت من تصميم الفورم و الكود  .. كتبت الكود و جربته على أوفيس 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

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

جربت على عجالة الملف على أوفيس 32/2010 ويندوز 64 بت في احدى السيبيرات و بالفعل الملف لم يعمل كما تفضلت ولم تتغير الشفافية

للأسف بدون توفري على جهاز فيه الويندوز 64 لن أتمكن بسهولة من معرفة سبب المشكلة ..

احدى مشاكل برمجة ال API هي تعدد اصدارات الاوفيس و الويندوز .. ان شاء الله قريبا سأتوفر على جهاز جديد يعمل على الويندوز 64 و سأقوم بتعديل كل الكودات

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

فكرة جميلة لم تخطر ببالي .. لقد تم تعديل الكود لكي يعمل في حالة وجود صورة على خلفية الفورم أو بدون

ملف للتحميل: https://app.box.com/s/6ahilnjx5zzae4ffnb8fyy3r6zwe9lgc

صورة من الشاشة:

الكود:

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

Option Explicit
Private WithEvents oAppEvents As Application

Private Sub UserForm_Initialize()
        'this bool flag is there to prevent the UserForm_Layout event from running when first activating the form
        bFlag = False
        ' hook the application events
        Set oAppEvents = Application
        Caption = "Adjustable Transparent UserForm -- (Client Area)"
        ScrollBar1.Min = 0
        ScrollBar1.Max = 255
        ScrollBar1.SmallChange = 3
        ScrollBar1.Value = ScrollBar1.Min
         bytScrollBarVal = ScrollBar1.Min
        Label1.Caption = "Transparency : " & (100 * ScrollBar1.Value \ 255) & "%"
        Application.OnTime Now, "StoreTheInitialFormBackGround"
End Sub

Private Sub UserForm_Layout()
    'Do not run the UpdateFormPicture sub when first activating the form
    If bFlag = True Then
        Call UpdateFormPicture
    End If
End Sub
  
 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call CleanUp
    Set oAppEvents = Nothing
End Sub

Private Sub ScrollBar1_Change()
    bytScrollBarVal = ScrollBar1.Value
    Call UpdateFormPicture
End Sub
Private Sub ScrollBar1_Scroll()
    bytScrollBarVal = ScrollBar1.Value
    Call UpdateFormPicture
End Sub
Private Sub CommandButton1_Click()
    Unload Me
End Sub

'Application events
Private Sub oAppEvents_SheetActivate(ByVal Sh As Object)
    Call UpdateFormPicture
End Sub
Private Sub oAppEvents_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Call UpdateFormPicture
End Sub
Private Sub oAppEvents_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
    Call UpdateFormPicture
    DoEvents
End Sub
Private Sub oAppEvents_WorkbookActivate(ByVal Wb As Workbook)
    Call UpdateFormPicture
    DoEvents
End Sub

2 - كود في ستاندار موديول:

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 Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch 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 ClientToScreen Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (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 AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length 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 GetClientRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) 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 FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function SetBkMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
Private Const PICTYPE_BITMAP = &H1
Private Const SRCCOPY = &HCC0020
Private Const AC_SRC_OVER = &H0
Private Const OPAQUE = &H2
Private Const GWL_EXSTYLE = (-20)          '
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private tRect As RECT
Private hInitialDCMemory As Long
Private frmHwnd As Long
Private frmDc As Long
Private hBrush As Long
Private hBmp As Long
Public bytScrollBarVal As Byte
Public bFlag As Boolean

Public Sub StoreTheInitialFormBackGround()
    Dim LB As LOGBRUSH
    Dim Realcolor As Long
    Dim tRed As OLE_COLOR, tGreen As OLE_COLOR, tBlue As OLE_COLOR
    
    'retrieve the form hwnd and DC
    frmHwnd = FindWindow(vbNullString, UserForm1.Caption)
    frmDc = GetDC(frmHwnd)
    'get the form's client dimensions
    GetClientRect frmHwnd, tRect
    'create a memory DC and store the initial form backColor or Background picture in it for later blending
    hInitialDCMemory = CreateCompatibleDC(frmDc)
    With tRect
        hBmp = CreateCompatibleBitmap(frmDc, .Right - .Left, .Bottom - .Top)
    End With
    Call SelectObject(hInitialDCMemory, hBmp)
    DoEvents
    'if the form has no picture set then store the form's backcolor in the memory DC
    If UserForm1.Picture Is Nothing Then
        'convert system color to RGB
        TranslateColor UserForm1.BackColor, 0, Realcolor
        tRed = Val(CStr(Realcolor And &HFF&))
        tGreen = Val(CStr((Realcolor And &HFF00&) / 2 ^ 8))
        tBlue = Val(CStr((Realcolor And &HFF0000) / 2 ^ 16))
        LB.lbColor = RGB(tRed, tGreen, tBlue)
        hBrush = CreateBrushIndirect(LB)
        SetBkMode hInitialDCMemory, OPAQUE
        FillRect hInitialDCMemory, tRect, hBrush
    Else 'if the form has a background picture then store the picture in the memory DC
        With tRect
            Call BitBlt(hInitialDCMemory, 0, 0, .Right - .Left, .Bottom - .Top, frmDc, .Left, .Top, SRCCOPY)
        End With
    End If
    'set the bool Flag to indicate that the form has already been activated
    bFlag = True
End Sub


Public Sub UpdateFormPicture()
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Dim tPt As POINTAPI
    Dim BF As BLENDFUNCTION
    Dim lBF As Long
    Dim scrDc As Long
    Dim frmClientWid As Long
    Dim frmClientHgt As Long
    Dim hDCMemory As Long
    
    'Update Label with current Transparency rate
        UserForm1.Label1.Caption = "Transparency : " & (100 * UserForm1.ScrollBar1.Value \ 255) & "%"
    'brievely make the form fully transparent in order to capture the screen area underneath the form
        SetWindowLong frmHwnd, GWL_EXSTYLE, GetWindowLong(frmHwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
        SetLayeredWindowAttributes frmHwnd, 0, 0, LWA_ALPHA
        scrDc = GetDC(0)
        SetLayeredWindowAttributes frmHwnd, 0, 255, LWA_ALPHA
    'retrieve the form's client dimensions
        GetClientRect frmHwnd, tRect
        With tRect
            frmClientWid = .Right - .Left
            frmClientHgt = .Bottom - .Top
        End With
    'create a memory DC to hold the screen area underneath the form
        hDCMemory = CreateCompatibleDC(scrDc)
        hBmp = CreateCompatibleBitmap(scrDc, frmClientWid, frmClientHgt)
        Call SelectObject(hDCMemory, hBmp)
        tPt.x = tRect.Left: tPt.Y = tRect.Top
        ClientToScreen frmHwnd, tPt
        Call BitBlt(hDCMemory, 0, 0, frmClientWid, frmClientHgt, scrDc, tPt.x, tPt.Y, SRCCOPY)
    'blend the form's initial backcolor with the screen image underneath the form
        With BF
            .BlendOp = AC_SRC_OVER
            .BlendFlags = 0
            .SourceConstantAlpha = 255 - bytScrollBarVal
            .AlphaFormat = 0
        End With
        RtlMoveMemory lBF, BF, 4
        AlphaBlend hDCMemory, 0, 0, frmClientWid, frmClientHgt, hInitialDCMemory, 0, 0, frmClientWid, frmClientHgt, lBF
    'Set the Form's Picture property to the resulting blended memory Bitmap
        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 UserForm1.Picture = IPic
    'cleanUp
        ReleaseDC frmHwnd, frmDc
        DeleteDC hDCMemory
        ReleaseDC 0, scrDc
End Sub

Public Sub CleanUp()
    DeleteObject hBrush
    DeleteObject hBmp
    bFlag = False
End Sub

الاستاد ياسر

ما هو نوع الخطأ .. هل  هو Compilation Error او  Runtime error  ...  و ما هي رسالة و رقم الخطأ اللدي يظهر