محمد أبوعبدالله

وجزاكم الله خيرا بالتوفيق اخي الكريم تحياتي

السلام عليكم ورحمة الله وبركاته مرحبا اخي الكريم الكود الجديد الآن يمكن التحكم بناتج البحث متاطبق وغير متاطابق (جزء من الاسم ) وذلك عن طريق المتغير chk ويمكن التحكم بقيمة المتغير كالتالي chk = 0 غير متطابق chk = 1 متطابق والان كود البحث كالتالي On Error Resume Next Dim mySqL As String Dim mySQLWhere As String Dim mySqLAnd As String Dim chk As Integer ' ÛíÑ ãÊØÇÈÞ ' chk = 0 ' ãÊÇØÇÈÞ chk = 1 mySqLAnd = " AND " mySqL = "SELECT * FROM tblSearch " If Len(Me.X1 & vbNullString) Then If (chk) Then mySQLWhere = "[X1] Like " & Chr$(39) & "*" & Me.X1 & "*" & Chr$(39) Else mySQLWhere = "[X1] = " & Chr$(39) & Me.X1 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X2 & vbNullString) Then If (chk) Then mySQLWhere = "[X2] Like " & Chr$(39) & "*" & Me.X2 & "*" & Chr$(39) Else mySQLWhere = "[X2] = " & Chr$(39) & Me.X2 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X3 & vbNullString) Then If (chk) Then mySQLWhere = "[X3] Like " & Chr$(39) & "*" & Me.X3 & "*" & Chr$(39) Else mySQLWhere = "[X3] = " & Chr$(39) & Me.X3 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X4 & vbNullString) Then If (chk) Then mySQLWhere = "[X4] Like " & Chr$(39) & "*" & Me.X4 & "*" & Chr$(39) Else mySQLWhere = "[X4] = " & Chr$(39) & Me.X4 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X5 & vbNullString) Then If (chk) Then mySQLWhere = "[X5] Like " & Chr$(39) & "*" & Me.X5 & "*" & Chr$(39) Else mySQLWhere = "[X5] = " & Chr$(39) & Me.X5 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X6 & vbNullString) Then If (chk) Then mySQLWhere = "[X6] Like " & Chr$(39) & "*" & Me.X6 & "*" & Chr$(39) Else mySQLWhere = "[X6] = " & Chr$(39) & Me.X6 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X7 & vbNullString) Then If (chk) Then mySQLWhere = "[X7] Like " & Chr$(39) & "*" & Me.X7 & "*" & Chr$(39) Else mySQLWhere = "[X7] = " & Chr$(39) & Me.X7 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X8 & vbNullString) Then If (chk) Then mySQLWhere = "[X8] Like " & Chr$(39) & "*" & Me.X8 & "*" & Chr$(39) Else mySQLWhere = "[X8] = " & Chr$(39) & Me.X8 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X9 & vbNullString) Then If (chk) Then mySQLWhere = "[X9] Like " & Chr$(39) & "*" & Me.X9 & "*" & Chr$(39) Else mySQLWhere = "[X9] = " & Chr$(39) & Me.X9 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(mySQLWhere) Then mySQLWhere = Left$(mySQLWhere, Len(mySQLWhere) - (Len(mySqLAnd) - 1)) End If Me.Search2.Form.Filter = mySQLWhere Me.Search2.Form.FilterOn = True وكود الطباعة كالتالي On Error Resume Next Dim stDocName As String Dim mySqL As String Dim mySQLWhere As String Dim mySqLAnd As String Dim chk As Integer ' ÛíÑ ãÊØÇÈÞ ' chk = 0 ' ãÊØÇÈÞ chk = 1 mySqLAnd = " AND " mySqL = "SELECT * FROM tblSearch " If Len(Me.X1 & vbNullString) Then If (chk) Then mySQLWhere = "[X1] Like " & Chr$(39) & "*" & Me.X1 & "*" & Chr$(39) Else mySQLWhere = "[X1] = " & Chr$(39) & Me.X1 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X2 & vbNullString) Then If (chk) Then mySQLWhere = "[x2] Like " & Chr$(39) & "*" & Me.X2 & "*" & Chr$(39) Else mySQLWhere = "[x2] = " & Chr$(39) & Me.X2 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X3 & vbNullString) Then If (chk) Then mySQLWhere = "[X3] Like " & Chr$(39) & "*" & Me.X3 & "*" & Chr$(39) Else mySQLWhere = "[X3] = " & Chr$(39) & Me.X3 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X4 & vbNullString) Then If (chk) Then mySQLWhere = "[X4] Like " & Chr$(39) & "*" & Me.X4 & "*" & Chr$(39) Else mySQLWhere = "[X4] = " & Chr$(39) & Me.X4 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X5 & vbNullString) Then If (chk) Then mySQLWhere = "[X5] Like " & Chr$(39) & "*" & Me.X5 & "*" & Chr$(39) Else mySQLWhere = "[X5] = " & Chr$(39) & Me.X5 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X6 & vbNullString) Then If (chk) Then mySQLWhere = "[X6] Like " & Chr$(39) & "*" & Me.X6 & "*" & Chr$(39) Else mySQLWhere = "[X6] = " & Chr$(39) & Me.X6 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X7 & vbNullString) Then If (chk) Then mySQLWhere = "[X7] Like " & Chr$(39) & "*" & Me.X7 & "*" & Chr$(39) Else mySQLWhere = "[X7] = " & Chr$(39) & Me.X7 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X8 & vbNullString) Then If (chk) Then mySQLWhere = "[X8] Like " & Chr$(39) & "*" & Me.X8 & "*" & Chr$(39) Else mySQLWhere = "[X8] = " & Chr$(39) & Me.X8 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(Me.X9 & vbNullString) Then If (chk) Then mySQLWhere = "[X9] Like " & Chr$(39) & "*" & Me.X9 & "*" & Chr$(39) Else mySQLWhere = "[X9] = " & Chr$(39) & Me.X9 & Chr$(39) End If mySQLWhere = mySQLWhere & mySqLAnd End If If Len(mySQLWhere) Then mySQLWhere = Left$(mySQLWhere, Len(mySQLWhere) - (Len(mySqLAnd) - 1)) End If Debug.Print mySQLWhere Me.Visible = False stDocName = "rep1" DoCmd.OpenReport stDocName, acPreview, , mySQLWhere 003.zip تحياتي

