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

اعرض الملف إمنح تطبيقك المظهر الإحترافي بإستخدام مربع حوار المهام بديل لـ MsgBox {سلسلة الأدوات المساعدة المخصصة} أرفق لك إحدى الأدوات الرائعة التي يمكن أن تغنيك عن الكثير من النماذج وتجعل رسائل التنبيه تشبه رسائل ويندوز حاولت قد الإمكان تبسيط طريقة الإستخدام وتوضيحها في التعليقات أرجو أن تنال إعجابكم مع تحياتي صاحب الملف منتصر الانسي تمت الاضافه 07/05/25 الاقسام قسم الأكسيس  

أخواني وأساتذتي ومعلمينا ( دون استثناء ) أعتقد أنه ومن خلال العنوان سيتسائل البعض عن أن المحاولات كانت كثيرة لبناء هذه الفكرة ولكنها مع التحديثات الجديدة تفشل !! وهذا الإعتقاد منطقي 😁 . إلا انه وبهذه التحديثات - واتمنى - أنه قد تم التعامل مع هذه الأخطاء بهذه النسخة المطورة والمحسنة . الإضافات التي تم تأمينها في هذه النسخة :- التعامل مع المرفقات بسلاسة وسهولة من خلال فكرة نسخ المرفق ولصقه في تطبيق الواتس اب ( سطح المكتب ) ، وليس من خلال المسار 😁 . إمكانية الإرسال لأكثر من رقم دفعة واحدة . افصل بين الرقمين بإشارة / فقط . إمكانية إضافة التعبيرات Emoji وإرسالها ضمن الرسائل في الواتس أب . من خلال زر زر لمسح محتوى الرسالة تهيئةً لإرسال جديد . من خلال الزر تضمين محدد لحجم الملفات والمرفقات المرسلة . ( خاص بأصحاب التطويرات الذين يريدون تقييد وإلزام المستخدم بحجم محدد ) . استخدام تايمر متغير للتعامل مع الإرسالات المتعددة لأكثر من رقم . واجهة محاكية وجذابة للبرنامج . لا تحتاج جداول أو مكتبات خارجية .... إلخ . تم كتابة الدوال والأكواد بطريقة تسهل على المطورين إعادة الهيكلة والتصميم حسب حاجتهم في برامجهم . واجهة البرنامج :- :- ضرورة تثبيت برنامج واتس اب سطح المكتب من متجر ويندوز . التأكد من فتح تطبيق الواتس أب سطح المكتب لديك ، لتلافي المشاكل عند اختلاف سرعة إستجابة الكمبيوتر من مستخدم لآخر . WhatsApp Sender 2025.zip

رغم أن معظم الأكواد تحتاج الى إعادة هيكلة وتصحيح ، ولكن جرب هذا المقترح ، بعد ما تمت تجربته على ملفك السابق :- Private Function GetDateColumn(ByVal searchDate As Date) As Long Dim cell As Range Dim searchRange As Range Set searchRange = wsData.Range(wsData.Cells(HEADER_ROW, DATE_COL_START), _ wsData.Cells(HEADER_ROW, wsData.Columns.Count)) For Each cell In searchRange If IsDate(cell.Value) Then If CDate(cell.Value) = searchDate Then GetDateColumn = cell.Column Exit Function End If End If Next cell GetDateColumn = 0 End Function جرب الملف التالي وشوف النتيجة Book5.zip

بعد إذن الاستاذ/ هشام جرب كود الأستاذ/هشام بعد تعديل بسيط Option Explicit Sub Transfer() Dim code As Variant, c As Boolean Dim tmp(0 To 4) As Boolean, xDate As String Dim f As Long, i As Long, j As Long Dim linge As Long, xCode As Boolean, Irow As Range Dim ColArr As Long, xName As String, n As Variant, val As Variant Dim lastRow As Long Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") Dim Data As Worksheet: Set Data = Sheets("Sheet3") ' التحقق من وجود التاريخ xDate = Format(CrWS.Range("D2").Value, "dd/mm/yyyy") If xDate = "" Then MsgBox "المرجوا تحديد التاريخ", vbInformation Exit Sub End If ' البحث عن العمود المطابق للتاريخ في الصف 3 With Data For ColArr = .Columns("E").Column To .Cells(3, .Columns.Count).End(xlToLeft).Column If Format(.Cells(3, ColArr).Value, "dd/mm/yyyy") = xDate Then f = ColArr Exit For End If Next ColArr If f = 0 Then MsgBox "لم يتم العثور على التاريخ", vbExclamation Exit Sub End If End With ' تحديد آخر صف يحتوي أكواد في العمود C من Sheet2 lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).Row xCode = False: c = False ' البدء من الصف 11 حتى يشمل أول طالب For i = 11 To lastRow code = CrWS.Cells(i, "C").Value If code <> "" Then linge = Data.Cells(Data.Rows.Count, "D").End(xlUp).Row n = Application.Match(code, Data.Range("D6:D" & linge), 0) If Not IsError(n) Then xCode = True ' مسح الصف الخاص بالكود الحالي فقط For ColArr = 0 To 4 Data.Cells(n + 5, f + ColArr).ClearContents Next ColArr ' نقل القيم For j = 0 To 4 xName = CrWS.Cells(10, 4 + j).Value For ColArr = 0 To 4 If Data.Cells(4, f + ColArr).Value = xName Then val = CrWS.Cells(i, 4 + j).Value If Not IsEmpty(val) Then Data.Cells(n + 5, f + ColArr).Value = val c = True If Not tmp(j) Then Data.Cells(5, f + ColArr).Value = CrWS.Cells(11, 4 + j).Value tmp(j) = True End If End If Exit For End If Next ColArr Next j End If End If Next i ' رسائل النهاية If Not xCode Then MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation ElseIf c Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Else MsgBox "لا توجد بيانات لترحيلها", vbInformation End If End Sub غياب3.xlsm

