Moosak

استخدم هذا الكود أخي عمر .. وهو بالعربي .. تضعه في موديول منفصل ثم تستدعيه كما هو موضح بالأسفل مثال : Public Function DateAsText(GivenDate As Date) As String Dim Daytxt, Monthtxt, Yeartxt As String Daytxt = NoToTxt(Day(GivenDate), "", "") 'Monthtxt = "من شهر " & NoToTxt(Month(GivenDate), "", "") ' فعل هذا السطر إذا أردت كتابة الشهر بالرقم وليس بالاسم Monthtxt = "من شهر " & MonthName(Month(GivenDate)) Yeartxt = "سنة" & NoToTxt(Year(GivenDate), "", "") DateAsText = Daytxt & "" & Monthtxt & " " & Yeartxt & "ميلادي" End Function Function NoToTxt(TheNo As Double, MyCur As String, MySubCur As String) As String Dim MyArry1(0 To 9) As String Dim MyArry2(0 To 9) As String Dim MyArry3(0 To 9) As String Dim MyNo As String Dim GetNo As String Dim RdNo As String Dim My100 As String Dim My10 As String Dim My1 As String Dim My11 As String Dim My12 As String Dim GetTxt As String Dim Mybillion As String Dim MyMillion As String Dim MyThou As String Dim MyHun As String Dim MyFraction As String Dim MyAnd As String Dim i As Integer Dim ReMark As String If TheNo > 999999999999.99 Then Exit Function If TheNo = 0 Then NoToTxt = "صفر" Exit Function End If MyAnd = " و" MyArry1(0) = "" MyArry1(1) = "مائة" MyArry1(2) = "مائتان" MyArry1(3) = "ثلاثمائة" MyArry1(4) = "أربعمائة" MyArry1(5) = "خمسمائة" MyArry1(6) = "ستمائة" MyArry1(7) = "سبعمائة" MyArry1(8) = "ثمانمائة" MyArry1(9) = "تسعمائة" MyArry2(0) = "" MyArry2(1) = " عشر" MyArry2(2) = "عشرون" MyArry2(3) = "ثلاثون" MyArry2(4) = "أربعون" MyArry2(5) = "خمسون" MyArry2(6) = "ستون" MyArry2(7) = "سبعون" MyArry2(8) = "ثمانون" MyArry2(9) = "تسعون" MyArry3(0) = "" MyArry3(1) = "واحد" MyArry3(2) = "اثنان" MyArry3(3) = "ثلاثة" MyArry3(4) = "أربعة" MyArry3(5) = "خمسة" MyArry3(6) = "ستة" MyArry3(7) = "سبعة" MyArry3(8) = "ثمانية" MyArry3(9) = "تسعة" '====================== GetNo = Format(TheNo, "000000000000.00") i = 0 Do While i < 15 If i < 12 Then MyNo = Mid$(GetNo, i + 1, 3) Else MyNo = "0" + Mid$(GetNo, i + 2, 2) End If If (Mid$(MyNo, 1, 3)) > 0 Then RdNo = Mid$(MyNo, 1, 1) My100 = MyArry1(RdNo) RdNo = Mid$(MyNo, 3, 1) My1 = MyArry3(RdNo) RdNo = Mid$(MyNo, 2, 1) My10 = MyArry2(RdNo) If Mid$(MyNo, 2, 2) = 11 Then My11 = "إحدى عشر" If Mid$(MyNo, 2, 2) = 12 Then My12 = "إثنى عشر" If Mid$(MyNo, 2, 2) = 10 Then My10 = "عشرة" If ((Mid$(MyNo, 1, 1)) > 0) And ((Mid$(MyNo, 2, 2)) > 0) Then My100 = My100 + MyAnd If ((Mid$(MyNo, 3, 1)) > 0) And ((Mid$(MyNo, 2, 1)) > 1) Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If ((Mid$(MyNo, 3, 1)) = 1) And ((Mid$(MyNo, 2, 1)) = 1) Then GetTxt = My100 + My11 If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My11 End If If ((Mid$(MyNo, 3, 1)) = 2) And ((Mid$(MyNo, 2, 1)) = 1) Then GetTxt = My100 + My12 If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My12 End If If (i = 0) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات" If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " مليار" If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " ملياران" End If End If If (i = 3) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين" If ((Mid$(MyNo, 1, 3)) = 1) Then MyMillion = " مليون" If ((Mid$(MyNo, 1, 3)) = 2) Then MyMillion = " مليونان" End If End If If (i = 6) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then MyThou = GetTxt + " ألف" Else MyThou = GetTxt + " آلاف" If ((Mid$(MyNo, 3, 1)) = 1) Then MyThou = " ألف" If ((Mid$(MyNo, 3, 1)) = 2) Then MyThou = " ألفان" End If End If If (i = 9) And (GetTxt <> "") Then MyHun = GetTxt If (i = 12) And (GetTxt <> "") Then MyFraction = GetTxt End If i = i + 3 Loop If (Mybillion <> "") Then If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd End If If (MyMillion <> "") Then If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd End If If (MyThou <> "") Then If (MyHun <> "") Then MyThou = MyThou + MyAnd End If If MyFraction <> "" Then If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur Else NoToTxt = ReMark + MyFraction + " " + MySubCur End If Else NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur End If End Function وطريقة استدعائه (كمصدر للخلية أو في الاستعلام) كالتالي : = DateAsText([Date])

