سامي الحداد

اخي الكريم وكما ذكر الاستاذ @kkhalifa1960جزاه الله خيرا اليك التعديل ووافني بالنتيجة. التاريخ.accdb

تفضل الكود Private Sub MyDato_AfterUpdate() If Not IsNull(Me.iDate) Then Dim currentDate As Date currentDate = DateValue(Me.iDate) Me.iDate = currentDate + TimeValue(Now) End If End Sub وهذا الملف من عنديDatabase9.accdb

وعليكم السلام تفضل اخي الكريم Public Sub ExportAttachments() Dim rs As DAO.Recordset Dim attachmentField As DAO.Field2 Dim attachmentRS As DAO.Recordset2 Dim attachmentCount As Long Dim attachmentPath As String attachmentPath = CurrentProject.Path & "\Saving\" Set rs = CurrentDb.OpenRecordset("Table1") If Not (rs.EOF And rs.BOF) Then rs.MoveFirst Do Until rs.EOF Set attachmentField = rs.Fields("Attachments") If Not attachmentField.Value Is Nothing Then Set attachmentRS = attachmentField.Value For attachmentCount = 1 To attachmentRS.RecordCount If Not FileExists(attachmentPath & attachmentRS.Fields("FileName")) Then attachmentRS.Fields("FileData").SaveToFile attachmentPath & attachmentRS.Fields("FileName") MsgBox "تم تصدير الملفات التالية: " & attachmentPath & attachmentRS.Fields("FileName"), vbInformation, "تمت عملية التصدير بنجاح " Else MsgBox "الملف موجود مسبقا تم إلغاء عملية التصدير: " & attachmentPath & attachmentRS.Fields("FileName"), vbCritical, "تم إلغاء عملية التصدير " End If attachmentRS.MoveNext Next attachmentCount End If rs.MoveNext Loop End If rs.Close Set rs = Nothing Set attachmentRS = Nothing End Sub Function FileExists(filePath As String) As Boolean FileExists = Dir(filePath) <> "" End Function 'والاستدعاء Private Sub Command3_Click() ExportAttachments End Sub وهذا ملف من عندي بالتوفيق تصدير المرفقات الى ملف خارجي.rar

date.accdb

عندي يعمل بشكل صحيح اخي

وعليكم السلام ورحمة الله وبركاته إدا كان لديك حقلين الاول للتاريخ والثاني للوقت اليك هذا الكود . استبدل YourDateField و YourTimeField بالأسماء الفعلية لحقول التاريخ والوقت في برنامجك. Private Sub YourDateField_AfterUpdate() If Not IsNull(Me.YourDateField) Then Me.YourTimeField = Now End If End Sub اما إذا كان الحقل هو نفسه للتاريخ والوقت اليك هذا الكود. ولا تنسى استبدل YourDateField بالاسم الفعلي في برنامجك. Private Sub YourDateTimeField_AfterUpdate() If Not IsNull(Me.YourDateTimeField) Then Dim currentDate As Date currentDate = DateValue(Me.YourDateTimeField) Me.YourDateTimeField = currentDate + TimeValue(Now) End If End Sub بالتوفيق

السلام عليكم بالاضافة لما تفضل به الاستاذ @kkhalifa1960 جزاه الله خيرا اليك التعديل يوجد خطاء في هذا الفانكشن remainingDays = Day(DateSerial(Year(currentDate), Month(currentDate) + 1, 0)) + remainingDays التعديل هنا Function CalculateRemainingPeriod(startDate As Date, endDate As Date) As String Dim remainingYears As Integer Dim remainingMonths As Integer Dim remainingDays As Integer Dim currentDate As Date currentDate = Date remainingYears = Year(endDate) - Year(currentDate) remainingMonths = Month(endDate) - Month(currentDate) remainingDays = Day(endDate) - Day(currentDate) If remainingDays < 0 Then remainingMonths = remainingMonths - 1 remainingDays = DateDiff("d", DateSerial(Year(currentDate), Month(currentDate) + 1, 0), endDate) End If If remainingMonths < 0 Then remainingYears = remainingYears - 1 remainingMonths = remainingMonths + 12 End If CalculateRemainingPeriod = remainingYears & " years, " & remainingMonths & " months, " & remainingDays & " days" End Function تم إضافة صندوق للرسائل لكل موظف بتاريخ انتهاء العقد بامكانك الاستغناء عنه إذا كان عدد الموظفين كثير والاكتفاء فقط برسائل العقود التي قاربت على الانتهاء. الرسالة تختفي بعد ثانيتين لكل موظف. وهذا الكود هنا. Opt = MesgBox(rs![الاسم] & ": " & remainingDays & " يوم/ أيام ", 1, vbInformation, "الأيام المتبقية لإنتهاء عقد السيد") وهذا الكود للعقود التي قاربت على الانتهاء بامكانك التعديل عليها بما يناسبك . Private Sub Form_Current() UpdateFields Dim rs As DAO.Recordset Set rs = Me.RecordsetClone If Not rs.EOF Then rs.MoveFirst Do Until rs.EOF If rs![نهاية عقد العمل] <= (Date + 1) Then If rs![نهاية عقد العمل] = (Date + 1) Then MsgBox "سينتهي عقد العمل يوم غد للسيد / " & rs!الاسم, 0 + 48, " !!! تنبيــــــــــــــــــــــــــــــــــه" ElseIf rs![نهاية عقد العمل] = Date Then MsgBox "اليوم هو أخر يوم لعقد العمل للسيد / " & rs!الاسم, 0 + 64, " !!! تنبيــــــــــــــــــــــــــــــــــه" ElseIf rs![نهاية عقد العمل] < Date Then MsgBox " إنتهى عقد العمل قبل (" & Str(Date - rs![نهاية عقد العمل]) & ") يوم / أيام للسيد / " & rs!الاسم, 48, "!!! إنتهى التاريخ المحدد لعقد العمل " End If End If rs.MoveNext Loop End If rs.Close Set rs = Nothing End Sub واخيرا اليك الملف عسى ان يكون هو المطلوب. بالتوفيق التاريخ.accdb

