نجوم المشاركات

اقدم لكم اليوم أداة ستزيد من إنتاجيتكم أثناء العمل مع الإستعلامات فبدلاً من العمل مع الإستعلامات من خلال جزء التنقل ستقوم هذه الأداة بتجميع جميع الإستعلامات داخل مربع قائمة والجميل أنه لن يتم تحميل القائمة إلا بالإستعلامات التي تم تحديد نوعها فمثلاً تريد العمل مع إستعلامات التحديث فقط أو الإلحاق فقط وهكذا بالإضافة إلى هذا يمكنك تصفية النتائج من خلال كتابة عبارة نصية تتضمنها جملة Sql فمثلاً تريد الإستعلامات التي تتضمن بيانات جدول محدد فيكفي أن تكتب إسم الجدول في مربع التصفية ليتم تصفية الإستعلامات التي تتضمن هذا الجدول فقط وكمثال رائع آخر وأعتقد أن جميعنا سيعجب به إذا قمنا مثلا بتعديل إسم عنصر تحكم في نموذج وسبق أن تم وضع عنصر التحكم هذا كمعيار لتصفية إستعلام أو أكثر فيمكن كتابة إسمه في مربع التصفية ليتبقى لدينا الإستعلامات التي ذكر فيها إسم عنصر التحكم هذا لا وأزيدكم من الشعر بيت يمكنكم بعد ذلك إستبدال إسم عنصر التحكم هذا بالإسم الجديد وإستعراض النتائج في إستعلام مؤقت وإذا نجح العمل يمكنك تحديث جملة Sql الخاصة بالإستعلام المحدد بالتعديلات الجديدة وهذا كله عن طريق الأداة وبدون حتى أن تضطر إلى فتح الإستعلام في وضع التصميم يوجد للأداة وظيفة أخرى وهي تعديل جملة Sql الخاصة بعناصر التحكم (مربعات التحرير والسرد ومربعات القائمة) وتقوم بنفس ماسبق ذكره ولكن على عبارة Sql لمصدر الصف الخاص بعنصر التحكم الأداة بسيطة ولا تحتوي إلا على ثلاثة نماذج فقط ستجدونها في المرفق بإسم القالب يمكنكم إستيرادها إلى تطبيقاتكم والعمل بها بكل سهولة ولكن الخيار المفضل لدي هو إستخدامها كوظيفة إضافية وهي ما ستجدونه داخل مجلد الوظيفة الإضافية مع مستند يشرح طريقة تثبيتها أرجو أن تجدوا في هذه الأداة الفائدة التي وجدتها أنا شخصيا وإذا كان لدى أي أحد منكم أي ملاحظات فالرجاء أن لا يبخل علينا بها تحياتي

السلام عليكم ورحمة الله تعالى وبركاته استاذتى الكرام رواد المنتدى المحترمين اولا : بعد أذن استاذى الجليل ومعلمى القدير الاستاذ @منتصر الانسي --------------------------- قمت بتحميل مرفق للاستاذ منتصر جزاه الله عنا كل خير من هذا الموضوع الشيق : قمت بدراسة المرفق وتحليله بصراحة المرفق والفكرة أعجبت بهم كثيرا قمت بعمل القليل من التطوير ويتمثل هذا التطوير فى ....... طب ما تحملوا وشوفوا انتم بنفسكم وبعد إذن ستاذى الجليل قمت باقتباس الاسم والصورة من الموضوع الاصلى لان هذا المرفق هو إمتداد فقط للأفكار وها هى بضاعتكم نردها اليكم أحسن الله اليكم وشكر لكم وجزاكم عنى وعن كل طلاب العلم خيرا إن شاء الله استاذى الجليل : اتمنى أن تنال أفكارى المتواضعة استحسانكم ورضاكم

توليد أرقام مستندات تلقائية مثل أرقام الفواتير والطلبات والسندات (ترقيم تلقائي احترافي) أربع أنماط للترقيم Yearly → INV-2026-000001 : التصفير واعادة الترقيم عند بدء العام الجديد Monthly → INV-2026-04-000001 : التصفير واعادة الترقيم عند بدء الشهر الجديد Daily → INV-2026-04-05-000001 : التصفير واعادة الترقيم عند بدء اليوم الجديد Sequential→ INV-000001 : ترقيم لا نهائى بدون اعادة بدء الترقيم مستمر بلا توقف المزايا : إنشاء تلقائي لجدول التسلسل : tblSequences وظيفته تخزين تسلسل الأرقام الفريد لكل مفتاح (Key) استرداد ذكي عند حذف جدول التسلسل : tblSequences عن طريق الخطأ تم تصميم الكود بحكمة ليعيد إنشاءه تلقائيا ويستأنف الترقيم من آخر رقم موجود في جدول البيانات الأصلي - أى لا انقطاع ولا تكرار أبدا التحكم الأمثل لإضافة بادئة مخصصة أى أنه يمكن عمل أكثر من عملية ترقيم لنفس الحقل حسب النوع, الفرع , المحافظة مثلا .... Cairo-2026-000018 Alex-2026-000001 التحكم فى شكل تنسيق الترقيم للأرقام بطول سلسلة مخصصة من 1 الى 10 مثل : 000001 أو 0000000001 أو حتى آمن في بيئة الشبكة المتعددة المستخدمين: عدم تكرار أي رقم حتى لو فتح عشرة مستخدمين نفس النموذج في نفس اللحظة مع عمل معالجة خاصة لمنع تعارض الطلبات المتزامنة مع حد أقصى للمحاولات لمنع التوقف التام تحت الضغط الشديد

