Mohamed Khaled Galal

28 دقائق مضت, شايب said:

اخي الفاضل انا ماني فاهم هل انتهت مشكلتك ؟

انتهت مشكلتي في النموذج التقليدي ولاكن انا اريد ان اطبق هذا الكود بداخل نموذج به Child كما في الصوره 

مرفق لك اخي قاعده البيانات

https://www.mediafire.com/file/7q9qj29k8xsbin1/QRSystemManagerFinal.accdb/file

وهذا هو الكود النهائي ولكن اريد ان اضيف عليه الChild لان مربع نص التحقق بداخله وليس في النموذج الرئيسي

Dim fieldValue As String
    fieldValue = Me.BundleCode.Value

    If Not IsNull(DLookup("[BundleCode]", "BundleDataINCutting", "[BundleCode] =" & Me.BundleCode.Value)) Then
           
    Else
    
   MsgBox "هذا البندل غير مسجل في جدول رقم 1"
   Me.Undo
   
    End If

اعتذر لك اخي الكريم على تعبك معي

2 دقائق مضت, شايب said:

شوف ردي السابق

جرب احذف السطر الرابع والخامس

تسلم جدا اخي الكود يعمل جيدا 

انا اعتذر لك اريد انا يطبق هذا الكود على الفورم وبداخله Child وهو الذي يحتوي على خليه التحقق 

BundleCode

7 دقائق مضت, شايب said:

علامات التنصيص لمعيار الحقل الرقمي تختلف عن الحقل النصي

جرب استبدل السطر الثالث لديك الى

If Not IsNull(DLookup("[BundleCode]", "BundleDataINCutting", "[BundleCode] =" & Me.BundleCode.Value)) Then

امر اخر طالما ان النموذج لديك مصدر بياناته جدول BundleDataOut وبالتالي القيمة المسجلة سوف تحفظ في الجدول فما هو الغرص من الاستعلام في السطر الرابع

DoCmd.RunSQL "INSERT INTO BundleDataOut (BundleCode) VALUES ('" & fieldValue & "')"

اخونا الشايب

تمام اخي هكذا الكود يعمل ولكن عندي النزول لكتابه كود جديد تظهر لي هذه الرساله

في 4‏/1‏/2024 at 18:20, kkhalifa1960 said:

بعد اذن استاذي @ابوخليل هل تقصد مابالشرح . إذا كذلك إليك المرفق . أما غير ذلك ارسل مرفقك موضح عليه طلبك .

DD448.rar 20.05 kB · 1 download

اخواني الكرام  مازالت المشكله متواجده مرفق لكم مثال على مشروعي

هذه المشكله التي تظهر عند كتابه الكود ثم التنقل الي الخليه التاليه له

اكتشفت انا هذه المشكله تظهر عند تحويل الخليه من Short Text  الي Number ولكن يجب ان تكون هذه الخليه Number  وليس Text

QRSystemManagerFinal.accdb

اخواني الكرام  مازالت المشكله متواجده مرفق لكم مثال على مشروعي

هذه المشكله التي تظهر عند كتابه الكود ثم التنقل الي الخليه التاليه له

QRSystemManagerFinal.accdb

up

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

لدي هذا الكود وهو يقوم بالتحقق من البيانات يوجد فورم به Child ودالخ مربع نص اذا قومت بكتابه كود المنتج يقوم بالتحقق اذا كان مدرج في جدول رقم 1 اما لا اذا كان مدرج يقوم بادراجه في مربع رقم2 اذا لم يكون مدرج تظهر رساله بان هذا المنتج غير مسجل في الجدول رقم 1

جدول رقم 1 اسمه (BundleDataINCutting).

جدول رقم 2 اسمه (BundleDataOut).

هذا هو الكود

Private Sub BundleCode_AfterUpdate()
    Dim fieldValue As String
    fieldValue = Me.BundleCode.Value

    If (IsNull(DLookup("[BundleCode]", "BundleDataINCutting", "[BundleCode] ='" & Me.BundleCode.Value & "'"))) Then
        
        MsgBox "هذا البندل غير مسجل في جدول رقم 1"
    Else
        
        DoCmd.RunSQL "INSERT INTO BundleDataOut (BundleCode) VALUES ('" & fieldValue & "')"
        
    End If

End Sub

up

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

كل عام وانتم بخير وعام سعيد عليكم يارب

كنت اريد مساعده في نسخ حقل من جدول الي جدول اخر كما في الصوره التاليه وهو رقم الاذن ولكن كل معرف له رقم الاذن الخاص به:

في الصوره الثانيه اريد عند كتابه رقم سريال البندل يتم استدعاء رقم الاذن الخاص به من الجدول الذي يسمي  BundleDataOut

