نجوم المشاركات

خلي الكود يفتحلك مستعرض الملفات وتختار منه الملف بدل ما هو مكتوب في الكود أخوي طلال 🙂

تفضل رابط الإصدار الرابع وبه التحكم في الصور

يمكن الوصول للنتيجة بدون استخدام دوال تجميع المجال وخصوصا ان الخبراء ينصحون بتجنب استخدامها في الاستعلام وللوصول للنتيجة عن طريق العلاقات النتيجة في استعلام q_1 EXAMPLE2000.mdb

تفضل تقسيم الى مجموعات.accdb.mdb

وعليكم السلام ورحمة الله وبركاته 🙂 استغن عن الأكسبلورر بهذا الكود ( ضعه في وحدة نمطية ) واستخمه كالتالي : Option Compare Database Option Explicit Enum AttacmentsType Image = 1 Sticker = 2 Document = 3 End Enum #If VBA7 Or Win64 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer #Else Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer #End If Private Const VK_NUMLOCK = &H90 Public Sub SendToWhatsApp(txtPhone As String, txtMSG As String, Optional txtAttchmentPath As String = "", Optional AttachmentType As AttacmentsType = Image) '---------------------------------------(التحقق من اكتمال البيانات) If Len(txtMSG & "") = 0 Then MsgBox "يرجى كتابة الرسالة": Exit Sub If txtAttchmentPath <> "" Then If Len(Dir(txtAttchmentPath, vbDirectory)) = 0 Then MsgBox "المرفق غير موجود .. تأكد من الرابط": Exit Sub End If txtMSG = Replace(txtMSG, vbCrLf, " %0a ") txtMSG = Replace(txtMSG, Chr(10), " %0a ") txtMSG = Replace(txtMSG, Chr(13), " %0a ") '---------------------------------------(بداية الإرسال) Dim Path As String Path = "whatsapp://send?phone=" & txtPhone & "&text=" & txtMSG CreateObject("Shell.Application").Namespace(0).ParseName(Path).InvokeVerb "Open" ' إرسال الرسالة Sleep 2000 SendKeys "~" Sleep 500 SendKeys "~" ' إرسال المرفق إن وجد If txtAttchmentPath <> "" Then SendKeys "+{TAB}" SendKeys "~" Sleep 1000 Select Case AttachmentType Case Is = 1 ' صورة SendKeys "{UP}" ' لإرسال الصور ' SendKeys "{UP}" ' لإرسال الملصقات ' SendKeys "{UP}" ' لفتح الكاميرة ' SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال Case Is = 2 ' ملصق SendKeys "{UP}" ' لإرسال الصور SendKeys "{UP}" ' لإرسال الملصقات ' SendKeys "{UP}" ' لفتح الكاميرة ' SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال Case Is = 3 ' مستند SendKeys "{UP}" ' لإرسال الصور SendKeys "{UP}" ' لإرسال الملصقات SendKeys "{UP}" ' لفتح الكاميرة SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال End Select SendKeys "~" Sleep 1000 SendKeys txtAttchmentPath, True SendKeys "~" Sleep 2000 SendKeys "~" Sleep 1000 SendKeys "~" End If 'If NumLock is off, turn it on If GetKeyState(VK_NUMLOCK) = 0 Then 'Send NumLock key press to turn it on SendKeys "{NUMLOCK}" End If '---------------------------------------( إعادة التركيز لبرنامج الأكسس) SetForegroundWindow Application.hWndAccessApp MsgBox " تم الإرســــــال ", vbMsgBoxRight, "" End Sub Sub test() ' لا تنس إضافة كود الدولة SendToWhatsApp "96899445566", "السلام عليكم", "C:\Users\User\Desktop\123.jpg", Image End Sub طريقة الاستخدام : SendToWhatsApp "96899445566", "السلام عليكم", "C:\Users\User\Desktop\123.jpg", Image راجع :

شكرا على مساعدتى اخوتى الكرام

حفظك الله يالغالي في مثال لي لأستاذنا الغالي ابو إبراهيم راح ادور عليه ارفقه قريب من مثالك باذن الله ارفق في اقرب فرصه تحياتي

في ما بعد قد يمكنني فعل ذلك فأنا ما زلت اتعلم اخي الكريم و هذه هي حدودي في الوقت الحالي

