Foksh

أخي الكريم ، يجب ان تكون الصيغة التي تم حفظ المشروع فيها Accde وليس Accdb كما في الصورة احفظ المشروع هكذا Make ACCDE وطبعاً ، لازم تعمل باسوورد على الـ VBA

نقاط مهمة جدا ذكرها أستاذنا @شايب ، وكنت قد فكرت بها أثناء الرد ، ولكني توجهت لطلب الأخ فقط 😊

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

ما اتضح لي من سياق الطلب ، هو تصدير من اكسيس الى إكسيل ، على العموم بالنسبة لهذه النقطة: ستجد في ملف الآكسيل حتى لو كان فارغاً وليس به اي بيانات ، ستجد ورقة جديدة باسم الجدول في الآكسيس وفيها ستجد البيانات التي تم تصديرها ، إلا إنك تريد العكس وهو الإستيراد 😊

يعني استيراد من ملف اكسيل إلى جدول في آكسيس ، 😅

@ابو جودي الحمد لله على السلامة ، وعودة طيبة بعد الغياب الطويل ، وأسأل الله ان تكون في تمام الصحة والعافية .

اخي الكريم تأكد انه ما عندك مشكلة بالأوفيس ، لإنه تمت تجربته على آكسيس ٢٠١٦ ويعمل بكفاءة ، اخي انت تريد تصدير من آكسيس الى إكسيل ، صح ؟ 🥴

Access Export.accdb

مقصد كلامك أنه عندما تقوم بكتابة مثلاً حرف م أن يكمل لك الاسماء التي تبدأ بحرف الـ م ؟؟

معلومة جميلة من المعلم @Moosak ، جزاك الله خيراً

تفضل أخي الكريم ,, ضع هذا الكود في حدث عند النقر وأعطيني النتيجة Dim dlg As FileDialog Dim fileName As String Set dlg = Application.FileDialog(msoFileDialogFilePicker) dlg.Filters.Add "ملفات Excel", "*.xls; *.xlsx" If dlg.Show = -1 Then fileName = dlg.SelectedItems(1) DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "YourQueryOrTableName", fileName, True MsgBox "تم تصدير البيانات بنجاح إلى: " & fileName, vbInformation Else MsgBox "تم الغاء اختيار الملف.", vbExclamation End If * استبدل YourQueryOrTableName باسم جدولك

تفضل أخي @jo_2010 افتح التقرير DAYS_DOC ، طبعاً التنسيق مسؤوليتك عيادات مريم.accdb أما هذا الشرط فأنا أعتذر وأترك المجال لأصحاب الخبرات ومعلميني الأفاضل .

أخي الكريم ، تأكد من اصدار الملف في المكتبة إن كان لديك Outlook قمت بتثبيت الـ Outlook وفتح الملف بدون ظهور الرسالة ، مع العلم أن أكسيس عندي 2016 / 64 بت * أعتقد أنه يجب إعداد الـ Outlook لهذه الخدمة

أخي الكريم ، تأكد من اصدار الملف في المكتبة إن كان لديك Outlook قمت بتثبيت الـ Outlook وفتح الملف بدون ظهور الرسالة ، مع العلم أن أكسيس عندي 2016 / 64 بت

ما هي نسخة الأوفيس لديك ، 64 أو 32 ؟ حسب الملف ، يجب ان تكون قد قمت بتثبيت Outlook في جهازك ، لإنه مطلوب ملف في مكتبة الـ vba تعتمد عليه

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

قد يكون أحد الأسباب اختلاف نواة النسخة التي لديك عن النسخة التي حفظ منها الملف ( 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"