خلاصه الموضوع:

اريد نسخ رقم الأذن من جدول LinesIN الي حقل رقم الأذن في جدول BundleDataOut ليتم استدعائه الي حقل رقم الأذن عند كتابه سريال البندل في جدول ProductionControl ولكل سريال بندل رقم الأذن الخاص به.

ومرفق لكم قاعده البيانات

https://www.mediafire.com/file/i6onmna1iy9678e/QRSystemManagerFinal.rar/file

في 3‏/9‏/2023 at 13:08, شايب said:

مع ان الاخ العزيز شايب فهمه على قده

ولكن محاولة بسيطة

بداية ممكن عمل استعلام الحاق وممكن العمل مباشرة مع مصدر السجلات

وهنا الاخ شايب عمل مع مصدر السجلات

Dim rs As Recordset
Dim rst As Recordset
Dim a As Integer
Set rs = CurrentDb.OpenRecordset("stages")
Set rst = CurrentDb.OpenRecordset("StageBundleUPC")
rs.MoveFirst
For a = 0 To rs.RecordCount - 1
If rs!AddStage = True Then
rst.AddNew
rst!CutColor = Me.txtco
rst!CutYSGPO = Me.txtysgpo
rst!CutTotal = Me.txtct
rst!CutNumber = Me.txtcn
rst!CutStyle = Me.CutStyle
rst!CutStages = rs!Stages
rst.Update
End If
rs.MoveNext
Next a
rs.Close: rst.Close
Set rs = Nothing: Set rst = Nothing
Me.Child15.Requery

الملف مرفق

الشايب

 

Sample.accdb 656 kB · 3 downloads

هذا هو المطلوب

انا عاجز عن الشكر فعلا فليس لدي من كلام اقوله

شكرا جدا جدا لك اخي العزيز 

للرفع

للرفع

من الممكن ان نلغي مربع المراحل في النموذج الرئيسي لنفعل الفكرخ الثانيه وهي النموذج على جه اليمين لاني اريد كل مرحله بجانبها مربع اختيار وللعلم البيانات الموجوده بالاسفل قمت بوضعها يدويا

اشكركم اخواني الكرام علي تعبكم معي

مشروعي باختصار 

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

بالنسبه لStage_subform قومت بوضعه لمعرفه الفكره التي اريدها فقط لاني اريد وضع مربع قابل للزياده يوجده به مراحل وكل مرحله بجانبها مربع اختيار 

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

لدي نموذج به بيانات ويوجد على الجانب الايمن للنموذج جدول به بعض البيانات اريد عندما اقوم بالتعليم على احد البيانات او مجموعه منهم يقوم بالاضاففي الSubform

مرفق قاعده البيانات 

Sample.rar

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

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

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

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

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

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  بحيث المدير يعلم بحدوث التغيير الذي يقوم به الموظف لحظيا

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

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

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

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

في 26‏/8‏/2023 at 07:51, Mohamed Khaled Galal said:

اشكرك اخي الكريم على مجهودك ولكني عند كتابه اي قيمه في المقاسات المخفيه لا تظهر يجب عند وضع اي قيمه في المقاسات يظهر الخانه الموجود بها القيمه فقط والباقي يكون مخفي اذا لم يتم وضع قيمه فيه

اخي الكريم لقد قمت بعمل ماهو مطلوب من خلال الكود التالي واشكرك جدا عل مجهودك الاكثر من رائع

If IsNull([S]) Then
Me.S.Height = 0
Me.S.Top = 0
Me.Label120.Height = 0
Me.Label120.Top = 0
Me.Detail.Height = 0
Else
Me.S.Height = 217
Me.S.Top = 510
Me.Label120.Height = 217
Me.Label120.Top = 291
Me.Items.Top = 0
Me.Items.Height = 218
Me.Cons_Pc.Top = 0
Me.Cons_Pc.Height = 218
Me.Other.Top = 0
Me.Other.Height = 218
Me.Detail.Height = 1
End If

If IsNull([M]) Then
Me.M.Height = 0
Me.M.Top = 0
Me.Label119.Height = 0
Me.Label119.Top = 0
Me.Detail.Height = 0
Else
Me.M.Height = 218
Me.M.Top = 510
Me.Label119.Height = 218
Me.Label119.Top = 291
Me.Items.Top = 0
Me.Items.Height = 218
Me.Cons_Pc.Top = 0
Me.Cons_Pc.Height = 218
Me.Other.Top = 0
Me.Other.Height = 218
Me.Detail.Height = 1
End If