اوكي

ولا يهمك فقط اخبرني باي اسم نعمل حساب وكلمة المرور وسوف اعمل الباقي ان شاءالله هل ثبتت برنامج ال Team Viewer وما هو الرقم وكلمة المرور ارسل لي الرقم ID وكلمة المرور

ولا يهمك يا دكتور محمد ان شاءالله نتواصل ساقوم بتثبيت برنامج Team Viewer وانت كذلك يجب ان تثبت هذا البرنامج عندك. هذا اولا وثانيا يجب ان يكون لديك حساب في الاوتلوك هل عملت الحساب؟ بانتظارك وساقوم بتثبيت برنامج التواصل الان. لا تنسى ان تعمل حساب في الاوتلوك ضروري.

اين وصلت مع الاوتلوك هل عملت حساب ؟ فقط اعمل حساب حتى نستطيع ربط الاوتولك والجي ميل لن تستغرق العملية اكثر من خمس دقائق بانتظارك

بعثت لك على الايميل المسجل في البرنامج هل وصلك ؟

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

https://www.microsoft.com/en-us/microsoft-365-life-hacks/organization/how-to-create-outlook-email-account تفضل دكتور محمد https://www.microsoft.com/en-us/microsoft-365/outlook/email-and-calendar-software-microsoft-outlook?ocid=cmmidy4nt6n

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

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

استاذي العزيز @Foksh هذه بعض الصور لقد نجحت في الارسال كما قلت سابقا. لا اعلم لماذا لم تستطيع دمج الجي ميل مع الاوتلوك مع ان الاداة من جوجل وفيها شرج وافي عن عملية الدمج وهي تعمل عندي بدون اي مشاكل. ساذهب للبيت الان وان شاءالله اتابع معكم.

اخي الكريم @rhmano البرنامج فتح معي المشكلة في برامج الحماية هي من تمنع الوصول للبرنامج بعد ان وضعت اسم البرنامج في قائمة الامان في برنامج الحماية فتح البرنامج بدون اي مشكلة وهذه بعض الصور من برنامجك. ممكن في بعض برامج الحماية لا تظهر لك اي رسالة. بالتوفيق

استاذي الدكتور محمد. هل استخدمت هذا البرنامج لعمل المزامنة بين الاوتلوك والجي ميل Google Workspace Migration for Microsoft Outlook لانه فعلا لم استطيع الارسال من الجي ميل الا بعد ان ثبتت هذا البرنامج بينما الارسال من الاوتلوك كان طبيعي بعد ان غيرت الكود كما اخبرتك سابقا. https://support.google.com/a/answer/176213?hl=en ومن هنا البرنامج. متابع معك بالتوفيق

