Foksh

ارسل المرفق اخي الكريم للمساعدة ، وسأدلك على الخطأ ان شاء الله حسب الكود في الملف

قد يكون أحد الأسباب اختلاف نواة النسخة التي لديك عن النسخة التي حفظ منها الملف ( 64 بت و 32 بت ) أو تأكد من اعدادات اللغة العربية في كنترول بانال ، مرفق صورة توضيحية من داخل نظام ويندوز 10 .

DbSearch.accdb بعد إذن أستاذنا ومعلمي @ابوخليل تفضل أخي @مالك درويش ابو تيمور ، هذا طلبك بدون استعلامات , البحث الأول في الجدول عن طريق الرقم والبحث الثاني يبحث في النتائج عن الصف والبحث الثالث يبحث في نتائج الفلترة الثانية عن الاسم DbSearch.accdb

السلام عليكم ، قمت بتجربة الأكواد ولكنها لم تعمل , اعتذر

شوف أخي الكريم ، لا أعلم ما الغاية من فكرتك ، ولك وجدت لك كود في موقع أجنبي لا أعلم إن كان يعمل كما ترغب أم لا . Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long Private Const WM_SETFOCUS As Long = &H7 Private Const EM_SETSEL As Long = &HB1 Private Sub YourForm_KeyDown(KeyCode As Integer, Shift As Integer) If Shift = acCtrlMask And KeyCode = vbKeyF Then ' افتح مربع البحث والاستبدال DoCmd.RunCommand acCmdFind ' تحديد التبويب ، طبعاً هنا تبويب البحث Dim tabToSelect As Long tabToSelect = 0 ' تبويب البحث ' العثور على معرف نافذة مربع الحوار Dim hwndFindReplace As Long hwndFindReplace = FindWindow("#32770", "Find and Replace") ' العثور على معرف التبويب المراد داخل مربع الحوار Dim hwndTabControl As Long hwndTabControl = FindWindowEx(hwndFindReplace, 0, "SysTabControl32", vbNullString) ' التبديل إلى التبويب المطلوب SendMessage hwndTabControl, WM_SETFOCUS, 0, 0 SendMessage hwndTabControl, TCM_SETCURSEL, tabToSelect, 0 ' إلغاء تبويب الاستبدال Dim hwndReplaceText As Long hwndReplaceText = GetDlgItem(hwndFindReplace, &H461) SendMessage hwndReplaceText, EM_SETSEL, 0, -1 End If End Sub سأقوم بتجربته غداً إن شاء الله لعدم توافر جهاز كمبيوتر في الوقت الحالي 😊 أيضاً كإضافة ، جرب هذا الكود الذي يقوم على تعطيل خيار استبدال بـ في مربع البحث. Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long Private Declare PtrSafe Function EnableWindow Lib "user32" (ByVal hWnd As Long, ByVal bEnable As Long) As Long Private Const WM_SETFOCUS As Long = &H7 Private Sub YourForm_KeyDown(KeyCode As Integer, Shift As Integer) If Shift = acCtrlMask And KeyCode = vbKeyF Then ' افتح مربع البحث والاستبدال DoCmd.RunCommand acCmdFind ' العثور على معرف نافذة مربع الحوار Dim hwndFindReplace As Long hwndFindReplace = FindWindow("#32770", "Find and Replace") ' العثور على معرف التبويب "استبدل ب" Dim hwndReplaceTab As Long hwndReplaceTab = FindWindowEx(hwndFindReplace, 0, "SysTabControl32", vbNullString) ' تعطيل خيار "استبدل ب" Dim hwndReplaceOption As Long hwndReplaceOption = GetDlgItem(hwndFindReplace, &H471) ' يمكن تغيير القيمة حسب إصدار Access EnableWindow hwndReplaceOption, False ' العودة إلى نافذة البحث EnableWindow hwndReplaceTab, True SendMessage hwndReplaceTab, WM_SETFOCUS, 0, 0 End If End Sub تركت لك الشرح في الأكواد لتسهيل فهم الكود ، وأيضاً سأقوم بتجربته غداً إن كان في العمر بقية إن شاء الله.

أعتقد مقصد أخونا أنه يريد التعديل على مربع البحث والإستبدال في آكسيس الناتج عن ضغط المفاتيح f+ctrl