بعد اذن اخي فادي تفضل من عمل اخونا صالح حمادي جربته وأستخدمه دوما في الشاشات التي تفتح على كامل الشاشة .. يعمل 100% ملائمة النموذج حسب حجم الشاشة صالح حمادي.rar

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

وعليكم السلام ورحمة الله وبركاته ,, فيما يخص الإيميل ، فهذه فكرة بسيطة من خلال النقر على مربع نص الإيميل على سبيل المثال :- Private Sub EMAIL_Click() Dim EmailAdd As String Dim GmailURL As String EmailAdd = Me.EMAIL.Value If Not IsValidEmails(EmailAdd) Then MsgBox "عنوان البريد الإلكتروني غير صالح", vbExclamation + vbMsgBoxRight, "" Exit Sub End If GmailURL = "https://mail.google.com/mail/?view=cm&fs=1&to=" & EmailAdd Application.FollowHyperlink GmailURL End Sub Function IsValidEmails(EMAIL As String) As Boolean Dim regex As Object Set regex = CreateObject("VBScript.RegExp") regex.Pattern = "^[\w-\.]+@([\w-]+\.)+[\w-]{2,4}$" regex.IgnoreCase = True IsValidEmails = regex.Test(EMAIL) End Function والطلب الثاني ، وهو فتح واتس أب ويب على دردشة محددة للرقم الذي تم النقر عليه ، حذح محاولتي البسيطة ( مشتقة من أحد ملفاتي سابقاً ) .. Private Sub MOB_Click() Dim WhatsURL As String Dim PhoneNum As String PhoneNum = Me.MOB.Value PhoneNum = CleanPhoneNum(PhoneNum) If PhoneNum = "" Then MsgBox "رقم الهاتف غير صالح", vbExclamation + vbMsgBoxRight, "" Exit Sub End If WhatsURL = "https://wa.me/" & PhoneNum Application.FollowHyperlink WhatsURL End Sub Function CleanPhoneNum(phone As String) As String Dim i As Integer Dim result As String result = "" For i = 1 To Len(phone) If IsNumeric(Mid(phone, i, 1)) Then result = result & Mid(phone, i, 1) End If Next i If Left(result, 2) = "00" Then result = Right(result, Len(result) - 2) ElseIf Left(phone, 1) = "+" Then result = Right(result, Len(result) - 1) End If CleanPhoneNum = result End Function

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

السلام عليكم ورحمة الله وبركاته حياكم الله جميعا عذرا اخي المفتاح الرئيسي صحيح ولا يوجد مشكلة فيه كانت المشكلة في نوع البيانات، كانت هناك بيانات نوعها رقم كبير وكانت خصائص قاعدة البيانات لا تسمح برقم كبير ، وعندما فعلت هذا الخيار ظهرت الجداول بشكل صحيح

تمام أخي الكريم ،، نستطيع تلافي المشكلة بإخفاء النموذج بشكل مؤقت أثناء المعاينة !! استخدم الكود التالي في زر المعاينة ، وجرب Private Sub btnPrint_Click() If lstResults.ListCount = 0 Then MsgBox "لا توجد نتائج لطباعتها", vbExclamation: Exit Sub End If Dim sh As Worksheet, nextRow As Long, i As Long, j As Long Const REPORT_SHEET As String = "تقرير الغياب" Me.Hide On Error Resume Next: Application.DisplayAlerts = False Worksheets(REPORT_SHEET).Delete Application.DisplayAlerts = True: On Error GoTo 0 Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count)) sh.Name = REPORT_SHEET For j = 0 To lstResults.ColumnCount - 1 sh.Cells(1, j + 1).Value = "العمود " & j + 1 Next j sh.Range("A1:" & sh.Cells(1, lstResults.ColumnCount).Address).Font.Bold = True nextRow = 2 For i = 0 To lstResults.ListCount - 1 For j = 0 To lstResults.ColumnCount - 1 sh.Cells(nextRow, j + 1).Value = lstResults.List(i, j) Next j nextRow = nextRow + 1 Next i sh.Columns.AutoFit sh.PageSetup.Orientation = xlPortrait sh.PageSetup.Zoom = False sh.PageSetup.FitToPagesWide = 1 sh.PageSetup.FitToPagesTall = 1 sh.PrintPreview Me.Show End Sub

التحديث الجديد يستحق الإنتظار 🤗

