ابو جودي

العفو منكم استاذى الجليل هذا بعد فضل رب العباد سبحانه وتعالى فضلكم وكل اساتذتى العظماء الذين اتعلم منهم وعلى ايديهم فلو لا الله سبحانه تعالى ثم انتم ما علمت ولا دريت ويعلم الله لكم وكل اساتذتى العظماء مكان فوق رأسي وتتربعون بداخل قلبى اسال الله ان لايحرمنا منكم ومن عطائكم وحتى تكتمل الفائدة خطر على بالى عمل الكود الاتى بنفس الفكرة للارقام Public Function MyNo(ByVal strNo As String, ByVal strLng As String) If strLng = "Ar" Then strNo = Replace(strNo, "0", ChrW(1632)) strNo = Replace(strNo, "1", ChrW(1633)) strNo = Replace(strNo, "2", ChrW(1634)) strNo = Replace(strNo, "3", ChrW(1635)) strNo = Replace(strNo, "4", ChrW(1636)) strNo = Replace(strNo, "5", ChrW(1637)) strNo = Replace(strNo, "6", ChrW(1638)) strNo = Replace(strNo, "7", ChrW(1639)) strNo = Replace(strNo, "8", ChrW(1640)) strNo = Replace(strNo, "9", ChrW(1641)) MyNo = strNo ElseIf strLng = "Ar" Then strNo = Replace(strNo, ChrW(1632), ChrW(48)) strNo = Replace(strNo, ChrW(1633), ChrW(49)) strNo = Replace(strNo, ChrW(1634), ChrW(50)) strNo = Replace(strNo, ChrW(1635), ChrW(51)) strNo = Replace(strNo, ChrW(1636), ChrW(52)) strNo = Replace(strNo, ChrW(1637), ChrW(53)) strNo = Replace(strNo, ChrW(1638), ChrW(54)) strNo = Replace(strNo, ChrW(1639), ChrW(55)) strNo = Replace(strNo, ChrW(1640), ChrW(56)) strNo = Replace(strNo, ChrW(1641), ChrW(57)) MyNo = strNo End If End Function وهذا المرفق DayuNameArabic. & English (1).mdb

اتفضل يا افندم

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

بارك الله فيكم ورضى الله عنكم وارضاكم استاذى الجليل

ممكن مرفق للاطلاع الله يبارك فى حضرتك

استاذى الجليل ومعلمى القدير واخى الحبيب الاستاذ @أبو عبدالله الحلوانى بعد جزاكم الله خيرا هذا المرفق على طريقتكم سلمتم ودمتم لنا وبارك الله لنا فيكم وكل اساتذتنا العظماء DayuNameArabic. & English.mdb

هههههههههه اسعدكم الله استاذى الجليل ومعلمى القدير كلماتك وسام على صدرى

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

عدد الاحرف الاقصى 255 لنوع الحقل Text ان كنت تريد عدد حروف اكثر من ذلك غير نوع الحقل من Text الى Memo

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

تمت كتابة الرسائل بالعربية ولضيق وقتى لم احولها لـ unicode ولكن لا انصح بكتابة العربى داخل محرر الاكواد تم تنقيح وتعديل بعد الاخطاء تم تفعيل الحذف ويتم معه حذف السجلات الفرعية والمرتبطة بالسجل الرئيسي والصورة تم تعديل ظهور الصورة بالتقرير Data Registration (v. 3).mdb

نسيت

اتفضل يا استاذ @alriashi فى انتظار ردك بعد التجربة Data Registration (v. 2).mdb

DayuNameArabic.mdb

ضع الكود الاتى فى موديول Public Function DayAr(dtDate) Dim strSat As String Dim strSun As String Dim strMon As String Dim strTues As String Dim strWed As String Dim strThurs As String Dim strFri As String strSat = ChrW("1575") & ChrW("1604") & ChrW("1587") & ChrW("1576") & ChrW("1578") strSun = ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1581") & ChrW("1583") strMon = ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1579") & ChrW("1606") & ChrW("1610") & ChrW("1606") strTues = ChrW("1575") & ChrW("1604") & ChrW("1579") & ChrW("1604") & ChrW("1575") & ChrW("1579") & ChrW("1575") & ChrW("1569") strWed = ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1585") & ChrW("1576") & ChrW("1593") & ChrW("1575") & ChrW("1569") strThurs = ChrW("1575") & ChrW("1604") & ChrW("1582") & ChrW("1605") & ChrW("1610") & ChrW("1587") strFri = ChrW("1575") & ChrW("1604") & ChrW("1580") & ChrW("1605") & ChrW("1593") & ChrW("1577") DayAr = Choose(Weekday(dtDate), strSun, strMon, strTues, strWed, strThurs, strFri, strSat) End Function يمكنك الان الحصول على اسم اليوم بالعربية لاى تاريخ من خلال استدعاء الروتين السابق باحد الاكواد الاتية - اسم اليوم الحالى من التاريخ الحالى DayAr(Date()) اسم اليوم بناء على تاريخ ما DayAr([[Fild Date Name])

