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

أخواني وأساتذتي ومعلمينا ( دون استثناء ) أشارككم في هذا الموضوع أداة بسيطة وفعالة قمت بتطويرها لأغراض إنشاء واستعادة نسخ احتياطية من قواعد بيانات اكسيس . ✔️ الهدف الأساسي من الأداة هو توفير طريقة مرنة وآمنة لأخذ نسخ احتياطية من الجداول المهمة بشكل دوري أو عند الحاجة ، وتسهيل استعادتها لاحقاً بنفس البنية والبيانات . صورة من واجهة الأداة :- الواضح من الواجهة ، أن الأداة ستمكنك من :- أولاً :- إنشاء نسخة احتياطية ضمن الإعدادات التي تحددها في زر "خيارات الحفظ" . عند النقر عليه ستجد هذه الإعدادات في الصورة .. مسار الحفظ للنسخ الإحتياطية سيكون فقط في المجلد Backup في المجلد الرئيسي Data الموجود بجانب قاعدة البيانات . نوع الملحق سيكون MDB و DAT . وهما النوعين الأكثر شمولاً واستخداماً في جميع الأفكار التي لها نفس الوظيفة . عدد النسخ التي ستحتفظ بها هو فقط ما تحدده . وسيتم حذف النسخ الأقدم تباعاً . بإمكانك تحديد كلمة مرور لحماية قاعدة بيانات الجداول . ولا ننصح بتغييرها لكل نسخة كي لا تتوه وتفقد بياناتك . إمكانية النسخ التلقائي حسب عدد الأيام أو الساعات الي تريد أخذ نسخة تلقائية فيه . ثانياً :- إنشاء نسخة احتياطية لجداول تقوم بتحديدها - ولك حرية اختيار الجداول في كل نسخة - حيث أنها لن تؤثر على سير عملية الإسترجاع لاحقاً . انظر الصورة للتوضيح :- على اليمين تظهر أسماء الجداول في القاعدة الحالية ( مرتبطة أو محلية ) . ولك الحرية باختيار جداول محددة بالنقر المزدوج على الجدول ، أو تحديد الكل / إلغاء الكل . حسب حاجتك . ثالثاً :- الأزرار كما هي في صورة واجهة الأداة ، تشير إلى :- زر "حفظ نسخة إحتياطية جديدة" :- لإنشاء نسخة إحتياطية حسب الإعدادات اتي تم تحديدها . زر "تحديث بيانات النُسخ الإحتياطية" :- لإعادة ترتيب السجلات في الجدول حسب النسخ الموجودة في مجلد انسخ الإحتياطي . زرا "نُسخ محددة" و "كافة النُسخ" :- لحذف محدد أو لجميع النسخ الإحتياطية . زر "إنشاء" في قسم "نسخة خاصة" :- مخصص لإنشاء نسخة خاصة في مكان يقوم المستخدم بتحديده وليس ضمن المسار المحدد في الإعدادات ، وبإسم متغير كيفما يريد . زر "استرجاع" في قسم "نسخة خاصة" :- مخصص لإسترجاع نسخة يقوم المستخدم بتحديدها بشكل يدوي من خلال مربع حوار اختيار ملف . زر "استرجاع" في قسم "استرجاع النسخة رقم" :- مخصص لاختيار نسخة محددة برقمها . حيث تظهر النسخ التي تم أخذها إحتياطياً ، في أعلى جزء النموذج والتنقل بينها من خلال الزرين < > . رابعاً :- في هذا الإصدار ( V1.0 ) من الأداة على عدم الإعتماد على أي مكتبات خارجية أو من مكتبات أكسيس . حيث تمت التجربة على إصدارات اكسيس ( 2010 فما فوق ) . Backup 2025 - V1.0.accdb.zip :- دائماً يسعدني إبدائكم الرأي والملاحظات حول الأخطاء والمشاكل التي يمكن مواجهتها في أي مشروع يتم تأسيسه في آكسيس أو غيره من لغات البرمجة . أولاً تأكد من وجود جدولي الأداة ( USysMyCopies و USysOptCopies ) عند نسخها الى مشروعك . مع العلم أنها مخفية كجداول نظام ، ويمكنك إظهارها كما في الصورة التالية :- ثانياً ، قم بالدخول الى خيارات الحفظ ، والنقر على زر "انقر لضبط مسار مجلد الحفظ بشكل آلي" لضبط وتحديد مسار مجلد الحفظ الرئيسي . فقط لأول مرة .

تم التحميل وجارى التجربة ان شاء الله

