jjafferr

كل اللي اقدر اقوله: الله يسامحك ، نسخت جزء من الكود ، وجزء تركته شوف رقم الخطأ اللي ظهر لك: 3021 ، وشوف الكود حقي كيف يصطاد هذا الرقم If Err.Number = 3021 Then MsgBox "لا يوجد تشابه بين الجدولين" Resume Exit_Report Else جعفر

بدل هذا السطر MsgBox "Exchange field value is " & rst!Exchange استعمل if rst!Exchange >0 then MsgBox "Exchange field value is Greater than Zero" else msgbox "Not Greater than Zero" endif

انا كان لي رأي في العلاقات ، وراعي الغنم عقّب عليّ جعفر

تفضل في هذا الاستعلام ، اذا الحقلين Monthly و Yaree كانوا متساوين في الجدولين ، سنحصل على سجلات ، واذا لا ، فلن نحصل على سجلات ، وبالزر اليمين في الاستعلام ، طلبنا رؤية الاستعلام بطريقة SQL ، فعملت نسخه منه ووضعته في الكود: Private Sub أمر2_Click() On Error GoTo err_Report 'If DCount("[coodkind]", "Tbl_Month", "[exchange]>0 And [Yaree] = Forms![frm_3]![Yaree] and Monthly = Forms![frm_3]![Monthly]") > 0 Then 'msg " اكمل السجلات بالجدول " Dim rst As DAO.Recordset mySQL = "SELECT Tbl_Month.exchange, Tbl_Month.Monthly, Tbl_Month.Yaree" mySQL = mySQL & " FROM Tbl_Month_exchange INNER JOIN Tbl_Month ON (Tbl_Month_exchange.Yaree = Tbl_Month.Yaree) AND (Tbl_Month_exchange.Monthly = Tbl_Month.Monthly)" mySQL = mySQL & " WHERE (((Tbl_Month.Monthly)=" & Forms!frm_3!Monthly & ") And ((Tbl_Month.Yaree)=" & Forms!frm_3!Yaree & "))" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst RC = rst.RecordCount MsgBox "Exchange field value is " & rst!Exchange Exit_Report: rst.Close: Set rst = Nothing Exit Sub err_Report: If Err.Number = 3021 Then MsgBox "لا يوجد تشابه بين الجدولين" Resume Exit_Report Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub جعفر 592.countmy.accdb.zip

تفضل

وعليكم السلام هاي الله يسلمك ، حزوره اعطنا مثال او اثنين من برنامجك بالبيانات ، وان شاء الله المسألة تصير اسهل لنا جعفر

تفضل يا سيدي

شكرا أخي شفان ما ادري ولا حاولت ادري ، قلت موضوع داخلي بينك وبين برنامجك وعيب اتدخل بينكم وانا شخصيا لا استعمل اوامر الاكسس هذه ، شوف اللي كتبته في هذا الرابط: انا استعمل هذه الوحدة النمطية: http://access.mvps.org/access/api/api0001.htm جعفر وعفوا ، عنك خطأ في كود التصدير ، فانت استخدمت acSpreadsheetTypeExcel12Xml بينما يجب ان تستخدم acSpreadsheetTypeExcel12 (او اي رقم اصغر منه ، ولكن ليس Xml)

إبدأ بالحقل Yaree

الله يطول في عمرك أخوي كاسر ، انت حطيت السؤال ، وانا رديت عليك لا تدخلني في امورك الخاصة مع البرنامج وبعدين وين انت اخبرت البرنامج عن هالكلام اللي الآن اخبرتني !! نعم اذا عندك حقل واحد فيه الشهر/السنة (2016/2) ، فهذاك الحقل اللي يجب تعمل العلاقة بين الجداول بيه جعفر

وعليكم السلام 1. علشان نأخذ قيمة Task في الوحدة النمطية ، لازم نشهرها في وحدة نمطية هكذا: Public Task As String فتكون متوفرة في البرنامج كاملا ، 2. لكي نستطيع ارسال Task (والذي هو عبارة عن SQL جاهز) ، يجب علينا حفظه كإستعلام عن طريق الامر QueryDef ، وقد حفظت الاستعلام بإسم qryExportExcel ، والذي نحذفه لما ننتهي من استخدامه ، 3. انا لم تعمل معي نافذة الحفظ "أختيار مكان الحفظ و اسم الملف" ، لذلك عملت متغير مؤقت saveFileAs22 ، Option Compare Database Public Task As String Public Sub exportTable(tName As String) On Error GoTo err_exportTable saveFileAs22 = "D:\myExcel.xls" Dim qrydf As QueryDef Set qrydf = CurrentDb.CreateQueryDef("qryExportExcel", Task) PauseTime = 2 ' Set duration. Start = Timer ' Set start time. Do While Timer < Start + PauseTime DoEvents ' Yield to other processes. Loop DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qryExportExcel", saveFileAs22, True 'Delete it CurrentDb.QueryDefs.Delete "qryExportExcel" Exit Sub err_exportTable: If Err.Number = 3012 Then 'Delete it, to make a new one CurrentDb.QueryDefs.Delete "qryExportExcel" Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub جعفر 591.ExportExcel.accdb.zip

