حمدى الظابط

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

up

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

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

Up

Up

يوجد بنموذج form1 مربع نص غير منضم باسم myname اريد وضعه وتعريفة فى كود الارسال حيث انى حاولت ولم افلح فى ذلك ولكم جزيل الشكر تجرية.rar

@عبد الله قدورطيب ممكن التصحيح والتعديل ويكون لك جزيل الشكر

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

الفرق فى حرف o و R فى كلمة FORm1 كنت هبعت تعليق بنفس اللى حضرتك بعته ولكن بعد التحقيق والتركيز وجد ان هناك خطأ فى ترتيب الحروف لك تحياتى

Me.y2.Enabled = False 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 If IsNull(Me.msg) Then MsgBox "لايوجد نص للارسال", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If If IsNull([subemail].Form![phone_number]) Then MsgBox "لايوجد رقم هاتف", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If Set fso = CreateObject("scripting.filesystemobject") fldrpath = CurrentProject.Path & "\" & "الشهادات" If Not fso.FolderExists(fldrpath) Then fso.createfolder (fldrpath) End If Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=" 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 & "*" & vbCrLf & vbCrLf & "*" & Me.sub.Value & "*" & vbCrLf & "*" & vbCrLf & "*" & Me.msg.Value & "*" Debug.Print strMSG Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=" & ReplaceLineBreaks(strMSG), vbMinimizedFocus 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") fldrpath = CurrentProject.Path & "\الشهادات\" & "شهادة" & "-" & Mytoname & "-" & Me.y2.Column(0) & ".pdf" DoCmd.OutputTo acOutputReport, "" & Me.y2.Column(0) & "", "PDFFormat(*.pdf)", fldrpath, False, "", , acExportQualityPrint Pause 2 SendKeys "~" ' إرسال المرفق إن وجد If Not IsNull(Me.attach1) Then SendKeys "+{TAB}" SendKeys "~" Pause 2 SendKeys "{UP}" ' لإرسال الصور SendKeys "{UP}" ' لإرسال الملصقات SendKeys "{UP}" ' لفتح الكاميرة SendKeys "{UP}" ' لإرسال مستند SendKeys "~" Pause 2 SendKeys Me.attach1 'like "D:\OneDrive\Print\001.pdf" SendKeys "~" Pause 2 SendKeys "~" SendKeys "{NUMLOCK}", True End If Pause 2 ' إزالة علامة الصح من أمام الرقم DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE email SET[SendStuts]='تم الارسال' , SelectRow ='T' WHERE [ID]=" & Mytoname DoCmd.SetWarnings True End If rs.MoveNext Wend End If SendKeys "{NUMLOCK}", True rs.Close Set rs = Nothing Set IE = Nothing Set IEE = Nothing ' إعادة التركيز لبرنامج الأكسس SetForegroundWindow Application.hWndAccessApp MsgBox " تم الإرســــــال ", vbMsgBoxRight, "" HandleExit: Exit Sub HandleError: If Err.Number = 0 Then Exit Sub ElseIf Err.Number = -2147467259 Then ' ما قادر يركز على شاشة الواتسأب Resume Next Else MsgBox Err.Number & vbNewLine & vbNewLine & Err.Description, , "send1_Click" End If Resume HandleExit Set rs = Nothing Me.y2.Enabled = True Me.y2 = "تم ارسال الشهادات بنجاح" End Sub

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

up