وعليكم السلام ورحمة الله وبركاته جرب هذا البرنامج وادعو لاستاذنا جغفر صاحب الموضوع تحياتي

يمكن ان شاء الله ولكن ارى الطريقة الاولى اصح من هذه حسابياً TEST_SUM_SECTOR.rar تحياتي

يمكنك استخدام نفس الكود واستبدال السطرينن الاخيرين فقط بـ stDocName = "rep1" DoCmd.OpenReport stDocName, acPreview, , strSQLWhere واستبدال السطرينن الاخيرين في الكود الاخير بـ stDocName = "rep1" DoCmd.OpenReport stDocName, acPreview, , myCriteria تحياتي

بالتوفيق اخي الكريم تحياتي

نعم الكود الثاني On Error GoTo Err_أمر39_Click If t2.SourceObject = "" Then MsgBox "غفواً.. لايمكن فتح تقرير قبل فتح النموذج" Exit Sub End If Dim stLinkCriteria As String stLinkCriteria = "[الموسم الدراسي]='" & [نص30] & "' And [القسم]='" & [نص32] & "' And [رقم الفوج]='" & [مربع_تحرير_وسرد35] & "'" Dim stDocName As String stDocName = ChrW(1578) & ChrW(1602) & ChrW(1585) & ChrW(1610) & ChrW(1585) & ChrW(49) DoCmd.OpenReport stDocName, acViewReport, , stLinkCriteria DoCmd.OutputTo acOutputReport, "تقرير1", acFormatXLS, CurrentProject.Path & "\" & stDocName & ".xls", True Exit_أمر39_Click: Exit Sub Err_أمر39_Click: MsgBox Err.Description Resume Exit_أمر39_Click

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم هذا كود يقوم بجميع برنامج اكسيل وجميع ملفاته المفتوحة ويمكن تنفيذ الامر لجميع البرامج التي تريد اغلاقها بتكرار الامر مع تغيير اسم البرنامج نضع الكود التالي في وحدة نمطية Function TaskKill(ProName) TaskKill = CreateObject("WScript.Shell").Run("taskkill /f /im " & ProName, 0, True) End Function ثم نستخدمه في زر امر كالتالي Private Sub Command01_Click() If TaskKill("Excel.exe") = 0 Then MsgBox "تم اغلاق جميع ملفات Excel المفتوحة" Else MsgBox "لا توجد ملفات Excel المفتوحة" End If End Sub تحياتي

