عند الارسال واتساب تظهر الرسالة متلاصقة

**سامي الحداد** · يناير 8, 2023

في 7‏/1‏/2023 at 16:38, حمدى الظابط said:

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

أخي حمدي

جرب الكود الان سبب تكرار الارسال هو هذه الاسطر

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)

اليك الكود كاملا بعد التعديل

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.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

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

بالتوفيق

**حمدى الظابط** · يناير 8, 2023

45 دقائق مضت, سامي الحداد said:

أخي حمدي

جرب الكود الان سبب تكرار الارسال هو هذه الاسطر

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)

اليك الكود كاملا بعد التعديل

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.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

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

بالتوفيق

السلام عليكم استاذ سامى

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

**Moosak** · يناير 9, 2023

أستاذ حمدي .. غير هذه إلى :

strMSG = " || *" & Me.myname.Value & "*" & " ||" & vbcrlf & "|| *" & Me.msg.Value & "*" & " ||" & vbcrlf & "|| *" & Me.attach.Value & "* ||" & vbcrlf & "|| " & "المرسل : *" & Me.sub

**حمدى الظابط** · يناير 9, 2023

27 دقائق مضت, Moosak said:

أستاذ حمدي .. غير هذه إلى :

strMSG = " || *" & Me.myname.Value & "*" & " ||" & vbcrlf & "|| *" & Me.msg.Value & "*" & " ||" & vbcrlf & "|| *" & Me.attach.Value & "* ||" & vbcrlf & "|| " & "المرسل : *" & Me.sub

صباح الخير هجرب حالا واخبرك بالنتيجة

32 دقائق مضت, Moosak said:

أستاذ حمدي .. غير هذه إلى :

strMSG = " || *" & Me.myname.Value & "*" & " ||" & vbcrlf & "|| *" & Me.msg.Value & "*" & " ||" & vbcrlf & "|| *" & Me.attach.Value & "* ||" & vbcrlf & "|| " & "المرسل : *" & Me.sub

**Moosak** · يناير 9, 2023

تأكد من اسم العنصر أو الحقل .

**حمدى الظابط** · يناير 9, 2023

6 ساعات مضت, Moosak said:

تأكد من اسم العنصر أو الحقل .

السلام عليكم

تم تعديل العنصر الى sub وتم الارسال كما فى الصورة والحمد لله اول خطوة طرحت امل ومازلت اطمع فى وجود مرفق و اسم المرسل و التوقيع فى الرسالة

ولحظة شئ اخر عند الضغط على اكثر من سجل للارسال لا يرسل الا لسجل واحد فقط

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

**حمدى الظابط** · يناير 10, 2023

up

**حمدى الظابط** · يناير 11, 2023

up

**حمدى الظابط** · يناير 12, 2023

السلام عليكم

اريد ان الكود يقراء مربعات النص sub ومربع النص myname ومربع النص attach بنفس الترتيب الموجود فى الكود

strMSG = " || *" & Me.myname.Value & "*" & " ||" & vbcrlf & "|| *" & Me.msg.Value & "*" & " ||" & vbcrlf & "|| *" & Me.attach.Value & "* ||" & vbcrlf & "|| " & "المرسل : *" & Me.sub

تسجيل الدخول

عند الارسال واتساب تظهر الرسالة متلاصقة

الردود الموصى بها

سامي الحداد

حمدى الظابط

Moosak

حمدى الظابط

Moosak

حمدى الظابط

حمدى الظابط

حمدى الظابط

حمدى الظابط

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information