عرض رسالة أو رسائل على المستخدم على فترات زمنية متقطعة

[مختار حسين محمود]

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

طبعا الرسائل العادية المعروفه لا تمكنا من ذلك خاصة وأن فيها على الأقل زر  ok فكتبت هذا الكود مستخدما اليوزر فورم لعرض رسالة على فترات زمنية متفطعة على المستخدم 

Option Explicit

Sub showUF()
 
  Dim i As Integer
  For i = 1 To 3                                                     'عدد مرات العرض
      Application.OnTime Now + TimeValue("00:00:01"), "UnloadUF"     ' مدة عرض الفورم
      UserForm1.Show
  Next i
    
End Sub

Sub UnloadUF()
  UserForm1.Hide
  Application.Wait Now + TimeValue("00:00:01")                       ' مدة اختفاء الفورم

End Sub

 

 

كيفية عرض عدة رسائل على المستخدم على فترات زمنية متقطعة   لتنفيذ هذا يلزم عدد معين من اليوزر فورم كل فورم به رسالة مختلفة
فاستخدمت أسلوب المصفوفات فى عرض هذه الرسائل على المستخدم فكان هذا الكود  الذى يعرض عددا من اليوزر فورم  زاحد تلو الآخر

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()

    iuserform = Array(UserForm1, UserForm2, UserForm3, UserForm4)
                   iuserform(X).Hide
    Application.Wait Now + TimeValue("00:00:01")
          
 
End Sub

 

تفضلوا المرفقات      كل عام وأنتم بخير

displays a timed messages on the UserForm by mokhtar.rar

displays a timed message on the UserForm by mokhtar.rar

[عبد العزيز البسكري]

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

ألف شكر أستاذي الغالي مختار حسين محمود على الملف الجميل و الفكرة الرائعة .. بارك الله فيك و زادك من علمه و فضله .. أردت فقط من باب " زيادة الخير خيرين " الاشارة إلى الملف الذي طرحته بمناسبة شهر رمضان .. طبعًا كان بعفوية لم أكن أقصد به عرض العديد من اليوزر فورمات المتتالية..  قصدت به تهنئة أساتذتي الأعزّاء الناشطين آنذاك بذلك الشّهر .. و قد كنتَ أنتَ سيّدي الكريم مختار حسين محمود من الأوائل الذين هنّأتهم .. فالملف بدون تعديل .. تفضّل الرابط :

http://www.officena.net/ib/topic/62222-هديّة-الشهر-الفضيل/

رابط الملف من جديد :

 

 

 

رمضان كريم.rar

[مختار حسين محمود]

الله الله الله  رووووعه يا زيزو  يا بسكرى   

ملف تحفة  جميلة         بجد تسلم ايدك .

هنأتنى برمضان الماضى  ولم أعرف والله الا الآن  وها أنا  أهنئك بعيد الأضحى  القادم

ان شاء الله يكون عيد خير وسعادة ومحبة عليك وعلى أهلك وعلينا وعلى كل المسلمين فى شتى أرجاء المعمورة  

[Yasser Fathi Albanna]

اخى الحبيب الغالى / مختار

فى البداية متبقاش تغيب عننا كدا تانى بهذه الأعمال الرائعة

جزاك الله خيرا أخى الفاضل

[ابو عبدالرحمن البغدادي]

السلام عليكم

شاشة عرض في غاية الروعة

عاشت الايادي على هذا العرض

 

[مختار حسين محمود]

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

أخى ابو عبدالرحمن مشكور على مرورك

[إبراهيم ابوليله]

اخى مختار

فينك ياراجل من زمان

وفيك اعمالك الحلوه

متبقاش تغيب علينا

تقبل تحياتى

[مختار حسين محمود]

أهلا أهلا بأستاذنا الغالى ابراهيم  ابو ليله  نورت الموضوع

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

كل سنة وأنت طيب يا غالى

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

بسم الله ما شاء الله عليك أخي المتميز مختار

أنا بفضل إنك متفصلش واصل بلا فواصل

 

شغلت الملف وجات الرسالة الخاصة بتحذير الانفجار ومسكت قلبي .. قلت ف بالي ربنا يستر والجهاز ميحصلوش حاجة وينفجر

ولما خلص زعلت إنه منفجرش ..كان نفسي يحصل حاجة جديدة (في انتظار التفجير في الإصدار القادم)