وعليكم السلام ورحمة الله وبركاته استكمالا لما تفضل به الأساتذة @Foksh و @hegazee من حلول مشكورة و إثراءا للموضوع أضع بين يديك اقتراحا إضافيا ربما قد يكون مناسبا لطلبك Private Sub Worksheet_Change(ByVal Target As Range) Const ColF As Long = 5, Irow As Long = 2, Max As Long = 5 Dim rng As Range, i As Long, ky() As String, Cnt$, tmp$, msg$, txt$ If Target.Column = ColF Then On Error GoTo Cleanup SetApp False For Each rng In Target txt = Trim(CStr(rng.Value)): msg = "" If txt = "" Then GoTo NextCell If InStr(txt, "/") > 0 Then msg = "(/) " & _ "خطأ: يرجى استخدام الشرطة العادية (-) بدلا من الشرطة المائلة" If msg = "" And InStr(txt, "-") = 0 Then msg = "خطأ: التنسيق غير صحيح" If msg = "" Then ky = Split(txt, "-") If UBound(ky) <> 1 Then msg = "خطأ: يجب أن يكون التنسيق بالشكل (رقم-رموز)" Else Cnt = ky(0): tmp = ky(1) If msg = "" And (Not IsNumeric(Cnt) Or Len(Cnt) < 1 Or Len(Cnt) > Irow) Then _ msg = "خطأ: الجزء الأول يجب أن يكون رقمًا مكونا من رقم أو رقمين فقط" If msg = "" And Len(tmp) > Max Then msg = "خطأ: الحد الأقصى للرموز بعد الشرطة هو 5 رموز" If msg = "" And Left(tmp, 1) = "0" Then msg = "خطأ: لا يسمح ببدء الجزء الثاني بصفر" For i = 1 To Len(tmp) - 1 If msg = "" And Mid(tmp, i, 1) Like "[A-Za-z]" And Mid(tmp, i + 1, 1) = "0" Then msg = "خطأ: لا يسمح بوجود صفر بعد الحرف الإنجليزي": Exit For End If Next i End If End If If msg <> "" Then MsgBox msg, vbCritical, "خطأ في إدخال رقم الحالة": rng.Value = "" NextCell: Next rng End If Cleanup: SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub Book1 v2.xlsm

السلام عليكم ورحمة الله وبركاته الأخوة والأخوات الكرام تحية طيبة وبعد،،، يوجد بالمرفقات ثلاث ملفات بعد فك الضغط 1- نموذج الـ Html باسم {ahmosAutoHtmlTemplate_V10} وتحتاج إليه فقط اذا اردت التعديل او اضافة اي شي للنموذج بشكل دائم ولإضافتة داخل البرنامج : - قم بنسخ كامل المحتوي ثم قم بتشغيل الكود التالي : [Call splitAutoTableSections] 2- ملف نصي باسم {Text_Table_Sample} ويستخدم بنسخ محتواه ثم الضغ علي الزر [Convert Copied Text To html] بالنموذج يتضمن هذا الملف مثال لجدول محدد بالعلامات التالية \t ---> vbTab علامة الفصل بين الأعمدة \n ---> vbLf علامة فصل السطور داخل الخلية \r\n -> vbNewLine علامة السطر الجديد 3- البرنامج باسم {Ahmos_AutoHtmlTable} يقوم البرنامج بتحويل الجداول الداخلية باستخدام استعلامات الـ SQL الي صفحة ويب و اي جدول خارجي عن طريق نسخ الجدول بالكامل او إذا كان الجدول علي شكل نص تم تجميعة برمجياً يوجد أمثلة كما يمكنك التجربة علي اي ملف اكسيل مع بعض الصور بعض أهم النقاط : 1- داخل هذه الوظيفة { Public Function autoTblBody } يتم معالجة محتوي الخلية للجداول الخارجية وهنا تم إضافة بعض المعاير مثل إذا كان المحتوي رقم اقل او بساوي 5 يتم توسيطة داخل الخلية اذا كانت القيم TRUE or False / YES or No يتم التوسيط وتغير اللون إذا كانت بداية الخلية = او ' يتم إزالتها وكذلك الوظيفة الخاصة بالجداول الداخلية { Public Function sqlToHtmlTbl } 2- يمكن إضافة عمود فارغ علي صفحة الـ HTML باستخدام addRecNumField = True وهو يضيف عمود recNum وفائدة هذا العمود يوجد وظيفة داخل الـ JavaScript تقوم بعمل ترقيم تلقائي لهذا العمود يتم الترقيم التلقائي عن 1- فتح الصفحة 2- عند التصدير وذلك حتي يتم تعدل الارقام علي الصفوف الظاهرة فقط 3- عند عمل إلي للتصفية Clear Filters الوظيفة هي function renumberTableColumn(columnHeadName, filterOnly = false) ويمكن ان تستخدم لترقيم اي عمود بكتابة اسم العمود بدل من columnHeadName هكذا 'recNum' اما filterOnly تحدد إذا كنت تريد ترقيم الصفوف الظاهرة فقط ام كامل الصفوف false كامل الصفوف true الظاهرة فقط اي ما يتبقي بعد البحث او التصفية 3- وظيفة saveTable تمكنك من حفظ الصفحة مرة اخري وفائدتها هي ان تقوم بحفظ نسخة اخري من الصفحة بعد حذف أعمدة او تصيفة صفوف function saveTable(deleteHiddenRows = true) وهي بشكل افتراضي تقوم بحذف الصفوف الغير ظاهرة من النسخة وليس من الأصل 4- ستجد Optional ByVal constFileName As String = "", _ داخل الوظيفة { strTbltToHtml و sqlTbltToHtml } ويسخدم هذا في تعديل هذه القيمة داخل نموذج الـ Html $fileName$ <span id="fileName" style="display: none;">$fileName$</span> وفائدتة هي وجود وظيفة في الـ java script {getExportFileName} تقوم بتحديد اسم الملف عند التصدير وتقوم بإضافة الوقت والتاريخ له فاذا كانت القيمة هنا $fileName$ او فارغة سيتم استخدام قيمة افتراضية [ahmosExTable] وغير ذلك ستسخدم أغلب وظائف الـ java script قمت بها بمساعدة الـ AI ولكن الحمد لله فاهمها بنسبة كبيرة 😁 بالتوفيق Ahmos_AutoHtmlTable_Files.zip

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