If IsNull([L]) Then
Me.L.Height = 0
Me.L.Top = 0
Me.Label118.Height = 0
Me.Label118.Top = 0
Me.Detail.Height = 0
Else
Me.L.Height = 217
Me.L.Top = 510
Me.Label118.Height = 217
Me.Label118.Top = 291
Me.Items.Top = 0
Me.Items.Height = 218
Me.Cons_Pc.Top = 0
Me.Cons_Pc.Height = 218
Me.Other.Top = 0
Me.Other.Height = 218
Me.Detail.Height = 1
End If

If IsNull([XS]) Then
Me.XS.Height = 0
Me.XS.Top = 0
Me.Label121.Height = 0
Me.Label121.Top = 0
Me.Detail.Height = 0
Else
Me.XS.Height = 217
Me.XS.Top = 510
Me.Label121.Height = 217
Me.Label121.Top = 291
Me.Items.Top = 0
Me.Items.Height = 218
Me.Cons_Pc.Top = 0
Me.Cons_Pc.Height = 218
Me.Other.Top = 0
Me.Other.Height = 218
Me.Detail.Height = 1
End If

If IsNull([XXS]) Then
Me.XXS.Height = 0
Me.XXS.Top = 0
Me.Label122.Height = 0
Me.Label122.Top = 0
Me.Detail.Height = 0
Else
Me.XXS.Height = 217
Me.XXS.Top = 510
Me.Label122.Height = 217
Me.Label122.Top = 291
Me.Items.Top = 0
Me.Items.Height = 218
Me.Cons_Pc.Top = 0
Me.Cons_Pc.Height = 218
Me.Other.Top = 0
Me.Other.Height = 218
Me.Detail.Height = 1
End If

If IsNull([XL]) Then
Me.XL.Height = 0
Me.XL.Top = 0
Me.Label117.Height = 0
Me.Label117.Top = 0
Me.Detail.Height = 0
Else
Me.XL.Height = 217
Me.XL.Top = 510
Me.Label117.Height = 217
Me.Label117.Top = 291
Me.Items.Top = 0
Me.Items.Height = 218
Me.Cons_Pc.Top = 0
Me.Cons_Pc.Height = 218
Me.Other.Top = 0
Me.Other.Height = 218
Me.Detail.Height = 1
End If

If IsNull([XXL]) Then
Me.XXL.Height = 0
Me.XXL.Top = 0
Me.Label116.Height = 0
Me.Label116.Top = 0
Me.Detail.Height = 0
Else
Me.XXL.Height = 217
Me.XXL.Top = 979
Me.Label116.Height = 217
Me.Label116.Top = 760
Me.Items.Top = 0
Me.Items.Height = 218
Me.Cons_Pc.Top = 0
Me.Cons_Pc.Height = 218
Me.Other.Top = 0
Me.Other.Height = 218
Me.Detail.Height = 1
End If

If IsNull([XXXL]) Then
Me.XXXL.Height = 0
Me.XXXL.Top = 0
Me.Label115.Height = 0
Me.Label115.Top = 0
Me.Detail.Height = 0
Else
Me.XXXL.Height = 217
Me.XXXL.Top = 979
Me.Label115.Height = 217
Me.Label115.Top = 760
Me.Items.Top = 0
Me.Items.Height = 218
Me.Cons_Pc.Top = 0
Me.Cons_Pc.Height = 218
Me.Other.Top = 0
Me.Other.Height = 218
Me.Detail.Height = 1
End If

If IsNull([XXXXL]) Then
Me.XXXXL.Height = 0
Me.XXXXL.Top = 0
Me.Label114.Height = 0
Me.Label114.Top = 0
Me.Detail.Height = 0
Else
Me.XXXXL.Height = 217
Me.XXXXL.Top = 979
Me.Label114.Height = 217
Me.Label114.Top = 760
Me.Items.Top = 0
Me.Items.Height = 218
Me.Cons_Pc.Top = 0
Me.Cons_Pc.Height = 218
Me.Other.Top = 0
Me.Other.Height = 218
Me.Detail.Height = 1
End If

If IsNull([XXXXXL]) Then
Me.XXXXXL.Height = 0
Me.XXXXXL.Top = 0
Me.Label113.Height = 0
Me.Label113.Top = 0
Me.Detail.Height = 0
Else
Me.XXXXXL.Height = 217
Me.XXXXXL.Top = 979
Me.Label113.Height = 217
Me.Label113.Top = 760
Me.Items.Top = 0
Me.Items.Height = 218
Me.Cons_Pc.Top = 0
Me.Cons_Pc.Height = 218
Me.Other.Top = 0
Me.Other.Height = 218
Me.Detail.Height = 1
End If

