مساعده في طريقه عمل اشعار عند التعديل في نموذج معين على الصفحه الرئيسيه

[Mohamed Khaled Galal]

اخواني الكرام 

اريد عمل اشعار في الصفحه الرئيسيه عند التعديل في نموذج معين سواء في الحقول ككل او حقل معين

بعد اضافه البيانات في نموذج TaskDue  والرجوع اليه لتعديل في حقل معين او كل الحقول بعد التعديل يطهر لي رساله على الشاشه الرئيسيه بانه تم تعديل في النموذج TaskDue والمعرف له لو يكن رقم 55

https://www.mediafire.com/file/djwtwr1r362t1qt/QRSystem1.rar/file

[Moosak]

نقلت لك دالة كنت صممتها في أحد برامجي لتتبع التعديلات على السجلات .. 🙂 

وهذه النتيجة :

والدالة تتابع جميع هذه العمليات : ( إضافة سجل جديد - التعديل على السجلات - حذف السجلات )

 

الدالة : 

Option Compare Database
Option Explicit


Public Enum NotificationTypeEnum
إضافة_سجل_جديد = 1
تعديل_البيانات = 2
حذف_السجل = 3
End Enum

' [NotfID], [FormName], [Type], [Action], [ByUser], [DateTime], [Done]

Public Function AddNotification(strFormName As String, NotificationType As NotificationTypeEnum, _
                                 Action As String) As Boolean
                                 
'دالة إضافة بيانات سجل التعديلات على سجلات البرنامج
 On Error GoTo Error_Handler
 
 Dim strSQL As String
 Dim UserName As String
 Dim NotfTxtType As String
 

Select Case NotificationType
    Case Is = 1: NotfTxtType = "إضافة سجل جديد"
    Case Is = 2: NotfTxtType = "تعديل البيانات"
    Case Is = 3: NotfTxtType = "حذف السجل"
End Select

AddNotification = True

UserName = Environ("UserName")

strSQL = "INSERT INTO EditsLog_T ( [FormName], [Type], [Action], [ByUser]) " & _
        " VALUES ('" & strFormName & "' ,'" & NotfTxtType & "' ,'" & Action & "' , '" & UserName & "' );"

CurrentDb.Execute strSQL

Error_Handler_Exit:
    On Error Resume Next
    
     Exit Function

Error_Handler:
   If Err.Number = 0 Then Resume Next
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Insert2History" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "Code: AddNotification"
    AddNotification = False
    Resume Error_Handler_Exit

End Function

Sub testNotf()

Debug.Print AddNotification("نموذج الحركات", تعديل_البيانات, "تفاصيل التعديل")

End Sub

الأكواد في النموذج : 

Private Function Add2History()
'دالة إضافة التعديلات لهذا النموذج

Dim strChange As String
strChange = "في السجل رقم ( " & Me.PreCode & " ) تم التعديل على الحقل( " & Screen.ActiveControl.Name & " ) مـن :  " & Screen.ActiveControl.OldValue & vbNewLine & "إلى :  " & Screen.ActiveControl.Text

'Debug.Print strChange

Call AddNotification(Me.Name, تعديل_البيانات, strChange)

End Function


Private Sub Form_AfterInsert()
AddNotification Me.Name, إضافة_سجل_جديد, "تم إضافة السجل : " & Me.PreCode

End Sub

Private Sub Form_Delete(Cancel As Integer)
AddNotification Me.Name, حذف_السجل, "تم حذف السجل : " & Me.PreCode

End Sub

ملفك بعد التعديل :

QRSystem1.zip

[Mohamed Khaled Galal]

12 ساعات مضت, Moosak said:

نقلت لك دالة كنت صممتها في أحد برامجي لتتبع التعديلات على السجلات .. 🙂 

وهذه النتيجة :

والدالة تتابع جميع هذه العمليات : ( إضافة سجل جديد - التعديل على السجلات - حذف السجلات )

 

الدالة : 

Option Compare Database
Option Explicit


Public Enum NotificationTypeEnum
إضافة_سجل_جديد = 1
تعديل_البيانات = 2
حذف_السجل = 3
End Enum

' [NotfID], [FormName], [Type], [Action], [ByUser], [DateTime], [Done]

Public Function AddNotification(strFormName As String, NotificationType As NotificationTypeEnum, _
                                 Action As String) As Boolean
                                 
'دالة إضافة بيانات سجل التعديلات على سجلات البرنامج
 On Error GoTo Error_Handler
 
 Dim strSQL As String
 Dim UserName As String
 Dim NotfTxtType As String
 

Select Case NotificationType
    Case Is = 1: NotfTxtType = "إضافة سجل جديد"
    Case Is = 2: NotfTxtType = "تعديل البيانات"
    Case Is = 3: NotfTxtType = "حذف السجل"
End Select

AddNotification = True

UserName = Environ("UserName")

strSQL = "INSERT INTO EditsLog_T ( [FormName], [Type], [Action], [ByUser]) " & _
        " VALUES ('" & strFormName & "' ,'" & NotfTxtType & "' ,'" & Action & "' , '" & UserName & "' );"

CurrentDb.Execute strSQL

Error_Handler_Exit:
    On Error Resume Next
    
     Exit Function

