محمد أبوعبدالله

صدقأ اخي الحبيب انا من اشد المعجب بك وأحاول دائماً الاستفادة من مشاركاتك ... ما شاء الله لا قوة الا بالله دمت لاخيك تحياتي

ربما تريد الحصول على الاسم الجديد اذا كان مرادك ذلك فيكون كالتالي Me.CRN = File_Pattern & Format(Next_Seq, "_0000.") & File_Type تحياتي

الخطأ الذي ظهر كان بسبب السطر التالي Me.CRN = sSourceFile وذلك لان حجم حقل CRN = 16 واما sSourceFile فهو نص طويل لذلك يجب ان يكون الحقل على الاقل = 255 او اجعله مذكرة وحقيقة لم افهم لماذا تنقل قيمة sSourceFile الى حقل CRN ثم تحذفه من خلال الاستعلام Query2 تحياتي

يوجد كود لاستاذنا جعفر يقوم بهذه الوظيفة وهو جزء من الموضوع التالي ضع الكود التالي في وحدة نمطية جديدة Public Function Biggest_Value_in_Folder(ByVal Fldr As String, Pttrn As String, Digts As Integer, fle_Type As String) As Double 'usage: 'Call Biggest_Value_in_Folder("D:\Temp", "EM_New_Section_Letter_Number_", 6, "jpg") Dim strFile As String Dim Digits_Only As String If Len(fle_Type & "") = 0 Then fle_Type = "*" If Right(Fldr, 1) <> "\" Then Fldr = Fldr & "\" strFile = Dir(Fldr & Pttrn & "*." & fle_Type) 'Debug.Print strFile Do Until strFile = "" 'NumberOfFiles = NumberOfFiles + 1 Digits_Only = Replace(strFile, "." & fle_Type, "") Digits_Only = Right(Digits_Only, Digts) If Val(Digits_Only) > Biggest_Value_in_Folder Then Biggest_Value_in_Folder = Val(Digits_Only) End If strFile = Dir() Loop End Function ثم قم بتعديل الكود كالتالي Dim rs As DAO.Recordset Dim fso, sSourceFile, sDestinationFile Set fso = CreateObject("Scripting.FileSystemObject") Set rs = CurrentDb.OpenRecordset("SELECT crn FROM BASIC_DATE") If rs.RecordCount = 0 Then Exit Sub End If rs.MoveFirst Do Until rs.EOF sSourceFile = Application.CurrentProject.Path & "\CONTACT\" & rs!crn & ".pdf" sDestinationFile = Application.CurrentProject.Path & "\CONTACT\old\" '-- تحقق من أن الملف موجود قبل إجراء عملية النسخ If fso.FileExists(sSourceFile) Then Dim MSAccPath As String Dim File_Type As String Dim File_Pattern As String Dim Next_Seq As Double 'make the next backup, by giving it the next sequence number File_Type = Mid(sSourceFile, InStrRev(sSourceFile, ".") + 1) File_Pattern = Mid(sSourceFile, InStrRev(sSourceFile, "\") + 1) File_Pattern = Mid(File_Pattern, 1, Len(File_Pattern) - Len(File_Type) - 1) Next_Seq = Biggest_Value_in_Folder(sDestinationFile, File_Pattern, 4, File_Type) + 1 Destination_File = sDestinationFile & File_Pattern & Format(Next_Seq, "_0000.") & File_Type FileCopy sSourceFile, Destination_File Me.P = sSourceFile fso.DeleteFile sSourceFile End If rs.MoveNext Loop إن واجهتك مشكلة في التطبيق ارفق بنا وارفق مثال ليتم التعديل عليه 🙂 تحياتي

وعليكم السلام ورحمة الله وبركاته انظر الجدول الجديد tblItemType وانظر ايضاً الحقل الجديد IdItemType في جدول صنف واكمل البيانات بنفس الطريقة عمل قائمة منسدلة من نوع الصنف.rar وهذه المشاركة ستفيدك في كيفية عمل ذاك تحياتي

اخي الكريم تجنباً لمثل هذا استخدم رقم عشوائي لاسم الملف بحيث لا يتكرر ولا يتم حذف القديم وهذا كود لتوليد رقم عشوائي Function fnAutoField() As String Dim strRndNo As String strRndNo = Format((999999999 * Rnd) + 1, "0000000000") fnAutoField = strRndNo End Function ويصبح الكود بالشكل التالي Sub CopyFile() Dim rs As DAO.Recordset Dim fso, sSourceFile, sDestinationFile Set fso = CreateObject("Scripting.FileSystemObject") Set rs = CurrentDb.OpenRecordset("SELECT crn FROM BASIC_DATE") Dim XXX As String XXX = fnAutoField() If rs.RecordCount = 0 Then Exit Sub End If rs.MoveFirst Do Until rs.EOF sSourceFile = Application.CurrentProject.Path & "\CONTACT\" & rs!crn & XXX & ".pdf" sDestinationFile = Application.CurrentProject.Path & "\CONTACT\old\" '-- تحقق من أن الملف موجود قبل إجراء عملية النسخ If fso.FileExists(sSourceFile) Then fso.CopyFile sSourceFile, sDestinationFile, True fso.DeleteFile sSourceFile End If rs.MoveNext Loop End Sub تحياتي