استبدال صندوق الرسائل فى الاكسس بنموذج رسائل احترافى بسطر واحد بس كل حاجة جاهزة مش محتاج تفكر في تصميم نموذج مش محتاج نموذج الرسائل يكون موجود اساسا مش محتاج تكتب كود كبير بعد كده لصندوق الرسائل استدعي الدالة وخلاص والنظام يعمل كل شئ النظام يقدم 4 أنواع رسائل جاهزة : { معلومة - نجاح - تحذير - خطأ } كل نوع بتصميمه ولونه وأيقونته معلومة : من خلال : UiInfo اللون : أزرق نجاح : من خلال : UiSuccess اللون : أخضر تحذير : من خلال : UiWarning اللون : برتقالي خطأ : من خلال : UiError اللون : أحمر 3 أنواع إدخال : { نص حر - رقم مع تحقق تلقائي - اختيار من قائمة } نص حر : من خلال : UiInput رقم مع تحقق تلقائي: من خلال : UiInputNum يرفض الحروف بدون ما تكتب سطر واحد اختيار من قائمة : من خلال : UiPick قرارات متعددة : { تأكيد نعم/لا - ثلاثة خيارات أزرار مخصصة بأسماء ترجعها النتيجة مباشرة } نعم / لا : من خلال : BlnUiConfirm يرجع True أو False مباشرة ثلاثة خيارات : من خلال :IntUiConfirm3 يرجع 1 أو 2 أو 0 أزرار مخصصة : من خلال :UiCustom يرجع اسم الزر اللي اتضغط مش رقمه دعم كامل للعربية والإنجليزية : { اتجاه النص RTL/LTR تلقائي - الأزرار والعناوين بالغتين من خلال معامل UiLangEn يكفي لتبديل كل شيء } أضف UiLangEn كآخر parameter وكل شيء يتبدل : اتجاه النص - الأزرار - العناوين الافتراضية ثيم موحد قابل للتخصيص : { ألوان الهيدر والأيقونات والأزرار كلها من UiTheme غير لون الـ Accent في مكان واحد وكل الرسائل تتغير } كل ألوان النظام مجمعة في UiTheme مناسب لأي مشروع قاعدة بيانات صغير أو كبير - عربي أو إنجليزي - مبتدئ أو محترف يبني نفسه : لا تثبيت ولا إعداد كل إجراء أو وظيفة واضحة الاسم - واضحة الـ return - واضحة الاستخدام اسم الوحدة النمطية : modUIMsgFramework كود الوحدة النمطية.. Option Explicit Option Compare Database Public Enum UiIcon UiIconInfo = 0 UiIconSuccess = 1 UiIconWarning = 2 UiIconError = 3 UiIconQuestion = 4 End Enum Public Enum UiMode UiModeAlert = 0 UiModeInput = 1 UiModeNumber = 2 UiModeList = 3 End Enum Public Enum UiLang UiLangAr = 0 UiLangEn = 1 End Enum Public Type UiParams strMessage As String strTitle As String strButtons As String strDefault As String strList As String strDetails As String strResult As String enuIcon As UiIcon enuMode As UiMode enuLang As UiLang End Type Public Type UiTheme lngAccent As Long lngHeader As Long lngBg As Long lngText As Long lngMuted As Long lngBorder As Long lngSuccess As Long lngWarning As Long lngError As Long lngInfo As Long lngQuestion As Long End Type Private Const STRFORMNAME As String = "frmUiMsg" Private Const STRMODNAME As String = "modUICore" Private Const MAX_BUTTONS As Integer = 5 Private Const FRM_W As Long = 9000 Private m_typParams As UiParams Public Function TypDefaultTheme() As UiTheme Dim typT As UiTheme typT.lngAccent = RGB(0, 120, 212) typT.lngHeader = RGB(32, 32, 38) typT.lngBg = RGB(245, 246, 250) typT.lngText = RGB(30, 30, 35) typT.lngMuted = RGB(120, 120, 130) typT.lngBorder = RGB(210, 212, 220) typT.lngSuccess = RGB(16, 124, 16) typT.lngWarning = RGB(200, 100, 0) typT.lngError = RGB(196, 43, 28) typT.lngInfo = RGB(0, 120, 212) typT.lngQuestion = RGB(104, 33, 122) TypDefaultTheme = typT End Function Private Function BlnFormExists(ByVal strName As String) As Boolean On Error Resume Next Dim objFrm As Object Set objFrm = CurrentProject.AllForms(strName) BlnFormExists = Not (objFrm Is Nothing) Set objFrm = Nothing On Error GoTo 0 End Function Private Sub LogError(ByVal strProc As String, _ ByVal lngNum As Long, _ ByVal strDesc As String) Debug.Print "[" & STRMODNAME & "." & strProc & "] " & _ "Err " & lngNum & ": " & strDesc & _ " @ " & Now() End Sub Public Function TypGetParams() As UiParams TypGetParams = m_typParams End Function Public Sub SetResult(ByVal strResult As String) m_typParams.strResult = strResult End Sub Private Sub ResetParams() Dim typEmpty As UiParams m_typParams = typEmpty End Sub Private Function StrDefaultTitle(ByVal enuIcon As UiIcon, _ ByVal enuLang As UiLang) As String If enuLang = UiLangAr Then Select Case enuIcon Case UiIconSuccess: StrDefaultTitle = "تم بنجاح" Case UiIconWarning: StrDefaultTitle = "تحذير" Case UiIconError: StrDefaultTitle = "خطأ" Case UiIconQuestion: StrDefaultTitle = "تأكيد" Case Else: StrDefaultTitle = "معلومة" End Select Else Select Case enuIcon Case UiIconSuccess: StrDefaultTitle = "Success" Case UiIconWarning: StrDefaultTitle = "Warning" Case UiIconError: StrDefaultTitle = "Error" Case UiIconQuestion: StrDefaultTitle = "Confirm" Case Else: StrDefaultTitle = "Information" End Select End If End Function Private Function StrValidateButtons(ByVal strBtns As String) As String Dim arrB() As String Dim intCnt As Integer Dim intI As Integer Dim strOut As String arrB = Split(strBtns, ",") intCnt = UBound(arrB) + 1 If intCnt > MAX_BUTTONS Then LogError "StrValidateButtons", 0, _ "تجاوز الحد الأقصى للأزرار (" & intCnt & "). سيتم اقتصارها على " & MAX_BUTTONS intCnt = MAX_BUTTONS End If For intI = 0 To intCnt - 1 If Len(strOut) > 0 Then strOut = strOut & "," strOut = strOut & Trim(arrB(intI)) Next intI StrValidateButtons = strOut End Function Private Function BlnBuildMsgForm() As Boolean On Error GoTo ErrHandler Dim typT As UiTheme Dim objFrm As Object Dim objCtl As Object Dim strTemp As String Dim intI As Integer Dim lngLeft As Long typT = TypDefaultTheme() Const HDR_H As Long = 900 Const ICON_L As Long = 200 Const ICON_T As Long = 150 Const ICON_W As Long = 600 Const ICON_H As Long = 600 Const TITLE_L As Long = 900 Const TITLE_T As Long = 200 Const TITLE_W As Long = 7800 Const TITLE_H As Long = 500 Const MSG_L As Long = 300 Const MSG_T As Long = 1050 Const MSG_W As Long = 8400 Const MSG_H As Long = 1400 Const DET_L As Long = 300 Const DET_T As Long = 2500 Const DET_W As Long = 8400 Const DET_H As Long = 700 Const INP_L As Long = 300 Const INP_T As Long = 3300 Const INP_W As Long = 8400 Const INP_H As Long = 450 Const DIV_T As Long = 4050 Const BTN_T As Long = 4250 Const BTN_W As Long = 1550 Const BTN_H As Long = 550 Const FRM_H As Long = 5000 Set objFrm = CreateForm strTemp = objFrm.Name With objFrm .Caption = "" .ScrollBars = 0 .RecordSelectors = False .NavigationButtons = False .DividingLines = False .BorderStyle = 1 .AutoCenter = True .PopUp = True .Modal = True .Width = FRM_W .Section(0).Height = FRM_H .Section(0).BackColor = typT.lngBg End With Set objCtl = CreateControl(strTemp, acRectangle, acDetail) With objCtl .Name = "recHeader": .Left = 0: .Top = 0 .Width = FRM_W: .Height = HDR_H .BackColor = typT.lngHeader: .BackStyle = 1 .BorderStyle = 0: .SpecialEffect = 0 End With Set objCtl = CreateControl(strTemp, acRectangle, acDetail) With objCtl .Name = "recIcon": .Left = ICON_L: .Top = ICON_T .Width = ICON_W: .Height = ICON_H .BackColor = typT.lngInfo: .BackStyle = 1 .BorderStyle = 0: .SpecialEffect = 0 End With Set objCtl = CreateControl(strTemp, acLabel, acDetail) With objCtl .Name = "lblIcon": .Caption = "i" .Left = ICON_L: .Top = ICON_T .Width = ICON_W: .Height = ICON_H .FontSize = 20: .FontBold = True .ForeColor = vbWhite: .BackStyle = 0: .TextAlign = 2 End With Set objCtl = CreateControl(strTemp, acLabel, acDetail) With objCtl .Name = "lblTitle": .Caption = "" .Left = TITLE_L: .Top = TITLE_T .Width = TITLE_W: .Height = TITLE_H .FontSize = 14: .FontBold = True .ForeColor = vbWhite: .BackStyle = 0: .TextAlign = 1 End With Set objCtl = CreateControl(strTemp, acLabel, acDetail) With objCtl .Name = "lblMessage": .Caption = "" .Left = MSG_L: .Top = MSG_T .Width = MSG_W: .Height = MSG_H .FontSize = 11: .ForeColor = typT.lngText .BackStyle = 0: .TextAlign = 1 End With Set objCtl = CreateControl(strTemp, acLabel, acDetail) With objCtl .Name = "lblDetails": .Caption = "" .Left = DET_L: .Top = DET_T .Width = DET_W: .Height = DET_H .FontSize = 9: .ForeColor = typT.lngMuted .BackStyle = 0: .Visible = False End With Set objCtl = CreateControl(strTemp, acTextBox, acDetail) With objCtl .Name = "txtInput" .Left = INP_L: .Top = INP_T .Width = INP_W: .Height = INP_H .FontSize = 11 .BorderColor = typT.lngBorder: .BackColor = vbWhite .Visible = False End With Set objCtl = CreateControl(strTemp, acComboBox, acDetail) With objCtl .Name = "cboList" .Left = INP_L: .Top = INP_T .Width = INP_W: .Height = INP_H .FontSize = 11 .BorderColor = typT.lngBorder: .BackColor = vbWhite .RowSourceType = "Value List" .LimitToList = True: .AllowValueListEdits = False .Visible = False End With Set objCtl = CreateControl(strTemp, acLine, acDetail) With objCtl .Name = "linDivider": .Left = 0: .Top = DIV_T .Width = FRM_W: .Height = 0 .BorderColor = typT.lngBorder: .BorderWidth = 1 End With For intI = 1 To MAX_BUTTONS lngLeft = 200 + ((intI - 1) * 1760) Set objCtl = CreateControl(strTemp, acCommandButton, acDetail) With objCtl .Name = "btn" & intI: .Caption = "btn" & intI .Left = lngLeft: .Top = BTN_T .Width = BTN_W: .Height = BTN_H .FontSize = 10: .FontBold = True .BackColor = typT.lngAccent: .ForeColor = vbWhite .BorderStyle = 0: .Visible = False .OnClick = "=ProcBtnClick(" & intI & ")" End With Next intI DoCmd.Save acForm, strTemp DoCmd.Close acForm, strTemp, acSaveYes DoCmd.Rename STRFORMNAME, acForm, strTemp BlnBuildMsgForm = True Set objCtl = Nothing: Set objFrm = Nothing Exit Function ErrHandler: LogError "BlnBuildMsgForm", Err.Number, Err.Description BlnBuildMsgForm = False Set objCtl = Nothing: Set objFrm = Nothing End Function Private Function BlnInjectMsgCode() As Boolean On Error GoTo ErrHandler Dim objMdl As Object Dim strCode As String Dim strOldCode As String DoCmd.OpenForm STRFORMNAME, acDesign, , , , acHidden Set objMdl = Forms(STRFORMNAME).Module If objMdl.CountOfLines > 0 Then strOldCode = objMdl.Lines(1, objMdl.CountOfLines) objMdl.DeleteLines 1, objMdl.CountOfLines End If strCode = StrFormCodeHeader() & _ StrFormCodeApplyIcon() & _ StrFormCodeApplyLang() & _ StrFormCodeSetupBtns() & _ StrFormCodeFillList() & _ StrFormCodeOpen() & _ StrFormCodeBtn() & _ StrFormCodeUnload() objMdl.AddFromString strCode If objMdl.CountOfLines < 10 Then If Len(strOldCode) > 0 Then objMdl.DeleteLines 1, objMdl.CountOfLines objMdl.AddFromString strOldCode End If LogError "BlnInjectMsgCode", 0, "AddFromString أنتج كوداً فارغاً، تم استعادة الكود القديم" BlnInjectMsgCode = False GoTo Cleanup End If DoCmd.Save acForm, STRFORMNAME DoCmd.Close acForm, STRFORMNAME, acSaveYes BlnInjectMsgCode = True Cleanup: Set objMdl = Nothing Exit Function ErrHandler: LogError "BlnInjectMsgCode", Err.Number, Err.Description BlnInjectMsgCode = False Set objMdl = Nothing End Function Private Function StrFormCodeHeader() As String Dim s As String s = "Option Explicit" & vbCrLf s = s & "Option Compare Database" & vbCrLf & vbCrLf s = s & "Private mintMode As Integer" & vbCrLf s = s & "Private mintLang As Integer" & vbCrLf & vbCrLf StrFormCodeHeader = s End Function Private Function StrFormCodeApplyIcon() As String Dim s As String s = "Private Sub ProcApplyIcon(ByVal intIcon As Integer)" & vbCrLf s = s & " Select Case intIcon" & vbCrLf s = s & " Case 1" & vbCrLf s = s & " Me.recHeader.BackColor = RGB(16,124,16)" & vbCrLf s = s & " Me.recIcon.BackColor = RGB(16,124,16)" & vbCrLf s = s & " Me.lblIcon.Caption = Chr(252)" & vbCrLf s = s & " Me.lblIcon.FontName = ""Wingdings""" & vbCrLf s = s & " Case 2" & vbCrLf s = s & " Me.recHeader.BackColor = RGB(200,100,0)" & vbCrLf s = s & " Me.recIcon.BackColor = RGB(200,100,0)" & vbCrLf s = s & " Me.lblIcon.Caption = Chr(56)" & vbCrLf s = s & " Me.lblIcon.FontName = ""Wingdings""" & vbCrLf s = s & " Case 3" & vbCrLf s = s & " Me.recHeader.BackColor = RGB(196,43,28)" & vbCrLf s = s & " Me.recIcon.BackColor = RGB(196,43,28)" & vbCrLf s = s & " Me.lblIcon.Caption = Chr(251)" & vbCrLf s = s & " Me.lblIcon.FontName = ""Wingdings""" & vbCrLf s = s & " Case 4" & vbCrLf s = s & " Me.recHeader.BackColor = RGB(104,33,122)" & vbCrLf s = s & " Me.recIcon.BackColor = RGB(104,33,122)" & vbCrLf s = s & " Me.lblIcon.Caption = Chr(63)" & vbCrLf s = s & " Me.lblIcon.FontName = ""Wingdings""" & vbCrLf s = s & " Case Else" & vbCrLf s = s & " Me.recHeader.BackColor = RGB(0,120,212)" & vbCrLf s = s & " Me.recIcon.BackColor = RGB(0,120,212)" & vbCrLf s = s & " Me.lblIcon.Caption = Chr(105)" & vbCrLf s = s & " Me.lblIcon.FontName = ""Arial""" & vbCrLf s = s & " End Select" & vbCrLf s = s & "End Sub" & vbCrLf & vbCrLf StrFormCodeApplyIcon = s End Function Private Function StrFormCodeApplyLang() As String Dim s As String s = "Private Sub ProcApplyLang(ByVal intLang As Integer)" & vbCrLf s = s & " Dim intAlign As Integer" & vbCrLf s = s & " intAlign = IIf(intLang = 0, 3, 1)" & vbCrLf s = s & " Me.lblTitle.TextAlign = intAlign" & vbCrLf s = s & " Me.lblMessage.TextAlign = intAlign" & vbCrLf s = s & " Me.lblDetails.TextAlign = intAlign" & vbCrLf s = s & " Me.txtInput.TextAlign = intAlign" & vbCrLf s = s & " Me.cboList.TextAlign = intAlign" & vbCrLf s = s & "End Sub" & vbCrLf & vbCrLf StrFormCodeApplyLang = s End Function Private Function StrFormCodeSetupBtns() As String Dim s As String s = "Private Sub ProcSetupBtns(ByVal strBtns As String, ByVal intLang As Integer)" & vbCrLf s = s & " Dim arrBtns() As String" & vbCrLf s = s & " Dim intTotal As Integer" & vbCrLf s = s & " Dim intI As Integer" & vbCrLf s = s & " Dim lngBtnW As Long" & vbCrLf s = s & " Dim lngBtnH As Long" & vbCrLf s = s & " Dim lngGap As Long" & vbCrLf s = s & " Dim lngTotalW As Long" & vbCrLf s = s & " Dim lngStartX As Long" & vbCrLf s = s & " Dim blnIsRtl As Boolean" & vbCrLf s = s & " arrBtns = Split(strBtns, "","")" & vbCrLf s = s & " intTotal = UBound(arrBtns) + 1" & vbCrLf s = s & " If intTotal > 5 Then intTotal = 5" & vbCrLf s = s & " blnIsRtl = (intLang = 0)" & vbCrLf s = s & " lngBtnW = 1550" & vbCrLf s = s & " lngBtnH = 550" & vbCrLf s = s & " lngGap = 200" & vbCrLf s = s & " lngTotalW = (intTotal * lngBtnW) + ((intTotal - 1) * lngGap)" & vbCrLf s = s & " lngStartX = (Me.Width - lngTotalW) \ 2" & vbCrLf s = s & " For intI = 1 To 5" & vbCrLf s = s & " Me(""btn"" & intI).Visible = False" & vbCrLf s = s & " Next intI" & vbCrLf s = s & " For intI = 1 To intTotal" & vbCrLf s = s & " With Me(""btn"" & intI)" & vbCrLf s = s & " .Caption = Trim(arrBtns(intI - 1))" & vbCrLf s = s & " If blnIsRtl Then" & vbCrLf s = s & " .Left = lngStartX + ((intTotal - intI) * (lngBtnW + lngGap))" & vbCrLf s = s & " Else" & vbCrLf s = s & " .Left = lngStartX + ((intI - 1) * (lngBtnW + lngGap))" & vbCrLf s = s & " End If" & vbCrLf s = s & " .Top = 4250: .Width = lngBtnW: .Height = lngBtnH" & vbCrLf s = s & " .Visible = True" & vbCrLf s = s & " End With" & vbCrLf s = s & " Next intI" & vbCrLf s = s & "End Sub" & vbCrLf & vbCrLf StrFormCodeSetupBtns = s End Function Private Function StrFormCodeFillList() As String Dim s As String s = "Private Sub ProcFillList(ByVal strItems As String, ByVal strDefault As String)" & vbCrLf s = s & " Dim arrItems() As String" & vbCrLf s = s & " Dim strSource As String" & vbCrLf s = s & " Dim intI As Integer" & vbCrLf s = s & " arrItems = Split(strItems, "","")" & vbCrLf s = s & " For intI = 0 To UBound(arrItems)" & vbCrLf s = s & " strSource = strSource & Trim(arrItems(intI)) & "";""" & vbCrLf s = s & " Next intI" & vbCrLf s = s & " Me.cboList.RowSource = strSource" & vbCrLf s = s & " If Len(Trim(strDefault)) > 0 Then" & vbCrLf s = s & " Me.cboList.Value = strDefault" & vbCrLf s = s & " ElseIf UBound(arrItems) >= 0 Then" & vbCrLf s = s & " Me.cboList.Value = Trim(arrItems(0))" & vbCrLf s = s & " End If" & vbCrLf s = s & "End Sub" & vbCrLf & vbCrLf StrFormCodeFillList = s End Function Private Function StrFormCodeOpen() As String Dim s As String s = "Private Sub Form_Open(Cancel As Integer)" & vbCrLf s = s & " On Error GoTo ErrHandler" & vbCrLf s = s & " Dim typP As UiParams" & vbCrLf s = s & " typP = TypGetParams()" & vbCrLf s = s & " mintMode = CInt(typP.enuMode)" & vbCrLf s = s & " mintLang = CInt(typP.enuLang)" & vbCrLf s = s & " Me.Caption = typP.strTitle" & vbCrLf s = s & " Me.lblTitle.Caption = typP.strTitle" & vbCrLf s = s & " Me.lblMessage.Caption = typP.strMessage" & vbCrLf s = s & " Me.lblDetails.Visible = (Len(Trim(typP.strDetails)) > 0)" & vbCrLf s = s & " If Me.lblDetails.Visible Then Me.lblDetails.Caption = typP.strDetails" & vbCrLf s = s & " ProcApplyIcon CInt(typP.enuIcon)" & vbCrLf s = s & " ProcApplyLang mintLang" & vbCrLf s = s & " ProcSetupBtns typP.strButtons, mintLang" & vbCrLf s = s & " Me.txtInput.Visible = (mintMode = 1 Or mintMode = 2)" & vbCrLf s = s & " Me.cboList.Visible = (mintMode = 3)" & vbCrLf s = s & " If mintMode = 1 Or mintMode = 2 Then" & vbCrLf s = s & " Me.txtInput.Value = typP.strDefault" & vbCrLf s = s & " Me.txtInput.SetFocus" & vbCrLf s = s & " End If" & vbCrLf s = s & " If mintMode = 3 Then" & vbCrLf s = s & " ProcFillList typP.strList, typP.strDefault" & vbCrLf s = s & " Me.cboList.SetFocus" & vbCrLf s = s & " End If" & vbCrLf s = s & " Exit Sub" & vbCrLf s = s & "ErrHandler:" & vbCrLf s = s & " Debug.Print ""Form_Open Err: "" & Err.Number & "" - "" & Err.Description" & vbCrLf s = s & " DoCmd.Close acForm, Me.Name" & vbCrLf s = s & "End Sub" & vbCrLf & vbCrLf StrFormCodeOpen = s End Function Private Function StrFormCodeBtn() As String Dim s As String s = "Public Function ProcBtnClick(ByVal intNum As Integer)" & vbCrLf s = s & " On Error GoTo ErrHandler" & vbCrLf s = s & " Dim strResult As String" & vbCrLf s = s & " Dim strWarn As String" & vbCrLf s = s & " Select Case mintMode" & vbCrLf s = s & " Case 1" & vbCrLf s = s & " If intNum = 1 Then" & vbCrLf s = s & " strResult = Nz(Me.txtInput.Value, """")" & vbCrLf s = s & " Else" & vbCrLf s = s & " strResult = ""__CANCEL__""" & vbCrLf s = s & " End If" & vbCrLf s = s & " Case 2" & vbCrLf s = s & " If intNum = 1 Then" & vbCrLf s = s & " If Len(Nz(Me.txtInput.Value, """")) > 0 Then" & vbCrLf s = s & " If Not IsNumeric(Me.txtInput.Value) Then" & vbCrLf s = s & " strWarn = IIf(mintLang = 0, ""أدخل رقماً صحيحاً"", ""Enter a valid number"")" & vbCrLf s = s & " MsgBox strWarn, vbExclamation" & vbCrLf s = s & " Me.txtInput.SetFocus" & vbCrLf s = s & " Exit Function" & vbCrLf s = s & " End If" & vbCrLf s = s & " End If" & vbCrLf s = s & " strResult = Nz(Me.txtInput.Value, """")" & vbCrLf s = s & " Else" & vbCrLf s = s & " strResult = ""__CANCEL__""" & vbCrLf s = s & " End If" & vbCrLf s = s & " Case 3" & vbCrLf s = s & " If intNum = 1 Then" & vbCrLf s = s & " strResult = Nz(Me.cboList.Value, """")" & vbCrLf s = s & " Else" & vbCrLf s = s & " strResult = ""__CANCEL__""" & vbCrLf s = s & " End If" & vbCrLf s = s & " Case Else" & vbCrLf s = s & " strResult = Me(""btn"" & intNum).Caption" & vbCrLf s = s & " End Select" & vbCrLf s = s & " SetResult strResult" & vbCrLf s = s & " DoCmd.Close acForm, Me.Name" & vbCrLf s = s & " Exit Function" & vbCrLf s = s & "ErrHandler:" & vbCrLf s = s & " Debug.Print ""ProcBtnClick Err: "" & Err.Number & "" - "" & Err.Description" & vbCrLf s = s & "End Function" & vbCrLf & vbCrLf StrFormCodeBtn = s End Function Private Function StrFormCodeUnload() As String Dim s As String s = "Private Sub Form_Unload(Cancel As Integer)" & vbCrLf s = s & " Dim typP As UiParams" & vbCrLf s = s & " typP = TypGetParams()" & vbCrLf s = s & " If Len(Nz(typP.strResult, """")) = 0 Then" & vbCrLf s = s & " SetResult ""__CANCEL__""" & vbCrLf s = s & " End If" & vbCrLf s = s & "End Sub" & vbCrLf StrFormCodeUnload = s End Function Private Function BlnEnsureForm() As Boolean On Error GoTo ErrHandler If BlnFormExists(STRFORMNAME) Then BlnEnsureForm = True Exit Function End If If Not BlnBuildMsgForm() Then LogError "BlnEnsureForm", 0, "BlnBuildMsgForm failed" Exit Function End If If Not BlnInjectMsgCode() Then LogError "BlnEnsureForm", 0, "BlnInjectMsgCode failed" Exit Function End If BlnEnsureForm = True Exit Function ErrHandler: LogError "BlnEnsureForm", Err.Number, Err.Description BlnEnsureForm = False End Function Private Function StrShowMsg(ByVal strMsg As String, _ ByVal enuIcon As UiIcon, _ ByVal strBtns As String, _ ByVal strTitle As String, _ ByVal enuMode As UiMode, _ ByVal strDef As String, _ ByVal strList As String, _ ByVal strDet As String, _ ByVal enuLang As UiLang) As String On Error GoTo ErrHandler If Not BlnEnsureForm() Then LogError "StrShowMsg", 0, "EnsureForm failed" StrShowMsg = "__CANCEL__" Exit Function End If If Len(Trim(strTitle)) = 0 Then strTitle = StrDefaultTitle(enuIcon, enuLang) End If ResetParams With m_typParams .strMessage = strMsg .strTitle = strTitle .strButtons = StrValidateButtons(strBtns) .enuIcon = enuIcon .enuMode = enuMode .strDefault = strDef .strList = strList .strDetails = strDet .enuLang = enuLang .strResult = "" End With DoCmd.OpenForm STRFORMNAME, acNormal, , , , acDialog StrShowMsg = m_typParams.strResult If Len(StrShowMsg) = 0 Then StrShowMsg = "__CANCEL__" ResetParams Exit Function ErrHandler: LogError "StrShowMsg", Err.Number, Err.Description ResetParams StrShowMsg = "__CANCEL__" End Function Public Sub UiInfo(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) Dim strBtns As String strBtns = IIf(enuLang = UiLangAr, "موافق", "OK") StrShowMsg strMsg, UiIconInfo, strBtns, strTitle, UiModeAlert, "", "", "", enuLang End Sub Public Sub UiSuccess(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) Dim strBtns As String strBtns = IIf(enuLang = UiLangAr, "موافق", "OK") StrShowMsg strMsg, UiIconSuccess, strBtns, strTitle, UiModeAlert, "", "", "", enuLang End Sub Public Sub UiWarning(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) Dim strBtns As String strBtns = IIf(enuLang = UiLangAr, "موافق", "OK") StrShowMsg strMsg, UiIconWarning, strBtns, strTitle, UiModeAlert, "", "", "", enuLang End Sub Public Sub UiError(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal strDetails As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) Dim strBtns As String strBtns = IIf(enuLang = UiLangAr, "موافق", "OK") StrShowMsg strMsg, UiIconError, strBtns, strTitle, UiModeAlert, "", "", strDetails, enuLang End Sub Public Function BlnUiConfirm(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) As Boolean Dim strBtns As String Dim strYes As String Dim strResult As String strBtns = IIf(enuLang = UiLangAr, "نعم,لا", "Yes,No") strYes = IIf(enuLang = UiLangAr, "نعم", "Yes") strResult = StrShowMsg(strMsg, UiIconQuestion, strBtns, strTitle, UiModeAlert, "", "", "", enuLang) BlnUiConfirm = (strResult = strYes) End Function Public Function IntUiConfirm3(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) As Integer Dim strBtns As String Dim strYes As String Dim strNo As String Dim strResult As String strBtns = IIf(enuLang = UiLangAr, "نعم,لا,إلغاء", "Yes,No,Cancel") strYes = IIf(enuLang = UiLangAr, "نعم", "Yes") strNo = IIf(enuLang = UiLangAr, "لا", "No") strResult = StrShowMsg(strMsg, UiIconQuestion, strBtns, strTitle, UiModeAlert, "", "", "", enuLang) Select Case strResult Case strYes: IntUiConfirm3 = 1 Case strNo: IntUiConfirm3 = 2 Case Else: IntUiConfirm3 = 0 End Select End Function Public Function UiInput(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal strDefault As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) As String Dim strBtns As String Dim strResult As String strBtns = IIf(enuLang = UiLangAr, "موافق,إلغاء", "OK,Cancel") strResult = StrShowMsg(strMsg, UiIconInfo, strBtns, strTitle, UiModeInput, strDefault, "", "", enuLang) UiInput = IIf(strResult = "__CANCEL__", "", strResult) End Function Public Function UiInputNum(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal strDefault As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) As String Dim strBtns As String Dim strResult As String strBtns = IIf(enuLang = UiLangAr, "موافق,إلغاء", "OK,Cancel") strResult = StrShowMsg(strMsg, UiIconInfo, strBtns, strTitle, UiModeNumber, strDefault, "", "", enuLang) Select Case strResult Case "__CANCEL__", "": UiInputNum = "" Case Else UiInputNum = IIf(IsNumeric(strResult), strResult, "") End Select End Function Public Function UiPick(ByVal strMsg As String, _ ByVal strItems As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal strDefault As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) As String Dim strBtns As String Dim strResult As String strBtns = IIf(enuLang = UiLangAr, "موافق,إلغاء", "OK,Cancel") strResult = StrShowMsg(strMsg, UiIconQuestion, strBtns, strTitle, UiModeList, strDefault, strItems, "", enuLang) UiPick = IIf(strResult = "__CANCEL__", "", strResult) End Function Public Function UiCustom(ByVal strMsg As String, _ ByVal strBtns As String, _ Optional ByVal enuIcon As UiIcon = UiIconQuestion, _ Optional ByVal strTitle As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) As String Dim strResult As String strResult = StrShowMsg(strMsg, enuIcon, strBtns, strTitle, UiModeAlert, "", "", "", enuLang) UiCustom = IIf(strResult = "__CANCEL__", "", strResult) End Function ' ===================================== ' أمثلة الاستخدام ' ===================================== ' UiSuccess "تم انشاء النظام بنجاح" ' UiInfo "رسالة معلومة" ' UiWarning "تحذير: لا يمكن التراجع" ' UiError "حدث خطأ", "", "تفاصيل الخطأ" ' ' If BlnUiConfirm("هل تريد الحذف؟") Then ... ' ' Select Case IntUiConfirm3("حفظ التغييرات؟") ' Case 1: ' نعم ' Case 2: ' لا ' Case 0: ' إلغاء ' End Select ' ' Dim s As String ' s = StrUiInput("أدخل اسمك", "", "محمد") ' If Len(s) > 0 Then ... ' ' Dim n As String ' n = StrUiInputNum("أدخل العمر", "", "25") ' ' Dim pick As String ' pick = StrUiPick("اختر قسم", "مبيعات,محاسبة,مخازن,إدارة") ' ' Dim choice As String ' choice = StrUiCustom("اختر خيار", "حفظ,تجاهل,إلغاء") ' Select Case choice ' Case "حفظ": ... ' Case "تجاهل": ... ' Case "": ' أُغلق بدون اختيار ' End Select طريقة الاعداد و التشغيل : بعد اضافة الوحدة النمطية: modUIMsgFramework الى قاعدة بياناتك استدعي من أي زر أمر داخل أى نموذج أو من النافذة الفورية مباشرة UiSuccess "تم انشاء النظام بنجاح" للتجربة الفورية فى المرفق تم اضافة ما يلى : وحدة نمطية باسم : modBuildTestUI ماكرو باسم : BuildTestUI شغل الماكرو BuildTestUI على الفور هيتم عمل جدول tblEmployees يحتوى على بيانات افتراضية غير حقيقية للتجربة وهيتم عمل نموذج اختبار متكامل وفتحة بشكل مباشر