Error_Handler:
   If Err.Number = 0 Then Resume Next
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Insert2History" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "Code: AddNotification"
    AddNotification = False
    Resume Error_Handler_Exit

End Function

Sub testNotf()

Debug.Print AddNotification("نموذج الحركات", تعديل_البيانات, "تفاصيل التعديل")

End Sub

الأكواد في النموذج : 

Private Function Add2History()
'دالة إضافة التعديلات لهذا النموذج

Dim strChange As String
strChange = "في السجل رقم ( " & Me.PreCode & " ) تم التعديل على الحقل( " & Screen.ActiveControl.Name & " ) مـن :  " & Screen.ActiveControl.OldValue & vbNewLine & "إلى :  " & Screen.ActiveControl.Text

'Debug.Print strChange

Call AddNotification(Me.Name, تعديل_البيانات, strChange)

End Function


Private Sub Form_AfterInsert()
AddNotification Me.Name, إضافة_سجل_جديد, "تم إضافة السجل : " & Me.PreCode

End Sub

Private Sub Form_Delete(Cancel As Integer)
AddNotification Me.Name, حذف_السجل, "تم حذف السجل : " & Me.PreCode

End Sub

ملفك بعد التعديل :

QRSystem1.zip 2.33 \u0645\u064a\u062c\u0627 \u0628\u0627\u064a\u062a · 3 downloads

متشكر جدا اخي الكريم على دعمك الدائم ولكن كنت اريد عمل اشعار من نوع pop up  بحيث المدير يعلم بحدوث التغيير الذي يقوم به الموظف لحظيا

[Moosak]

14 دقائق مضت, Mohamed Khaled Galal said:

ولكن كنت اريد عمل اشعار من نوع pop up  بحيث المدير يعلم بحدوث التغيير الذي يقوم به الموظف لحظيا

الآن لديك جدول به كل التعديلات .. يمكنك الآن إضافة الطريقة التي تناسبك لعرض هذه الإشعارات كيفما تشاء 🙂 

[Mohamed Khaled Galal]

19 دقائق مضت, Moosak said:

الآن لديك جدول به كل التعديلات .. يمكنك الآن إضافة الطريقة التي تناسبك لعرض هذه الإشعارات كيفما تشاء 🙂 

متشكر جدا اخي الكريم

[Moosak]

 

هذه أحد الطرق من مكتبتي :

 

*إظهار رسالة إشعار فوق شريط الويندوز Show Balloon Tooltip*

وهناك ملف مرفق كمثال ..

شكل الرسالة :

*شرح الكود:*
نظام إشعارات أو رسائل فوق شريط الويندوز ..
يمكن وضعها عند أي حدث تريد أو عند زر أمر أو .. أو .. أو .. أو ..
ويمكنك تغيير الأيقونة التي تظهر جنب الرسالة والأيقونة التي تظهر برأس الرسالة كذلك

*الكود:*
' قم بنقل الموديول والكلاس الموجدان في الملف المرفق إلى برنامجك ومن ثم تضبط رسالتك بالطريقة المذكورة في الأسفل، أو انسخ  الأكواد من هنا كاتالي :
' أضف موديول جديد باسم Mod_Balloon_Msg 
' وألصق فيه الكود التالي:
'=================================

Option Compare Database

Dim bt As CLS_BALLOON_MSG

Public Enum btIcon
    btNone
    btInformation
    btWarning
    btCritical
End Enum

Public Function ShowBalloonTooltip(strHeading As String, strMessage As String, lngIcon As btIcon)
    'Wrapper function to call the class so it can be called from an add-in code library
    Set bt = New CLS_BALLOON_MSG
    With bt
        .Heading = strHeading
        .Message = strMessage
        .Icon = lngIcon
        .Show
    End With
End Function

Public Function HideIcon()
    If Not bt Is Nothing Then
        With bt
            .Hide
        End With
    End If
End Function

'=====================(تم أنشيء موديول من نوع كلاس Class واسمه :)==(Mod_Balloon_Msg)==( وألصق فيه التالي:)

Option Compare Database
Option Explicit

Private mlngIcon As Long
Private mstrHeading As String
Private mstrMessage As String

Private Const APP_SYSTRAY_ID = 999

Private Const NOTIFYICON_VERSION = &H3

Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const NIF_STATE = &H8
Private Const NIF_INFO = &H10

Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIM_SETFOCUS = &H3
Private Const NIM_SETVERSION = &H4
Private Const NIM_VERSION = &H5

Private Const NIS_HIDDEN = &H1
Private Const NIS_SHAREDICON = &H2

Private Const NIIF_NONE = &H0
Private Const NIIF_INFO = &H1
Private Const NIIF_WARNING = &H2
Private Const NIIF_ERROR = &H3
Private Const NIIF_GUID = &H5
Private Const NIIF_ICON_MASK = &HF
Private Const NIIF_NOSOUND = &H10
   
Private Const WM_USER = &H400
Private Const NIN_BALLOONSHOW = (WM_USER + 2)
Private Const NIN_BALLOONHIDE = (WM_USER + 3)
Private Const NIN_BALLOONTIMEOUT = (WM_USER + 4)
Private Const NIN_BALLOONUSERCLICK = (WM_USER + 5)