تفضل Like "*" & [forms]![conform_shM]![tt1] & "*" letter.accdb تحياتي

تفضل مثال لعمل تصفية لقائمة بناءا على قائمة اخرى EV-Gov.rar تحياتي

انشىء جدول وليكن اسمه مثلاُ tbl1 به حقلين NameAr ، NameFr تحياتي

letter.rar

السلام عليكم ضع نفس المعيار المستخدم في النموذج الفرعي في الاستعلام Like [forms]![conform_shM]![tt1] & "*" تحياتي

وعليكم السلام ورحمة الله وبركاته انشىء جدول به حقلين NameAr ، NameFr واكتب الاسم عربي وامامه في الحقل الثاني اكتب الاسم بالفرنسي ثم استخدم دالة كدالة DLookup مثلاُ بالطريقة التالية =DLookup("[NameFr]"; "[tbl1]"; "[NameAr] ='" & me.txtName & "'") تحياتي

وعليكم السلام ورحمة الله وبركاته حياك الله اخي الحبيب ابوعبدالله الفكرة اخي ابوعبدالله كالتالي 1 - فتح قاعدة البيانات في وضع الخاص 2 - إزالة كلمة المرور 3 - تحويل قاعدة البيانات من accdb الى accde 4 - تعيين كلمة مرور من جديد لكلتا القاعدتين accdb و accde هذا الموديل للخطوات 1 ، 2 ، 4 Public Sub Set_Pass(sDBName As String, soLdPass As String, Optional sNewPass As String = "") Dim db As DAO.Database On Error GoTo Err: Set db = OpenDatabase(sDBName, True, False, ";PWD=" & soLdPass) db.NewPassword soLdPass, sNewPass Exit Sub Err: Resume Next End Sub وهذا الكود في زر امر لتنفيذ جميع الخطوات Dim app As New Access.Application Dim DB_Full_Name As String Dim DB_Directory As String Dim oLdPass As String, NewPass As String oLdPass = 777 '1 And 2 Set_Pass Me.DB_File, oLdPass, oLdPass Set_Pass Me.DB_File, oLdPass, "" DB_Full_Name = Me.DB_File DB_Directory = Mid(DB_Full_Name, 1, Len(DB_Full_Name) - 6) & ".accde" '3 app.SysCmd 603, DB_Full_Name, DB_Directory '4 oLdPass = "" NewPass = 777 Set_Pass Me.DB_File, oLdPass, NewPass Set_Pass DB_Directory, oLdPass, NewPass تحياتي

وعليكم السلام ورحمة الله وبركاته يمكن استخدام دالة Like بالشكل التالي Like "*" & [Forms]![frm1]![txt1] & "*" تحياتي

جزاك الله خيرا يا ابو عبدالله ورضي الله عنك دمت بكل خير تحياتي

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم تحياتي

اخي الكريم بمجرد ان تخفي شاشة الاكسيس فانت قمت بحماية بنسبة كبيرة وحماية الجداول وقاعدة البيانات لها اكثر من طريقة اكتب في محرك البحث حماية ستظهر لك نتائج كثيرة https://www.officena.net/ib/search/?q=حماية&quick=1&type=forums_topic&nodes=89 اعتقد ان المشكلة التي معك حاليا كيفية حماية مجلد المرفقات تحياتي

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

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

