Foksh

اخي الكريم استعمل خاصية البحث في المنتدى ، ستجد الكثير من المواضيع التي تفيدك . على العموم ، في هذه مشاركة للأستاذ @kkhalifa1960 أعتقد ممكن يكون فيها فايدة لك .

هي الفكرة مش بصعوبتها ، بقدر ما هي في كمية المشاكل اللي ممكن تحصل أثناء إدخال البيانات . غداً إن كان في العمر بقية نشوف الموضوع

جربي التعديل الاخير Private Sub TextBox1_LostFocus() ' التحقق من أن مربع النص ليس فارغًا If Not IsEmpty(Me.TextBox1.Value) Then ' التحقق من وجود الأقواس وإزالتها إن وجدت Dim cleanedValue As String cleanedValue = Me.TextBox1.Value If cleanedValue Like "*(*" And cleanedValue Like "*)*" Then cleanedValue = Replace(cleanedValue, "(", "") cleanedValue = Replace(cleanedValue, ")", "") End If ' تحويل القيمة إلى عددين Dim values() As String values = Split(cleanedValue, " - ") ' التحقق من أن هناك قيمتين مفصولتين بفاصلة "-" If UBound(values) = 1 Then ' تحويل القيم إلى أرقام Dim lowValue As Double Dim highValue As Double lowValue = CDbl(values(0)) highValue = CDbl(values(1)) ' تحديث قيم low و high في مربعي النص المستهدفين Me.low.Value = lowValue Me.high.Value = highValue Else ' رسالة تنبيه إذا كان التنسيق غير صحيح MsgBox "يرجى إدخال القيم بالتنسيق الصحيح (على سبيل المثال: 10 - 15)" End If End If End Sub

Private Sub TextBox1_LostFocus() ' التحقق من أن مربع النص ليس فارغًا If Not IsEmpty(Me.TextBox1.Value) Then ' تحويل القيمة إلى عددين بدون الأقواس Dim cleanedValue As String cleanedValue = Replace(Me.TextBox1.Value, "(", "") cleanedValue = Replace(cleanedValue, ")", "") Dim values() As String values = Split(cleanedValue, " - ") ' التحقق من أن هناك قيمتين مفصولتين بفاصلة "-" If UBound(values) = 1 Then ' تحويل القيم إلى أرقام Dim lowValue As Double Dim highValue As Double lowValue = CDbl(values(0)) highValue = CDbl(values(1)) ' تحديث قيم low و high في مربعي النص المستهدفين Me.low.Value = lowValue Me.high.Value = highValue Else ' رسالة تنبيه إذا كان التنسيق غير صحيح MsgBox "يرجى إدخال القيم بالتنسيق الصحيح (على سبيل المثال: 10 - 15)" End If End If End Sub جربي كده مع الأقواس

يعني ممكن يكون المحتوى في Reference نصي ورقمي ؟؟

جربي اكتبي القيم بدون الأقواس ، مثلاً 10 - 25

بالافتراض أن صيغة الرقم المكتوبة في الحقل الأول بهذا الشكل 25 - 10 Private Sub TextBox1_LostFocus() ' التحقق من أن مربع النص ليس فارغًا If Not IsEmpty(Me.TextBox1.Value) Then ' تحويل القيمة إلى عددين Dim values() As String values = Split(Me.TextBox1.Value, " - ") ' التحقق من أن هناك قيمتين مفصولتين بفاصلة "-" If UBound(values) = 1 Then ' تحويل القيم إلى أرقام Dim lowValue As Double Dim highValue As Double lowValue = CDbl(values(0)) highValue = CDbl(values(1)) ' تحديث قيم low و high في مربعي النص المستهدفين Me.low.Value = lowValue Me.high.Value = highValue Else ' رسالة تنبيه إذا كان التنسيق غير صحيح MsgBox "يرجى إدخال القيم بالتنسيق الصحيح (على سبيل المثال: 10 - 15)" End If End If End Sub حيث أن TextBox1 هو مربع النص الذي به القيمة سابقة ، وعند الخروج منه سينقل القيم تلقائيا للمربعين low و high . لعدم توافر جهاز كمبيوتر حالياً ، أعلميني بالنتيجة.

ارسل مرفق أخي الكريم للعمل عليه 😊