وعليكم السلام دكتور محمد شوف التعديل على الكود ولان الوقت عندي الان الرابعة والنصف صباحا سوف اتواصل معك غدا بإذن الله . Private Sub cmdExportCrt_Click() On Error GoTo Error_Handler If IsNull(Me.Titletxt) Or Len(Me.Titletxt) = 0 Then MsgBox "Please write the Title": Exit Sub If IsNull(Me.Messagetxt) Or Len(Me.Messagetxt) = 0 Then MsgBox "Please write the Message": Exit Sub Dim rs As DAO.Recordset Set rs = Me.Recordset rs.MoveFirst Do While Not rs.EOF '********* Me.Processtxt = Me.Processtxt & "جار الآن الإرسال لـ" & Me.EmpName & "..." & vbNewLine & Me.EmpEmail & vbNewLine DoCmd.SendObject acSendReport, "CertificatesEmailR", "PDFFormat(*.pdf)", Me.EmpEmail, , , Me.Titletxt, Me.Messagetxt, True, True '********* Me.Processtxt = Me.Processtxt & "تم الإرسال بنجاح ." & vbNewLine rs.MoveNext Loop rs.MoveFirst Set rs = Nothing Error_Handler_Exit: On Error Resume Next Set rs = Nothing Exit Sub Error_Handler: MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _ Err.Number & vbCrLf & "Error Source: LoopRecExample" & vbCrLf & "Error Description: " & _ Err.Description, vbCritical, "An Error has Occured!" Resume Error_Handler_Exit End Sub التغير في الكود في هذا السطر فقط. من DoCmd.SendObject acSendReport, "CertificatesEmailR", "PDFFormat(*.pdf)", Me.EmpEmail, , , Me.Titletxt, Me.Messagetxt, False, False الى DoCmd.SendObject acSendReport, "CertificatesEmailR", "PDFFormat(*.pdf)", Me.EmpEmail, , , Me.Titletxt, Me.Messagetxt, True, True تحياتي

تفضل اخي الكريم هذا الكود لتحويل التقرير إلى صيغة pdf Private Sub أمر65_Click() Dim varItem As Variant Dim myWhere As String Dim Criteria As String Dim ReportName As String ReportName = "rap_liste_stagiere_grade_groupe1" Criteria = varItem myWhere = "" ' Loop through the selected items in the ListBox For Each varItem In Me.lst_XX.ItemsSelected ' Add each selected item to the string myWhere = myWhere & "'" & Me.lst_XX.ItemData(varItem) & "', " Next varItem ' Remove the trailing comma and space from the string myWhere = Left(myWhere, Len(myWhere) - 2) DoCmd.OpenReport "rap_liste_stagiere_grade_groupe1", acViewPreview, , "[grade] in (" & myWhere & ")" DoCmd.OutputTo acOutputReport, ReportName, acFormatPDF DoCmd.Close acReport, ReportName, acSaveNo End Sub نفس الكود تستطيع ان تستخدمه في طباعة التقرير مع تغير بسيط في هذا السطر DoCmd.OutputTo acOutputReport, ReportName, acFormatPDF بالتوفيق

تفضل اخي الكريم On Error Resume Next ' تعيين القيم المطلوبة لعرض النموذج Me.WindowWidth = 1920 ' تعيين القيم المطلوبة لارتفاع المساحة الداخلية للنموذج Me.WindowHeight = 1080 ' توسيط النموذج على الشاشة Me.Left = (Application.Width - Me.Width) / 2 Me.Top = (Application.Height - Me.Height) / 2 On Error GoTo 0 بالتوفيق

السلام عليكم عندك أخطاء في كتابة الكود انظر للتعديل If MsgBox("هل تريد الحفظ", vbYesNo, "خطابات الضمان") = vbYes Then Application.SetOption "Confirm Record Changes", False If Not IsNull(BA3) And Not IsNull(BA17) And Not IsNull(BA22) And Not IsNull(BA21) And BA5 > N2 And BA1 = "زيادة" Then N3 = BA5 - N2 N4 = N3 + N2 BA19 = N4 Forms![ShowNew1]![BA19] = N4 Forms![ShowNew1]![N2] = N4 DoCmd.RunCommand acCmdSaveRecord Application.SetOption "Confirm Record Changes", True ElseIf Not IsNull(BA3) And Not IsNull(BA17) And Not IsNull(BA22) And Not IsNull(BA21) And BA5 < N2 And BA1 = "تخفيض" Then N3 = N2 - BA5 N4 = N2 - N3 BA19 = N4 Forms![ShowNew1]![BA19] = N4 Forms![ShowNew1]![N2] = N4 DoCmd.RunCommand acCmdSaveRecord Application.SetOption "Confirm Record Changes", True ElseIf Not IsNull(BA3) And Not IsNull(BA17) And Not IsNull(BA22) And Not IsNull(BA21) And BA5 = N2 And BA1 = "رد" Then N3 = BA5 - N2 BA19 = N3 Forms![ShowNew1]![BA19] = N3 Forms![ShowNew1]![N2] = N3 DoCmd.RunCommand acCmdSaveRecord Application.SetOption "Confirm Record Changes", True MsgBox "تم الحفظ بنجاح" ElseIf IsNull(BA1) Or IsNull(BA3) Or IsNull(BA17) Or IsNull(BA22) Or IsNull(BA21) Then MsgBox "أكمل البيانات الاساسية قالناقصة ايمة التسوية - رقم الخطاب - تاريخ الاصدار - تاريخ السريان" End If End If إذا لم يعمل معك التعديل ارفق مثالك هنا حتى نستطيع مساعدتك بالتوفيق

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

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم عمل استعلام لمعرفة المكرر وهذا ملفك بعد الاضافة بالتوفيق Database2.accdb