هذا الموضوع يعد مهماً وحيوياً لمصممي ومطوري النظم أكثر من المستخدم العادي خاصة عند استخدام حدث Timer مع أي نموذج ويريد مطور النظام فتح محرر الأكواد (VBA) في نفس وقت عرض النماذج هنا تحدث المشكلة الكلاسيكية: المطور لا يستطيع تعديل أي كود لأن التايمر النموذج يعطل التركيز داخل المحرر و يسبب أخطاء بفضل هذه الفكرة الثورية هذا الأمر أصبح من الماضي السحيق فكرة العمل باختصار 1 - عند فتح النموذج يبدأ TimerInterval تلقائياً 2 - إذا تم فتح محرر VBA بأى طريقة كانت يتم إيقاف التايمر فوراً 3 - عند إغلاق المحرر والعودة إلى النماذج يتم تشغيل التايمر من جديد تلقائياً وفوراً 4 - لا حاجة لتمرير اسم النموذج الرئيسي أو اسم عنصر الـ Subform يدوياً 5 - المطلوب فقط هو تمرير اسم عنصر التحكم الذي سيتم عرض الوقت فيه (Label أو TextBox) حسب الحاجة والرغبة مميزات الحل ذكـي : يكتشف النموذج الرئيسي والفرعي تلقائياً متعدد : يعمل مع أكثر من نموذج في نفس الوقت مـــرن : يدعم Label و TextBox كعناصر عرض للوقت آمـــن : إذا تم حذف الوحدة النمطية يتحول تلقائياً إلى Fallback Mode باستخدام دالة الوقت الرئيسية : Now() خفيف : لا يعتمد على Timer إضافي للمراقبة جاهــز : يعمل مع النماذج الرئيسية و الفرعية أو الرئيسية المستقلة أو الرئيسية والفرعية معا ----------------------------------------------------- الوحدة النمطية العامة الاسم المقترح: basClockManager الكود... Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function SetWinEventHook Lib "user32" ( _ ByVal eventMin As Long, _ ByVal eventMax As Long, _ ByVal hmodWinEventProc As LongPtr, _ ByVal pfnWinEventProc As LongPtr, _ ByVal idProcess As Long, _ ByVal idThread As Long, _ ByVal dwFlags As Long) As LongPtr Private Declare PtrSafe Function UnhookWinEvent Lib "user32" ( _ ByVal hWinEventHook As LongPtr) As Long Private Declare PtrSafe Function GetAncestor Lib "user32" ( _ ByVal hwnd As LongPtr, _ ByVal gaFlags As Long) As LongPtr #Else Private Declare Function SetWinEventHook Lib "user32" ( _ ByVal eventMin As Long, _ ByVal eventMax As Long, _ ByVal hmodWinEventProc As Long, _ ByVal pfnWinEventProc As Long, _ ByVal idProcess As Long, _ ByVal idThread As Long, _ ByVal dwFlags As Long) As Long Private Declare Function UnhookWinEvent Lib "user32" ( _ ByVal hWinEventHook As Long) As Long Private Declare Function GetAncestor Lib "user32" ( _ ByVal hwnd As Long, _ ByVal gaFlags As Long) As Long #End If Private Const EVENT_SYSTEM_FOREGROUND As Long = &H3 Private Const WINEVENT_OUTOFCONTEXT As Long = &H0 Private Const GA_ROOT As Long = 2 Private gHook As LongPtr Private gAccessHwnd As LongPtr Private gClocks As Object Private Sub EnsureClockStore() If gClocks Is Nothing Then Set gClocks = CreateObject("Scripting.Dictionary") End If End Sub Private Function MakeClockKey(frm As Access.Form) As String On Error GoTo ErrorHandler Dim vParentForm As Access.Form Dim vControlName As String Set vParentForm = frm.Parent vControlName = GetSubformControlName(vParentForm, frm) If Len(vControlName) > 0 Then MakeClockKey = vParentForm.Name & "|" & vControlName & "|" & frm.Name Exit Function End If ErrorHandler: MakeClockKey = frm.Name End Function Private Function CreateClockState(frm As Access.Form, _ ByVal pControlName As String, _ ByVal pIntervalMS As Long) As Object Dim vState As Object Set vState = CreateObject("Scripting.Dictionary") Dim vIsSubform As Boolean Dim vParentName As String Dim vSubCtlName As String On Error Resume Next vParentName = frm.Parent.Name vSubCtlName = GetSubformControlName(frm.Parent, frm) vIsSubform = (Len(vSubCtlName) > 0) On Error GoTo 0 vState.Add "Key", MakeClockKey(frm) vState.Add "HostFormName", frm.Name vState.Add "ParentFormName", vParentName vState.Add "SubformControlName", vSubCtlName vState.Add "IsSubform", vIsSubform vState.Add "ControlName", pControlName vState.Add "WasStoppedByVBE", False vState.Add "IntervalMS", pIntervalMS Set CreateClockState = vState End Function Public Sub StartSmartClock(frm As Access.Form, _ ByVal pControlName As String, _ Optional ByVal pIntervalMS As Long = 1000) On Error GoTo ErrorHandler EnsureClockStore Dim vKey As String Dim vState As Object vKey = MakeClockKey(frm) If gClocks.Exists(vKey) Then gClocks.Remove vKey Set vState = CreateClockState(frm, pControlName, pIntervalMS) gClocks.Add vKey, vState frm.TimerInterval = pIntervalMS If gAccessHwnd = 0 Then gAccessHwnd = Application.hWndAccessApp If gHook = 0 Then gHook = SetWinEventHook( _ EVENT_SYSTEM_FOREGROUND, _ EVENT_SYSTEM_FOREGROUND, _ 0, _ AddressOf ForegroundChangedProc, _ 0, 0, _ WINEVENT_OUTOFCONTEXT) End If Exit Sub ErrorHandler: End Sub Public Sub StopSmartClock(frm As Access.Form) On Error Resume Next EnsureClockStore Dim vKey As String vKey = MakeClockKey(frm) frm.TimerInterval = 0 If gClocks.Exists(vKey) Then gClocks.Remove vKey End If If gClocks.Count = 0 Then If gHook <> 0 Then UnhookWinEvent gHook gHook = 0 End If Set gClocks = Nothing End If End Sub Public Sub SmartClockTimer(frm As Access.Form) On Error Resume Next EnsureClockStore Dim vKey As String Dim vState As Object vKey = MakeClockKey(frm) If Not gClocks.Exists(vKey) Then Exit Sub Set vState = gClocks(vKey) If IsVbeOpen() Then vState("WasStoppedByVBE") = True frm.TimerInterval = 0 Exit Sub End If Dim vTimeText As String vTimeText = Format$(Now(), "dd/mm/yyyy hh:nn:ss AM/PM") If Len(vState("ControlName")) > 0 Then UpdateControlDisplay frm, vState("ControlName"), vTimeText End If End Sub Private Function IsVbeOpen() As Boolean On Error Resume Next IsVbeOpen = Application.VBE.MainWindow.Visible If Err.Number <> 0 Then IsVbeOpen = False On Error GoTo 0 End Function Private Sub UpdateControlDisplay(frm As Access.Form, ByVal pControlName As String, ByVal pDisplayText As String) On Error Resume Next Dim vControl As Access.Control Set vControl = frm.Controls(pControlName) If vControl Is Nothing Then Exit Sub Select Case vControl.ControlType Case acTextBox If vControl.Value <> pDisplayText Then vControl.Value = pDisplayText End If Case acLabel If vControl.Caption <> pDisplayText Then vControl.Caption = pDisplayText End If End Select End Sub Private Function GetSubformControlName(vParentForm As Access.Form, vChildForm As Access.Form) As String On Error Resume Next Dim vControl As Access.Control For Each vControl In vParentForm.Controls If vControl.ControlType = acSubform Then If vControl.Form Is vChildForm Then GetSubformControlName = vControl.Name Exit Function End If End If Next vControl End Function Private Function GetStateTargetForm(vState As Object, ByRef vForm As Access.Form) As Boolean On Error GoTo ErrorHandler If vState("IsSubform") Then If (SysCmd(acSysCmdGetObjectState, acForm, vState("ParentFormName")) And acObjStateOpen) = 0 Then Exit Function Set vForm = Forms(vState("ParentFormName")).Controls(vState("SubformControlName")).Form Else If (SysCmd(acSysCmdGetObjectState, acForm, vState("HostFormName")) And acObjStateOpen) = 0 Then Exit Function Set vForm = Forms(vState("HostFormName")) End If GetStateTargetForm = Not (vForm Is Nothing) Exit Function ErrorHandler: Set vForm = Nothing End Function #If VBA7 Then Public Sub ForegroundChangedProc( _ ByVal hWinEventHook As LongPtr, _ ByVal eventId As Long, _ ByVal hwnd As LongPtr, _ ByVal idObject As Long, _ ByVal idChild As Long, _ ByVal dwEventThread As Long, _ ByVal dwmsEventTime As Long) #Else Public Sub ForegroundChangedProc( _ ByVal hWinEventHook As Long, _ ByVal eventId As Long, _ ByVal hwnd As Long, _ ByVal idObject As Long, _ ByVal idChild As Long, _ ByVal dwEventThread As Long, _ ByVal dwmsEventTime As Long) #End If On Error Resume Next If gClocks Is Nothing Then Exit Sub If gClocks.Count = 0 Then Exit Sub If GetAncestor(hwnd, GA_ROOT) <> gAccessHwnd Then Exit Sub Dim vKey As Variant Dim vState As Object Dim vForm As Access.Form For Each vKey In gClocks.Keys Set vState = gClocks(vKey) If vState("WasStoppedByVBE") Then If GetStateTargetForm(vState, vForm) Then vForm.TimerInterval = vState("IntervalMS") Dim vTimeText As String vTimeText = Format$(Now(), "dd/mm/yyyy hh:nn:ss AM/PM") If Len(vState("ControlName")) > 0 Then UpdateControlDisplay vForm, vState("ControlName"), vTimeText End If vState("WasStoppedByVBE") = False End If End If Next vKey End Sub ----------------------------------------------------- طريقة الاستدعاء في النماذج نموذج يعرض الوقت في Label الكود... Private Sub Form_Load() Application.Run "StartSmartClock", Me, "lblTime", 1000 End Sub Private Sub Form_Timer() Application.Run "SmartClockTimer", Me End Sub Private Sub Form_Unload(Cancel As Integer) Application.Run "StopSmartClock", Me End Sub ----------------------------------------------------- نموذج يعرض الوقت في TextBox الكود... Private Sub Form_Load() Application.Run "StartSmartClock", Me, "txtTime", 1000 End Sub Private Sub Form_Timer() Application.Run "SmartClockTimer", Me End Sub Private Sub Form_Unload(Cancel As Integer) Application.Run "StopSmartClock", Me End Sub ----------------------------------------------------- نموذج بدون عرض نصي للوقت الكود... Private Sub Form_Load() Application.Run "StartSmartClock", Me, "", 1000 End Sub Private Sub Form_Timer() Application.Run "SmartClockTimer", Me End Sub Private Sub Form_Unload(Cancel As Integer) Application.Run "StopSmartClock", Me End Sub ----------------------------------------------------- كما تلاحظون الاستدعاء سهل وموحد سواء أردنا عرض الوقت في TextBox أو Label Application.Run "StartSmartClock", Me, "", 1000 ملاحظة هامة حول معامل : TimerInterval وهو المعامل الثالث فى الاستدعاء (Interval) الرقم: 1000 هو قيمة TimerInterval يمثل الفاصل الزمني بالميلي ثانية القيمة الافتراضية : 1000 (ثانية واحدة) تم ضبطها مسبقاً داخل الوحدة النمطية هل هو إجباري؟ لايمكن حذفه والاعتماد على القيمة الافتراضية طرق الاستدعاء المختلفة مع المعامل : ' الطريقة الأولى: تمرير قيمة مخصصة (مثلاً نصف ثانية) Application.Run "StartSmartClock", Me, "lblTime", 500 ' الطريقة الثانية: حذف المعامل (يتم استخدام 1000 تلقائياً) Application.Run "StartSmartClock", Me, "lblTime" في بعض الحالات قد يرغب المصمم في عمل التالى : ساعة عادية لذلك سوف تكون قيمة : TimerInterval =1000 (ثانية واحدة) ساعة دقيقة (Stopwatch) تكون قيمة TimerInterval = 100 (جزء من الثانية) ساعة بطيئة (تحديث نادر) تكون قيمة TimerInterval = 5000 (5 ثوانٍ) لهذا السبب تم جعل هذا المعامل اختيارياً مع استخدام القيمة الإفتراضية المنطقية مع إتاحة المجال للمصمم لتغييره حسب احتياجاته ----------------------------------------------------- نموذج مع Fallback ( منتهى الأمان ) الكود... Option Compare Database Option Explicit Private mIsSmartClockActive As Boolean Private Sub Form_Load() AttemptStartSmartClock End Sub Private Sub Form_Timer() Dim vTimeText As String vTimeText = Format$(Now(), "dd/mm/yyyy hh:nn:ss AM/PM") If mIsSmartClockActive Then Application.Run "SmartClockTimer", Me Me.txtDClock = vTimeText Else ' Fallback: النموذج يحدث نفسه بنفسه Me.txtDClock = vTimeText Me.lblDClock.Caption = vTimeText End If End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next If mIsSmartClockActive Then Application.Run "StopSmartClock", Me End If Me.TimerInterval = 0 On Error GoTo 0 End Sub Private Sub AttemptStartSmartClock() On Error GoTo FallbackMode Application.Run "StartSmartClock", Me, "lblDClock", 1000 mIsSmartClockActive = True Exit Sub FallbackMode: Err.Clear mIsSmartClockActive = False Me.TimerInterval = 1000 End Sub ----------------------------------------------------- الخلاصة النهائية :الاستدعاء المناسب عرض الوقت في : Label LabelStartSmartClock Me, "lblTime" عرض الوقت في : TextBox StartSmartClock Me, "txtTime" بدون عرض نصى للوقت مثلا : ساعة عقارب (بدون عرض نصي) StartSmartClock Me, "" نموذج فرعي (Subform) نفس الكود - يتم اكتشافه تلقائياً نماذج متعددة في نفس الوقت مدعوم بالكامل ملاحظات مهمة إعدادات الأمان : يجب تفعيل Trust access to the VBA project object model في إعدادات Trust Center إصدار Access : يعمل مع Access 2007 والإصدارات الأحدث مراجع إضافية : لا يحتاج إلى إضافة أي مراجع Fallback Mode : إذا تم حذف الوحدة النمطية، يتحول النموذج تلقائياً إلى استخدام Now() مع هذا الحل الفريد أصبح : التحكم في TimerInterval أثناء فتح محرر VBA أمراً تلقائياً بالكامل، دون أي تدخل يدوي أو تعقيدات سهولة فتح محرر VBA و إضافة أو تعديل أى أكواد في نفس وقت عرض النماذج وبدون أن تحدث المشكلة الكلاسيكية بسبب : TimerInterval استمتع بتجربة تطوير سلسة وخالية من المشاكل