تعديل للكود السابق: Private Sub Command1_Click() Dim strDB As String On Error Resume Next Set appAccess = CreateObject("Access.Application") Err.Clear strDB = CurrentProject.Path & "\FolderN\" & Me.n_Folder & "\" & Me.program & ".accdb" appAccess.OpenCurrentDatabase strDB 'If Err.Number <> 0 Then If Err.Number = 7866 Then strDB = CurrentProject.Path & "\FolderN\" & Me.n_Folder & "\" & Me.program & ".mdb" appAccess.OpenCurrentDatabase strDB End If appAccess.DoCmd.OpenForm Me.form_open appAccess.Visible = True Set appAccess = Nothing End Sub

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

حدثت مشكلة عندي في الملف ولم استطع ارفاقة بدل الجملة عندك بهذه DLookUp("[Material Type]";"[Group]";"[Group no] =" & [No] & "")

وعليكم السلام ورحمه الله وبركاته اتفضل شوف الرابط ادناه

السلام عليكم ورحمة الله وبركاته يامرحبا تراحيب المطر يسعد صباحك أبو احمد نعم هذا ما اردته بارك الله فيك ونفع بعلمك ورزقك حسن الخاتمة والشكر موصول للأخ الطحان

جرب هذا الكود: Private Sub Command1_Click() Dim strDB As String strDB = CurrentProject.Path & "\FolderN\" & Me.n_Folder & "\" & Me.program & ".accdb" Set appAccess = CreateObject("Access.Application") appAccess.OpenCurrentDatabase strDB appAccess.DoCmd.OpenForm Me.form_open appAccess.Visible = True Set appAccess = Nothing End Sub

تم عمل دالة للحصول على رقم ترتيب السجل ومن ثم الحصول على رقم المجموعة من خلال الإستعلام. اسم الاستعلام Query3 يعاب على الدالة أنها بطيئة لأنها تقوم بفتح الجدول بعدد السجلات ولكنها تغنيكم عن تخزين/حفظ قيمة الترتيب والمجموعة. إذا عجبتكم الفكرة غدا بإذن الله أفكر معكم في الخطوة الثانية. والاستعلام Query4 لعرض أول وآخر رقم لكل مجموعة. تقسيم الى مجموعات.accdb_02.mdb

أيضا جرب هذا الكود: Private Sub Form_Current() Dim Msg As String If IsNull(Me.adadno) Then Exit Sub 'If Me.adadno <> DLookup("[A]", "[Database]", "[crn] ='" & Me.adadno & "'") Then 'إذا كان الحقل نصي If Not IsNull(DLookup("[crn]", "[Database]", "[crn]=" & Me.adadno)) Then Msg = "القيمة " & Me.adadno & " موجودة هل تريد تكرارها؟" Beep If vbYes = MsgBox(Msg, vbQuestion + vbYesNo + vbDefaultButton2, "تننبيه") Then Exit Sub Else Undo 'Exit Sub End If End If End Sub

تفضل تقسيم الى مجموعات.accdb

حقيقة لم افهم المقصود بشكل جيد هلا تكرمت بمزيد من التوضيح مثل ماذا تعني بالتقسيم الي مجموعات واين تريد ان يظهر هذا التقسيم في جدول ام تقرير وماذا تعني بتغير المجموعات وعلي اي اساس يتم التغير اعتذر لعدم افادتك بالوقت الحالي، ولكن كما تعلم فان فهم السؤال شطر الجواب كما يقال

تفضل هذا التعديل لكن لن يعمل على متصفح الاكسس بشكل مباشر و ضعت لك ازرار لعرض البحث على متصفح الانترنت الافتراضي لديك web-البحث.accdb

السلام عليكم تم تصويب الكود حسب الطلب... بن علية حاجي بيان ناجح 6.xlsm

اخواني اقدم لكم هذا البرنامج الرائع وهو من تصميم استاذنا محمد عبادي جزاه الله الف خير وهذا البرنامج يضهر لنا جزء من الامكانيات الرائعه للاكسس حيث انه مصمم بالاكسس ويقوم بعمل صلاحيات مستخدمين لبرنامجك فلا تحتاج نسخ كودات او انشاء نماذج وما الى ذلك واليكم شرحه بالصور بعد فتح البرنامج سيضهر لكم بالشكل الاتي الخطوة الثانية الخطوة الثالثة الخطوة الرابعة والاخيرة والبرنامج ستجدونة في المرفقات ولم يتبقى شيئ سوى الدعاء لصاحب البرنامج ________________________________________________________________________________________.rar