وعليكم السلام نصيحتي ان تبذل الوقت وتعمل حقول التقرير بالطريقة العادية ، لأنها ستوفر عليك الوقت لاحقا (مثل ما لاحظت ، طلبك صعب التعامل معه برمجيا ، ولكنه سهل بالطريقة العادية) ولكن ، اليك الجواب حسب طريقتك: . ليصبح الكود: Option Compare Database Const Insh = 1440 Private Sub Report_Open(Cancel As Integer) Dim i, wd, iLeft, Field_No wd = 0.3 * Insh iLeft = 0 For i = 1 To 30 Field_No = 31 - i If Field_No = 2 Then 'الحقل رقم 2 اعمل عرضه 4 اضعاف Me("a" & Field_No).Width = wd * 4 Me("a" & Field_No).Left = iLeft Else 'بقية الحقول عرضها متساوي Me("a" & Field_No).Width = wd Me("a" & Field_No).Left = iLeft End If iLeft = Me("a" & Field_No).Left + Me("a" & Field_No).Width Next i End Sub جعفر 590.TestDBR.accdb.zip

وعليكم السلام الجدول الاصل يجب ان يكون فهرس الحقلين لا يقبل وجود قيم شبيهة: . وبعدين ، الملعب لك ، وافعل ما شئت: لاحظ خطوط العلاقة ، فانت تقول ان الحقل Monthly في الجدول tbl1 ، فيه قيمة واحدة (1)(No Duplicates) ، بينما الحقل المرتبط به من الجدول tbl_Month فيه قيم مالا نهاية (Duplicates OK) . جعفر 589.alaqat.accdb.zip

السلام عليكم الميزة في هذ الطرقة انك تتحكم في إظهار المجلدات والملفات ، مثلا: تستطيع ان تُظهر ملفات بصيغ معينه فقط ، او لا تُظهر ملفات بصيغة معينة ، تستطيع ان تُخفي ملفات اسمها فيه احرف معينة ، مثلا اذا كان عندك ملف اسمه jj.doc ، وكنت تعمل نُسخ منه وتسميها jj_01.doc و jj_02.doc ، فيمكنك وحسب صلاحيات المستخدم ان تُظهر ما تريد وتخفي الباقي ونفس الشئ مع المجلدات جعفر

السلام عليكم دائما يُفضل استخدام API الوندوز على اوامر الاكسس ، لأن الاكسس قد يُغيّر هذا الامر او يُلغيها من احد اصداراته ، وهذا ما حدث مع العديد والعديد منها ، منها على سبيا المثال لا الحصر: Application.FileSearch adp Security mdw import DBF لذلك يُنصح انه تستعمل دوال الوندوز بدلا من دوال الاكسس قدر المستطاع جعفر

الآن فهمت الذي تريد عمله!! اذا كان الملف موجود في المجلد الهدف ، اذن افتحه ، واذا ما موجود في المجلد الهدف ، ولكنه موجود في المجلد المصدر ، اذن اعمل نسخه منه الى المجلد الهدف ن ثم افتحه من هناك ، واذا لم يتواجد في المجلدين ، اعطي رسالة الانذار بعدم وجود الشهادة: Private Sub cmd_Open_the_File_from_Destination_Click() Dim strFilePath As String Source = DLookup("[attachemnts bath]", "bath", "[ID] = 1") Destination = DLookup("[attachemnts bath]", "bath", "[ID] = 2") strFilePath = Destination & "\" & Me.ID & ".PDF" If Dir(strFilePath) <> "" Then Application.FollowHyperlink strFilePath ElseIf Dir(Source & "\" & Me.ID & ".PDF") <> "" Then FileCopy Source & "\" & Me.ID & ".PDF", Destination & "\" & Me.ID & ".PDF" 'give the slow PCs wait time until copying is completed PauseTime = 2 ' Set duration. Start = Timer ' Set start time. Do While Timer < Start + PauseTime DoEvents ' Yield to other processes. Loop Application.FollowHyperlink strFilePath Else MsgBox "There are no GAS Certificates saved for this Property. Please Add or Scan a new document!" End If End Sub 584.2.Copy PDF from A folder To B Folder.accdb.zip