وعليكم السلام ورحمة الله وبركاته اطبعه Pdf سيكون صورة طبق الاصل من التقرير الكود التالي يقوم بتصدير البيانات الموجودة بالتقرير الى اكسيل On Error GoTo Err_أمر39_Click If t2.SourceObject = "" Then MsgBox "غفواً.. لايمكن فتح تقرير قبل فتح النموذج" Exit Sub End If Dim stLinkCriteria As String stLinkCriteria = "[الموسم الدراسي]='" & [نص30] & "' And [القسم]='" & [نص32] & "' And [رقم الفوج]='" & [مربع_تحرير_وسرد35] & "'" Dim stDocName As String stDocName = ChrW(1578) & ChrW(1602) & ChrW(1585) & ChrW(1610) & ChrW(1585) & ChrW(49) DoCmd.OpenReport stDocName, acViewReport, , stLinkCriteria DoCmd.OutputTo acOutputReport, "تقرير1", acFormatXLS, CurrentProject.Path & "\" & stDocName & ".xls", True Exit_أمر39_Click: Exit Sub Err_أمر39_Click: MsgBox Err.Description Resume Exit_أمر39_Click المستخدم.rar تحياتي

وعليكم السلام ورحمة الله وبركاته هناك فكرة تعتمد على عدد ارقام او حروف مربع النص وبناءاً عليه يتم تغيير حجم الخط مثال Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) If Len(Me.TextBox1) >= 11 Then Me.TextBox1.FontSize = 11 Else Me.TextBox1.FontSize = 13 End If End Sub تحياتي

وعليكم السلام ورحمة الله وبركاته الكود موجود في النموذج الرئيسي (نموذج2) وهذه العناصر غير موجود به كما ان Me.Text12.Value مكرر كما انه لا يوجد Error_ErrorZ: كما ان تقسيم الكود على سطرين خطأ كما ان السطرين الاخيرين زيادة عن الكود MsgBox "تم حفظ بيانات" End Sub الكود بعد التعديل Private Sub BeforeUpdate_Click() On Error GoTo Error_ErrorZ If IsNull(Me.الصفحة1!Text12.Value) Or IsNull(Me.الصفحة1!Text13.Value) & _ " Or IsNull(Me.الصفحة1!Text14.Value) Or IsNull(Me.الصفحة1!Text15.Value) Or IsNull(Me.الصفحة1!Text16.Value)" Then MsgBox "هذه الحقول مطلوبة" Me.Undo End If Error_ErrorZ: End Sub الموظفين_3.rar تحياتي