كلامك عين الصواب

مهو انا ما وضعتهوش وقاصد ده .. لأنه لسه في تحديثات جديدة وقلت نشوقكم حبتين

ما انت لو وضعت كود انشاء الجداول مكنش حصل كده

أخي الفاضل ، الجداول مخفية .. انظر الصورة لإظهارها تم ذكر التوضيح في المشاركة الأصلية

اشكرك اخي الكريم ملاحظات غاية بالاهميه وسنأخذها بعين الاعتبار عاشت ايدك على المساعدة

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

الف شكر اخي الكريم لمجهودك

بعد التجربة الاخ والأستاذ الطيب @Foksh شغال بامتياز هدا هو المطلوب بالضبط جزاك الله خيرا . جزاك الله خيرا و بارك الله فيك.

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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub GetData() On Error GoTo EndClear Dim WS As Workbook, CrWS As Worksheet, dest As Worksheet, i As Long, tmp As Long Dim début As Long, tbl1 As Long, tbl2 As Long, ColArr As Variant, xPath As String ColArr = Split("1 2 3 4"): SetApp False Set dest = ThisWorkbook.Sheets("Sheet1"): xPath = ThisWorkbook.Path & "\aa.xlsb" If Dir(xPath) = "" Then MsgBox "الملف غير موجود: " & xPath, vbExclamation: GoTo CleanExit Set WS = Workbooks.Open(xPath) Set CrWS = WS.Sheets("Sheet1") If IsEmpty(dest.Cells(1, 1)) Then For i = 0 To UBound(ColArr) dest.Cells(1, i + 1).Value = CrWS.Cells(1, CLng(ColArr(i))).Value Next i End If début = 2: tbl1 = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row: tmp = tbl1 - début + 1 If tmp <= 0 Then MsgBox "لا توجد بيانات للنسخ", vbExclamation: GoTo CleanExit tbl2 = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 For i = 0 To UBound(ColArr) dest.Cells(tbl2, i + 1).Resize(tmp).Value = _ CrWS.Cells(début, CLng(ColArr(i))).Resize(tmp).Value Next i Application.Goto dest.Range("A1"), True CleanExit: If Not WS Is Nothing Then WS.Close False SetApp True If tmp > 0 Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Exit Sub EndClear: Resume CleanExit End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub ترحيل v2.rar