اعرض الملف ⭐ هدية ~ مرسال الواتس أب الجديد 2025⭐ أخواني وأساتذتي ومعلمينا ( دون استثناء ) أعتقد أنه ومن خلال العنوان سيتسائل البعض عن أن المحاولات كانت كثيرة لبناء هذه الفكرة ولكنها مع التحديثات الجديدة تفشل !! وهذا الإعتقاد منطقي 😁 . إلا انه وبهذه التحديثات - واتمنى - أنه قد تم التعامل مع هذه الأخطاء بهذه النسخة المطورة والمحسنة . الإضافات التي تم تأمينها في هذه النسخة :- التعامل مع المرفقات بسلاسة وسهولة من خلال فكرة نسخ المرفق ولصقه في تطبيق الواتس اب ( سطح المكتب ) ، وليس من خلال المسار 😁 . إمكانية الإرسال لأكثر من رقم دفعة واحدة . افصل بين الرقمين بإشارة / فقط . إمكانية إضافة التعبيرات Emoji وإرسالها ضمن الرسائل في الواتس أب . من خلال زر زر لمسح محتوى الرسالة تهيئةً لإرسال جديد . من خلال الزر تضمين محدد لحجم الملفات والمرفقات المرسلة . ( خاص بأصحاب التطويرات الذين يريدون تقييد وإلزام المستخدم بحجم محدد ) . استخدام تايمر متغير للتعامل مع الإرسالات المتعددة لأكثر من رقم . واجهة محاكية وجذابة للبرنامج . لا تحتاج جداول أو مكتبات خارجية .... إلخ . تم كتابة الدوال والأكواد بطريقة تسهل على المطورين إعادة الهيكلة والتصميم حسب حاجتهم في برامجهم . واجهة البرنامج :- :- ضرورة تثبيت برنامج واتس اب سطح المكتب من متجر ويندوز . التأكد من فتح تطبيق الواتس أب سطح المكتب لديك ، لتلافي اختلاف سرعة إستجابة الكمبيوتر من مستخدم لآخر . صاحب الملف Foksh تمت الاضافه 07/03/25 الاقسام قسم الأكسيس  

طيب و بمناسبة الرفع والشوط والله مش هزعلك اتفضل 1- Show And Hdie لاخفاء واظهار الامر الخاص باخفاء واظهار الملفات والمجلدات بعد الاخفاء سوف تكون بهذا الشكل طبعا اى مجلدات او ملفات مخفيه لن يستطيع المستخدم الذى يريد العبث اعادة اظهارها والاطلاع عليها لان أمر اظهار الملفات او المجلدات المخفيه اساسا اختفى 2- usb Open And Lock تفعيل / عدم تفعيل قراءة اى شئ من منفذ USB عند استخدام : USB LOOK لو عندك الف منفذ Usb ادخل بهم اى فلاشة او هردات محمولة لن يتم قرائتها مطلقا usb Open And Lock.zip Show And Hdie.zip

ما شاء الله ، مبدع فيما طرحت . أثار الموضوع اهتمامي سابقاً في مناقشة سابقة ومداخلة قوية لك ، مما جعلني أتحرى عن موضوع الحقن بشكل عميق وأحاول تنفيذه في مشاريعي تالياً .. ومن سياق الحديث الذي طرحته ، اعتقد أن استخدام المعلمات بدلاً من سلاسل نصية سيكون من خطوات الأمان التي قد يجب تنفيذها . أيضاً على ما أعتقد استخدامنا لمطهرات النصوص قد يأتي بنتيجة جيدة ومساعدة ,, على سبيل المثال ، هذه فكرة بسيطة أيضاً وقد تكون قابلة للتطوير والتحديث بشمولية ,, If InStr(Me.txtUser, "'") > 0 Or InStr(Me.txtUser, ";") > 0 Then MsgBox "تم استخدام رموز غير مسموح بها في اسم المستخدم", vbExclamation Exit Sub End If ولهذا السبب كنت قد استخدمت محاولة لم أقم بتجربتها بعد ، على أحد المشاريع باستخدام هذه الدالة :- Public Function Sanitizer(ByVal userInput As String, Optional ByVal context As String = "sql") As String Dim sanitized As String sanitized = Trim(userInput) Select Case LCase(context) Case "sql" sanitized = Replace(sanitized, "'", "''") sanitized = Replace(sanitized, ";", "") sanitized = Replace(sanitized, "--", "") Case "name" sanitized = Replace(sanitized, "'", "") sanitized = Replace(sanitized, ";", "") sanitized = Replace(sanitized, "*", "") sanitized = Replace(sanitized, "=", "") Case "pure" Case Else sanitized = Replace(sanitized, "'", "''") End Select Sanitizer = sanitized End Function وعلى سبيل المثال كإستخدام في الاستعلامات :- Dim filter As String filter = "[U_UserName]='" & Sanitizer(Me.txtUser, "sql") & "' AND [U_Password]='" & Sanitizer(Me.txtPass, "sql") & "'" DoCmd.OpenForm "frmDashboard", , , filter وكمثال على ما طرحته سابقاً لفتح نموذج بفلترة .. DoCmd.ApplyFilter , "[U_UserName]='" & Sanitizer(Me.txtSearch, "sql") & "'" أو حتى في نموذج تسجيل الدخول لاسم المستخدم ، كانت المحاولة :- Dim newUser As String newUser = Sanitizer(Me.txtNewUser, "name") هذه كانت الفكرة التي خطرت لي ، ولكن لاحقاً قمت بتحديثها لإظهار رسالة تحذيرية تلقائية إذا تم رصد مدخل خطير أو محاولات حقن نصية 😁