Encode input data in a barcode or Qr-Code

برنامج مجانى تماما كامل لمتابعة ذوى الاحتياجات الخاصة والمهارات والأهداف التى يجب تجاوزها فى كل مرحلة والتى توضع حسب خطط منظمة ومتسلسلة ومتصلة يصلح لمراكز التأهيل وبه اسلوب ووضع خطط لكلاً من (مهارات التنمية - صعوبات التعلم - مهارات التخاطب - تأهيل وظيفى ...) ويمكن البرنامج من وضع جلسات وأعادتها ووضع تقارير عن كل شىء من الخطط والأهداف والجلسات والاخصائى وطرق البحث المكثفة والمتخصصة عن الحالات ووضع وتقييم الحالة وما تم من انجازات خلال تنفي> الخطط اللهم أكتب الشفاء لكل من أصابه ابتلاء واللهم أليك السؤال وفعلك ما شئت فأرحم عباداً يا من كتبت على نفسك الرحمة وأن الرحمن الدنيا والأخرة ورحيمهما نسألكم الدعاء أخوكم فى الله وليد الجمل سائلاً لله أن يجعله سبباً فى تحسين حالات أولادنا وأطفالنا ورحمة من الله لنا

أقدم لكم اليوم أداة بسيطة ولكن فائدتها كبيرة لما تختصره من الوقت والجهد في كتابة الأوامر الخاصة بمربعات حوار الرسائل MsgBox خصوصاً في حالة النصوص الطويلة بإستخدام هذه الأداة لن تحتاج إلا إلى إدخال عنوان الرسالة والنص الخاص بها وتحديد بقية الخيارات من خلال تحديدها من قائمة الخيارات بدون الحاجة إلى أي معرفة برمجية وعند الإنتهاء من تحديد الخيارات يمكنك إستعراض الرسالة للتأكد من ظهورها بالشكل المطلوب وعندها كل ماعليك هو نقر زر لنسخ صيغة الأمر والذهاب للمكان المطلوب في تطبيقك ولصقه بإمكان الأداة القيام بإنشاء صيغتين للأمر 1- صيغة الأمر البسيطة والتي ستكون بالشكل التالي MsgBox "نص الرسالة",vbOk,"العنوان" 2- صيغة الأمر ضمن شرط If وستظهر عندما تحتوي الرسالة على أكثر من زر لتصبح بالشكل التالي If MsgBox ("نص الرسالة",vbOkCancel,"العنوان")=vbOk Then End If كذلك ستجد خيارات إضافية كإمكانية تحديد إتجاه الرسالة لتناسب الرسائل باللغة العربية أو الإنجليزية وإمكانية الإحتفاظ بالنص في متغير والذي يكون مفيداً للغاية عند العمل مع النصوص الطويلة والتي تحتوي على أكثر من سطر وغيرها من المزايا الإضافية التي ستجدونها من خلال تجربتكم للأداة. كما ذكرت فالأداة بسيطة جداً لدرجة أني لم أحتاج لإضافة أي تعليمات توضيحية لطريقة عملها فهي لاتحتوي إلا على نموذج واحد فقط ويمكنك تخصيص قاعدة بيانات مستقلة للقيام بمساعدتك في إنشاء الصيغ لبقية التطبيقات أو إستيراد النموذج لأي تطبيق والعمل به بكل بساطة. كفائدة إضافية وحتى لا تحتاج لإستيراد النموذج إلى جميع تطبيقاتك فقد أنشأت منه نسخة تعمل كوظيفة إضافية Add-In مرفق معها مستند وورد يشرح طريقة تثبيتها وإستخدامها أرجو أن تنال هذا الأداة إعجابكم وإذا كانت هناك أي ملاحظات فأرجو ذكرها تحياتي

