جعفر الطريبق

الاستاد الفاضل مختار حسين شكرا على المتابعة في بداية الماكرو 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 و نفس الأمر بالنسبة للفراغات فهو أمر مرتبط بما يريده طالب الكود أو المستخدم ... يمكن تعديل الأكواد على حسب الرغبة و على حسب عدد الحروف المطلوبة

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 ء آ أ ؤ إ ئ ا ب ة ت ث ج ح خ د ذ ر ز س ش ص ض ط ظ ع غ ف ق ك ل م ن ه و ى ي السلام عليكم يمكن تبسيط الكود باستغلال القيمة العددية للحروف : 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

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

استادي الفاضل ياسر لقد قمت بتجريب الكود على جهاز أخر في احدى محلات الانتيرنيت تحت نظام الويندوز 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 ... و ما هي رسالة و رقم الخطأ اللدي يظهر