تفضل Sub FormatUniqueCellsInRow() Dim ws As Worksheet Dim lastRow As Long, startRow As Long Dim r As Long, i As Long, j As Long Dim values(1 To 7) As Variant Dim count As Long Dim data As Variant On Error GoTo ErrorHandler Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من تغيير "Sheet1" إلى اسم الورقة الفعلي startRow = 3 ' الصف الذي تبدأ منه البيانات lastRow = ws.Range("C3:I" & ws.Rows.Count).Find(What:="*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' تنظيف التنسيقات السابقة من الأعمدة C:I و O With ws.Range("C" & startRow & ":I" & lastRow & ",O" & startRow & ":O" & lastRow) .Interior.ColorIndex = xlNone .Font.ColorIndex = xlAutomatic .Font.Bold = False End With ' تحميل النطاق إلى مصفوفة data = ws.Range("C" & startRow & ":I" & lastRow).Value ' المرور على كل صف For r = 1 To lastRow - startRow + 1 ' تخزين قيم الصف الحالي For i = 1 To 7 values(i) = data(r, i) Next i ' فحص القيم الفريدة For i = 1 To 7 count = 0 If Not IsEmpty(values(i)) Then For j = 1 To 7 If CStr(values(j)) = CStr(values(i)) Then count = count + 1 End If Next j ' إذا كانت القيمة فريدة If count = 1 Then ' تطبيق التنسيق على الخلية في C:I With ws.Cells(r + startRow - 1, i + 2) .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With ' تطبيق نفس التنسيق على الخلية في العمود O في نفس الصف With ws.Cells(r + startRow - 1, "O") .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With End If End If Next i Next r MsgBox "تمت معالجة البيانات بنجاح!", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub

قلة تركيز DLookup_01.accdb

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

جميل ، وهذا ما كنت اعمل عليه في هذه الفكرة ,, ودون شرحها هنا ، في المرفق نموذجين كأفكار قابلة للتحوير والتعديل حسب حاجتنا . مع العلم أنني قمت بإضافات قد لا تحتاجها ، ولكنها من باب الفضول والزيادة 😅 data1-1.zip

كنت عامل موضوع بهذا الخصوص ولكن لتصفير و حذف بيانات أكثر من جدول ان اردت التوسع هذا رابط الموضوع https://www.officena.net/ib/topic/106503-حذف-بيانات-جداول-منضمة-ومرتبطه-دفعة-واحدة-على-حسب-اختيارك/#comment-642632

تفضل أخي عبدالعزيز @Abdelaziz Osman 🙂 هذا الاستعلام لو بتشغله في ال VBA : ' DELETE statement | جملة DELETE Dim sqlDelete As String sqlDelete = "DELETE FROM [TABINDX]" sqlDelete = sqlDelete & " WHERE [ID] = " & var_ID ' Execute The Query | تنفيذ الاستعلام CurrentDb.Execute sqlDelete وهذ لو بتشغله كاستعلام أكسس : DELETE FROM [TABINDX] WHERE [ID] = var_ID ولا تنسى أن تضع قيمة ال ID المطلوب حذفه مكان الـمتغير : var_ID ولو بتحذف كافة محتويات الجدول تكتب كذا : CurrentDb.Execute "DELETE FROM TABINDX"

احسنت وبارك الله فيك شكرا لتجاوبك تمت التجربة مع بعض التعديلات البسيطه وكانت فعاله Dim ctrl As Control For Each ctrl In Me.Controls If (ctrl.ControlType = acTextBox Or ctrl.ControlType = acComboBox) Then If (Nz(ctrl.Value, "") = "") Then MsgBox "يرجى تعبئة جميع الحقول قبل الحفظ." & vbCrLf & _ "الحقل الفارغ: " & ctrl.Name, vbExclamation ctrl.SetFocus Exit Sub End If End If Next ctrl ' إذا جميع الحقول تم تعبئتها، يتم الحفظ DoCmd.RunCommand acCmdSaveRecord MsgBox "تم الحفظ بنجاح بنجاح", 0 + 64 + 1048576, "مؤكد" DoCmd.Close

كثيرون استفسروا عن كيفية اختيار اسم مخزن في الجدول ، بدلاً من كتابة الرقم بشكل يدوي . ولذا قد صورت هذا الفيديو كفكرة سريعة على الخطوات - وصولاً إلى النتيجة ,, طبعاً كلمة كثيرون = في مجموعة الواتس أب الخاصة بقسم آكسيس وليس في المنتدى 🤣

في المعايير النصية لبعض الاستعلامات نستخدم WHERE U_UserName = '" & strUser & "' AND U_Password = '" & strPass & "'") وكذلك الحال في دوال تجميع المجال "[U_FullName]='" & [tx3] & "'") ايضا عندما نضع معيار نصي لفتح فورم من خلال فورم اخر DoCmd.OpenForm "frm2", , , "[U_UserName]='" & [tx2] & "'" وكذلك الحال عند الفلترة بمعيار نصي DoCmd.ApplyFilter , "[U_UserName]='" & [tx9] & "'" وحيث ان الحقول النصية تقبل كتابة أي احرف أو أرقام أو رموز خاصة وبالتي يمكن توظيفها بطريقة معينة لتنفيذ اجراء غير شرعي الحقيقة التي يعلمها اي شخص لديه خبرة في الحماية أن الرموز الخاصة ورسائل الخطأ غير المعالجة تمثل الطريق الأسهل للاختراق في الحالة الاولى معيار نصي في استعلام يمكن تسجيل دخول غير شرعي بكافة صلاحيات مستخدم رقم 1 ويمكن تنفيذ استعلام حذف او الحاق او او ... الخ في حالة رقم 2 مع دوال تجميع المجال يمكن تنفيذ الدالة دون معرفة المعيار وتعود باول او اخر او اكبر سجل وفقا لنوع الدالة في الحالة الثالثة نحتاج أحيانا لفتح فورم وإحضار بيانات محددة للعرض و يمكن من خلال توظيف الرمز فتح الفور مع اول سجل او كافة السجلات ويمكن استعراضها والتنقل بينها هنا لا داعي لمعرفة المعيار فقط رموز ونجوم يتم كتابتها بطريقة معينة وكذلك في الحالة الرابعة الفلترة يمكن فلترة كافة البيانات والتنقل بدون الحاجة لمعرفة المعيار والسؤال هل هذا هو الرمز الوحيد الذي يمكن استغلاله (') الاجابة لا ولكن ركزنا عليه لكونه الأكثر استخدام في قاعدة البيانات اخيرا هل يمكن انهاء المشكلة وخصوصا ان الرمز مطلوب للمعايير النصية نعم يمكن بتتبع المدخلات للحقول النصية المرتبطة باجراء ومن اسهل الطرق استخدام دالة Replace strPass = Replace(Me.U_Password, "'", "_") ايضا استخدام رسائل معالجة الاخطاء وتحديد الاجراء عند حدوث خطأ ونكتفي بهذا القدر عن الرمز (') وقد نتحدث غن رمز اخر لايقل خطورة والله الموفق الشايب