بالفعل كان محتاج ضبط اكثر تفضل الكود امن جديد Dim myCriteria As String myCriteria = Null If Not IsNull(Me.X1) Then myCriteria = "[X1] LIKE '*" & Me.X1 & "*'" End If If Not IsNull(Me.X2) Then myCriteria = (myCriteria + " AND ") & "[X2] LIKE '*" & Me.X2 & "*'" End If If Not IsNull(Me.X3) Then myCriteria = (myCriteria + " AND ") & "[X3] LIKE '*" & Me.X3 & "*'" End If If Not IsNull(Me.X4) Then myCriteria = (myCriteria + " AND ") & "[X4] LIKE '*" & Me.X4 & "*'" End If If Not IsNull(Me.X5) Then myCriteria = (myCriteria + " AND ") & "[X5] LIKE '*" & Me.X5 & "*'" End If If Not IsNull(Me.X6) Then myCriteria = (myCriteria + " AND ") & "[X6] LIKE '*" & Me.X6 & "*'" End If If Not IsNull(Me.X7) Then myCriteria = (myCriteria + " AND ") & "[X7] LIKE '*" & Me.X7 & "*'" End If If Not IsNull(Me.X8) Then myCriteria = (myCriteria + " AND ") & "[X8] LIKE '*" & Me.X8 & "*'" End If If Not IsNull(Me.X9) Then myCriteria = (myCriteria + " AND ") & "[X9] LIKE '*" & Me.X9 & "*'" End If Me.Search2.Form.Filter = myCriteria Me.Search2.Form.FilterOn = True لا مشكلة الآن ممكن نعمل على الاسماء الخاصة بك بدون مشاكل ان شاء الله اذا كانت المشكلة في اسماء الحقول فيمكن تغيرها حسب ما كانت عليه او بالشكل الجديد بجون مشاكل ان شاء الله بالخدمة اخي الكريم تحياتي

وضع لك اسماء الحقول التي تم تغييرها في حقل العنوان في الجدول انظر اليه حتى لا يختلط عليك الامر لا قدر الله تحياتي

وجزاكم الله خيرا واخبرنا بالنتيجة بارك الله فيك تحياتي

السلام عليكم اخي الكريم وضعت لك عدد 2 زر امر للبحث بطريقتين الاثنين يعملان بكفاءة باذن الله ولكني احتجت الى تغيير اسماء الحقول حتى استطيع احصل على نتيجة سريعة للبحث كت انشأت الجداول الفرعية المساعدة ( المنطقة - النوع ) الكود الاول وهو يستخدم فلتر للنموذج الفرعي myCriteria = myCriteria & "(" myCriteria = myCriteria & "[tblSearch].[X1]= '" & Me.X1 & "'" myCriteria = myCriteria & " or " myCriteria = myCriteria & "[tblSearch].[X2]= '" & Me.X2 & "'" myCriteria = myCriteria & " or " myCriteria = myCriteria & "[tblSearch].[X3]= '" & Me.X3 & "'" myCriteria = myCriteria & " or " myCriteria = myCriteria & "[tblSearch].[X4]= '" & Me.X4 & "'" myCriteria = myCriteria & " or " myCriteria = myCriteria & "[tblSearch].[X5]= '" & Me.X5 & "'" myCriteria = myCriteria & " or " myCriteria = myCriteria & "[tblSearch].[X6]= '" & Me.X6 & "'" myCriteria = myCriteria & " or " myCriteria = myCriteria & "[tblSearch].[X7]= '" & Me.X7 & "'" myCriteria = myCriteria & " or " myCriteria = myCriteria & "[tblSearch].[X8]= '" & Me.X8 & "'" myCriteria = myCriteria & " or " myCriteria = myCriteria & "[tblSearch].[X9]= '" & Me.X9 & "'" myCriteria = myCriteria & ")" Debug.Print myCriteria Me.Search2.Form.Filter = myCriteria Me.Search2.Form.FilterOn = True الكود الثاني يعتمد على Sql Dim mySqL As String Dim mySQLWhere As String Dim strSQL As String Dim SqLK As String SqLK = " AND " mySqL = "SELECT * FROM tblSearch " If Len(Me.X1 & vbNullString) Then mySQLWhere = "WHERE [X1] Like " & Chr$(39) & "*" & Me.X1 & "*" & Chr$(39) End If If Len(Me.X2 & vbNullString) Then mySQLWhere = "WHERE [X2] Like " & Chr$(39) & "*" & Me.X2 & "*" & Chr$(39) End If If Len(Me.X3 & vbNullString) Then mySQLWhere = "WHERE [X3] Like " & Chr$(39) & "*" & Me.X3 & "*" & Chr$(39) End If If Len(Me.X4 & vbNullString) Then mySQLWhere = "WHERE [X4] Like " & Chr$(39) & "*" & Me.X4 & "*" & Chr$(39) End If If Len(Me.X5 & vbNullString) Then mySQLWhere = "WHERE [X5] Like " & Chr$(39) & "*" & Me.X5 & "*" & Chr$(39) End If If Len(Me.X6 & vbNullString) Then mySQLWhere = "WHERE [X6] Like " & Chr$(39) & "*" & Me.X6 & "*" & Chr$(39) End If If Len(Me.X7 & vbNullString) Then mySQLWhere = "WHERE [X7] Like " & Chr$(39) & "*" & Me.X7 & "*" & Chr$(39) End If If Len(Me.X8 & vbNullString) Then mySQLWhere = "WHERE [X8] Like " & Chr$(39) & "*" & Me.X8 & "*" & Chr$(39) End If If Len(Me.X9 & vbNullString) Then mySQLWhere = "WHERE [X9] Like " & Chr$(39) & "*" & Me.X9 & "*" & Chr$(39) End If strSQL = mySqL & mySQLWhere Debug.Print strSQL Me.Search2.Form.RecordSource = strSQL Me.Search2.Requery بالمناسبة اضفت مليون سجل ونفذت الامر بالطريقتين والحمد لله النتائج ممتازة ثواني قليلة فقط 003.rar تحياتي