مشاركة مع استاذى الجليل ومعلمى القدير @د.كاف يار هذه فكرتى المتواضعة IMAGE (Judy).accdb

اتفضل

طيب بالرغم من اننى كنت انتظر الرد عن نتيجة التجربة وابداء رايكم الكريم فى الفكرة الا انه طالما تم التأشير بأفضل اجابة يبدو انها بفضل الله تعالى نالت رضاكم وللعلم انا شخصيا الفكرة عجبتنـــــى

السلام عليكم استاذ @alriashi هذا المرفق يحتوى على اللبنة الأولى لبناء قاعدة البيانات طبعا عذا من وجهة نظرى المتواضعة وعلى قدر تفكيرى البسيط قدر يكون لأحد اساتذتى العظماء رأى مغاير ومخالف لفكرتى ان شاء الله تعالى غدا ان كنا من اهل الدنيا اكمل الباقى . الانت انتهيت من تصميم الجداول المناسبة ومن نماذج ادخال وتسجيل البيانات وتم وضع كود عند التحديث للرقم الشحصى فى النموذج اللرئيسى frmPersonalData يبحث عن الرقم ان كان موجود من الاساس فى البيانات الرئيسية أو بيانات الاقارب من خلال استعلام التوحيد qryUnionPrsNo فى حالة ان الرقم موجود مسبقا تفيد رسالة بذلك مع التوجه للسجل الذى به هذا الرقم ... سوف اقدم باقى افكارى غدا ان شاء الله بعد تجربتكم لذلك الجزء مبدئيا وافادتى بنتيجة التجربة Data Registration.mdb

اولا لابد من اضافة المكتبة الاتية Microsoft Scripting Runtime بدون اضافة المكتبة لن يعمل الكود طيب الكود الاتى فى المديول لانشاء المجلدات Option Compare Database Option Explicit 'Requires reference 'set a reference >>---> Microsoft Scripting Runtime #If Win64 Then Private Declare PtrSafe Function PathIsRelative Lib "Shlwapi" _ Alias "PathIsRelativeA" (ByVal Path As String) As Long #Else Private Declare Function PathIsRelative Lib "Shlwapi" _ Alias "PathIsRelativeA" (ByVal Path As String) As Long #End If Public Enum EMakeDirStatus ErrSuccess = 0 ErrRelativePath ErrInvalidPathSpecification ErrDirectoryCreateError ErrSpecIsFileName ErrInvalidCharactersInPath End Enum Const MAX_PATH = 260 Function MakeMultiStepDirectory(ByVal PathSpec As String) As EMakeDirStatus '''''''''''''''''''''''''' ' MakeMultiStepDirectory ' '''''''''''''''''''''''''' Dim FSO As Scripting.FileSystemObject Dim DD As Scripting.Drive Dim B As Boolean Dim Root As String Dim DirSpec As String Dim N As Long Dim M As Long Dim S As String Dim Directories() As String Set FSO = New Scripting.FileSystemObject ' ensure there are no invalid characters in spec. On Error Resume Next Err.Clear S = Dir(PathSpec, vbNormal) If Err.Number <> 0 Then MakeMultiStepDirectory = ErrInvalidCharactersInPath Exit Function End If On Error GoTo 0 ' ensure we have an absolute path B = CBool(PathIsRelative(PathSpec)) If B = True Then MakeMultiStepDirectory = ErrRelativePath Exit Function End If ' if the directory already exists, get out with success. If FSO.FolderExists(PathSpec) = True Then MakeMultiStepDirectory = ErrSuccess Exit Function End If ' get rid of trailing slash If Right(PathSpec, 1) = "\" Then PathSpec = Left(PathSpec, Len(PathSpec) - 1) End If ' ensure we don't have a filename N = InStrRev(PathSpec, "\") M = InStrRev(PathSpec, ".") If (N > 0) And (M > 0) Then If M > N Then ' period found after last slash MakeMultiStepDirectory = ErrSpecIsFileName Exit Function End If End If If Left(PathSpec, 2) = "\\" Then ' UNC -> \\Server\Share\Folder... N = InStr(3, PathSpec, "\") N = InStr(N + 1, PathSpec, "\") Root = Left(PathSpec, N - 1) DirSpec = Mid(PathSpec, N + 1) Else ' Local or mapped -> C:\Folder.... N = InStr(1, PathSpec, ":", vbBinaryCompare) If N = 0 Then MakeMultiStepDirectory = ErrInvalidPathSpecification Exit Function End If Root = Left(PathSpec, N) DirSpec = Mid(PathSpec, N + 2) End If Set DD = FSO.GetDrive(Root) Directories = Split(DirSpec, "\") DirSpec = DD.Path For N = LBound(Directories) To UBound(Directories) DirSpec = DirSpec & "\" & Directories(N) If FSO.FolderExists(DirSpec) = False Then On Error Resume Next Err.Clear FSO.CreateFolder (DirSpec) If Err.Number <> 0 Then MakeMultiStepDirectory = ErrDirectoryCreateError Exit Function End If End If Next N MakeMultiStepDirectory = ErrSuccess End Function وتسهيلا ولاضفاء مرونة فى الاستخدام قمت بكتابة الروتين الاتى ليتم استخدامة هو فقط Public Function MD(strPathDr) As EMakeDirStatus MD = MakeMultiStepDirectory(strPathDr) End Function يتم استدعاء الروتين من خلال MD(***) مع تغيير الـ *** بالمسار للمجلدات على سبيل المثال لو اردنا عمل مجلد فى القطاع D على ان يكون اسمه Officena ونريد بداخله مجلد باسم Access ونريد بجوار المجلد Access مجلد باسم Moh3sam وبداخلة مجلد باسم Judy وبداخل مجلد مجلد Access مجلد باسم VBA يكون الكود كالأتى MD("D:\Officena\Access\VBA") MD("D:\Officena\Moh3sam\Judy")