If IsNull([XXXXXXL]) Then
Me.XXXXXXL.Height = 0
Me.XXXXXXL.Top = 0
Me.Label112.Height = 0
Me.Label112.Top = 0
Me.Detail.Height = 0
Else
Me.XXXXXXL.Height = 217
Me.XXXXXXL.Top = 979
Me.Label112.Height = 217
Me.Label112.Top = 760
Me.Items.Top = 0
Me.Items.Height = 218
Me.Cons_Pc.Top = 0
Me.Cons_Pc.Height = 218
Me.Other.Top = 0
Me.Other.Height = 218
Me.Detail.Height = 1
End If

If IsNull([Total]) Then
Me.Total.Height = 0
Me.Total.Top = 0
Me.Label143.Height = 0
Me.Label143.Top = 0
Me.Detail.Height = 0
Else
Me.Total.Height = 217
Me.Total.Top = 979
Me.Label143.Height = 217
Me.Label143.Top = 760
Me.Items.Top = 0
Me.Items.Height = 218
Me.Cons_Pc.Top = 0
Me.Cons_Pc.Height = 218
Me.Other.Top = 0
Me.Other.Height = 218
Me.Detail.Height = 1
End If

في 24‏/8‏/2023 at 15:15, ابوخليل said:

كان الله في عونك

تفضل

QRSystem1.rar 1.53 \u0645\u064a\u062c\u0627 \u0628\u0627\u064a\u062a · 5 downloads

اشكرك اخي الكريم على مجهودك ولكني عند كتابه اي قيمه في المقاسات المخفيه لا تظهر يجب عند وضع اي قيمه في المقاسات يظهر الخانه الموجود بها القيمه فقط والباقي يكون مخفي اذا لم يتم وضع قيمه فيه

منذ ساعه, ابوخليل said:

هذا ليس مثال بل مشروع كامل

اولا .. يوجد مشاكل برمجية عند فتح المشروع حتى بعد ربط الجداول

ثانيا مشروع vba مقفل بكلمة مرور

المثال بارك الله فيك .. هو ان تنزع التقرير ومصدر بياناته فقط  في قاعدة بيانات جديدة وترفقها هنا

السلام عليكم اخي الكريم

لقد قمت بفصل التقرير في قاعده بيانات جديده ارجو الضغط على مفتاح SHIFT عند فتح قاعده البيانات والضغط على التقرير وكتابه رقم 4111 لبظهر التقرير المراد التعديل عليه 

المثال المرفق

https://www.mediafire.com/file/nvt5io4t19xa4kq/QRSystemManagerFinal.rar/file

تم رفع المثال

14 دقائق مضت, شايب said:

نعم ممكن حقلين وثلاثة وعشرة

وهذا الامر للطريقة التي اشار اليها الاخ شايب وايضا لطريقة الاستاذ الكبير

ولكن الاخ شايب سوف يشرح ذلك في الطريقة التي اشار اليها

في زر الامر نضع الامر التالي

DoCmd.OpenForm "frm2", acNormal, , , acFormAdd, , [ID] & "|" & [Discount]

هنا لدينا حقلي المعرف والحسم وفصلنا بينهما بـ  & "|" &

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

ثم في نموذج الوجهة اي النموذج الثاني وضعنا الامر التالي

Dim a As Variant
a = Split(Me.OpenArgs, "|")
Me.ID = a(0)
Me.Discount = a(1)

الملف مرفق

اخونا الفاضل شايب

 

db1.rar 42.02 kB · 1 download

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

12 ساعات مضت, شايب said:

مشاركة مع استاذنا

طريقة اخرى بدون استخدام متغير عام

تحميل القيمة مباشرة في امر فتح النموذج

باستخدام الامر التالي

DoCmd.OpenForm "frm2", acNormal, , , acFormAdd, , ID

وفي النموذج الثاني في حدث عند التحميل نضع الامر

Me.ID = Me.OpenArgs

اخير في تعديل الاستاذ الكبير وكذلك في تعديل اخونا شايب

يفضل ان تضع امر معالجة الخطأ في حالة كون حقل id في النموذج الاول فارغ

والله الموفق

شكرا لك اخي هل يمكن ان اضيف حقل اخر مع ID  بحيث عند فتح النموذج الثاني يقوم بملئ حقلين

12 ساعات مضت, شايب said:

مشاركة مع استاذنا

طريقة اخرى بدون استخدام متغير عام

تحميل القيمة مباشرة في امر فتح النموذج

باستخدام الامر التالي

DoCmd.OpenForm "frm2", acNormal, , , acFormAdd, , ID

وفي النموذج الثاني في حدث عند التحميل نضع الامر

Me.ID = Me.OpenArgs

اخير في تعديل الاستاذ الكبير وكذلك في تعديل اخونا شايب

يفضل ان تضع امر معالجة الخطأ في حالة كون حقل id في النموذج الاول فارغ

والله الموفق

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