وعلى فكرة أنا هبلغ عنك بتهمة الإرهاب (بلاش شغل الإرهاب والتفجير والكلام ده .. عشان فيه ناس زي حالاتي بتصدق)

[مختار حسين محمود]

أهلا أهلا بأخى وأستاذى العزيز الغالى  كل سنة وأنت طيب

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

 

[ابو يوسف المصري]

كل عام وانت بخير استاذ مختار اتعرف اني اكثر واحد مبسوط بيك لانك جعلت للصعايده اهلي يد تساهم في تطوير   برمجة الاكسيل و كمان مبسوط اكتر انه الاستاذ ياسر الذي يدخل السرور لقلبي بمجرد رؤية مساهماته رجع بالسلامه فكل عام و جميع الاهل و الاحباب و الاصدقء و كل من ينبض قلبه بخير و سلام وهداية من الرحمن

[ابوحمزه المصرى]

تسلم الايادى اللى بتعمل برمجه بتنادى ... تحيه للصعايده الجدعان واولهم الاستاذ مختار

[مختار حسين محمود]

أخى العزيز  أبو يوسف المصرى  وأخى العزيز  صلاح المصرى  كل سنة وأنتما بخير

والله أنا سعيد جدا بكلامكما بحقى  و أبقى سعيد جدا جدا جدا لما بتعلم شىء جديد ومفيد  و أقدمه للزملاء فى المنتدى

شاكر مروركما الكريم   وتقبلا تحياتى

 

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

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

فقط عندي اقتراح أن يتم تفريغ الفورم من الداكرة ال  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

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

 

 

[عبد العزيز البسكري]

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

بارك الله فيك أستاذنا القدير جعفر الطريبق على اللمسة السحريّة و الإضافة المميّزة ..جزاك الله خيرًا و زادها بميزان حسناتك     

                                                           فائق احتراماتي

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

السلام عليكم

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

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

 

 

 

 

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

[Yasser Fathi Albanna]

الله عليك يا أ / جعفر

عمل أكثر من رائع

بارك الله فيك وجزاك الله خيرا وجعله فى ميزان حسناتك

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

[عبد العزيز البسكري]

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

بارك الله فيك أستاذنا الفاضل جعفر الطريبق على الفكرة الممتازة و المميّزة ..إختصارٌ للوقت و الجهد و حجم الملف .. بارك الله فيك و زادها بميزان حسناتك .. فقط لو سمحت لو أردت أن أستعرض في  هذه المساجات بوكس الكلمات مثلاً " عبد العزيز 1 " "عبد العزيز 2" "عبد العزيز 3" "عبد العزيز4" .....إلخ ..لغاية " عبد العزيز 10" ..أين و كيف أكتب ذلك في الكود لو سمحت و تكرّمت ..ألف شكر مقدّمًا.

                                                                                                                             فائق احتراماتي

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

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

Message:="Showing message number :  ", 

بالتاي

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

 

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

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

[عبد العزيز البسكري]

بارك الله فيك أستاذنا القدير جعفر الطريبق على الاجابة و الشّرح و التّوضيح .. جزاك الله خيرًا و زادها بميزان حسناتك ..فقط كنت أقصد أن يتغير الاسم برقمه .. أمّا ما تحصّلت عليه هو تغيّر الأرقام من 1 إلى 10 .. أمّا الاسم بقي ثابت .. حبّذا لو تكرّمت بجعل الاسم مع الرقم هو الذي يتغيّر بدل الأرقام .. ألف شكر مسبّقًا على تميّزك بهذه الأفكار الشيّقة .

                                                                                                              فائق احتراماتي

 

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

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

(غير حروف الاسم 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

 

 

[عبد العزيز البسكري]

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

بارك الله فيك أستاذنا القدير جعفر الطريبق على التجاوب المثمر و الفعّال .. نعم قد تم عمل المطلوب .. جزاك الله خيرًا و زادها بميزان حسناتك

                                                                                                فائق احتراماتي

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

أخي الغالي جعفر

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

جربت الملف على ويندوز 10 نظام 64 بت // أوفيس 2013 64 بت

وعدلت في الكود ليناسب نظام 64 ولكن لم يعمل الفورم معي

إليك الملف المرفق بعد التعديل

API Message Window Jaafar Tribak.rar

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

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

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

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

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

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