حمدى الظابط

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

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

تم واشكرك للتنويه

اشكرك ولك تحياتى وودى وتقديرى

السلام عليكم بعد التجربة النتيجة كما كانت بمرفق الموضوع بل بيتم ارسال الرسالة مرتين لنفس الشخص كما موجود فى الصورة وهذا هو الكود بعد التعديل تعبتك معايا ارجو قبول الاعتذار 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 Me.myname.SetFocus If IsNull(Me.msg) Then MsgBox "لايوجد نص للارسال", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If If IsNull([email1].Form![phone_number]) Then MsgBox "لايوجد رقم هاتف", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If DoCmd.OpenForm "email4", acNormal Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & " || *" & Me.myname.Value & "*" & " || *" & Me.msg.Value & "*" & " || *" & Me.attach.Value & "* || " & "المرسل : *" & Me.sub & "*" & "& app_sent =0" Pause 3 SendKeys "{TAB}" 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 & "*" & " || *" & Me.msg.Value & "*" & " || *" & Me.attach.Value & "* || " & "المرسل : *" & Me.sub strMSG = ReplaceLineBreaks(strMSG) Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & strMSG & "*" & "& app_sent =0" Pause 3 Set IE = Nothing Set IEE = Nothing Dim objClipboard As Object Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objClipboard.SetText (MyFile) objClipboard.PutInClipboard Pause 5 SendKeys "+{TAB}" Call SendKeys("{Enter}", True) Pause 2 Call SendKeys("{Enter}", True) Pause 5 Langauge ELanguage.en Pause 5 Call SendKeys("^v", True) Call SendKeys("{Enter}", True) Pause 5 Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objClipboard.SetText ReplaceLineBreaks(Me.msg) objClipboard.PutInClipboard Pause 1 Call SendKeys("^v", True) Pause 5 Call SendKeys("{Enter}", True) Pause 1 DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE email SET[SendStuts]='تم الارسال' , SelectRow ='T' WHERE [ID]=" & Mytoname DoCmd.Requery DoCmd.SetWarnings True SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" End If rs.MoveNext Wend End If rs.Close Set rs = Nothing MsgBox "تم الارسال" End Sub ' =================================(وهذه دالة لجعل الواتسأب يقبل السطور الجديدة في النص المرسل) Function ReplaceLineBreaks(text As String) As String ReplaceLineBreaks = Replace(text, vbCrLf, " %0a ") ReplaceLineBreaks = Replace(ReplaceLineBreaks, Chr(10), " %0a ") ReplaceLineBreaks = Replace(ReplaceLineBreaks, Chr(13), " %0a ") End Function

بعد التجربة وبعد الاحتفاظ بكود الدالة لم يتم الارسال

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

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 Me.myname.SetFocus If IsNull(Me.msg) Then MsgBox "لايوجد نص للارسال", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If If IsNull([email1].Form![phone_number]) Then MsgBox "لايوجد رقم هاتف", vbCritical + vbMsgBoxRight, "تنبيه" Exit Sub End If DoCmd.OpenForm "email4", acNormal Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & " || *" & Me.myname.Value & "*" & " || *" & Me.msg.Value & "*" & " || *" & Me.attach.Value & "* || " & "المرسل : *" & Me.sub & "*" & "& app_sent =0" Pause 3 SendKeys "{TAB}" 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") Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=" Pause 3 Set IE = Nothing Set IEE = Nothing Dim objClipboard As Object Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objClipboard.SetText (MyFile) objClipboard.PutInClipboard Pause 5 SendKeys "+{TAB}" Call SendKeys("{Enter}", True) Pause 2 Call SendKeys("{Enter}", True) Pause 5 Langauge ELanguage.en Pause 5 Call SendKeys("^v", True) Call SendKeys("{Enter}", True) Pause 5 Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objClipboard.SetText (Me.msg) objClipboard.PutInClipboard Pause 1 Call SendKeys("^v", True) Pause 5 Call SendKeys("{Enter}", True) Pause 1 DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE email SET[SendStuts]='تم الارسال' , SelectRow ='T' WHERE [ID]=" & Mytoname DoCmd.Requery DoCmd.SetWarnings True SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" SendKeys "+{TAB}" End If rs.MoveNext Wend End If rs.Close Set rs = Nothing MsgBox "تم الارسال" End Sub

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

up

بعد التجربة حذفت Text عندما هر لى حطأ ثم ظهر لى هذا الخطأ كما فى الصورة

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

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

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

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

السلام عليكم تحياتى وتقديرى وجعلك لله عونا لنا وفى ميزان حسناتك بالنسبة للكود الاول تم حل النصف الاول من الكود وهو ظهور رسالة فى حالة عدم وجود نص اما الجزء الثانى ( فى حالة عدم وجود رقم هاتف ) لم يتم الحل لذلك اسمح لى ان اوضح لكل المطلوب بشأن الجزء الثانى وهو عند عدم وجود رقم هاتف يكتب فى حقل SendStuts لايوجد رقم هاتف توضيح اكثر اثناء الارسال لاكثر من رقم من قائمة الاسماء عند اتمام الارسال فى حقل SendStuts بيكتب امام كل سجل تم الارسال واذا كان هناك سجل لم يكن فيه رقم هاتف اريد ان يكتب فى حقل SendStuts لا يوجد رقم هاتف اما بخصوص هذا الكود فهو بعطى نتيجة لكل السجلات لا بوجد وتساب وليس للرقم الغير مشترك فقط On Error GoTo ErrorHandler ' Your code to send the message using WhatsApp goes here ErrorHandler: If Err.Number = "-2147023170" Then ' This error number corresponds to the "Object doesn't support this property or method" error MsgBox "The mobile number is not connected to WhatsApp. Please try a different number." Else MsgBox "An error occurred while sending the message: " & Err.Description Exit Sub End If

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

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

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

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

السلام عليكم ورحمة الله وبركاته 1 - فى حالة عدم وجود نص فى مربع النص الغير منضم msg تظهر رسالة تنبيه ( لايوجد نص للارسال ) 2 - فى حالة عدم وجود رقم هاتف فى السجل يكتب فى حقل حالة الارسال ( لايوجد هاتف ) وفى حالة عدم اشتراك رقم الهاتف فى الوتساب يكتب فى حقل حالة الارسال ليس لديه واتساب وكل الاحترام والتقدير للجميع تجرية.rar

السلام عليكم نعم اقصد ارسال الى البريد مرفق الملف بكود الارسال تجرية.rar

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

السلام عليكم ورحمة الله وبركاته وجمعة مباركة على الجميع ان شاء الله ارجو تركيب هذا الكود على كود الارسال الموجود بالنموذج الرئيسى حيث اننى حاولت ولاسف فشلت علما ان هذا الكود موجود فى النموذج الفرعى حيث ان حقل SendStuts يبين حالة الارسال وشكرا للمساعدة DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE email SET[SendStuts]=Null , SelectRow ='T' " DoCmd.Requery DoCmd.SetWarnings True تجرية.rar

up