Me.y2.Enabled = False 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 If IsNull(Me.msg) Then MsgBox "لايوجد نص للارسال", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If If IsNull([subemail].Form![phone_number]) Then MsgBox "لايوجد رقم هاتف", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If Set fso = CreateObject("scripting.filesystemobject") fldrpath = CurrentProject.Path & "\" & "الشهادات" If Not fso.FolderExists(fldrpath) Then fso.createfolder (fldrpath) End If Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=" 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 & "*" & vbCrLf & vbCrLf & "*" & Me.sub.Value & "*" & vbCrLf & "*" & vbCrLf & "*" & Me.msg.Value & "*" Debug.Print strMSG Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=" & ReplaceLineBreaks(strMSG), vbMinimizedFocus 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") fldrpath = CurrentProject.Path & "\الشهادات\" & "شهادة" & "-" & Mytoname & "-" & Me.y2.Column(0) & ".pdf" DoCmd.OutputTo acOutputReport, "" & Me.y2.Column(0) & "", "PDFFormat(*.pdf)", fldrpath, False, "", , acExportQualityPrint Pause 2 SendKeys "~" ' إرسال المرفق إن وجد If Not IsNull(Me.attach1) Then SendKeys "+{TAB}" SendKeys "~" Pause 2 SendKeys "{UP}" ' لإرسال الصور SendKeys "{UP}" ' لإرسال الملصقات SendKeys "{UP}" ' لفتح الكاميرة SendKeys "{UP}" ' لإرسال مستند SendKeys "~" Pause 2 SendKeys Me.attach1 'like "D:\OneDrive\Print\001.pdf" SendKeys "~" Pause 2 SendKeys "~" SendKeys "{NUMLOCK}", True End If Pause 2 ' إزالة علامة الصح من أمام الرقم DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE email SET[SendStuts]='تم الارسال' , SelectRow ='T' WHERE [ID]=" & Mytoname DoCmd.SetWarnings True End If rs.MoveNext Wend End If SendKeys "{NUMLOCK}", True rs.Close Set rs = Nothing Set IE = Nothing Set IEE = Nothing ' إعادة التركيز لبرنامج الأكسس SetForegroundWindow Application.hWndAccessApp MsgBox " تم الإرســــــال ", vbMsgBoxRight, "" HandleExit: Exit Sub HandleError: If Err.Number = 0 Then Exit Sub ElseIf Err.Number = -2147467259 Then ' ما قادر يركز على شاشة الواتسأب Resume Next Else MsgBox Err.Number & vbNewLine & vbNewLine & Err.Description, , "send1_Click" End If Resume HandleExit Set rs = Nothing Me.y2.Enabled = True Me.y2 = "تم ارسال الشهادات بنجاح" End Sub فى نهاية الكود تخرج هذه الرسالة

السلام عليكم ورحمة الله وبركاتة اريد كود فى استعلام Q_email يقوم بارسال كل شهادة لكل طالب حسب الاسم و ID الخاص بالطالب غير هذا الكود [Forms]![from1]![ID] لان مشكلة الكود الموجود حاليا يجب ادخال رقم الطالب يدويا فى كل مرة للإرسال وطبعا الامر مجهد ومتعب لذلك اريد كود يرسل شهادة كل طالب على حدى دون اى تدخل يدوى ملحوظة / او اى طريقة اخرى غير كود الاستعلام يوفى بالغرض تحياتى وشكرى لكل من مر على هذا الموضوع تجرية.rar

السلام عليكم ورحمة الله وبركاتة عنوان المرسل يشير باسم مربع نص غير منضم باسم myname عند الارسال لم يقبل كود الارسال هذا المريع ويعطى رسالة كما موجود بالصورة ارجو التصحيح مع ذكر اسباب هذا الخطأ ولكم جزيل الشكر والتقدير ملحوظة / ارجو وضع بريدك الاكترونى والباسورد فى جدول settings تجرية.rar

up

up

up

up

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

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

المنقذ الاستاذ جعفر اشكرك وبالفعل اصبح الكود يقراء دائما نتعلم منك لك كل الود والاحترام والتقدير لشخصك الراقى الكريم

السلام عليكم ورحمة الله وبركاته بعد اضافة نموذج فرعى الكود الموجود داخل مربع النص الغير منضم sub لا يقراء علما انه يقراء قبل اضافة النموذج الفرعى وشكرا لكل من مر على الموضوع تجرية.rar