جرب هذا الـ TreeView (نفس الملف من الرابط) ، وقد عملت عليه بعض التعديلات: 1. الزر اليمين لا يعمل ، 2. يفتح النموذج مباشرة على \:D جعفر SampTree_StartFolder.zip

اذا حذفت الملف من الاصل ، فسيعطيك البرنامج رسالة بعدم وجود الشهادة ، ولكن ولكي اثبت لك: احذف هذا السطر FileCopy Source & "\" & Me.ID & ".PDF", Destination & "\" & Me.ID & ".PDF" واستبدله بهذا السطر Name Source & "\" & Me.ID & ".PDF" As Destination & "\" & Me.ID & ".PDF" هنا الكود لا يقوم بنسخ الملف من المصدر ، وانما بنقله من المصدر ، وسوف يقوم بفتحه ، ثم انظر في مجلد المصدر ، فلن تراه هناك ، بل ستراه في مجلد الهدف جعفر

تفضل الكود لهذه العملية هو Private Sub cmd_Open_All_Click() Dim rst As DAO.Recordset Set rst = Me.RecordsetClone rst.MoveLast: rst.MoveFirst RC = rst.RecordCount For i = 1 To RC Application.FollowHyperlink rst!Site rst.MoveNext Next i rst.Close: Set rst = Nothing End Sub جعفر 579.1.test90.mdb.zip

وعليكم السلام لا ارى كيف ذلك ، فالكود يأخذ مسار المجلد الذي تم النسخ اليه: Private Sub cmd_Open_the_File_from_Destination_Click() ... strFilePath = Destination & "\" & Me.ID & ".PDF" ... Application.FollowHyperlink strFilePath ... End Sub هل اخذت الكود والصقته ببرنامجك (يعني غير البرنامج الذي ارفقته انا) ؟ اذا فعلت ، فيجب عليك ان تضيف حقل ID للجدول bath ، بحيث: ID = 1 لسجل الـ Source ID = 2 لسجل الـ Destination جعفر

السلام عليكم أختي ، الظاهر ان الكود فيه مشكلة ، وتم اكتشافها وتعديلها هنا: جعفر

كان في خطأ في الكود ، والحمدلله استطعت معرفته وتغييره حاليا الكود يعطيك فقط اذا في ايام متتالية اكثر من 8 ايام مثلا (انت تحدد هذا اليوم ، وحتى ممكن نضعه في النموذج الذي به التواريخ من-الى). الكود اصبح: Option Compare Database Function Check_Abs(EN) On Error GoTo err_Check_Abs If EN = 0 Then aaaa = 1 End If 'EN = Employee Name WAS 'EN = Employee Code NOW Dim rst As DAO.Recordset fD = [Forms]![frm_get_attendance_data]![Date_From] eD = [Forms]![frm_get_attendance_data]![Date_To] 'myCriteria = "[Emp_Name]='" & EN & "'" myCriteria = "[Emp_Code]=" & EN myCriteria = myCriteria & " And [Leave_Type]='غياب'" myCriteria = myCriteria & " And [day_date] Between " & DateFormat(fD) & " And " & DateFormat(eD) 'Set rst = CurrentDb.OpenRecordset("Select * From tbl_Attendance_in Where [Emp_Name]='" & EN & "' And [Leave_Type]='غياب' And [day_date] Between '" & DateFormat(fD) & "' And '" & DateFormat(eD) & "'") Set rst = CurrentDb.OpenRecordset("Select * From tbl_Attendance_in Where " & myCriteria & " Order by [day_date]") rst.MoveLast: rst.MoveFirst RC = rst.RecordCount Seq = 1 Prev_Date = rst![day_date] For i = 1 To RC If rst![day_date] = DateAdd("d", 1, Prev_Date) Then Seq = Seq + 1 'do we have a Next Day 'Next Day iNext_Day = DateAdd("d", 1, rst![day_date]) 'Move to Next Records 'and compare days rst.MoveNext If rst![day_date] <> iNext_Day And Seq >= 8 Then Check_Abs = Correct_Names(Seq) Exit For End If rst.MovePrevious Else Seq = 1 End If Prev_Date = rst![day_date] Next_ii: rst.MoveNext Next i ' If Seq >= 8 Then ' Check_Abs = Seq & " ايام متتالية" ' Else ' Check_Abs = RC & " ايام غير متتالية" ' End If Exit_Check_Abs: rst.Close: Set rst = Nothing Exit Function err_Check_Abs: If Err.Number = 3021 Then If Seq >= 8 Then Check_Abs = Correct_Names(Seq) Else Check_Abs = "" End If Resume Exit_Check_Abs Else MsgBox Err.Number & vbCrLf & Err.Description End If End Function Function Correct_Names(N) Select Case N Case 2 Correct_Names = " يومان متتاليان" Case 3 To 10 Correct_Names = N & " ايام متتالية" Case Else Correct_Names = N & " يوم متتالي" End Select End Function جعفر 588.حصر الغياب.mdb.zip

