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

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

تعبتك معي أخي الغالي جعفر

يبدو أنني سأنتظر حتى تحدث جهازك .. لنسخة  64 بت ....

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

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

السلام عليكم

أستاذى الفاضل جعفر بارك الله فيك وجزيت خيرا على هذه الاضافات القوية للموضوع

ولى سؤال : هل هناك MsgBox  بدون أى زر  زى ok  cancel   Retry  والكلام ده          و تختفى هذه الـ  MsgBox  بدون تدخل المستخدم ؟

لو كانت الاجابة بنعم برجاء ارفاق كود  للتجربة    تحياتى

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

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

جوابا على سؤالك ليس هنالك 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

 

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

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

أستاذى العزيز جعفر بارك الله فيك وجزيت خيرا على ما تقدمه لنا من خبرات وعلم نافع

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

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

أتعبتك معي .. لا عليك

الكود لم يعمل أيضاً .. لا أدري أين الخلل ؟؟؟

عموماً دعك من الأمر الآن ..يمكنني الانتظار حتى تقوم بتحديث نظام الويندوز لديك

تقبل وافر تقديري واحترامي

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

أساتذتى الأفاضل والزملاء الأعزاء

أنا الآن بصدد عمل MsgBox من النوع standrd لها أزرار نعم لكن تختفي بتدخل أو بدون تدخل المستخدم بعد فترة زمنية

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

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

السلام عليكم

تفضلوا التسخة 64 بيت ... كتبت الكود و جربته على ال Windows7 64bit  Office10  64bit 

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

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

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" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (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" (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" (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" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe 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 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&, ByVal 0, 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

 

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

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

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

ولا حرمنا الله منك أبداً ...

ولا تنسى أن تطل علينا ولو لدقائق كل يوم ، فوجودك بيننا يسعدنا كثيراً (أم أنك تستكثر هذه السعادة علينا )