سامي الحداد

الله ييارك فيك اخي الكريم.

قد لا يحتوي متغير addPath على مسار ملف صالح. يجب عليك التحقق من أن قيمة addPath هي مسار ملف صالح وأن الملف موجود في هذا الموقع. قد لا يتم تعيين المتغير المحتوي على المجلد بشكل صحيح. يجب عليك التحقق من أن قيمة containsFolder هو مسار المجلد الصحيح الذي يحتوي على الملف المراد إضافته. قد لا يتم تعيين متغير itemToZip بشكل صحيح. يجب عليك التحقق من أن قيمة itemToZip هو اسم الملف الصحيح لإضافته إلى أرشيف zip. قد تكون هناك مشكلة في fSource.items.Item ((i)) مقارنة الاسم في حلقة For. يجب عليك التحقق من صحة المقارنة ومن أنه تم العثور على الملف الصحيح المراد إضافته. هل البرنامج موجود في فولدر واحد ام يندرج تحت عدة فولدرات ؟

جرب هذه الاضافة ووافنا بالنتيجة. Private Sub Form_Load() Me.Image1.SizeMode = fmPictureSizeClip End Sub

من بعد إذن الاستاذ @kkhalifa1960 جزاه الله خيرا الاخوة الكرام تم إضافة صائد الاخطاء لكود الاستاذ @kkhalifa1960 للوقوف على نوع الخطأ . لكل الاخوة الذين صادفتهم مشكلة في البرنامج الرجاء إعادة المحاولة وتحديث برنامج الضغط الوين رار ضروري وإعلامنا بالنتيجة. تحياتي للجميع Sub AddToZip(ByVal zipArchivePath As String, ByVal addPath As String) Dim sh As Object Dim fSource As Object Dim fTarget As Object Dim iSource As Object Dim sourceItem As Object Dim i As Long Set sh = CreateObject("Shell.Application") Set fTarget = sh.Namespace((zipArchivePath)) If fTarget Is Nothing Then createZipFile zipArchivePath Set fTarget = sh.Namespace((zipArchivePath)) If fTarget Is Nothing Then MsgBox "فشل إنشاء ملف مضغوط", vbCritical Exit Sub End If End If Dim containingFolder As String Dim itemToZip As String containingFolder = Left(addPath, InStrRev(addPath, "\")) itemToZip = Mid(addPath, InStrRev(addPath, "\") + 1) Set fSource = sh.Namespace((containingFolder)) For i = 0 To fSource.items.Count - 1 If fSource.items.Item((i)).Name = itemToZip Then Set sourceItem = fSource.items.Item((i)) Exit For End If Next i If sourceItem Is Nothing Then MsgBox "فشل العثور على ملف لإضافة ملف مضغوط ", vbCritical Exit Sub End If On Error Resume Next fTarget.CopyHere sourceItem If Err.Number <> 0 Then MsgBox "فشل في إضافة ملف لضغطه", vbCritical Err.Clear End If On Error GoTo 0 End Sub

جرب هذا التعديل و وافنا بالنتيجة Private Sub mail_DblClick(Cancel As Integer) Dim Msg As String If IsNull(Mail) Or Len(Mail) = 0 Then MsgBox "حقل البريد الإلكتروني فارغ. الرجاء إدخال عنوان البريد الإلكتروني " Exit Sub End If Msg = "<div style='direction:rtl; font-family:Consolas, Courier;'>" & _ " hey " & namecus & "<br>" & _ "</div>" Dim O As Outlook.Application Dim M As Outlook.MailItem Set O = New Outlook.Application Set M = O.CreateItem(olMailItem) With M .BodyFormat = olFormatHTML .HTMLBody = Msg '.Body = txt - if you see olformatplain .To = Mail '.CC="khate9191@gmail.com;khateb91@outlook.com" '.BCC="hateeb991@gmail.com" .Subject = " new mail " & Now() .Display '.send End With Set M = Nothing Set O = Nothing End Sub تحياتي

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

وعليكم السلام تفضل اخي جرب الكود واعلمني بالنتيجة لانني لا استخدم الاوتلوك. Private Sub mail_DblClick(Cancel As Integer) Dim Msg As String If Len(Mail) = 0 Then MsgBox "حقل البريد الإلكتروني فارغ. الرجاء إدخال عنوان البريد الإلكتروني " Exit Sub End If Msg = "<div style='direction:rtl; font-family:Consolas, Courier;'>" & _ " hey " & namecus & "<br>" & _ "</div>" Dim O As Outlook.Application Dim M As Outlook.MailItem Set O = New Outlook.Application Set M = O.CreateItem(olMailItem) With M .BodyFormat = olFormatHTML .HTMLBody = Msg '.Body = txt - if you see olformatplain .To = Mail '.CC="khate9191@gmail.com;khateb91@outlook.com" '.BCC="hateeb991@gmail.com" .Subject = " new mail " & Now() .Display '.send End With Set M = Nothing Set O = Nothing End Sub تحياتي

السلام عليكم بالاضافة لما تفضل بة اساتذتي الكرام جرب تغير هذه الاسطر . و وافنا بالنتيجة Dim strInvoiceID As String Set rsFatora = db.OpenRecordset("SELECT * FROM tblFatora WHERE FatoraId <> '" & strInvoiceID & "'") Set rsHaraka = db.OpenRecordset("SELECT * FROM tblHaraka WHERE Fatora_id <> '" & strInvoiceID & "'") بالتوفيق

نعم اخي @محمد احمد لطفى تحتاج الى مكتبة Microsoft Excel XX.X Object Library xx.x = رقم نسحة الاوفيس لديك 12.0 او 14.0 او 15.0 الخ.. تحياتي

اخي العزيز @العبيدي رعد الجدول user&pass كان في ملفك من الاساس تحديد الصلاحيات يتم عن طريق دخول الادمن من نموذج تسجيل الدخول او الجدول ثم اعطاء كل الصلاحيات للنماذج وتفعيل كل الخانات ما عدا Button Disable. ضروري ان يكون الزر غير مفعل وبعدها تستطيع ان تكمل مع باقي المستخدمين واعطاء كل مستخدم الصلاحية المطلوبة. وإغلاق الازرار بالنسبة لهذا الخطاء هو انه زر الامر Command0 غير موجود في هذا القورم . وهناك ايضا خطاء انه تم تفعيل زر Button Disable لان الشخص ابو ايمان له كل الصلاحيات إذن يجب إلغاء هذا الزر وعدم تفعيله اذا كان الادمن. سارفق لك نفس ملفك الاول والذي عملت عليه واعطيت سامي صلاحية الادمن وكلمة المرور 555 انظرا جيدا كيف تم العمل واكمل . واي استفسار بخدمتكم . ربما أتاخر في الاجابة بسببت فرق التوقيت تحياتي صلاحيات.accdb

حياك الله اخي الدكتور محمد اليك ثلاثة ملفات باكواد مختلفة وجميعها تعمل بشكل صحيح مع الويندوز 10 والاوفيس 2019 . وكما ذكرت سابقا لن استطع التطبيق على الويندوز 7 والاوفس 2010 لانني لا املكهم. اتمنى من باقي الاعضاء والاساتذة ممن لديهم إمكانية تجربة الملف وإبداء الرأي حتى نستطيع حل المشكلة. وكنت أتمنى من الاخ @tamer.murad صاحب الموضوع ان يبدي رأيه أيضا. تحياتي لشخصكم الكريم 1275940712_AllVer.MediaSoft.rar

كلا استاذي الكريم محمد هذا الكود يختلف عن السابق انظر للاكواد هنا في المشاركتين. بخدمتكم استاذي الكريم تحياتي

تفضل اخي شوف التعديل هل هو المطلوب؟ Option Compare Database Option Explicit Dim strSQL As String Dim rs As DAO.Recordset Dim PreviousSearchText As String Private Sub CmdClear_Click() Me.TEXT_CHERCHE = "" Me.Query_no_subform.Form.Filter = "" Me.Query_no_subform.Form.FilterOn = False Me.Query_no_subform.Form.Requery End Sub '1 OK Private Sub TEXT_CHERCHE_Change() If Me.TEXT_CHERCHE.Text = "" Then Me.Query_no_subform.Form.Filter = "" Me.Query_no_subform.Form.FilterOn = False Else Dim strSQL As String strSQL = "numéro_coud LIKE " & Chr(34) & Me.TEXT_CHERCHE.Text & "*" & Chr(34) Me.Query_no_subform.Form.Filter = strSQL Me.Query_no_subform.Form.FilterOn = True If Me.Query_no_subform.Form.Recordset.RecordCount = 0 Then MsgBox "لم يتم العثور على سجلات للنص المدخل", vbInformation, "تنبيه" End If End If End Sub Private Sub cmdPrintPreview_Click() Me.TEXT_CHERCHE.SetFocus strSQL = "numéro_coud LIKE " & Chr(34) & Me.TEXT_CHERCHE.Text & "*" & Chr(34) ' Open the report in print preview mode DoCmd.OpenReport "MyReport", acViewPreview, , strSQL End Sub Private Sub TEXT_CHERCHE_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 27 Then Me.TEXT_CHERCHE.Text = "" Me.Query_no_subform.Form.Filter = "" Me.Query_no_subform.Form.FilterOn = False End If End Sub تحياتي my PR.accdb

بالاضافة لما تفضل به الاستاذ @kkhalifa1960 جزاه الله خيرا اليك مشاركتي Option Compare Database Option Explicit Dim strSQL As String Dim rs As DAO.Recordset Private Sub CmdClear_Click() Me.TEXT_CHERCHE = "" Me.Query_no_subform.Form.Filter = "" Me.Query_no_subform.Form.FilterOn = False End Sub Private Sub TEXT_CHERCHE_Change() strSQL = "numéro_coud LIKE " & Chr(34) & Me.TEXT_CHERCHE.Text & "*" & Chr(34) Me.Query_no_subform.Form.Filter = strSQL Me.Query_no_subform.Form.FilterOn = True Set rs = Me.Query_no_subform.Form.Recordset If (rs.RecordCount <> 0) Then rs.MoveFirst Do Until rs.EOF rs.Edit rs![oui/non] = True ' change "chkBoxFieldName" with the actual name of your checkbox field rs![date_à_regler] = Date ' change "dateFieldName" with the actual name of your date field rs.Update rs.MoveNext Loop Else MsgBox "السجل المطلوب تم التحقق منه سابقا بتاريخ " End If End Sub Private Sub cmdPrintPreview_Click() Me.TEXT_CHERCHE.SetFocus strSQL = "numéro_coud LIKE " & Chr(34) & Me.TEXT_CHERCHE.Text & "*" & Chr(34) ' Open the report in print preview mode DoCmd.OpenReport "MyReport", acViewPreview, , strSQL End Sub وهذا ملفك بعد التعديل. هل هو المطلوب؟ بالتوفيق my PR.accdb

هل ممكن ان ترفق ملفك حتى نرى اين المشكلة ؟ وجرب هذا التعديل Private Sub Form_Load() Dim OldLong As Long Dim nodX As Node Set nodX = TreeView1.Nodes.ADD(, , "R", "أعدادات النظام", 3) Set nodX = TreeView1.Nodes.ADD("R", tvwChild, "C1", "بيانات الشركة", 2) Set nodX = TreeView1.Nodes.ADD("R", tvwChild, "C2", "بيانات مستخدمي النظام", 5) Set nodX = TreeView1.Nodes.ADD("R", tvwChild, "C3", "كلمات المرور", 1) Set nodX = TreeView1.Nodes.ADD("R", tvwChild, "C4", "بيانات المطورين", 4) nodX.EnsureVisible OldLong = GetWindowLong(TreeView1.hwnd, GWL_EXSTYLE) SetWindowLong TreeView1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL InvalidateRect hwnd, 0, False Dim formsDictionary As New Scripting.Dictionary formsDictionary.ADD ChrW(&H62A), "frmCompany" formsDictionary.ADD ChrW(&H622), "frmSystemUserData" formsDictionary.ADD ChrW(&H643), "frmPassword" formsDictionary.ADD ChrW(&H62C), "frmDeveloper" End Sub 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 ولك بمثل ما دعوت أخي الدكتور محمد تحياتي

السلام عليكم وهذه مشاركتي مع الاساتذة جزاهم الله كل خير =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