أخي وصديقي العزيز ، أحيانا التوضيح للهدف من الطلب يكون بغاية الأهمية لتسهيل الحلول ، على العموم ، تفضل هذا التعديل البسيط بناءً على طلبك . Dim db As Database Dim rs As Recordset Dim formName As String Dim found As Boolean Set db = CurrentDb Set rs = db.OpenRecordset("Frm_Nams") For Each frm In Application.CurrentProject.AllForms formName = frm.Name ' التحقق من عدم تكرار الاسم قبل الإضافة found = False rs.MoveFirst Do Until rs.EOF If rs.Fields("Frm_Namo").Value = formName Then found = True Exit Do End If rs.MoveNext Loop If Not found Then rs.AddNew rs.Fields("Frm_Namo").Value = formName rs.Update End If Next frm rs.Close Set rs = Nothing Set db = Nothing MsgBox "تم إضافة أسماء النماذج بنجاح", vbInformation وأخبرني بالنتيجة ، متابع

تفضل أخي الكريم ،، Function ConvertCurrencyToArabic(ByVal MyNumber) Dim Temp Dim AED, Cents Dim DecimalPlace, Count ReDim Place(9) As String Place(2) = " ألف " Place(3) = " مليون " Place(4) = " مليار " Place(5) = " تريليون " MyNumber = Trim(Str(MyNumber)) DecimalPlace = InStr(MyNumber, ".") If DecimalPlace > 0 Then Temp = Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2) Cents = ConvertTens(Temp) MyNumber = Trim(Left(MyNumber, DecimalPlace - 1)) End If Count = 1 Do While MyNumber <> "" Temp = ConvertHundreds(Right(MyNumber, 3)) If Temp <> "" Then AED = Temp & Place(Count) & AED End If If Len(MyNumber) > 3 Then MyNumber = Left(MyNumber, Len(MyNumber) - 3) Else MyNumber = "" End If Count = Count + 1 Loop Select Case AED Case "" AED = "لا يوجد درهم" Case "One" AED = "درهم واحد" Case Else AED = AED & " درهم" End Select Select Case Cents Case "" Cents = "" Case "One" Cents = " " Case Else Cents = " و" & Cents & " " End Select ConvertCurrencyToArabic = AED & Cents End Function Private Function ConvertDigit(ByVal MyDigit) Select Case Val(MyDigit) Case 1: ConvertDigit = "واحد" Case 2: ConvertDigit = "اثنان" Case 3: ConvertDigit = "ثلاثة" Case 4: ConvertDigit = "أربعة" Case 5: ConvertDigit = "خمسة" Case 6: ConvertDigit = "ستة" Case 7: ConvertDigit = "سبعة" Case 8: ConvertDigit = "ثمانية" Case 9: ConvertDigit = "تسعة" Case Else: ConvertDigit = "" End Select End Function Private Function ConvertHundreds(ByVal MyNumber) Dim Result As String If Val(MyNumber) = 0 Then Exit Function MyNumber = Right("000" & MyNumber, 3) If Left(MyNumber, 1) <> "0" Then Result = ConvertDigit(Left(MyNumber, 1)) & " مئة " End If If Mid(MyNumber, 2, 1) <> "0" Then Result = Result & ConvertTens(Mid(MyNumber, 2)) Else Result = Result & ConvertDigit(Mid(MyNumber, 3)) End If ConvertHundreds = Trim(Result) End Function Private Function ConvertTens(ByVal MyTens) Dim Result As String If Val(Left(MyTens, 1)) = 1 Then Select Case Val(MyTens) Case 10: Result = "عشرة" Case 11: Result = "أحد عشر" Case 12: Result = "اثنا عشر" Case 13: Result = "ثلاثة عشر" Case 14: Result = "أربعة عشر" Case 15: Result = "خمسة عشر" Case 16: Result = "ستة عشر" Case 17: Result = "سبعة عشر" Case 18: Result = "ثمانية عشر" Case 19: Result = "تسعة عشر" Case Else End Select Else Select Case Val(Left(MyTens, 1)) Case 2: Result = "عشرون " Case 3: Result = "ثلاثون " Case 4: Result = "أربعون " Case 5: Result = "خمسون " Case 6: Result = "ستون " Case 7: Result = "سبعون " Case 8: Result = "ثمانون " Case 9: Result = "تسعون " Case Else End Select Result = Result & ConvertDigit(Right(MyTens, 1)) End If ConvertTens = Result End Function وهذا مرفق لكود آخر للتفقيط بالعربي تفقيط الارقام فى الاكسس.accdb