اللي قدر على دفندر وجذوره كلها في وندوز .. احتمال لا يقدر على مجلد محمي بواسطة وندوز انا عرضت لك مثال ليس الا .. انه كل شيء ممكن في علم البرمجة نحذف كلمة : (مستحيل .. لا يمكن ) من قاموسنا المستحيل اليوم قد يصبح ممكنا غدا .. نعم قلناها بالامس ونراها ايوم

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

اتفضل الطريقة نعم بدون حبة الملح : Salt ولحالة آمن ولكن حبة الملح هذه تزيد من قوة التأمين فى فى التشفير جدا جدا جدا

لمنع موضوع الحق انا استخدم الداله Public Function SafeSql(strValue As String) As String If IsNull(strValue) Or strValue = "" Then SafeSql = "NULL" Else SafeSql = "'" & Replace(strValue, "'", "''") & "'" End If End Function وامرر لها اسم المستخدم وكلمة المرور strUserName = SafeSql(strUserName)

تفضل أخي الكريم ، محاولتي البسيطة . حيث في الورقة الثانية = موقف الغياب اليومي ، قمت بإضافة زر للتحديث ، وتم استدعاءه للدالة التي تم انشاؤها في مديول عام :- Sub ExtractAbsentEmployees() Dim wsMain As Worksheet Dim wsReport As Worksheet Dim targetDate As Date Dim dayNum As Integer Dim targetCol As Integer Dim lastRow As Long Dim i As Long Dim reportRow As Long Set wsMain = ThisWorkbook.Sheets("MainSheet") Set wsReport = ThisWorkbook.Sheets("موقف الغياب اليومي") wsReport.Range("A5:D" & wsReport.Rows.Count).ClearContents targetDate = wsReport.Range("C2").Value dayNum = Day(targetDate) targetCol = 3 + dayNum If targetCol < 4 Or targetCol > 34 Then MsgBox ".تاريخ غير صالح يجب أن يكون اليوم بين 1 و 31", vbExclamation Exit Sub End If lastRow = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row reportRow = 5 For i = 4 To lastRow If wsMain.Cells(i, targetCol).Value = "غ" Then wsReport.Cells(reportRow, 1).Value = wsMain.Cells(i, 1).Value wsReport.Cells(reportRow, 2).Value = wsMain.Cells(i, 2).Value wsReport.Cells(reportRow, 3).Value = wsMain.Cells(i, 3).Value wsReport.Cells(reportRow, 4).Value = targetDate reportRow = reportRow + 1 End If Next i If reportRow = 5 Then MsgBox "لا يوجد موظفين متغيبين في هذا التاريخ", vbInformation End If End Sub وفي الورقة الثالثة "موقف الغياب الشهري" ، أيضاً تم انشاء زر لاستدعاءه الدالة التالية من نفس المديول :- Sub GenerateMonthlyAbsenceReport() Dim wsMain As Worksheet Dim wsReport As Worksheet Dim startDate As Date, endDate As Date Dim currentDate As Date Dim dayNum As Integer, targetCol As Integer Dim lastRow As Long, reportRow As Long, i As Long Dim empName As String, empJob As String Dim dateList As String, dayList As String Dim dateCount As Integer Dim dayName As String Set wsMain = ThisWorkbook.Sheets("MainSheet") Set wsReport = ThisWorkbook.Sheets("موقف الغياب الشهري") If Not IsDate(wsReport.Range("C2").Value) Or Not IsDate(wsReport.Range("C3").Value) Then MsgBox "الرجاء إدخال تاريخين صالحين في الخلايا C2 و C3", vbExclamation + vbMsgBoxRight, "" Exit Sub End If startDate = wsReport.Range("C2").Value endDate = wsReport.Range("C3").Value If startDate > endDate Then MsgBox "خطأ: تاريخ البداية يجب أن يكون قبل تاريخ النهاية", vbExclamation + vbMsgBoxRight, "" Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With wsReport .Range("A6:F" & .Rows.Count).ClearContents .Range("6:" & .Rows.Count).RowHeight = 15 End With lastRow = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row reportRow = 6 For i = 4 To lastRow empName = wsMain.Cells(i, 2).Value empJob = wsMain.Cells(i, 3).Value If empName = "" Then GoTo NextEmployee dateList = "" dayList = "" dateCount = 0 currentDate = startDate Do While currentDate <= endDate dayNum = Day(currentDate) targetCol = 3 + dayNum If targetCol >= 4 And targetCol <= 34 Then If wsMain.Cells(i, targetCol).Value = "غ" Then dayName = wsMain.Cells(2, targetCol).Value If dateList <> "" Then dateList = dateList & vbLf & Format(currentDate, "yyyy-mm-dd") dayList = dayList & vbLf & dayName Else dateList = Format(currentDate, "yyyy-mm-dd") dayList = dayName End If dateCount = dateCount + 1 End If End If currentDate = DateAdd("d", 1, currentDate) Loop If dateCount > 0 Then With wsReport .Cells(reportRow, 1).Value = reportRow - 5 .Cells(reportRow, 2).Value = empName .Cells(reportRow, 3).Value = empJob .Cells(reportRow, 4).Value = dateCount .Cells(reportRow, 5).Value = dateList .Cells(reportRow, 6).Value = dayList .Cells(reportRow, 5).WrapText = True .Cells(reportRow, 6).WrapText = True If dateCount > 1 Then .Rows(reportRow).RowHeight = 15 * dateCount End If End With reportRow = reportRow + 1 End If NextEmployee: Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If reportRow > 6 Then ' MsgBox "تم إنشاء التقرير بنجاح", vbInformation + vbMsgBoxRight, "" Else MsgBox "لا توجد أيام غياب في الفترة المحددة", vbInformation + vbMsgBoxRight, "" End If End Sub وتركت لك التعديل متاحاً من خلال تحديد الصف أو العمود ... إلخ . وهذا ملفك بعد التعديل . راجعه وأخبرنا بالنتيجة .. موقف غياب موظفين.zip

