حمدى الظابط قام بنشر يناير 31, 2023 قام بنشر يناير 31, 2023 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
jjafferr قام بنشر يناير 31, 2023 قام بنشر يناير 31, 2023 وعليكم السلام اخوي حمدي 🙂 لا لا لا ، هاي مو مقبولة منك !! بما انك حاولت حل المسألة بنفسك ، اكيد بعدة محاولات ، واخذ منك وقت ، فليش تبخل علينا بوقتك وما تخبرنا تفاصيل طلبك ، وشو المطلوب ، وشو رسالة الخطأ !! الاعضاء عندهم وقت معين في تصفح المنتدى والمساعدة ، ولما يشوفوا سؤال مبتور ، ينتقلون الى موضوع آخر ، ويبقى موضوعك معلق ويتأخر الرد 😞 معلش ، عتاب من اخ الى اخوه 🙂 جعفر
حمدى الظابط قام بنشر يناير 31, 2023 الكاتب قام بنشر يناير 31, 2023 (معدل) 1 ساعه مضت, jjafferr said: وعليكم السلام اخوي حمدي 🙂 لا لا لا ، هاي مو مقبولة منك !! بما انك حاولت حل المسألة بنفسك ، اكيد بعدة محاولات ، واخذ منك وقت ، فليش تبخل علينا بوقتك وما تخبرنا تفاصيل طلبك ، وشو المطلوب ، وشو رسالة الخطأ !! الاعضاء عندهم وقت معين في تصفح المنتدى والمساعدة ، ولما يشوفوا سؤال مبتور ، ينتقلون الى موضوع آخر ، ويبقى موضوعك معلق ويتأخر الرد 😞 معلش ، عتاب من اخ الى اخوه 🙂 جعفر الراقى الاستاذ / جعفر انا ارسلت كثيرا موضوع بذلك الطلب مرفق فيه قاعدة البيانات للتصحيح والافادة ولاسف اكثر من 5 ايام لم احد يرد ولم اجد رد فقمت بمحاولات حتى ظهر لى ان هناك خطأ فى اخر الكود كما موجود يالصورة تحياتى وودى وتقديرى تم تعديل يناير 31, 2023 بواسطه حمدى الظابط
عبد الله قدور قام بنشر يناير 31, 2023 قام بنشر يناير 31, 2023 (معدل) السلام عليكم بحثت بنظرة سريعة على الكود وجدت عندك خمس تعليمات IF ولكن المغلق منها ثلاث فقط انت بحاجة الى مرتين END IF تم تعديل يناير 31, 2023 بواسطه عبد الله قدور 1
حمدى الظابط قام بنشر يناير 31, 2023 الكاتب قام بنشر يناير 31, 2023 منذ ساعه, عبد الله قدور said: السلام عليكم بحثت بنظرة سريعة على الكود وجدت عندك خمس تعليمات IF ولكن المغلق منها ثلاث فقط انت بحاجة الى مرتين END IF @عبد الله قدورطيب ممكن التصحيح والتعديل ويكون لك جزيل الشكر
عمر ضاحى قام بنشر فبراير 1, 2023 قام بنشر فبراير 1, 2023 19 ساعات مضت, حمدى الظابط said: @عبد الله قدورطيب ممكن التصحيح والتعديل ويكون لك جزيل الشكر 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") End If 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 End If 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 rs.MoveNext Wend End If End If 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 جرب كده يمكن تتحل مش متأكد من موقعهم 100% لاني تهت شويه فى الكود
حمدى الظابط قام بنشر فبراير 1, 2023 الكاتب قام بنشر فبراير 1, 2023 3 ساعات مضت, عمر ضاحى said: 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") End If 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 End If 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 rs.MoveNext Wend End If End If 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 جرب كده يمكن تتحل مش متأكد من موقعهم 100% لاني تهت شويه فى الكود للاسف قد جربت ذلك قبل كده وجربت طرق اخرى ولكن لم افلح وشكرا لمحولتك وجزاك اله خير
jjafferr قام بنشر فبراير 1, 2023 قام بنشر فبراير 1, 2023 اخي حمدي 🙂 انصحك قراءة المشاركات التالية (ومافي داعي تقرأ بقية الموضوع) ، اللي اتكلم فيها عن طريقة معرفة اخطاء البرمجة واهمية تنسيق الكود ، وبالتالي يقلل من اخطاء المبرمج : . . . الظاهر كان عندك كود شغال ، وقمت بإضافة اجزاء عليه وبدون ان تغلق الجُمل الثلاثة اللي تحتها خط !! . انا اوقفت اسطر المربع الاصفر اللي فوق ، لأنه تكرار لنفس الاسطر في المربع الثاني ، وجميع السطور اللي اوقفتها ، وضعت امامها j ' حتى تتعرف عليها ، واوقفت هذا السطر ، لأنك لم تضع مكتبة الوندوز الخاصة بها : 'j SetForegroundWindow Application.hWndAccessApp . لا اضمن ان الكود يشتغل ، فلم ولا اعرف طريقة تشغيله ، وانت فقط تستطيع التجربة Private Sub send1_pdf() On Error Resume Next 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 MyFile 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 Me.myname.SetFocus 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) 'j If Not rs.BOF And Not rs.EOF Then 'j rs.MoveFirst 'j While (Not rs.EOF) 'j If rs.Fields("SelectRow") = "R" Then 'j Mytoname = rs.Fields(0) 'j stname1 = rs.Fields("toname") Dim strMSG As String strMSG = "*المرسل : " & Me.myname.Value & "*" & vbCrLf & vbCrLf & "*" & Me.sub1.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") MyFile = CurrentProject.Path & "\الشهادات\" & "شهادة" & "-" & Mytoname & "-" & Me.y2.Column(0) & ".pdf" DoCmd.OutputTo acOutputReport, "" & Me.y2.Column(0) & "", "PDFFormat(*.pdf)", MyFile, 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 ' إعادة التركيز لبرنامج الأكسس 'j 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, , "send_Click" End If Resume HandleExit Set rs = Nothing Me.y2.Enabled = True Me.y2 = "تم ارسال الشهادات بنجاح" End Sub جعفر 1
حمدى الظابط قام بنشر فبراير 1, 2023 الكاتب قام بنشر فبراير 1, 2023 استاذ جعفر حين ياتى الكبير ننحنى ونرفع له القبعه اولا اشكرك على المدخله الكريمة التى اسعتدنى ثانيا اشكرك على الدرس المفيد الذى ارسلته فى الموضوع ثالثا ملحظتك صائبة فى تقرار الاسطر وكانت هى السبب فى تعطيل الكود رايعا بعد التعديل وجد الكود يفتح الوتساب ويرسل النص ولكن للاسف بدون تقرير ومرفق الملف بعد التعديل كل الشكر والتقدير والاحترام لشخصك الراقى تجرية.rar
jjafferr قام بنشر فبراير 1, 2023 قام بنشر فبراير 1, 2023 اولا تمت الاجابة على سؤال هذا الموضوع ، وثانيا انا غير متخصص في رسائل الواتساب 😁 فخلينا نلتزم بقوانيم المنتدى : سؤال لكل موضوع 🙂 فعليه ، رجاء افتح موضوع جديد 🙂 جعفر 1
حمدى الظابط قام بنشر فبراير 1, 2023 الكاتب قام بنشر فبراير 1, 2023 31 دقائق مضت, jjafferr said: اولا تمت الاجابة على سؤال هذا الموضوع ، وثانيا انا غير متخصص في رسائل الواتساب 😁 فخلينا نلتزم بقوانيم المنتدى : سؤال لكل موضوع 🙂 فعليه ، رجاء افتح موضوع جديد 🙂 جعفر حااااااضر ولك تحياتى 1
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.