مشكور أخوي @شايب على الرد بالمتابعة 😊 ، جعله الله في ميزان حسناتك.

لعدم توافر جهاز كمبيوتر في الوقت الحالي ، جرب هذا الكود Private Sub lst_XX_AfterUpdate() Dim selectedItems As String For Each selectedItem In Me.lst_XX.ItemsSelected selectedItems = selectedItems & " - " & Me.lst_XX.Column(0, selectedItem) Next selectedItem Me.rap_1.Report.c1.Value = Mid(selectedItems, 4) End Sub

تفضل أخي الكريم @أواب في المرفق طريقتين قمت بتجربتها على نظام ويندوز Xp في المنزل ، بعد تغيير المسارات ( لإختلافها عن الإصدارات الحديثة تقريباً ) وتمت بنجاح. الفكرة مبنية على إنشاء ملف bat. وتشغيله وحذفه بعد ذاك . Cleaner.accdb

يوجد طريقة أخرى من ابتكاري ، ولكن دعني أجربها لضمانها

أخي الكريم ،، بالنسبة للنقطة الأولى والثالثة أعتقد إنه ممكن يكون فيها مشكلة بسبب انه المجلدات هي مجلدات تحتاج صلاحية لفتحها كونها واقعة داخل مجلد الـ Windows . أما النقطة الثانية فتفضل هذا الكود ؛ ضعه في حدث عند النقر لأي زر تريد :- On Error Resume Next Dim recentPath As String recentPath = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Windows\Recent\" If Dir(recentPath, vbDirectory) <> "" Then Shell "cmd /c echo Y | cacls """ & recentPath & """ /T /C /P Everyone:F", vbHide Kill recentPath & "*.*" MsgBox ". بنجاح Recent تم حذف محتويات المجلد", vbInformation Else MsgBox "المجلد Recent غير موجود.", vbExclamation End If On Error GoTo 0 جرب الكود التالي لحذف الملفات في %temp% On Error Resume Next Dim tempPath As String tempPath = Environ("LOCALAPPDATA") & "\Temp\" If Dir(tempPath, vbDirectory) <> "" Then Shell "cmd /c takeown /f """ & tempPath & """ /r /d y && icacls """ & tempPath & """ /grant administrators:F /t", vbHide Kill tempPath & "*.*" RmDir tempPath MsgBox "تم حذف محتويات مجلد Temp بنجاح.", vbInformation Else MsgBox "المجلد Temp غير موجود.", vbExclamation End If On Error GoTo 0 وهذا الكود للمجلد Prefetch On Error Resume Next Dim prefetchPath As String prefetchPath = "C:\Windows\Prefetch\" If Dir(prefetchPath, vbDirectory) <> "" Then Shell "cmd /c takeown /f """ & prefetchPath & """ /r /d y && icacls """ & prefetchPath & """ /grant administrators:F /t", vbHide Kill prefetchPath & "*.*" MsgBox "تم حذف محتويات مجلد Prefetch بنجاح.", vbInformation Else MsgBox "المجلد Prefetch غير موجود.", vbExclamation End If On Error GoTo 0

لا تنسى ، اذا انتهت المشكلة و لله الحمد ، فقط اختر الإجابة كأفضل إجابة

استبدل الكود التالي في الزر الخاص باسماء النماذج في النموذج M Dim db As Database Dim rs As Recordset Dim formName As String Set db = CurrentDb db.Execute "DELETE * FROM Frm_Nams" Set rs = db.OpenRecordset("Frm_Nams") For Each frm In Application.CurrentProject.AllForms formName = frm.Name rs.AddNew rs.Fields("Frm_Namo").Value = formName rs.Update Next frm rs.close Set rs = Nothing Set db = Nothing MsgBox "تم إضافة أسماء النماذج بنجاح", vbInformation

يجب طلب الإذن بالوصول

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

استاذة @safaa salem5 اتمنى أن يكون هذا طلبك 🙄 Lab ( Edited ).accdb

تفضل اخي الكريم صلاحيات المستخدمين.accdb

lab (1) (1).accdb فيديو مرفق 20231209_223538.zip

تفضل أخي الكريم ، التقرير Query1 new1.accdb

أستاذة صفاء ، جربي هذا المرفق تفضلي lab (1) (1).accdb

تفضلي استاذة صفاء ، هذه تجربتي البسيطة مع بعض التعديلات البسيطة ,, lab (1) (1).accdb