اتفضل اخي الكريم موقع رفع الملفات https://www.gulf-up.com/ https://www.mediafire.com/ تحياتي

وعليكم السلام ورحمة الله وبركاته مرحبا اخي الكريم وارجو من الله ان تفيد وتسفيد في منتدانا الرائع من فضلك اخي الكريم ارفق الجداول الاساسية فقط وبها بيان واحد فقط ليتم التعديل حسب احتياجات البرنامج تحياتي

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم TEST_SUM_SECTOR.rar تحياتي

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

وعليكم السلام ورحمة الله وبركاته يوجد اكثر من برنامج لتحزيم البرنامج ويوجد واحد بسيط الاستخدام باسم Smart Install Maker متاح على الانترنت ان شاء الله وبه اكثر من لغة تحياتي

اخي الكريم باذن الله كل شىء متاح وقد سألت عن مكان حفظ النسخة الاحتياطية واجبتك وقد وجدت اكثر من نموذج ووحدة نمطية لعمل نسخة احتياطية من البرنامج ويكفي كود واحد فقط استخدمه عند الخروج من البرنامج Public Function vback() Dim DBOld As String Dim DBNew As String Dim BackUpname As String Dim BackUpType As String DBOld = DLookup("pate1", "copy1") ' ÞÇÚÏÉ ÈíÇäÇÊ ÇáãÑÊÈØÉ DBNew = DLookup("pate_copy", "copy1") ' ãßÇä ÍÝÙ ÇáäÓÎÉ BackUpname = DLookup("c_ymd", "copy1") BackUpType = DLookup("cv", "copy1") Shell "cmd.exe /C copy " & """" & DBOld & """" & " " & """" & _ DBNew & "\" & CurrentProject.name & Format(Date, "yyyy-mm-dd") & "-" & Format(Now(), "Hh-Nn-Ss-AMPM") & BackUpType & """", 0 End Function سيقوم بحفظ اخر نسخة من البرنامج بالتاريخ (اسم البرنامج - سنة - شهر - يوم - ساعة - دقيقة - ثانية ) وفي حدث عند الخروج في النموذج الرئيسي ضع الكود التالي Call vback تحياتي

وعليكم السلام ورحمة الله وبركاته استخدم الكود التالي Private Sub Form_BeforeUpdate(Cancel As Integer) If Len(Me.Text2 & "") = 0 Or Len(Me.Text4 & "") = 0 Then Me.Undo End If End Sub 3ا1لمستخدمين.rar تحياتي

وجزاكم الله خيرا تسلم يا غالي تحياتي

لديك جدول باسم copy1 موضح به مكان قاعدة البينات ومسار النسخة الاحتياطية وصيغة الجفظ يمكنك تحديد المكان حسب رغبتك او حسب حاجة البرنامج لذلك تحياتي

اتفضل استاذنا الغالي D33.rar تحياتي