حسناً أخي الكريم ، ولا يهمك .. بسيطة جرب هذا التعديل على قاعدتك التي تحتوي بيانات أكبر ، وتأكد من أخذ نسخة احتياطية منها ( أو نسخة أخرى اعملها للتجربة ) :- Private Sub أمر1069_Click() On Error GoTo ErrorHandler Dim db As DAO.Database Dim rsSource As DAO.Recordset Dim rsDest As DAO.Recordset Dim strSQL As String Dim currentCode As Long DoCmd.SetWarnings False Set db = CurrentDb db.Execute "DELETE FROM tab_degree_mauel", dbFailOnError db.Execute "INSERT INTO tab_degree_mauel(code_fonct, nom_prenom, grade_actuel, categorie, numero_indice_categorie, degre, numero_indice_degre, duree, date_effet, faid_31_12, date_signature_decision, date_reunion_comession, date_calcul_faid_31_12, num_decision) " & _ "SELECT code_fonct, nom_prenom, grade_actuel, categorie, numero_indice_categorie, degre, numero_indice_degre, duree, date_effet, faid_31_12, date_signature_decision, date_reunion_comession, date_calcul_faid_31_12, num_decision " & _ "FROM tab_degree_saisie", dbFailOnError strSQL = "SELECT t1.code_fonct, t1.nom_prenom, t1.degre, t1.numero_indice_degre, t1.date_effet " & _ "FROM tab_degree_saisie t1 " & _ "INNER JOIN (SELECT nom_prenom, MAX(degre) AS MaxDegre " & _ "FROM tab_degree_saisie " & _ "GROUP BY nom_prenom) t2 " & _ "ON t1.nom_prenom = t2.nom_prenom AND t1.degre = t2.MaxDegre" Set rsSource = db.OpenRecordset(strSQL, dbOpenDynaset) If Not (rsSource.EOF And rsSource.BOF) Then rsSource.MoveFirst Do Until rsSource.EOF currentCode = Nz(rsSource!code_fonct, 0) Set rsDest = db.OpenRecordset("SELECT * FROM tbl_info_fonctionnaire WHERE num = " & currentCode, dbOpenDynaset) If rsDest.EOF Then rsDest.AddNew rsDest!num = currentCode Else rsDest.Edit End If rsDest!grade = rsSource!degre rsDest!num_indice_grade = Nz(rsSource!numero_indice_degre, 0) rsDest!date_effet_grade_actuel = Nz(rsSource!date_effet, Date) rsDest.Update rsDest.Close rsSource.MoveNext Loop End If MsgBox "تم تحديث البيانات بنجاح", vbInformation + vbMsgBoxRight, "" Cleanup: On Error Resume Next If Not rsSource Is Nothing Then rsSource.Close Set rsSource = Nothing End If If Not rsDest Is Nothing Then rsDest.Close Set rsDest = Nothing End If Set db = Nothing DoCmd.SetWarnings True Me.Requery Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical + vbMsgBoxRight, "خطأ" Resume Cleanup End Sub

وعليكم السلام ورحمة الله وبركاته ,, هذه محاولة بسيطة قد لا تكون بدقة فكرة الأستاذ @hegazee :- Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, val As String Dim regex As Object Set regex = CreateObject("VBScript.RegExp") regex.Pattern = "^\d{1,2}-([a-zA-Z][1-9]\d*|[1-9]\d*[a-zA-Z]?)$" For Each c In Intersect(Target, Columns("E")) If Not IsEmpty(c) Then val = c.Value If Not regex.Test(val) Or Len(val) > 8 Then MsgBox "صيغة غير صحيحة! يجب أن تكون:" & vbCrLf & vbCrLf & _ "تستخدم شرطة (-) فقط (.1)" & vbCrLf & _ "لا تبدأ الأرقام بصفر (.2)" & vbCrLf & _ "لا يوجد صفر بعد الحرف الإنجليزي (.3)" & vbCrLf & _ "(12-a1234 :مثال ) الحد الأقصى 8 أحرف (.4)", _ vbExclamation + vbMsgBoxRight, "تصحيح" Application.Undo End If End If Next c End Sub جربها وأخبرنا بالنتيجة ..

انا افتكرت ان الفكرة واضحة ، على العموم اجعل مصدر بيانات النموذج = الجدول trans وحدد لكل كومبوبوكس مكانه في الجدول هذا اذا كنت فاهمك صح طبعاً 😅

وعليكم السلام ورحمة الله وبركاته ,, أخي الكريم ، بداية حتى تبدأ بداية سليمة ، حاول الإبتعاد عن الأسماء العربية لمكونات قاعدة البيانات . وأيضاً استحدام المسافة بين التسميات التي لها أكثر من كلمة .... إلخ من أساسيات مهمة عند تصميم قواعد البيانات . على العموم .. في حدث قبل التحديث لمربع النص "اسم الصنف" ، استخدم الكود التالي البسيط دون تعقيد .. Private Sub اسم_الصنف_BeforeUpdate(Cancel As Integer) If DCount("*", "[جرد المستودع]", "[اسم الصنف] = '" & Me![اسم الصنف] & "'") > 0 Then MsgBox "هذا الصنف موجود مسبقاً", vbExclamation + vbMsgBoxRight, "": Cancel = True: Me.Undo End If End Sub منع التكرار.zip

السلام عليكم ورحمه الله وبركاته ممكن تستخدم الكود التالي عند ظهور الاخطاء الخاصه من 32 الي 64 Private Declare Function استبدلها الي Private Declare PtrSafe Function ----------------------------------------------------------------- Private Declare استبدلها الي Private Declare PtrSafe

الف شكر استاذي على المساعدة