وعليكم السلام ورحمة الله وبركاته أخي أحمد .. الطريقة الأنسب أخي أحمد أن يكون جدول الدرجات منفصل .. ثم تضع بياناته في قائمة منسدلة .. ثم بعد ذلك في النموذج الخاص بتسجيل الدرجات تضع كود تسجيل الدرجة في الحقل الرقمي المرغوب ( لن تحتاج للحقل المحسوب ) .. هذا المثال : وهذا الكود ( عند تحديث القائمة المنسدلة ) : Private Sub DrjhCbo_AfterUpdate() Me.eldarga2 = Me.DrjhCbo.Column(1) End Sub المرفق : الدرجه (1).accdb

ولعله الحب من أول نظرة عامل عمايله معاك 😂 العفو حبيبنا .. 🌹 اللهم آمين وإياكم .. 🤲

وعليكم السلام ورحمة الله وبركاته عمي جعفر 🙂 جزاك الله خيراً .. وإحساناً .. وأجرا ..🌹😊 هل الصياغة السابقة تؤثر على الأداء ؟

تفضل أخي عمر .. هذا هو الكود مع إضافة روتين منفصل لحساب أول وآخر الشهر ( تم التعديل على الكود الخاص بك ) 🙂 : Private Sub cmdTMNOMins_Click() If Me.txtMonthNo <= 1 Then MsgBox "ان اقل شهر فى السنه هو شهر 1 (يناير) لا يمكن ان يكون اقل من هذا", vbCritical, "خطأ" Me.txtMonthNo = 1 Exit Sub Else Me.txtMonthNo = Me.txtMonthNo - 1 firstAndLastDay Me.txtMonthNo End If End Sub Private Sub cmdTMNOPlas_Click() If Me.txtMonthNo >= 12 Then MsgBox "ان الاشهر السنه هي 12 شهر لا يمكن ان يكون اكثر من هذا", vbCritical, "خطأ" Me.txtMonthNo = 12 Exit Sub Else Me.txtMonthNo = Me.txtMonthNo + 1 firstAndLastDay Me.txtMonthNo End If End Sub Private Sub firstAndLastDay(MonthNum As Integer) Me.txtdate1 = DateSerial(Year(Date), MonthNum, 1) Me.txtdate2 = DateSerial(Year(Date), MonthNum + 1, 0) End Sub المرفق: ForDate.accdb

على الرحب والسعة أخي العزيز 🙂

ما يخطر ببالي هو أنا السجل الحالي غير محفوظ بعد ( Not Saved ) . الأفضل أن ترفق مثال (مرفق) ليتضح الأمر .

هات مرفق .. أو صورة للكويري ..

نعم أخي طارق ممكن .. ضع الكود في حدث بعد التحديث للحقل الذي تريده .

حسب ما فهمت .. قمت بعمل زر في النموذج لإضافة السجلات ووضعت له الكود التالي : Private Sub EnterBtn_Click() Dim ID As String Dim N, X As Integer ID = Me.bar N = Me.n_istimara.Value For X = 1 To N DoCmd.SetWarnings False DoCmd.RunSQL "INSERT INTO istimaraALL ( bar, m, istimaracode ) SELECT '" & ID & "', " & X & " , 'istimaracode Here' ;" DoCmd.SetWarnings True Next X Me.istimarabassemSubform.Requery End Sub ليعطيك النتيجة 🙂 : وللعلم : أنت وضعت istimaracode كشرط أساسي (مطلوب) لإضافة السجلات بالأسفل ، لذلك يحتاج تعدلها في الكود وتضع القيمة التي تريدها في المكان المحدد هنا : DoCmd.RunSQL "INSERT INTO istimaraALL ( bar, m, istimaracode ) SELECT '" & ID & "', " & X & " , 'istimaracode Here' ;" أو أن تلغي خيار أنه حقل "مطلوب" من خيارات الجدول istimaraALL .. وتضيفها بنفسك لاحقا في النموذج . المرفق : 1358524440_.rar

