سامي الحداد

السلام عليكم وهذه مشاركتي مع الاساتذة جزاهم الله كل خير =IIf(Len("" & [Strdate] & [Enddate])=0,"No Date",[zofdate]) fmmm3.accdb

هاي ما اعرفها (و عسثق&حشسس) بالنسبة ل tblsecurtytype فهذا عملته لبرنامج ثاني حيث الدخول للبرنامج يتم عن طريق التاكد من المستخدم .

نعم اخوي رعد يضع في كل فورم هذا الكود. Private Sub Form_Open(Cancel As Integer) Call UserPermission(Me, GetUserLoginID()) End Sub وإذا كان الفورم فيه ازرار تريدها ان تكون غير مفعلة تضع باقي الكود فيصبح كالاتي. Private Sub Form_Open(Cancel As Integer) Call UserPermission(Me, GetUserLoginID()) If TempVars!IsFormOpened = 1 Then Exit Sub Else Call DisableButton(Me, GetUserLoginID, Me.cmdSetPermission, هنا تضع اسم الزر مثلا Me.Addnew) End If End Sub حياك الله تستطيع ان تبدا من الجدول نعم فقط لك كمسؤول . ومن ثم عليك إغلاق كل الابواب وعدم السماح بالدخول من الخلف.

اخي واستاذي الحبيب @الحلبي من المحتمل أن تكون المشكلة التي تواجهها متعلقة بالطريقة التي يتم بها التعامل مع النص العربي في الإصدار الأقدم من Office و Windows. في Office 2010 و Windows 7 ، يكون ترميز الأحرف الافتراضي للنص هو ANSI ، والذي قد لا يدعم جميع أحرف Unicode ، بما في ذلك الأحرف العربية. وللتغلب على هذه المشكلة هناك طريقتين الحل الاول هو تغيير ترميز الأحرف الافتراضيه للملفات النصية ، وسوف نغير ترميز الأحرف الافتراضي إلى UTF-8 ساضع الكود هنا للطريقة الاولى جرب ووافيني بالنتيجة. Option Explicit #If Win64 Then Private Declare PtrSafe Function SetFileApisToOEM Lib "kernel32" () As Long Private Declare PtrSafe Function SetFileApisToANSI Lib "kernel32" () As Long #Else Private Declare Function SetFileApisToOEM Lib "kernel32" () As Long Private Declare Function SetFileApisToANSI Lib "kernel32" () As Long #End If Private Sub TreeView1_Click() Dim strFormName As String Dim formsDictionary As New Scripting.Dictionary SetFileApisToANSI System.PrivateProfileString("", "", "") System.PrivateProfileString("", "", "") SetFileApisToOEM System.PrivateProfileString("", "", "") System.PrivateProfileString("", "", "") formsDictionary.Add "بيانات الشركة", "frmCompany" formsDictionary.Add "بيانات مستخدمي النظام", "frmSystemUserData" formsDictionary.Add "كلمات المرور", "frmPassword" formsDictionary.Add "بيانات المطورين", "frmDeveloper" strFormName = TreeView1.SelectedItem.Text If formsDictionary.Exists(strFormName) Then DoCmd.OpenForm formsDictionary(strFormName) Else MsgBox "عذرا هذا النموذج غير موجود", vbExclamation, "تنبيه" End If End Sub عذرا اخي الدكتور محمد لم اجرب الكود لانني لا املك الويندوز 7 والاوفيس 2010 . بانتظار تجربتك. تحياتي

تم حذف السطر الاول من ملف الاكسس بواسطة كود من الاكسس وهذا هو الكود. Sub DeleteFirstRow() Dim xlApp As Excel.Application Set xlApp = New Excel.Application Dim xlWorkbook As Excel.Workbook Set xlWorkbook = xlApp.Workbooks.Open("C:\xxxxx\0125.xls")غير مسار الملف xlWorkbook.Sheets(1).Activate Dim firstRow As Excel.Range Set firstRow = xlApp.ActiveSheet.Range("A1:IV1") firstRow.Delete xlWorkbook.Save xlWorkbook.Close xlApp.Quit End Sub بالتوفيق