اللهم اغفر له وارحمه واجعله مثواه الجنة والهم أهله وذويه الصبر والسلوان

اللهم امين .. أتم يارب شفاءه على أكمل وجه بالشكل الذى يرضيك يا أكرم الأكرمين واربط على اهله وذويه بالصبر على هذا

بارك الله فيك وزادك الله من فضله وعود حميدا .... نورت المنتدى

جزاك الله خيرا وبارك فيك ابا احمد سوف اعمل عليه .. واطوع الاستعلامات لاستخراج ما اريد

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

ارفق ملف يحتوي أكثر من شرط أخي الكريم ، مع العلم ان ارتفاع جزء التفاصيل سيكون حسب ارتفاع المربعات النصية !!!!!!

جزاكم الله خير فكره جميلة جدا و يحتاجها كل مطوري الاكسيس

هذا الموضوع خصيصا قد يكون جديد بهذا الشكل على مجتمع مستخدمين قواعد بيانات أكسس

يتم عمل الحماية للمجلد كما اشرت يتم فتح قاعدة البيانات الامامية من خلال قاعدة مشفرة accde ولا ننسى توفيرها مره للنواة 32 بت ومرة أخرى للنواة 64 بت ويمكن للمبرمج الاحتفاظ بالقاعدة قبل التشفير واستخدامها مع كل تطبيقاته لو استخدم نفس تشفير القواعد الامامية بنفس كلمة المرور وظيفتها تمرير كلمة المرور للقاعدة الامامية المشفرة لفتحها وطبعا القاعدة الخلفية للجداول سوف تكون مشفرة بكلمة مرور كذلك ربط الجداول من القاعدة الامامية سوف يمرر كلمة المرور للارتباط او اعاادة الاتصال بالقاعدة الخلفية القاعدتان الامامية والخلفية وكذلك القاعدة الوسيطة والتى وظيفتها فتح القاعدة الاماميه نستخدم معهم اخفاء الاطار نهائيا ايقاف مفاتيح الهوت كى لمنع فتح المحرر ايقاف عمل مفتاح الشيفت ولو اردتم اضافة معالجة لتحديد صلاحيات المستخدمين او مجموعات العمل للقاعدة الامامية تلكم الافكار مجتمعة معا تكون حماية لن أقول يستحيل كسرها او تخطيها بل سوف أكتفى بالقول بأنها سوف تكون قوية قوية فوية فوية قوية جدا جدا جدا جدا لا بأس بها ويصعب تجاوزها وكسرها وممكن احفاء كلمة مرور الاتصال لجهاز السيرفر عن المستخدمين اساسا وتتم عملية الاتصال مبدئيا بجهاز السيرفر من خلال حفظ معلومات الاتصال (حفظ بيانات الاعتماد ) من خلال اول نموذج وكل ما سبق موجود فى المنتدى