Database8.rar تحياتي

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم Private Sub Text0_DblClick(Cancel As Integer) On Error Resume Next Dim fs, cf, strFolder ' التأكد من وجود مجلد المفرقات AttachmentX strFolder = CurrentProject.Path & "\" & "AttachmentX" Set fs = CreateObject("Scripting.FileSystemObject") ' اذا كان مجلد المرفقات AttachmentX غير موجود يتم انشاءه If fs.FolderExists(strFolder) = False Then MsgBox "تحذير !!! مجلد المرفقات غير موجود ! وسيتم انشائه ان شاء الله بجوار البرنامج", vbExclamation, "officena" Set cf = fs.CreateFolder(strFolder) End If ' عرض مربع حواري لاختيار الصورة Dim Fpathz As Variant With Application.FileDialog(3) .Title = "Choose File" .Filters.Clear .Filters.Clear .Filters.Add "png image", "*.png" .Filters.Add "jpg image", "*.jpg" .Filters.Add "jpeg image", "*.jpeg" .Filters.Add "pdf File", "*.pdf" .AllowMultiSelect = False .InitialFileName = "" If .Show = -1 Then Fpathz = .SelectedItems(1) ' نقل الصورة الى مجلد المرفقات AttachmentX بنفس الامتداد Dim DBwithEXT, DBwithoutEXT As String Dim XXX As String XXX = fnAutoField() DBwithEXT = Dir(Fpathz) DBwithoutEXT = Left(DBwithEXT, Len(DBwithEXT) - 4) FileCopy Fpathz, Application.CurrentProject.Path & "\AttachmentX" & "\" & DBwithoutEXT & XXX & "+" & [IdEmp] & Right(DBwithEXT, 4) Me.Text0 = Application.CurrentProject.Path & "\AttachmentX" & "\" & DBwithoutEXT & XXX & "+" & [IdEmp] & Right(DBwithEXT, 4) End If End With End Sub وهذا لتوليد رقم عشوائي للمرفقات Function fnAutoField() As String Dim strRndNo As String strRndNo = Format((999999999 * Rnd) + 1, "0000000000") fnAutoField = strRndNo End Function Database8.rar تحياتي

بارك الله فيك استاذنا الفاضل ونفع الله بك تحياتي

الحقيقة ليتك قمت بفتح موضوع جديد بما انك ستعمل على قاعدة بيانات مختلفة منعا لمخالفة قوانين المنتدى يلزمنا الآن تعديل الكود مرة اخرى وما ينطبق عليه لا ينطبق على ما سبق الوحدة النمطية الجديدة Option Compare Database Option Explicit Function CalcAgeY(vDate1 As Date, vdate2 As Date) Dim vYears As Integer, vMonths As Integer, vDays As Integer vMonths = DateDiff("m", vDate1, vdate2) + 1 vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2) + 1 If vDays < 0 Then vMonths = vMonths - 1 vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2) + 1 End If vYears = vMonths \ 12 vMonths = vMonths Mod 12 CalcAgeY = vYears End Function Function CalcAgeM(vDate1 As Date, vdate2 As Date) Dim vYears As Integer, vMonths As Integer, vDays As Integer vMonths = DateDiff("m", vDate1, vdate2) + 1 vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2) + 1 If vDays < 0 Then vMonths = vMonths - 1 vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2) + 1 End If vYears = vMonths \ 12 vMonths = vMonths Mod 12 CalcAgeM = vMonths End Function Function CalcAgeD(vDate1 As Date, vdate2 As Date) As String Dim vYears As Integer, vMonths As Integer, vDays As Integer vMonths = DateDiff("m", vDate1, vdate2) + 1 vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2) + 1 If Day(vDate1) = 31 Then vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2) + 1 If vDays < 0 Then vMonths = vMonths - 1 vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2) + 1 End If vYears = vMonths \ 12 vMonths = vMonths Mod 12 CalcAgeD = vDays End Function وهذا في الاستعلام يوم D: CalcAgeD([from];[too]) شهر M: CalcAgeM([from];[too]) سنة Y: CalcAgey([from];[too]) باليوم والشهر.rar تحياتي

السلام عليكم عرض التقرير لا يناسب الورق المحدد في اعدادت الطباعة A5 بل يناسب ورق A1 واليك مقاسات الاوراق بالسم A1 = 59.4 × 84.1 A2 = 42.0 × 59.4 A3 = 29.7 × 42.0 A4 = 21.0 × 29.7 A5 = 14.8 × 21.0 A6 = 10.5 × 14.8 اليك التعديل بعد جعل الورق A4 عرضي وازالة الزيادات ايجار معدات للغير1.rar تحياتي

ما المقصود محسوبة يدوياً اود ان ابنهك الى شىء هام دالة DateDiff في الاساس تقوم بعرض الفاصل بين تاريخين سواء يوم او شهر او سنة فمثلاً الفاصل الزمني بين 01/01/2021 الى 31/12/2021 لن يكون 1 سنة بل سيكون 11 شهر + 30 يوم الفاصل الزمني بين 01/01/2021 الى 31/01/2021 لن يكون شهر بل سيكون 30 يوم الفاصل الزمني بين 01/01/2021 الى 31/03/2021 لن يكون ثلاثة اشهر بل سيكون 2 شهر + 30 يوم وبناءأ عليه فالكود المستخدم صحيح 100% باذن الله والشكر موصول لصاحب الكود الاساسي جعله الله في ميزان حسناته تحياتي