Private Const NOTIFYICONDATA_V1_SIZE As Long = 88
Private Const NOTIFYICONDATA_V2_SIZE As Long = 488
Private Const NOTIFYICONDATA_V3_SIZE As Long = 504
Private NOTIFYICONDATA_SIZE As Long

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type

'API updated by Colin Riddington - Oct 2018
#If VBA7 Then
    Private Type NOTIFYICONDATA
      cbSize As Long
      hWnd As LongPtr
      uId As Long
      uFlags As Long
      uCallbackMessage As Long
      hIcon As LongPtr
      szTip As String * 128
      dwState As Long
      dwStateMask As Long
      szInfo As String * 256
      uTimeoutAndVersion As Long
      szInfoTitle As String * 64
      dwInfoFlags As Long
      guidItem As GUID
    End Type
#Else
    Private Type NOTIFYICONDATA
      cbSize As Long
      hWnd As Long
      uId As Long
      uFlags As Long
      uCallbackMessage As Long
      hIcon As Long
      szTip As String * 128
      dwState As Long
      dwStateMask As Long
      szInfo As String * 256
      uTimeoutAndVersion As Long
      szInfoTitle As String * 64
      dwInfoFlags As Long
      guidItem As GUID
#End If

'APIs to handle system notifications
#If VBA7 Then
    'https://learn.microsoft.com/en-us/windows/win32/api/shellapi/nf-shellapi-shell_notifyicona
    'Sends a message to the taskbar's status area.
    Private Declare PtrSafe Function Shell_NotifyIcon Lib "shell32.dll" _
       Alias "Shell_NotifyIconA" _
      (ByVal dwMessage As LongPtr, _
       lpData As NOTIFYICONDATA) As LongPtr
    
    'https://learn.microsoft.com/en-us/windows/win32/api/winver/nf-winver-getfileversioninfosizea
    'Determines whether the operating system can retrieve version information for a specified file.
    'If version information is available, GetFileVersionInfoSize returns the size, in bytes, of that information.
    Private Declare PtrSafe Function GetFileVersionInfoSize Lib "version.dll" _
       Alias "GetFileVersionInfoSizeA" _
      (ByVal lptstrFilename As String, _
       lpdwHandle As Long) As Long
    
    'https://learn.microsoft.com/en-us/windows/win32/api/winver/nf-winver-getfileversioninfoa
    'Retrieves version information for the specified file.
    Private Declare PtrSafe Function GetFileVersionInfo Lib "version.dll" _
       Alias "GetFileVersionInfoA" _
      (ByVal lptstrFilename As String, _
       ByVal dwHandle As LongPtr, _
       ByVal dwLen As LongPtr, _
       lpData As Any) As Long
       
     'https://learn.microsoft.com/en-us/windows/win32/api/winver/nf-winver-verqueryvaluea
     'Retrieves specified version information from the specified version-information resource.
     'To retrieve the appropriate resource, before you call VerQueryValue, you must first call the GetFileVersionInfoSize function, and then the GetFileVersionInfo function.
    Private Declare PtrSafe Function VerQueryValue Lib "version.dll" _
       Alias "VerQueryValueA" _
      (pBlock As Any, _
       ByVal lpSubBlock As String, _
       lpBuffer As Any, _
       nVerSize As Long) As LongPtr
    
    'https://learn.microsoft.com/en-us/previous-versions/windows/desktop/legacy/aa366535(v=vs.85)
    'Copies a block of memory from one location to another.
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
       Alias "RtlMoveMemory" _
      (Destination As Any, _
       Source As Any, _
       ByVal Length As LongPtr)
#Else
    Private Declare Function Shell_NotifyIcon Lib "shell32.dll" _
       Alias "Shell_NotifyIconA" _
      (ByVal dwMessage As Long, _
       lpData As NOTIFYICONDATA) As Long
    
    Private Declare Function GetFileVersionInfoSize Lib "version.dll" _
       Alias "GetFileVersionInfoSizeA" _
      (ByVal lptstrFilename As String, _
       lpdwHandle As Long) As Long
    
    Private Declare Function GetFileVersionInfo Lib "version.dll" _
       Alias "GetFileVersionInfoA" _
      (ByVal lptstrFilename As String, _
       ByVal dwHandle As Long, _
       ByVal dwLen As Long, _
       lpData As Any) As Long
       
    Private Declare Function VerQueryValue Lib "version.dll" _
       Alias "VerQueryValueA" _
      (pBlock As Any, _
       ByVal lpSubBlock As String, _
       lpBuffer As Any, _
       nVerSize As Long) As Long
    
    Private Declare Sub CopyMemory Lib "kernel32" _
       Alias "RtlMoveMemory" _
      (Destination As Any, _
       Source As Any, _
       ByVal Length As Long)
#End If

Private Const WM_GETICON = &H7F
                                 
Private Const WM_SETICON = &H80
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
Private Const LR_LOADFROMFILE = &H10
                                          
Private Const ICON_SMALL = 0&
Private Const ICON_BIG = 1&