أتمنى أن يكون هذا طلبك Private Sub reference_LostFocus() If Not IsEmpty(Me.reference.Value) Then Dim inputText As String Dim i As Integer Dim currentChar As String Dim currentNumber As String Dim isNumberStarted As Boolean Dim numbersFound As Integer Dim hasDecimal As Boolean inputText = Replace(Me.reference.Value, "(", "") inputText = Replace(inputText, ")", "") currentNumber = "" isNumberStarted = False numbersFound = 0 hasDecimal = False For i = 1 To Len(inputText) currentChar = Mid(inputText, i, 1) If IsNumeric(currentChar) Or currentChar = "." Then If currentChar = "." Then If hasDecimal Then MsgBox "Error: Invalid numeric format" Exit Sub Else hasDecimal = True End If End If currentNumber = currentNumber & currentChar isNumberStarted = True ElseIf isNumberStarted Then numbersFound = numbersFound + 1 If numbersFound = 1 Then Me.low.Value = currentNumber ElseIf numbersFound = 2 Then Me.high.Value = currentNumber Exit For End If currentNumber = "" isNumberStarted = False hasDecimal = False End If Next i If numbersFound = 1 Then Me.high.Value = currentNumber End If If Len(Me.low.Value) = 0 Or Len(Me.high.Value) = 0 Then MsgBox "Error: No valid numeric values found" End If End If End Sub هذا الكود يدعم الأقواس أو بدونها ، ويدعم الأرقام الصحيحة والأرقام العشرية ، ويدعم ان كان في الحقل Reference حروف نصية أو لا .

كنت متوقع ، على العموم تفضلي , ومرفق فيديو للتوضيح Private Sub reference_LostFocus() If Not IsEmpty(Me.reference.Value) Then Dim inputText As String Dim i As Integer Dim currentChar As String Dim currentNumber As String Dim isNumberStarted As Boolean Dim numbersFound As Integer Dim hasDecimal As Boolean inputText = Me.reference.Value currentNumber = "" isNumberStarted = False numbersFound = 0 hasDecimal = False For i = 1 To Len(inputText) currentChar = Mid(inputText, i, 1) If IsNumeric(currentChar) Or currentChar = "." Then If currentChar = "." Then If hasDecimal Then MsgBox "Error: Invalid numeric format" Exit Sub Else hasDecimal = True End If End If currentNumber = currentNumber & currentChar isNumberStarted = True ElseIf isNumberStarted Then numbersFound = numbersFound + 1 If numbersFound = 1 Then Me.low.Value = currentNumber ElseIf numbersFound = 2 Then Me.high.Value = currentNumber Exit For End If currentNumber = "" isNumberStarted = False hasDecimal = False End If Next i If Len(Me.low.Value) = 0 Or Len(Me.high.Value) = 0 Then MsgBox "Error: No valid numeric values found" End If End If End Sub 2023_12_12_210437.zip

أخت @safaa salem5 ، تفضلي هذا التعديل الأخير على الكود ، في Reference Private Sub reference_LostFocus() If Not IsEmpty(Me.reference.Value) Then Dim inputText As String Dim i As Integer Dim currentChar As String Dim currentNumber As String Dim isNumberStarted As Boolean Dim numbersFound As Integer inputText = Me.reference.Value currentNumber = "" isNumberStarted = False numbersFound = 0 For i = 1 To Len(inputText) currentChar = Mid(inputText, i, 1) If IsNumeric(currentChar) Then currentNumber = currentNumber & currentChar isNumberStarted = True ElseIf isNumberStarted Then numbersFound = numbersFound + 1 If numbersFound = 1 Then Me.low.Value = currentNumber ElseIf numbersFound = 2 Then Me.high.Value = currentNumber Exit For End If currentNumber = "" isNumberStarted = False End If Next i If Len(Me.low.Value) = 0 Or Len(Me.high.Value) = 0 Then MsgBox "Error: No valid numeric values found" End If End If End Sub طبعاً هذا الكود بالإفتراض أن القيم الرقمية هي أرقام صحيحة وليست كسرية !

قد يختلف المسار عند البعض ، فمثلاً عندي ويندوز 10 و أوفيس 2016 Folder Pathe :- C:\Program Files\Microsoft Office\root\Office16 GRAPH File Path :- "C:\Program Files\Microsoft Office\root\Office16\GRAPH.EXE"

اخي الكريم استعمل خاصية البحث في المنتدى ، ستجد الكثير من المواضيع التي تفيدك . على العموم ، في هذه مشاركة للأستاذ @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