عدلت لك الكود ليقبل أكثر من ملف ويحفظ كل مسار في سجل جديد ..

تم التعديل أخي .. كنت نسيان تضيف فاصلة (,) في الكود قبل الفلتر . 1276627580_-Copy.accdb

وعليكم السلام ورحمة الله وبركاته .. بارك الله فيك أخي سيمو وغفر الله لك ولوالديك ولجميع أحبابك .. الحقيقة إضافة مفيدة جدا وقيمة أيضا ويكثر استخدمها للمبرمجين .. وكإضافة بسيطة لنفس الموضوع في نفس السياق إكتشفتها من وقت قريب أن هذا الخيار يظهر لك عند الضغط على زر الشفت مع الزر الأيمن للماوس على الملف 🙂

ضع هذا الكود في حدث عند وجود شوائب أو On Dirty للنموذج هكذا : Private Sub Form_Dirty(Cancel As Integer) Me.lastupdate = Now End Sub وأفضل أن تستخدم Now بدل Date .. ليعطيك التاريخ والوقت

تفضل هذا هو الكود 🙂 : Sub GetFiles() Dim fdialog As Office.FileDialog Dim filepath As String Dim Item As Variant Set fdialog = Application.FileDialog(msoFileDialogFilePicker) With fdialog .Title = "Select image" .AllowMultiSelect = True .Filters.Clear .Filters.Add "Image file", "*.jpg ; *.bmp ; *.png" If .Show Then For Each Item In .SelectedItems DoCmd.GoToRecord , , acNewRec filepath = .SelectedItems(1) [PthIn1] = filepath Next Else Exit Sub End If End With MsgBox "تم إضافة الملفات بنجاح" End Sub

هل هذا هو الكود الذي تريد التعديل عليه؟

وعليكم السلام ورحمة الله وبركاته .. الكود موجود ولكن نحتاج مرفق للتطبيق عليه .. 🙂

وفقك الله أخي نبيل @nabilalibibo .. ولا تنسى التأشير عليها كأفضل إجابة 👍😉

تم تعديل الكود : Public Sub Check(FiledName As Control) Dim X As Integer Dim Count As Integer Dim TL As Integer Dim L, M As String TL = Len(FiledName) For X = 1 To TL L = Mid(FiledName, X, 1) M = Mid(FiledName, X, 2) If IsNumeric(L) = True Then If L > 5 Then Count = Count + 1 End If End If If IsNumeric(M) = True Then If M > 5 Then Count = Count + 1 End If End If Next X If Count > 0 Then FiledName.FontBold = True FiledName.ForeColor = vbRed Else FiledName.FontBold = False FiledName.ForeColor = vbBlack End If End Sub والآن تتعرف عليها بفضل الله .. المرفق : الرقم 5.accdb

وعند جهينة الخبر اليقين 😅

هذه مشاركتي 🙂 Private Sub Months_AfterUpdate() If Me.Months = "6 شهور" Then Me.End = DateAdd("M", 6, Me.Start) End If If Me.Months = "سنة" Then Me.End = DateAdd("M", 12, Me.Start) End If End Sub DateAdd.accdb

هذا الحل الذي أعددته في حال أن الأخ @elghoultk قال أن حقل النص بهذه الطريقة ( 15 - 20) .. ولكن قد سبقني بها عكاشة @kanory 😅 الحل أن تضع هذه الدالة في محرر الأكواد : Public Sub Check(FiledName As Control) Dim X As Integer Dim Count As Integer Dim TL As Integer Dim L As String TL = Len(FiledName) For X = 1 To TL L = Mid(FiledName, X, 1) If IsNumeric(L) = True Then If L > 5 Then Count = Count + 1 End If End If Next X If Count > 0 Then FiledName.FontBold = True FiledName.ForeColor = vbRed Else FiledName.FontBold = False FiledName.ForeColor = vbBlack End If End Sub ثم تناديها عند حدث بعد التغيير لمربع النص + وكذلك عند حدث في الحالي للنموذج .. هكذا : ( ولا تنسى تغيير اسم مربع النص ) 🙂 Private Sub Form_Current() If IsNull(Me.NumberxTxt) Then Exit Sub Check NumberxTxt End Sub Private Sub NumberxTxt_AfterUpdate() Check NumberxTxt End Sub والنتيجة عند عدم وجود رقم أكبر من الخمسة : وعند تحقق المطلوب : مرفق المثال : الرقم 5.accdb