#If VBA7 Then
    'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-loadimagea
    'Loads an icon, cursor, animated cursor, or bitmap.
    Private Declare PtrSafe Function apiLoadImage Lib "user32" _
       Alias "LoadImageA" _
       (ByVal hInst As LongPtr, _
       ByVal lpszName As String, _
       ByVal uType As LongPtr, _
       ByVal cxDesired As LongPtr, _
       ByVal cyDesired As LongPtr, _
       ByVal fuLoad As LongPtr) _
       As Long
    
    'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-sendmessagea
    'Sends the specified message to a window or windows.
    'The SendMessage function calls the window procedure for the specified window and does not return until the window procedure has processed the message.
    Private Declare PtrSafe Function apiSendMessageLong Lib "user32" _
       Alias "SendMessageA" _
       (ByVal hWnd As LongPtr, _
       ByVal wMsg As Long, _
       ByVal wParam As LongPtr, _
       ByVal lParam As LongPtr) _
       As LongPtr
#Else
    Private Declare Function apiLoadImage Lib "user32" _
       Alias "LoadImageA" _
       (ByVal hInst As Long, _
       ByVal lpszName As String, _
       ByVal uType As Long, _
       ByVal cxDesired As Long, _
       ByVal cyDesired As Long, _
       ByVal fuLoad As Long) _
       As Long
    
    Private Declare Function apiSendMessageLong Lib "user32" _
       Alias "SendMessageA" _
       (ByVal hWnd As Long, _
       ByVal wMsg As Long, _
       ByVal wParam As Long, _
       ByVal lParam As Long) _
       As Long
#End If

Private Const SHGFI_ICON = &H100
Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_TYPENAME = &H400
Private Const SHGFI_ATTRIBUTES = &H800
Private Const SHGFI_ICONLOCATION = &H1000

Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const MAX_PATH = 260

Private Type SHFILEINFO
   hIcon As Long
   iIcon As Long
   dwAttributes As Long
   szDisplayName As String * MAX_PATH
   szTypeName As String * 80
End Type

#If VBA7 Then
    'https://learn.microsoft.com/en-us/windows/win32/api/shellapi/nf-shellapi-shgetfileinfoa
    'Retrieves information about an object in the file system, such as a file, folder, directory, or drive root.
    Private Declare PtrSafe Function apiSHGetFileInfo Lib "shell32.dll" _
       Alias "SHGetFileInfoA" _
       (ByVal pszPath As String, _
        ByVal dwFileAttributes As LongPtr, _
        psfi As SHFILEINFO, _
        ByVal cbSizeFileInfo As LongPtr, _
        ByVal uFlags As LongPtr) _
        As LongPtr
            
     'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-destroyicon
    'Destroys an icon and frees any memory the icon occupied.
    Private Declare PtrSafe Function apiDestroyIcon Lib "user32" _
       Alias "DestroyIcon" _
       (ByVal hIcon As LongPtr) _
       As LongPtr
#Else
    Private Declare Function apiSHGetFileInfo Lib "shell32.dll" _
       Alias "SHGetFileInfoA" _
       (ByVal pszPath As String, _
        ByVal dwFileAttributes As Long, _
        psfi As SHFILEINFO, _
        ByVal cbSizeFileInfo As Long, _
        ByVal uFlags As Long) _
        As Long
            
    Private Declare Function apiDestroyIcon Lib "user32" _
       Alias "DestroyIcon" _
       (ByVal hIcon As Long) _
       As Long
#End If

Private psfi As SHFILEINFO

Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3

#If VBA7 Then
    'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-showwindow
    'Sets the specified window's show state e.g. normal/maximized/minimized/restore
    Private Declare PtrSafe Function apiShowWindow Lib "user32" _
       Alias "ShowWindow" _
       (ByVal hWnd As LongPtr, _
       ByVal nCmdShow As LongPtr) _
       As LongPtr
#Else
    Private Declare Function apiShowWindow Lib "user32" _
       Alias "ShowWindow" _
       (ByVal hWnd As Long, _
       ByVal nCmdShow As Long) _
       As Long
#End If

Private Sub ShellTrayAdd()
   
   Dim nID As NOTIFYICONDATA
   
   If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion
   
   With nID
   
      .cbSize = NOTIFYICONDATA_SIZE
      .hWnd = Application.hWndAccessApp
      
      .uId = APP_SYSTRAY_ID
      .uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
      .dwState = NIS_SHAREDICON
      .hIcon = fSetIcon(GetAppIcon)
      
      .szTip = "DHLGM Message Service" & vbNullChar
      .uTimeoutAndVersion = NOTIFYICON_VERSION
      
   End With
   
   Call Shell_NotifyIcon(NIM_ADD, nID)
   
   Call Shell_NotifyIcon(NIM_SETVERSION, nID)
       
End Sub

Private Sub ShellTrayRemove()

   Dim nID As NOTIFYICONDATA
   
   If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion
      
   With nID
      .cbSize = NOTIFYICONDATA_SIZE
      .hWnd = Application.hWndAccessApp
      .uId = APP_SYSTRAY_ID
   End With
   
   Call Shell_NotifyIcon(NIM_DELETE, nID)
   Call apiDestroyIcon(nID.hIcon)
End Sub

Private Sub ShellTrayModifyTip(nIconIndex As Long)

   Dim nID As NOTIFYICONDATA

   If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion
   
   With nID
      .cbSize = NOTIFYICONDATA_SIZE
      .hWnd = Application.hWndAccessApp
      .uId = APP_SYSTRAY_ID
      .uFlags = NIF_INFO
      .dwInfoFlags = nIconIndex
      
      .szInfoTitle = mstrHeading & vbNullChar
      .szInfo = mstrMessage & vbNullChar
   End With

   Call Shell_NotifyIcon(NIM_MODIFY, nID)

