اتفضل
بس نصيحة لوجه الله لا تستخدم الأحرف العربية فى تسمية الحقول والكائنات والعناصر وكذلك لا تحاول استخدامها فى محرر الأكواد لسببين
1- عند استخدامها تتداخل الأكواد وقد تعجز عن التعديل عليها مستقبلا وقد تعجز اساسا عن فهم الكود وبناء الجمل من النظر الى الترتيب المعكوس بسبب الأحرف العربية كما يحدث فى دوال المجال على سبيل المثال وليس الحصر
2- عند محاولة استخدام قاعدة البيانات فى ويندوز لم يتم اعداد اللغة الاقليمية الى اللغة العربية له يحدث خطأ ولا يتم تنفيذ الاوامر البرمجية وبالتالى لن تعمل القاعدة وقد لا تعرف من الرسالة أن اللغة العربية هى المشكلة
ملاحظة وضعت عدد اتنين زر امر لزيادة ونقصان الكمية افضل من زيادتها بالضغط على اسم الصنف كما تريد
ولكن ان اردت ذلك لا يوجد عندى ادنى مشكلة
أنا وضعت أفضل تصور من وجهة نظرى آخذا فى الاعتبار كل ما خطر على بالى لإضفاء المرونة واليسر فى التعامل
واخيرا اتفضل قاعدتك بعد التعديل ان شاء الله تجد ما تريد
مثال إدراج الأصناف فى الفاتورة بشروط_( v 2 ).accdb
طيب وبما انك وصلت للحل
لتعم الفائدة
Dim db As DAO.Database
Dim rst As DAO.Recordset
' Open the database
Set db = DBEngine.OpenDatabase(".\officenaDB.mdb")
' Open the Recordset
Set rst = db.OpenRecordset ("SELECT * FROM Customers WHERE CustomerId = 'officena'", dbOpenDynaset)
استخدم الكود الاتى
Private Sub Form_Close()
On Error GoTo QuitApp_Err
DoCmd.Quit acSave
QuitApp_Exit:
Exit Sub
QuitApp_Err:
MsgBox Error$
Resume QuitApp_Exit
End Sub
طيب وليه كل ده
اضف الحقول الاتية فى الجدول الرئيسي
منقطع - مفصول - موقوف
على ان تكون من النوع Yes/No
منقطع = yes
مفصول = yes
موقوف = yes
وسوى استعلام ومرر اليه القيمى المعلمه ليقوم بعمل الفلتر تبعا للحالة الممرة
او الابسط
سوى عدد استعلامات تبعا لعدد الحالات وفى المعيار اختر حقل الفتر yes تبعا لكل حالة
الموضوع ابسط من البساطة
لا يمكن عمل ذلك من الاستعلام بطريقة مباشرة
ولكن يمكن اذا كان الكود الاتى فى وحدة نمطية لتتمكن استدعاء الكود فى زوايا التطبيق المختلفة حتى لو فى استعلام
الروتين المستخدم فى الوخدة النمطية :
Public Function CheckFolder(strFolderPath As String) As Boolean
Dim strIsFolder As String
strFolderPath = strFolderPath
strIsFolder = Dir(strFolderPath, vbDirectory)
If strIsFolder = "" Then CheckFolder = False Else: CheckFolder = True
End Function
الان فى الاستعلام وحسب ما اشرتم فى رأس الموضوع اضف فى حقل جديد السطر الاتى
CheckFolder([folderName])
مع العلم ان حقل الـ folderName فى الاستعلام لابد وان يحتوى على المسار كاملا للمجلد
اتفضل يا سيدى احلام معاليك اوامر يا باش مهندس @Moosak
اى خدمه
يارب تنبسط بس
تعتمد الفكرة على وضع الروتين الاتى فى وحدة نمطية
Public opt As Integer
Public Function MesgBox(ByVal msgText As String, _
Optional ByVal TimeInSeconds As Integer, _
Optional ByVal intButtons = vbDefaultButton1, _
Optional TitleText As String = "WScript") As Integer
On Error GoTo MesgBox_Err
Dim winShell As Object
Set winShell = CreateObject("WScript.Shell")
MesgBox = winShell.PopUp(msgText, TimeInSeconds, TitleText, intButtons)
MesgBox_Exit:
Exit Function
MesgBox_Err:
winShell.PopUp Err & " : " & Err.Description, 0, "MesgBox()", vbCritical
Resume MesgBox_Exit
End Function
ويتم استدعاء الورتين من خلال
opt = MesgBox(Me.n & vbCr & vbCr & " Please wait . . .", 1, vbInformation, "Info")
حيث ان بناء الكود كالاتى
'Syntax: opt = MesgBox(msgTxt,intSeconds,Buttons+Icon+DefaultButton,"Title")
اولا بارك الله فى عمرك وعلمك وعملك وجزاكم كل خير
ثانيا انا اقل طويلب علم ولست مبرمجا على الاطلاق مجرد هاو
ثالثا كنت ابلور فكرة من الامس شبيه بفكرة حضرتك
استخدمت الروتين الاتى فى وحدة نمطية
Function OpenReport(ByRef rptName As String, ByRef qryName As String)
On Error GoTo ErrorHandler
DoCmd.OpenReport rptName, acViewPreview, , , , qryName
procDone:
Exit Function
ErrorHandler:
MsgBox$ Err.Number & ": " & Err.Description
Resume procDone
End Function
على ان يتم استدعاءه بالسطر الاتى
OpenReport("rpt2", "Query2")
نفس فكرة حضرتك
طبعا بسبب الغموض وعدم التوضيح الكافى كنت فى انتظار اضافة المرفق
Chang Record Sources Report VBA(V3).mdb
طيب بعد التمعن فى الفوكيرة اللى فاتت لابد من التطبيق بتلك الالية بعدد 7 استعلامات
الاستعلام النهائى والذى يظهر القيم المكررة هو qryUnionMob
3or2Colume (2).accdb
وهذه فكرتى المتواضعة من خلال وظيفة داخل وحدة نمطية
Function GoExt(strText As String)
Dim strExtractionWord As String: strExtractionWord = Nz(Left([strText], InStr([strText] & "", " ") - 1), strText)
Select Case strExtractionWord
Case Is = strText: GoExt = strText
Case Is = "مصر": GoExt = "جهورية" & " " & strText
Case Is = "العربية": GoExt = "المملكة" & " " & strText
Case Is = "المتحدة": GoExt = "الولايات" & " " & strText
Case Is = "الاردنية": GoExt = "المملكة العربية" & " " & strText
End Select
End Function
يتم استدعاء الوظيفة من خلال
GoExt([text1])
ولا انصح بكتابة الأحرف العربية داخل محرر الاكود
ممكن نستخدم اليونيكود او جدول واستخدام DLookup
ويكون التطبيق كالاتى
Option Compare Database
Option Explicit
#If VBA7 Or Win64 Then
Public Declare PtrSafe Function apiGetSystemMenu Lib "user32" Alias "GetSystemMenu" (ByVal hwnd As Long, ByVal flag As Long) As Long
Public Declare PtrSafe Function apiEnableMenuItem Lib "user32" Alias "EnableMenuItem" (ByVal hMenu As Long, ByVal wIDEnableMenuItem As Long, ByVal wEnable As Long) As Long
#Else
Public Declare Function apiEnableMenuItem Lib "user32" Alias "EnableMenuItem" (ByVal hMenu As Long, ByVal wIDEnableMenuItem As Long, ByVal wEnable As Long) As Long
Public Declare Function apiGetSystemMenu Lib "user32" Alias "GetSystemMenu" (ByVal hWnd As Long, ByVal flag As Long) As Long
#End If
Const MF_BYCOMMAND = &H0&
Const MF_DISABLED = &H2&
Const MF_ENABLED = &H0&
Const MF_GRAYED = &H1&
Const SC_CLOSE = &HF060&
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4
Const SWP_NOMOVE = &H2
Const SWP_FRAMECHANGED = &H20
Const WS_MINIMIZEBOX = &H20000
Const WS_MAXIMIZEBOX = &H10000
Const WS_SYSMENU = &H80000
Public Function EnableDisableControlBoxX(bEnable As Boolean, Optional ByVal lhWndTarget As Long = 0) As Long
On Error GoTo Err_EnableDisableControlBoxX
Dim lhWndMenu As Long
Dim lReturnVal As Long
Dim lAction As Long
lhWndMenu = apiGetSystemMenu(IIf(lhWndTarget = 0, Application.hWndAccessApp, lhWndTarget), False)
If lhWndMenu <> 0 Then
If bEnable Then
lAction = MF_BYCOMMAND Or MF_ENABLED
Else
lAction = MF_BYCOMMAND Or MF_DISABLED Or MF_GRAYED
End If
lReturnVal = apiEnableMenuItem(lhWndMenu, SC_CLOSE, lAction)
End If
EnableDisableControlBoxX = lReturnVal
Exit_EnableDisableControlBoxX:
Exit Function
Err_EnableDisableControlBoxX:
MsgBox "Error:" & Err.Number & vbCrLf & "Description: " & Err.Description
Resume Exit_EnableDisableControlBoxX
End Function
ويمكنك عدم تفعيل زر الاغلاق من خلال
EnableDisableControlBoxX False
ويمكنك الرجوع للوضع الاصلى بإعادة فاعلية زر الاغلاق من
EnableDisableControlBoxX True