بالاضافة لما تفضل به الاساتذة اليك مشاركتي Sub CopyTableStructure() If Not TableExists("tblOld") Then MsgBox "Table 'TblOld' does not exist in the current database." Exit Sub End If Dim strPath As String strPath = CurrentProject.FullName DoCmd.TransferDatabase acImport, "Microsoft Access", strPath, acTable, "tblOld", "TblNew", True End Sub Function TableExists(tblName As String) As Boolean TableExists = (CurrentDb.TableDefs(tblName).Name = tblName) End Function testdate4.mdb

مثل ما تفضل به الاستاذ @ابو البشر والكود له جزاه الله خيرا . انا فقط حذفت السطر الاول من الاكسل حسب طلبك جرب ووافينا بالنتيجة . testdate4.rar

نعم أخي الكريم تفضل Private Sub TreeView1_Click() Dim strFormName As String Dim formsDictionary As New Scripting.Dictionary formsDictionary.ADD "بيانات الشركة", "frmCompany" formsDictionary.ADD "بيانات مستخدمي النظام", "frmSystemUserData" formsDictionary.ADD "كلمات المرور", "frmPassword" formsDictionary.ADD "بيانات المطورين", "frmDeveloper" strFormName = TreeView1.SelectedItem.Text If formsDictionary.Exists(strFormName) Then DoCmd.OpenForm formsDictionary(strFormName) Else MsgBox "عذرا هذا النموذج غير موجود", vbExclamation, "تنبيه" End If End Sub واليك الملف بعد التعديل . المكتبات المطلوبة انظر الصورة بالتوفيق MediaSoft 2.rar

وعليكم السلام تفضل اخي الكريم هذا هو الكود المستخدم لفتح اي فورم عندك Private Sub TreeView1_Click() Dim strFormName As String strFormName = TreeView1.SelectedItem.Text DoCmd.OpenForm strFormName End Sub واليك الملف بعد التعديل لقد اضفت لك كل النماذج . هل هو المطلوب؟ MediaSoft 1.rar

المعذرة اخي الكريم نسيت ان اضيف هذا وهو اسم الزر المراد اخفاءه في الكود. Private Sub Form_Open(Cancel As Integer) Call UserPermission(Me, GetUserLoginID()) If TempVars!IsFormOpened = 1 Then Exit Sub Else Call DisableButton(Me, GetUserLoginID, Me.cmdSetPermission, Me. اسم الزر المراد اخفاءه) End If End Sub

وعليكم السلام أخي الكريم بالنسبة ل All Forms فهي للادمن فقط. اما بالنسبة لزر Disable Button فهو لاخفاء زر معين في نموذج أو من القائمة الرئيسية مثلا : في النموذج لديك مستخدم يستطيع ان يضيف ولكن لا يستطيع ان يحذف وهذا النموذج فيه اضافة وحذف هنا يأتي زر الاخفاء بحيث هذا المستخدم لا يستطيع ان يحذف, فقط يستطيع الاضافة. لهذا اضفت هذه الخاصية لتعطيل زر معين. أدخل باسم المستخدم B على ما اعتقد سترى ان زر صفحة الادمن غير مفعلة. وهناك بعض الازرار مفعلة ولكن ليس لدية الصلاحية لفتح النموذج. واليك كيفية عمل ذلك.. استدعاء وظيفة User Permission في كل نموذج ضمن الحدث Form_Open Private Sub Form_Open(Cancel As Integer) Call UserPermission(Me, GetUserLoginID()) End Sub -------------------------------------------------------------------------- إذا كان لديك بعض الأزرار لتعطيلها للمستخدم العادي ، فاستدع الوظيفة "UserPermission" و "DisableButton" ضمن حدث Form_Open Private Sub Form_Open(Cancel As Integer) Call UserPermission(Me, GetUserLoginID()) If TempVars!IsFormOpened = 1 Then Exit Sub Else Call DisableButton(Me, GetUserLoginID, Me.cmdSetPermission) End If End Sub يجب إضافة كل النماذج في جدول tbl_Forms ضروري. اتمنى ان اكون قد وفقت في الشرح وبخدمتكم. تحياتي