اما بالنسبة لكلمة المرور راى المتواضع عدم استخدامها بشكل صريح وكذلك لا احبذ تشفير ثنائى الاتجاه بل الافضل ان يكون احادى الاتجاه ثنائى الاتجاه يمكن التعرف عليه من خلال الهندسة العكسية طيب كنت قد كتبت داله تعتمد على تشفير : MD5 ولكن انا كتبتها بدون الاعتماد على اى مكتبات تخص ال .net وكذلك اعتمد على التشفير : SHA256 لانه اكثر امانا من سابقه الا انه يعتمد على .net ولكن بما اننى بقدر الامكان لا احب الاعتماد على اى مراجع ومكتبات خارجية بقدر الامكان فكرتى كانت الدمج بين التشفيرين بحيث اذا توفرت المكتة اللازمة يتم التشفير بناء على : SHA256 وان لم تتوفر فى نظام التشغيل يتم الاعتماد على التشفير : MD5 والاكواد كالاتى Private Function ToLong(ByVal dblValue As Double) As Long dblValue = dblValue - 4294967296# * Int(dblValue / 4294967296#) If dblValue < 0 Then dblValue = dblValue + 4294967296# If dblValue > 2147483647# Then ToLong = CLng(dblValue - 4294967296#) Else ToLong = CLng(dblValue) End If End Function Private Function RotateLeft32(ByVal lngValue As Long, ByVal intBits As Integer) As Long Dim dblValue As Double dblValue = CDbl(lngValue And &HFFFFFFFF) RotateLeft32 = ToLong(dblValue * (2 ^ intBits) + dblValue / (2 ^ (32 - intBits))) End Function Private Function GenerateSalt() As String Dim strChars As String, strResult As String Dim i As Long strChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" Randomize For i = 1 To 16 strResult = strResult & Mid(strChars, Int(Rnd() * Len(strChars)) + 1, 1) Next GenerateSalt = strResult End Function Public Function MD5Hash(ByVal strText As String) As String Dim arrK(0 To 63) As Long, arrS(0 To 63) As Integer Dim a As Long, b As Long, c As Long, d As Long, f As Long, g As Long, temp As Long Dim h0 As Long, h1 As Long, h2 As Long, h3 As Long Dim msg() As Byte, msgLen As Long, paddedLength As Long Dim lenInBits As Currency Dim chunk(0 To 15) As Long Dim i As Long, offset As Long For i = 0 To 63 arrK(i) = ToLong(Abs(Sin(i + 1)) * 4294967296#) Next i For i = 0 To 15: arrS(i) = Array(7, 12, 17, 22)(i Mod 4): Next i For i = 16 To 31: arrS(i) = Array(5, 9, 14, 20)(i Mod 4): Next i For i = 32 To 47: arrS(i) = Array(4, 11, 16, 23)(i Mod 4): Next i For i = 48 To 63: arrS(i) = Array(6, 10, 15, 21)(i Mod 4): Next i msg = StrConv(strText, vbFromUnicode) msgLen = UBound(msg) + 1 paddedLength = ((msgLen + 8) \ 64 + 1) * 64 ReDim Preserve msg(0 To paddedLength - 1) msg(msgLen) = &H80 lenInBits = msgLen * 8 For i = 0 To 7 msg(paddedLength - 8 + i) = (lenInBits / (2 ^ (8 * i))) And &HFF Next i h0 = &H67452301 h1 = &HEFCDAB89 h2 = &H98BADCFE h3 = &H10325476 For offset = 0 To paddedLength - 1 Step 64 For i = 0 To 15 chunk(i) = ToLong(CDbl(msg(offset + i * 4)) + _ CDbl(msg(offset + i * 4 + 1)) * &H100 + _ CDbl(msg(offset + i * 4 + 2)) * &H10000 + _ CDbl(msg(offset + i * 4 + 3)) * &H1000000) Next i a = h0: b = h1: c = h2: d = h3 For i = 0 To 63 If i < 16 Then f = (b And c) Or ((Not b) And d) g = i ElseIf i < 32 Then f = (d And b) Or ((Not d) And c) g = (5 * i + 1) Mod 16 ElseIf i < 48 Then f = b Xor c Xor d g = (3 * i + 5) Mod 16 Else f = c Xor (b Or (Not d)) g = (7 * i) Mod 16 End If temp = d d = c c = b b = ToLong(CDbl(b) + RotateLeft32(ToLong(CDbl(a) + f + arrK(i) + chunk(g)), arrS(i))) a = temp Next i h0 = ToLong(CDbl(h0) + a) h1 = ToLong(CDbl(h1) + b) h2 = ToLong(CDbl(h2) + c) h3 = ToLong(CDbl(h3) + d) Next offset MD5Hash = LCase( _ Right("00000000" & Hex(h0), 8) & _ Right("00000000" & Hex(h1), 8) & _ Right("00000000" & Hex(h2), 8) & _ Right("00000000" & Hex(h3), 8)) End Function Public Function HashPasswordSHA256(ByVal Password As String) As String Dim xmlObj As Object Dim bytes() As Byte Dim hash() As Byte Dim i As Integer Dim result As String ' استخدام كائن MSXML2 Set xmlObj = CreateObject("System.Security.Cryptography.SHA256Managed") ' تحويل النص إلى مصفوفة بايتات bytes = StrConv(Password, vbFromUnicode) ' حساب التجزئة hash = xmlObj.ComputeHash_2(bytes) ' تحويل النتيجة إلى سلسلة نصوص For i = LBound(hash) To UBound(hash) result = result & LCase(Right("0" & Hex(hash(i)), 2)) Next i ' إعادة النتيجة النهائية HashPasswordSHA256 = result ' تنظيف الموارد Set xmlObj = Nothing End Function Public Function HashPassword(strPassword As String, Optional ByRef strSalt As String) As String If strSalt = "" Then strSalt = GenerateSalt() On Error GoTo UseMD5 ' المحاولة الأولى باستخدام SHA-256 HashPassword = HashPasswordSHA256(strPassword & strSalt) Exit Function UseMD5: HashPassword = MD5Hash(strPassword & strSalt) End Function Public Sub UpdateExistingPasswords() On Error GoTo ErrHandler Dim rs As DAO.Recordset Dim strSalt As String ' تحديث جدول المستخدمين النشطين Set rs = CurrentDb.OpenRecordset("SELECT UserID, UserPassword, Salt FROM tblUsers", dbOpenDynaset) Do While Not rs.EOF If IsNull(rs!salt) Then strSalt = GenerateSalt() rs.Edit rs!salt = strSalt rs!UserPassword = HashPassword(rs!UserPassword, strSalt) rs.Update LogEvent "تم تحديث مستخدم: " & rs!UserID, Information, "UpdateExistingPasswords" End If rs.MoveNext Loop rs.Close Set rs = Nothing ' تحديث جدول المستخدمين المعلقين Set rs = CurrentDb.OpenRecordset("SELECT UserID, UserPassword, Salt FROM tbl01PendingUsers", dbOpenDynaset) Do While Not rs.EOF If IsNull(rs!salt) Then strSalt = GenerateSalt() rs.Edit rs!salt = strSalt rs!UserPassword = HashPassword(rs!UserPassword, strSalt) rs.Update LogEvent "تم تحديث مستخدم معلق: " & rs!UserID, Information, "UpdateExistingPasswords" End If rs.MoveNext Loop rs.Close Set rs = Nothing MsgBox "تم تحديث كلمات المرور القديمة بنجاح.", vbInformation Exit Sub ErrHandler: HandleError "UpdateExistingPasswords", "حدث خطأ أثناء تحديث كلمات المرور" If Not rs Is Nothing Then rs.Close End Sub Public Sub UpdateExistingPasswordsByUserID(lngUserID As Long) On Error GoTo ErrHandler Dim rs As DAO.Recordset Dim strSalt As String ' تحديث جدول المستخدمين النشطين Set rs = CurrentDb.OpenRecordset("SELECT UserID, UserPassword, Salt FROM tblUsers WHERE UserID = " & lngUserID, dbOpenDynaset) If Not rs.EOF Then If IsNull(rs!salt) Then strSalt = GenerateSalt() rs.Edit rs!salt = strSalt rs!UserPassword = HashPassword(rs!UserPassword, strSalt) rs.Update LogEvent "تم تحديث مستخدم: " & rs!UserID, Information, "UpdateExistingPasswordsByUserID" End If End If rs.Close Set rs = Nothing ' تحديث جدول المستخدمين المعلقين Set rs = CurrentDb.OpenRecordset("SELECT UserID, UserPassword, Salt FROM tbl01PendingUsers WHERE UserID = " & lngUserID, dbOpenDynaset) If Not rs.EOF Then If IsNull(rs!salt) Then strSalt = GenerateSalt() rs.Edit rs!salt = strSalt rs!UserPassword = HashPassword(rs!UserPassword, strSalt) rs.Update LogEvent "تم تحديث مستخدم معلق: " & rs!UserID, Information, "UpdateExistingPasswordsByUserID" End If End If rs.Close Set rs = Nothing MsgBox "تم تحديث كلمة المرور بنجاح للمستخدم: " & lngUserID, vbInformation Exit Sub ErrHandler: HandleError "UpdateExistingPasswordsByUserID", "حدث خطأ أثناء تحديث كلمة المرور للمستخدم: " & lngUserID If Not rs Is Nothing Then rs.Close End Sub طبعا الدوال الاخيرة : Public Sub UpdateExistingPasswords() Public Sub UpdateExistingPasswordsByUserID(lngUserID As Long) هى خاصة بقاعدتى من تعجبه فكرة التشفير لضمان زيادة الامان يستطيع التعديل عليهم باسماء الجداول والحقول الخاصة به هو وجميعنا يعلم ان الامان هو : مسألة نسبية ولكن الجميع يحاول جاهد تأمين البيانات وتأمين الاكواد اما من العبث الغير مقصود او العبث المقصود او حفظا للحقوق موضوع التأمين يختلف حسب توجهات كل شخص فى النهاية وقوة وضعف التأمين تعتمد على افكار المبرمج فى النهاية بجانب لغة البرمجة