End Sub

Private Sub SetShellVersion()

   Select Case True
      Case IsShellVersion(6)
         NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V3_SIZE
      
      Case IsShellVersion(5)
         NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V2_SIZE
      
      Case Else
         NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V1_SIZE
   End Select

End Sub

#If VBA7 Then
    Private Function IsShellVersion(ByVal Version As LongPtr) As Boolean
    Dim lpBuffer As LongPtr
#Else
    Private Function IsShellVersion(ByVal Version As Long) As Boolean
    Dim lpBuffer As Long
#End If

   Dim nBufferSize As Long
   Dim nUnused As Long
   'Dim lpBuffer As Long
   Dim nVerMajor As Integer
   Dim bBuffer() As Byte
   
   Const sDLLFile As String = "shell32.dll"
   
   nBufferSize = GetFileVersionInfoSize(sDLLFile, nUnused)
   
   If nBufferSize > 0 Then
    
      ReDim bBuffer(nBufferSize - 1) As Byte
    
      Call GetFileVersionInfo(sDLLFile, 0&, nBufferSize, bBuffer(0))
    
      If VerQueryValue(bBuffer(0), "\", lpBuffer, nUnused) = 1 Then
         
         CopyMemory nVerMajor, ByVal lpBuffer + 10, 2
        
         IsShellVersion = nVerMajor >= Version
      
      End If
    
   End If
  
End Function

Private Function GetSelectedOptionIndex() As Long

    GetSelectedOptionIndex = 2
                            
End Function

Public Property Get Icon() As btIcon
    Icon = mlngIcon
End Property

Public Property Let Icon(ByVal lngIcon As btIcon)
    mlngIcon = lngIcon
End Property

Public Property Get Heading() As String
    Heading = mstrHeading
End Property

Public Property Let Heading(ByVal strHeading As String)
    mstrHeading = strHeading
End Property

Public Property Get Message() As String
    Message = mstrMessage
End Property

Public Property Let Message(ByVal strMessage As String)
    mstrMessage = strMessage
End Property

Public Sub Show()
       Call ShellTrayAdd
       ShellTrayModifyTip mlngIcon
End Sub

Public Sub Hide()
   ShellTrayRemove
End Sub

Private Function fSetIcon(strIconPath As String) As Long
Dim hIcon As Long
   hIcon = apiLoadImage(0&, strIconPath, IMAGE_ICON, 16&, 16&, LR_LOADFROMFILE)
   If hIcon Then
      fSetIcon = hIcon
   End If
End Function

Public Function GetAppIcon() As String
    Dim dbs As DAO.Database, prp As Property
    Const conPropNotFoundError = 3270
    On Error GoTo GetAppIcon_Error
   
    Beep
    Set dbs = CurrentDb
    GetAppIcon = dbs.Properties("AppIcon")

ExitHere:
   Exit Function

GetAppIcon_Error:

    Select Case Err.Number
    Case 3270 'PropertyC Not Found
        'db doesn't have an associated icon - no message needed
       ' MsgBox "Current Database needs to have a custom icon", vbCritical, "No Icon Found"
        Resume ExitHere
    Case Else
        MsgBox "An Unexpected Error has occured please inform IT Support Error " & Err.Number & " " & Err.Description & " in procedure GetAppIcon of Class Module BalloonTooltip", vbCritical, "db2"
        Resume ExitHere
    End Select
    'Debug Only
    Resume

End Function

*طريقة الاستدعاء (الاستخدام):*

ShowBalloonTooltip "عنوان الرسالة", "نص الرسالة", btInformation

msg Balloon.accdb

[Mohamed Khaled Galal]

16 دقائق مضت, Moosak said:

 

هذه أحد الطرق من مكتبتي :

 

*إظهار رسالة إشعار فوق شريط الويندوز Show Balloon Tooltip*

وهناك ملف مرفق كمثال ..

شكل الرسالة :

*شرح الكود:*
نظام إشعارات أو رسائل فوق شريط الويندوز ..
يمكن وضعها عند أي حدث تريد أو عند زر أمر أو .. أو .. أو .. أو ..
ويمكنك تغيير الأيقونة التي تظهر جنب الرسالة والأيقونة التي تظهر برأس الرسالة كذلك*الكود:*
' قم بنقل الموديول والكلاس الموجدان في الملف المرفق إلى برنامجك ومن ثم تضبط رسالتك بالطريقة المذكورة في الأسفل، أو انسخ  الأكواد من هنا كاتالي :
' أضف موديول جديد باسم Mod_Balloon_Msg 
' وألصق فيه الكود التالي:
'=================================

Option Compare Database

Dim bt As CLS_BALLOON_MSG

Public Enum btIcon
    btNone
    btInformation
    btWarning
    btCritical
End Enum

Public Function ShowBalloonTooltip(strHeading As String, strMessage As String, lngIcon As btIcon)
    'Wrapper function to call the class so it can be called from an add-in code library
    Set bt = New CLS_BALLOON_MSG
    With bt
        .Heading = strHeading
        .Message = strMessage
        .Icon = lngIcon
        .Show
    End With
End Function

Public Function HideIcon()
    If Not bt Is Nothing Then
        With bt
            .Hide
        End With
    End If
End Function

'=====================(تم أنشيء موديول من نوع كلاس Class واسمه :)==(Mod_Balloon_Msg)==( وألصق فيه التالي:)

Option Compare Database
Option Explicit

Private mlngIcon As Long
Private mstrHeading As String
Private mstrMessage As String

Private Const APP_SYSTRAY_ID = 999

Private Const NOTIFYICON_VERSION = &H3

Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const NIF_STATE = &H8
Private Const NIF_INFO = &H10

Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIM_SETFOCUS = &H3
Private Const NIM_SETVERSION = &H4
Private Const NIM_VERSION = &H5

Private Const NIS_HIDDEN = &H1
Private Const NIS_SHAREDICON = &H2

Private Const NIIF_NONE = &H0
Private Const NIIF_INFO = &H1
Private Const NIIF_WARNING = &H2
Private Const NIIF_ERROR = &H3
Private Const NIIF_GUID = &H5
Private Const NIIF_ICON_MASK = &HF
Private Const NIIF_NOSOUND = &H10
   
Private Const WM_USER = &H400
Private Const NIN_BALLOONSHOW = (WM_USER + 2)
Private Const NIN_BALLOONHIDE = (WM_USER + 3)
Private Const NIN_BALLOONTIMEOUT = (WM_USER + 4)
Private Const NIN_BALLOONUSERCLICK = (WM_USER + 5)

Private Const NOTIFYICONDATA_V1_SIZE As Long = 88
Private Const NOTIFYICONDATA_V2_SIZE As Long = 488
Private Const NOTIFYICONDATA_V3_SIZE As Long = 504
Private NOTIFYICONDATA_SIZE As Long

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type

'API updated by Colin Riddington - Oct 2018
#If VBA7 Then
    Private Type NOTIFYICONDATA
      cbSize As Long
      hWnd As LongPtr
      uId As Long
      uFlags As Long
      uCallbackMessage As Long
      hIcon As LongPtr
      szTip As String * 128
      dwState As Long
      dwStateMask As Long
      szInfo As String * 256
      uTimeoutAndVersion As Long
      szInfoTitle As String * 64
      dwInfoFlags As Long
      guidItem As GUID
    End Type
#Else
    Private Type NOTIFYICONDATA
      cbSize As Long
      hWnd As Long
      uId As Long
      uFlags As Long
      uCallbackMessage As Long
      hIcon As Long
      szTip As String * 128
      dwState As Long
      dwStateMask As Long
      szInfo As String * 256
      uTimeoutAndVersion As Long
      szInfoTitle As String * 64
      dwInfoFlags As Long
      guidItem As GUID
#End If

'APIs to handle system notifications
#If VBA7 Then
    'https://learn.microsoft.com/en-us/windows/win32/api/shellapi/nf-shellapi-shell_notifyicona
    'Sends a message to the taskbar's status area.
    Private Declare PtrSafe Function Shell_NotifyIcon Lib "shell32.dll" _
       Alias "Shell_NotifyIconA" _
      (ByVal dwMessage As LongPtr, _
       lpData As NOTIFYICONDATA) As LongPtr
    
    'https://learn.microsoft.com/en-us/windows/win32/api/winver/nf-winver-getfileversioninfosizea
    'Determines whether the operating system can retrieve version information for a specified file.
    'If version information is available, GetFileVersionInfoSize returns the size, in bytes, of that information.
    Private Declare PtrSafe Function GetFileVersionInfoSize Lib "version.dll" _
       Alias "GetFileVersionInfoSizeA" _
      (ByVal lptstrFilename As String, _
       lpdwHandle As Long) As Long
    
    'https://learn.microsoft.com/en-us/windows/win32/api/winver/nf-winver-getfileversioninfoa
    'Retrieves version information for the specified file.
    Private Declare PtrSafe Function GetFileVersionInfo Lib "version.dll" _
       Alias "GetFileVersionInfoA" _
      (ByVal lptstrFilename As String, _
       ByVal dwHandle As LongPtr, _
       ByVal dwLen As LongPtr, _
       lpData As Any) As Long
       
     'https://learn.microsoft.com/en-us/windows/win32/api/winver/nf-winver-verqueryvaluea
     'Retrieves specified version information from the specified version-information resource.
     'To retrieve the appropriate resource, before you call VerQueryValue, you must first call the GetFileVersionInfoSize function, and then the GetFileVersionInfo function.
    Private Declare PtrSafe Function VerQueryValue Lib "version.dll" _
       Alias "VerQueryValueA" _
      (pBlock As Any, _
       ByVal lpSubBlock As String, _
       lpBuffer As Any, _
       nVerSize As Long) As LongPtr
    
    'https://learn.microsoft.com/en-us/previous-versions/windows/desktop/legacy/aa366535(v=vs.85)
    'Copies a block of memory from one location to another.
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
       Alias "RtlMoveMemory" _
      (Destination As Any, _
       Source As Any, _
       ByVal Length As LongPtr)
#Else
    Private Declare Function Shell_NotifyIcon Lib "shell32.dll" _
       Alias "Shell_NotifyIconA" _
      (ByVal dwMessage As Long, _
       lpData As NOTIFYICONDATA) As Long
    
    Private Declare Function GetFileVersionInfoSize Lib "version.dll" _
       Alias "GetFileVersionInfoSizeA" _
      (ByVal lptstrFilename As String, _
       lpdwHandle As Long) As Long
    
    Private Declare Function GetFileVersionInfo Lib "version.dll" _
       Alias "GetFileVersionInfoA" _
      (ByVal lptstrFilename As String, _
       ByVal dwHandle As Long, _
       ByVal dwLen As Long, _
       lpData As Any) As Long
       
    Private Declare Function VerQueryValue Lib "version.dll" _
       Alias "VerQueryValueA" _
      (pBlock As Any, _
       ByVal lpSubBlock As String, _
       lpBuffer As Any, _
       nVerSize As Long) As Long
    
    Private Declare Sub CopyMemory Lib "kernel32" _
       Alias "RtlMoveMemory" _
      (Destination As Any, _
       Source As Any, _
       ByVal Length As Long)
#End If

Private Const WM_GETICON = &H7F
                                 
Private Const WM_SETICON = &H80
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
Private Const LR_LOADFROMFILE = &H10
                                          
Private Const ICON_SMALL = 0&
Private Const ICON_BIG = 1&

#If VBA7 Then
    'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-loadimagea
    'Loads an icon, cursor, animated cursor, or bitmap.
    Private Declare PtrSafe Function apiLoadImage Lib "user32" _
       Alias "LoadImageA" _
       (ByVal hInst As LongPtr, _
       ByVal lpszName As String, _
       ByVal uType As LongPtr, _
       ByVal cxDesired As LongPtr, _
       ByVal cyDesired As LongPtr, _
       ByVal fuLoad As LongPtr) _
       As Long
    
    'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-sendmessagea
    'Sends the specified message to a window or windows.
    'The SendMessage function calls the window procedure for the specified window and does not return until the window procedure has processed the message.
    Private Declare PtrSafe Function apiSendMessageLong Lib "user32" _
       Alias "SendMessageA" _
       (ByVal hWnd As LongPtr, _
       ByVal wMsg As Long, _
       ByVal wParam As LongPtr, _
       ByVal lParam As LongPtr) _
       As LongPtr
#Else
    Private Declare Function apiLoadImage Lib "user32" _
       Alias "LoadImageA" _
       (ByVal hInst As Long, _
       ByVal lpszName As String, _
       ByVal uType As Long, _
       ByVal cxDesired As Long, _
       ByVal cyDesired As Long, _
       ByVal fuLoad As Long) _
       As Long
    
    Private Declare Function apiSendMessageLong Lib "user32" _
       Alias "SendMessageA" _
       (ByVal hWnd As Long, _
       ByVal wMsg As Long, _
       ByVal wParam As Long, _
       ByVal lParam As Long) _
       As Long
#End If

Private Const SHGFI_ICON = &H100
Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_TYPENAME = &H400
Private Const SHGFI_ATTRIBUTES = &H800
Private Const SHGFI_ICONLOCATION = &H1000

Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const MAX_PATH = 260

Private Type SHFILEINFO
   hIcon As Long
   iIcon As Long
   dwAttributes As Long
   szDisplayName As String * MAX_PATH
   szTypeName As String * 80
End Type

#If VBA7 Then
    'https://learn.microsoft.com/en-us/windows/win32/api/shellapi/nf-shellapi-shgetfileinfoa
    'Retrieves information about an object in the file system, such as a file, folder, directory, or drive root.
    Private Declare PtrSafe Function apiSHGetFileInfo Lib "shell32.dll" _
       Alias "SHGetFileInfoA" _
       (ByVal pszPath As String, _
        ByVal dwFileAttributes As LongPtr, _
        psfi As SHFILEINFO, _
        ByVal cbSizeFileInfo As LongPtr, _
        ByVal uFlags As LongPtr) _
        As LongPtr
            
     'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-destroyicon
    'Destroys an icon and frees any memory the icon occupied.
    Private Declare PtrSafe Function apiDestroyIcon Lib "user32" _
       Alias "DestroyIcon" _
       (ByVal hIcon As LongPtr) _
       As LongPtr
#Else
    Private Declare Function apiSHGetFileInfo Lib "shell32.dll" _
       Alias "SHGetFileInfoA" _
       (ByVal pszPath As String, _
        ByVal dwFileAttributes As Long, _
        psfi As SHFILEINFO, _
        ByVal cbSizeFileInfo As Long, _
        ByVal uFlags As Long) _
        As Long
            
    Private Declare Function apiDestroyIcon Lib "user32" _
       Alias "DestroyIcon" _
       (ByVal hIcon As Long) _
       As Long
#End If

Private psfi As SHFILEINFO

Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3

#If VBA7 Then
    'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-showwindow
    'Sets the specified window's show state e.g. normal/maximized/minimized/restore
    Private Declare PtrSafe Function apiShowWindow Lib "user32" _
       Alias "ShowWindow" _
       (ByVal hWnd As LongPtr, _
       ByVal nCmdShow As LongPtr) _
       As LongPtr
#Else
    Private Declare Function apiShowWindow Lib "user32" _
       Alias "ShowWindow" _
       (ByVal hWnd As Long, _
       ByVal nCmdShow As Long) _
       As Long
#End If

Private Sub ShellTrayAdd()
   
   Dim nID As NOTIFYICONDATA
   
   If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion
   
   With nID
   
      .cbSize = NOTIFYICONDATA_SIZE
      .hWnd = Application.hWndAccessApp
      
      .uId = APP_SYSTRAY_ID
      .uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
      .dwState = NIS_SHAREDICON
      .hIcon = fSetIcon(GetAppIcon)
      
      .szTip = "DHLGM Message Service" & vbNullChar
      .uTimeoutAndVersion = NOTIFYICON_VERSION
      
   End With
   
   Call Shell_NotifyIcon(NIM_ADD, nID)
   
   Call Shell_NotifyIcon(NIM_SETVERSION, nID)
       
End Sub

Private Sub ShellTrayRemove()

   Dim nID As NOTIFYICONDATA
   
   If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion
      
   With nID
      .cbSize = NOTIFYICONDATA_SIZE
      .hWnd = Application.hWndAccessApp
      .uId = APP_SYSTRAY_ID
   End With
   
   Call Shell_NotifyIcon(NIM_DELETE, nID)
   Call apiDestroyIcon(nID.hIcon)
End Sub

Private Sub ShellTrayModifyTip(nIconIndex As Long)

   Dim nID As NOTIFYICONDATA

   If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion
   
   With nID
      .cbSize = NOTIFYICONDATA_SIZE
      .hWnd = Application.hWndAccessApp
      .uId = APP_SYSTRAY_ID
      .uFlags = NIF_INFO
      .dwInfoFlags = nIconIndex
      
      .szInfoTitle = mstrHeading & vbNullChar
      .szInfo = mstrMessage & vbNullChar
   End With

   Call Shell_NotifyIcon(NIM_MODIFY, nID)

End Sub

Private Sub SetShellVersion()

   Select Case True
      Case IsShellVersion(6)
         NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V3_SIZE
      
      Case IsShellVersion(5)
         NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V2_SIZE
      
      Case Else
         NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V1_SIZE
   End Select

End Sub

#If VBA7 Then
    Private Function IsShellVersion(ByVal Version As LongPtr) As Boolean
    Dim lpBuffer As LongPtr
#Else
    Private Function IsShellVersion(ByVal Version As Long) As Boolean
    Dim lpBuffer As Long
#End If

   Dim nBufferSize As Long
   Dim nUnused As Long
   'Dim lpBuffer As Long
   Dim nVerMajor As Integer
   Dim bBuffer() As Byte
   
   Const sDLLFile As String = "shell32.dll"
   
   nBufferSize = GetFileVersionInfoSize(sDLLFile, nUnused)
   
   If nBufferSize > 0 Then
    
      ReDim bBuffer(nBufferSize - 1) As Byte
    
      Call GetFileVersionInfo(sDLLFile, 0&, nBufferSize, bBuffer(0))
    
      If VerQueryValue(bBuffer(0), "\", lpBuffer, nUnused) = 1 Then
         
         CopyMemory nVerMajor, ByVal lpBuffer + 10, 2
        
         IsShellVersion = nVerMajor >= Version
      
      End If
    
   End If
  
End Function

Private Function GetSelectedOptionIndex() As Long

    GetSelectedOptionIndex = 2
                            
End Function

Public Property Get Icon() As btIcon
    Icon = mlngIcon
End Property

Public Property Let Icon(ByVal lngIcon As btIcon)
    mlngIcon = lngIcon
End Property

Public Property Get Heading() As String
    Heading = mstrHeading
End Property

Public Property Let Heading(ByVal strHeading As String)
    mstrHeading = strHeading
End Property

Public Property Get Message() As String
    Message = mstrMessage
End Property

Public Property Let Message(ByVal strMessage As String)
    mstrMessage = strMessage
End Property

Public Sub Show()
       Call ShellTrayAdd
       ShellTrayModifyTip mlngIcon
End Sub

Public Sub Hide()
   ShellTrayRemove
End Sub

Private Function fSetIcon(strIconPath As String) As Long
Dim hIcon As Long
   hIcon = apiLoadImage(0&, strIconPath, IMAGE_ICON, 16&, 16&, LR_LOADFROMFILE)
   If hIcon Then
      fSetIcon = hIcon
   End If
End Function

Public Function GetAppIcon() As String
    Dim dbs As DAO.Database, prp As Property
    Const conPropNotFoundError = 3270
    On Error GoTo GetAppIcon_Error
   
    Beep
    Set dbs = CurrentDb
    GetAppIcon = dbs.Properties("AppIcon")

ExitHere:
   Exit Function

GetAppIcon_Error:

    Select Case Err.Number
    Case 3270 'PropertyC Not Found
        'db doesn't have an associated icon - no message needed
       ' MsgBox "Current Database needs to have a custom icon", vbCritical, "No Icon Found"
        Resume ExitHere
    Case Else
        MsgBox "An Unexpected Error has occured please inform IT Support Error " & Err.Number & " " & Err.Description & " in procedure GetAppIcon of Class Module BalloonTooltip", vbCritical, "db2"
        Resume ExitHere
    End Select
    'Debug Only
    Resume

End Function

*طريقة الاستدعاء (الاستخدام):*

ShowBalloonTooltip "عنوان الرسالة", "نص الرسالة", btInformation

msg Balloon.accdb 504 kB · 1 download

بارك الله فيك اخي الكريم