تواصلاً لهذه السلسلة أقدم لكم اليوم أداة رائعة تقوم بإضافة التعليمات المساعدة لتطبيقات الأكسس لتظهر بمظهر البرامج الإحترافية حيث تسمح لكم الأداة بإنشاء ملف تعليمات مقسم إلى عناوين رئيسية تحتوي على مواضيع فرعية بحيث يكون لكل موضوع فرعي التعليمات الخاصة به مرفق لكم مجلد يحتوي على ثلاثة ملفات 1 - القالب وهو نسخة فارغة تحتوي على الكائنات الضرورية والتي يتم إستيرادها إلى التطبيق الخاص بكم (ويمكن إستخدامه في إنشاء التعليمات لأي تطبيق وإستيراد الكائنات المطلوبة بعد الإنتهاء كتابة كل التعليمات الخاصة بالتطبيق حيث يوجد هناك ثلاثة نماذج لن تحتاجونها إلى في نسخة التطوير ويمكن الإستغناء عنها في الإصدار المخصص للمستخدم النهائي) 2 - عرض توضيحي يوضح لكم طريقة العمل بالأداة والذي أرجو أن يتم التركيز على الخطوات الموضحة فيه 3 - مثال عملي قمت فيه بتوضيح الطرق المختلفة للإستفادة من الأداة في مثال مشابه للواقع أرجو أن تكون هذه الأداة إضافة مفيدة لكل الإعضاء تحياتي