وعليكم السلام ورحمة الله وبركاته تم رفع الملف بالمشاركه الاولي في الموضوع جزى الله عنا خيرا استاذنا الغالي ياسر خليل

جزاك الله خير اخي

الأخوة الكرام أسعد الله مساءكم ووفقكم لك خير تحديث جديد يتضمن بعض التعديلات علي نموذج الـ html وهي 1- تم إضافة ميزة البحث بقيم متعدده يفصل بينهم | أو ; أو , وهذا في البحث العام او الحث الخاص بكل نموذج (2) 3- ميزة نسخ كامل محتوي العمود مع أمكانية أختيار الفاصل بينهم او كتابة فاصل جديد (4) وأيضاً اختيار ضم عنوان العمود أم لا (5) 6- تم معالجة بعض القيم لعرض أفضل 7- تم تحسين طريقة نسخ محتوي الخلية للتناسب مع الخلية التي تحمل رابط بداخلها صوره لبعض النتائج بالتوفيق Ahmos_AutoHtmlTable_V1.1_Files.zip

أنت اللي حاط الوقت .. تصرف !! 😂😅

أحسنت أستاذنا الكريم وبارك الله فيك وزادك الله من فضله

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

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

وعليكم السلام-تفضل

وعليكم السلام-تفضل أعتقد ان هذا سيكون أفضل مما طلبت قائمة منسدلة.xlsx

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

أفضل إرفاق الملف الأصلي للإطلاع عليه .. حيث أن تكوين السطر بهذا الشكل غير منطقي .. حاول تساعد الأعضاء عشان يقدروا يساعدوك تقبل تحياتي عموماً جرب الكود التالي إذا ظبطت معاك كان بها فهي نعمة من الله إذا لم تظبط معاك فلن أساهم في الموضوع إلا بعد إرفاق الملف الأصلي (يسر علينا كي تجد المساعدة) Sub Max() Dim LR3 As Long, LR4 As Long, XX3 LR3 = 10: LR4 = 13 XX3 = Range("B11").Value Range("D7").Value = Worksheets("Seen").Evaluate("=MAX(IF(D" & LR3 & ":D" & LR4 & "= " & XX3 & ",E" & LR3 & ":E" & LR4 & "))") End Sub تقبل تحياتي