1. اعمل استعلام ، وادخل فيه اي حقلين من اي جدول ، احدهما فيه بيانات ، والاخر مافيه بيانات ، اذا استعمل '*' Like في الحقل الذي ليس فيه بيانات ، سترى انه لا تحصل على سجلات اصلا ، مع ان الحقل الآخر فيه بيانات ، هذه كانت مشكلتك ، لأنه لما تستعمل المعيار Peinture ، سترى ان الحقل Heure مثلا ليس به بيانات ، واذا استعملت المعيار '*' Like عليه ، فلن تحصل على اي نتيجة. لذا ، كان لازم نتخلص من معايير '*' Like للحقول التي لا توجد بها معايير ، لذا فقمت بحذفها ، وهذا لا يؤثر على نتائج الاستعلام. 2. ونتيجة الى حذف '*' Like للحقول التي ليست بها معايير ، اصبح لدينا الكثير من " & "And" & " الزائدة ، والتي تمنع من عمل SQL الاستعلام ، فاضطررت الى حذفها ، 3. بقية And الاولى ، والتي كان يجب حذفها كذلك ، فاسهل سطر لحذفها كان هذا جعفر

نعم ، كانت هناك مشكلة عندما الحقل يكون فارغ ، والمعيار '*' Like ، فلا تحصل على نتائج تم تغيير الكود الى: Function SearchCriteria() Dim strProject As String Dim strProfil, strMachine, strRepere, strDone, strTime, strUnits As String Dim strFirstDate, strLastDate As Date Dim Task As String Dim strCriteria As String '.................................................................................. If IsNull(Me.cboTime) Then Else strTime = " And [Heure] = '" & Me.cboTime & "' " End If '................................................................................. If IsNull(Me.cboProject) Then Else strProject = " And [N° BS] = '" & Me.cboProject & "' " End If '................................................................................. If IsNull(Me.cboMachine) Then Else strMachine = " And [Machine] = '" & Me.cboMachine & "' " End If '................................................................................. If IsNull(Me.cboProfil) Then Else strProfil = " And [Désignation] = '" & Me.cboProfil & "' " End If '................................................................................ If IsNull(Me.cboRepere) Then Else strRepere = " And [Repères] = '" & Me.cboRepere & "' " End If '................................................................................ If IsNull(Me.cboDone) Then Else strDone = " And [Done] = '" & Me.cboDone & "' " End If '................................................................................ If IsNull(Me.txtFirstDate) Or IsNull(Me.txtLastDate) Then Else strFirstDate = " And [LaDate]>= #" & Format(txtFirstDate, "mm/dd/yyyy") & "#" _ & " And [LaDate] <= #" & Format(txtLastDate, "mm/dd/yyyy") & "#" End If '................................................................................ If IsNull(Me.cboUnits) Then Else strUnits = " And [Units from] = '" & Me.cboUnits & "' " End If '................................................................................ strCriteria = strProject & strMachine & strProfil & strRepere & strDone & strFirstDate & strTime & strUnits Task = "select * from tblRealisation where " & strCriteria 'Debug.Print Replace(Task, "where And", "where") Me.RealisationSubForm.Form.RecordSource = Replace(Task, "where And", "where") Me.RealisationSubForm.Form.Requery End Function جعفر

البرنامج يرى التواريخ بين التاريخين ، ثم يحسب الايام المتتالية (3 ايام في الرابط) ، ولا يهمه مكان الايام المتتاليه !! واذا وجد ايام متتالية حسب الطلب ، لا يحسب الايام المتتاليه الاخرى. رجاء المحاولة مرة اخرى جعفر