اعمل تنسيق شرطي للخلية أخي العزيز .. بحيث لوكان قيمة مربع النص >5 يكون الخط سميك .. هذا حسب ما فهمته على فرض أن محتوى الخلية كله أرقام ، إلا إن كان قصدك أن محتوى الخلية يكون عبارة عن نص هكذا = ( 15 - 20) ؟ فالحل سيكون مختلف . للتكرم بالتوضيح .

تفضل أخي أحمد أحمد أحمد 🙂 ضع هذا الكود في موديول : Public Sub TakeBackup() On Error GoTo MyErr Dim OldFile, NewFile, CopyMyDB, wheretoBackup, BackupFolder, DBName As String OldFile = CurrentProject.FullName BackupFolder = SelectFolder DBName = Left(CurrentProject.Name, InStrRev(CurrentProject.Name, ".") - 1) NewFile = BackupFolder & "\" & DBName & "-Backup-" & Format(Date, "dd-mm-yyyy") & "-" & Format(Now(), "Hh-Nn-ss-AMPM.") & Right(OldFile, 5) CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewFile & """" Shell CopyMyDB, 0 MsgBox "Backup........Done" & vbNewLine & vbNewLine & "Saved in :" & vbNewLine & NewFile, , " " MyErr: If Err.Number <> 0 Then MsgBox Err.Number & " - " & Err.Description End If End Sub Public Function SelectFolder() On Error GoTo ErrorHandler Dim FileDialog As Object Dim sPath As String Dim sFile As String Set FileDialog = Access.Application.FileDialog(4) With FileDialog .AllowMultiSelect = False .Filters.Clear .Show .Title = "Please select folder" SelectFolder = .SelectedItems(1) End With ExitHandler: Exit Function ErrorHandler: Select Case Err.Number Case Is = 5 MsgBox ChrW("1604") & ChrW("1602") & ChrW("1583") & ChrW("32") & ChrW("1578") & ChrW("1605") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1594") & ChrW("1575") & ChrW("1569") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1605") & ChrW("1585") & ChrW("32") & ChrW("46") & ChrW("46") & ChrW("46") & ChrW("32") & ChrW("40") & ChrW("32") & ChrW("1604") & ChrW("1605") & ChrW("32") & ChrW("1578") & ChrW("1602") & ChrW("1605") & ChrW("32") & ChrW("1576") & ChrW("1578") & ChrW("1582") & ChrW("1583") & ChrW("1610") & ChrW("1583") & ChrW("32") & ChrW("1571") & ChrW("1609") & ChrW("32") & ChrW("1605") & ChrW("1587") & ChrW("1575") & ChrW("1585") & ChrW("41") _ , vbMsgBoxRight + vbMsgBoxRtlReading, _ ChrW("1578") & ChrW("1606") & ChrW("1576") & ChrW("1610") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("40") & ChrW("32") & ChrW("65") & ChrW("116") & ChrW("116") & ChrW("101") & ChrW("110") & ChrW("116") & ChrW("105") & ChrW("111") & ChrW("110") & ChrW("32") & ChrW("41") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1607") Case Else MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description Resume ExitHandler End Select End Function ثم قم باستدعائه هكذا : Call TakeBackup()

ببساطة يا عزيزنا @elghoultk .. تنسخ الدالة ( لكل ليبل الدالة الخاصة به ) .. وتغير اسم الدالة والبيانات اللي فيها حسب المطلوب .. وتحط نداء كل دالة في حدث عند التغيير للعناصر الثلاثة وفي الحالي للنموذج .. أو للخطوة الأخيرة تعمل دالة ثانية أو روتين عام تحط فيها النداءات كلها وبعدين تنادي الروتين مرة وحدة في حدث عند التغيير . إن شاء الله يكون واضح 😁 وبالمثال يتضح المقال 🙂