أخي الكريم @العبيدي رعد الملف الذي ارفقته لك فيه كل ما طلبت يمكن جنابكم ما فتحتم الملف. سجل الدخول بإسم Sami وكلمة المرور 555 ادخل على صلاحيات المستخدمين واختار المستخدم من القائمة وسترى النماذج والتي بامكانك تغيرها على حسب النماذج التي في برنامجك ومنها تستطيع ان تعطي الصلاحيات لكل نموذج . إذا الموضوع صعب عليك ارفق برنامجك هنا وساعمل لك الصلاحيات المطلوبة لكل مستخدم .. الموضع سهل جدا وما فيه اي تعقيد. غير المستخدم سامي واجعله الادمن وغير اسماء المستخدمين واعطيهم الصلاحيات الطلوبه. بانتظار ردك. تحياتي

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

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

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

الملف المرفق العملاء 2 هو طلبك اما الصورة فهذا الملف لم ارفقة هنا مجرد توضيح فقط لعمل تغير طريقة عمل البحث طبعا هذا مجرد رأي .

السلام عليكم تفضل أخي الكريم تم التعديل على ملفك في المشاركة الاولى . هل هو المطلوب وافنا بالنتيجة. انا لي رأي اخر في عملية البحث انظر للصوره ان احببت سارفق لك الملف . بالتوفيق العملاء 2.accdb

اخي العزيز ابو جودي إنّا لله وإنّا إليه راجعون رحمه الله وآجرك. حسن الله عزاكم فيه، وعظَّم لكم الأجور، وألهمكم التسليم للمقدور، نقول جميعاً كما قال الصابرون إنّا لله وإنّا إليه راجعون.٠

أخي حمدي جرب الكود الان سبب تكرار الارسال هو هذه الاسطر Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & " || *" & Me.myname.Value & "*" & " || *" & Me.msg.Value & "*" & " || " & Me.attach.Value & "* || " & "المرسل : *" & Me.sub & "*" & "& app_sent =0" Pause 3 SendKeys "{TAB}" Call SendKeys("~", True) اليك الكود كاملا بعد التعديل Dim IEE As Object Dim SQL As String Dim fso As Object Dim fldrname As String Dim fldrpath As String Dim Mytoname As String Dim stname1 As String Dim rs As DAO.Recordset Set rs = CurrentDb.OpenRecordset("email") rs.MoveLast: rs.MoveFirst Dim IE As Object DoCmd.RunCommand acCmdSaveRecord If Nz(DCount("SelectRow", "email", "SelectRow = 'R'"), 0) = 0 Then MsgBox "يجب اختيار المرسل اليه اولا", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If Me.myname.SetFocus If IsNull(Me.msg) Then MsgBox "لايوجد نص للارسال", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If If IsNull([email1].Form![phone_number]) Then MsgBox "لايوجد رقم هاتف", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If DoCmd.OpenForm "email4", acNormal 'Set IE = CreateObject("InternetExplorer.Application") 'IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & " || *" & Me.myname.Value & "*" & " || *" & Me.msg.Value & "*" & " || *" & Me.attach.Value & "* || " & "المرسل : *" & Me.sub & "*" & "& app_sent =0" 'Pause 3 'SendKeys "{TAB}" 'Call SendKeys("~", True) If Not rs.BOF And Not rs.EOF Then rs.MoveFirst While (Not rs.EOF) If rs.Fields("SelectRow") = "R" Then Mytoname = rs.Fields(0) stname1 = rs.Fields("toname") Dim strMSG As String strMSG = " || *" & Me.myname.Value & "*" & " || *" & Me.msg.Value & "*" & " || *" & Me.attach.Value & "* || " & "المرسل : *" & Me.sub strMSG = ReplaceLineBreaks(strMSG) Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & strMSG & "*" & "& app_sent =0" Pause 3 Set IE = Nothing Set IEE = Nothing Dim objClipboard As Object Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objClipboard.SetText (MyFile) objClipboard.PutInClipboard Pause 5 SendKeys "+{TAB}" Call SendKeys("{Enter}", True) Pause 2 Call SendKeys("{Enter}", True) Pause 5 Langauge ELanguage.en Pause 5 Call SendKeys("^v", True) Call SendKeys("{Enter}", True) Pause 5 Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objClipboard.SetText ReplaceLineBreaks(Me.msg) objClipboard.PutInClipboard Pause 1 Call SendKeys("^v", True) Pause 5 Call SendKeys("{Enter}", True) Pause 1 DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE email SET[SendStuts]='تم الارسال' , SelectRow ='T' WHERE [ID]=" & Mytoname DoCmd.SetWarnings True SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" End If rs.MoveNext Wend End If rs.Close Set rs = Nothing MsgBox "تم الارسال" End Sub ' =================================(وهذه دالة لجعل الواتسأب يقبل السطور الجديدة في النص المرسل) Function ReplaceLineBreaks(text As String) As String ReplaceLineBreaks = Replace(text, vbCrLf, " %0a ") ReplaceLineBreaks = Replace(ReplaceLineBreaks, Chr(10), " %0a ") ReplaceLineBreaks = Replace(ReplaceLineBreaks, Chr(13), " %0a ") End Function المعذرة أخي لم أجرب الكود على البرنامج وذلك لانشغالي . جرب الكود هذا وان شاءالله عندما يسمح الوقت ساكون معكم . بالتوفيق