واتفضل هذا مثال فقط ينقصه اعادة ربط الجداول المرتبطة من قاعدة الخلفية فقط حتى يعمل النسخ الاحتياطى على اكمل وجه frontend.mdb db.mdb

اتفضل يا سيدى جرب الكود الاتى ورد على من فضلك هل تم تنفيذ النسخ التلقائى لقاعدة بيانات الجداول ملاحظة هامة لن تحتاج لتحديد مسار قاعدة البيانات الخلفية ولا لتعديل اى شئ فقط استخدم الكود الاتى ,, كذلك وضعت تقريبا شرح لكل شئ على الكود '-----------------------------------------------------------' '-----------------------------------------------------------' ' _ +-----------officena-----------+ _ ' ' /o) | ||||| | (o\ ' ' / / | @(~O^O~)@ | \ \ ' ' ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) ' ' ((\ \) +/o)----------3ssam---------(o\+ (/ /)) ' ' (\\\ \_/ / \ \_/ ///) ' ' \ / \ / ' ' \____/________Mohammed Essam________\____/ ' '--25-10-2021-----------------------------------------------' '-----------------------------------------------------------' Option Compare Database Option Explicit Function RunSub() Dim dbs As DAO.Database Dim tdf As DAO.TableDef Dim strPathDB As String Dim strNameExtensionDB As String Dim strNameDB As String Dim strExtensionDB As String Dim strBackupPath As String Dim strNewNameBackupDB As String Dim fso As Object Dim Syso As Object Set dbs = CurrentDb() With dbs For Each tdf In .TableDefs 'Is the table a linked table? If tdf.Attributes And dbAttachedODBC Or tdf.Attributes And dbAttachedTable Then With tdf 'Connect property contains path of link strPathDB = .Properties("Connect").Value 'Path of linked database tables strPathDB = Replace(strPathDB, ";DATABASE=", vbNullString) End With End If Next tdf End With 'Backup path directory strBackupPath = CurrentProject.Path & "\Backup\" Set fso = CreateObject("scripting.filesystemobject") 'Create the Backup folder if it does not exist If Not fso.FolderExists(strBackupPath) Then fso.createfolder (strBackupPath) 'Database name with extension strNameExtensionDB = Right(strPathDB, Len(strPathDB) - InStrRev(strPathDB, "\")) 'Database name without extension strNameDB = Left(strNameExtensionDB, InStrRev(strNameExtensionDB, ".") - 1) 'extension only strExtensionDB = Right(strPathDB, Len(strPathDB) - InStrRev(strPathDB, ".")) 'New name for backup database strNewNameBackupDB = strNameDB & "-Backup-" & Format(Now, "mm-yyyy") & "." & strExtensionDB 'Backup database save path directory strBackupPath = strBackupPath & strNewNameBackupDB DBEngine.Idle 'Copy the backup database to its directory Set Syso = CreateObject("Scripting.FileSystemObject") Syso.copyfile strPathDB, strBackupPath Set Syso = Nothing DoCmd.RunCommand acCmdExit End Function

انتظر سوف اقوم بعمل القليل من التعديلات لاضفى عليها السهولة والمرونة بالنسبة لحضرتك

طبيعى يا افندم قاعدة البيانات فى مجلد تم عمل مشاركة له انظر الى الجداول المرتبطة فى قاعدة بياناتك الامامية التى تفتح منها وانظر للجداول مرتبطة بالقاعدة الخلفية عن طريقة اسم الجهاز او ال ip

وعليكم السلام ورحمة الله تعالى وبركاته اممم وليه الهماشى واللا تقصد حضرتك لو الاجهزة فى اماكن محتلفة ولا يمكن ربطهم من خلال شبكة محلية يتم عمل شبكة الهماشى ؟!