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

**مختار حسين محمود** · سبتمبر 20, 2015

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

**عبد العزيز البسكري** · سبتمبر 20, 2015

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

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

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

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

رمضان كريم.rar

**مختار حسين محمود** · سبتمبر 20, 2015

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

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

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

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

**Yasser Fathi Albanna** · سبتمبر 20, 2015

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

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

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

سبتمبر 20, 2015

السلام عليكم

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

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

**مختار حسين محمود** · سبتمبر 21, 2015

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

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

**إبراهيم ابوليله** · سبتمبر 21, 2015

اخى مختار

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

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

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

تقبل تحياتى

**مختار حسين محمود** · سبتمبر 21, 2015

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

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

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

ياسر خليل أبو البراء · سبتمبر 27, 2015

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

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

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

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

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

**مختار حسين محمود** · سبتمبر 28, 2015

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

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

ابو يوسف المصري · سبتمبر 29, 2015

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

ابوحمزه المصرى · سبتمبر 29, 2015

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

**مختار حسين محمود** · سبتمبر 30, 2015

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

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

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

**جعفر الطريبق** · أكتوبر 1, 2015

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

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

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

**عبد العزيز البسكري** · أكتوبر 1, 2015

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

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

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

**جعفر الطريبق** · أكتوبر 2, 2015

السلام عليكم

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

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** · أكتوبر 2, 2015

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

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

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

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

**عبد العزيز البسكري** · أكتوبر 2, 2015

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

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

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

**جعفر الطريبق** · أكتوبر 2, 2015

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

Message:="Showing message number :  ",

بالتاي

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

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

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

**عبد العزيز البسكري** · أكتوبر 2, 2015

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

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

**جعفر الطريبق** · أكتوبر 2, 2015

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

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

**عبد العزيز البسكري** · أكتوبر 2, 2015

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

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

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

ياسر خليل أبو البراء · أكتوبر 2, 2015

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

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

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

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

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

API Message Window Jaafar Tribak.rar

**جعفر الطريبق** · أكتوبر 3, 2015

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

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

**جعفر الطريبق** · أكتوبر 3, 2015

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

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

تسجيل الدخول

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

الردود الموصى بها

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information