وعليكم السلام ورحمة الله وبركاتة مشاركة مع الاستاذ خليفة جزاه الله خيرا تفضل اخي الكريم لقد عملت لك المطلوب وان شاءالله يكون حسب طلبك هذا ما سمح بة وفتي . المستخدمين كالتالي الاسم: علي كلمة المرور 123 الاسم: رضوان كلمة المرور 123 الاسم: سامي كلمة المرور 555 سامي لديه كل الصلاحيات اما علي فله بعض الصلاحيات وبالنسبة لرضوان ليس لديه اي صلاحية حاول ان تتعرف على كيفية العمل .. أسف جدا لن استطيع الشرح مع الصور الان بالتوفيق ساغيب عن المنتدى لبضعة ايام بسبب السفر والعمل. PasswordLogin_RC4_v5.4.accdb

وعليكم السلام مشاركة مع الاساتذة تفضل التعديل =IIf(Format([التاريخ],"yyyy/mm")<Format(Now(),"yyyy/mm") And [تم الدفع]=0,"قسط متأخر",IIf(Format([التاريخ],"yyyy/mm")>Format(Now(),"yyyy/mm") And [تم الدفع]=0,"لم يحن وقت السداد",IIf(Format([التاريخ],"yyyy/mm")=Format(Now(),"yyyy/mm") And [تم الدفع]=0,"جاهز للسداد"," تم السداد"))) 182.accdb

وعليكم السلام اخي الكريم جرب التعديل ووافنا بالنتيجة تحياتي Database3.accdb

تفضل اخي الكريم بالتوفيق Database2.accdb

وعليكم السلام اخي الكريم بما انك لم ترفق ملفك اليك هذا الكود عسى ان يكون هو طلبك ... Dim strSQL As String Dim i As Integer Dim Msg As String Dim NewID As String If NewData = "" Then Exit Sub NewID = UCase(Trim(Left(NewData, 3))) Msg = "'" & NewData & "' غير موجود حاليًا في قائمة الأنواع." & vbCr & vbCr Msg = Msg & "هل تريد إنشاء سجل نوع جديد?" i = MsgBox(Msg, vbQuestion + vbYesNo, "نوع غير معروف...") If i = vbYes Then strSQL = "Insert Into [Your Table Here] ([Your ComboBox],[FieldName]) values ('" & NewID & "','" & NewData & "')" CurrentDb.Execute strSQL, dbFailOnError Response = acDataErrAdded Else Response = acDataErrContinue End If غير الاسماء حسب مسميات الحقول والقائمة المنسدلة والجدول لديك تحياتي

السلام عليكم لقد عملت برنامج خاص للبحث في جميع حقول الجداول ووضعته في هذه المشاركة جرب ووافيني بالنتيجة ساضع البرنامج هنا مرة ثانية ربما يستفاد منة باقي الاعضاء تحياتي Search All Tables 2020 New.accdb