ظهور خطأ فى كود ارسال تقرير الى واتساب

[حمدى الظابط]

السلام عليكم ورحمة الله وبركاته

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

 

تجرية.rar

تم تعديل يناير 22, 2023 بواسطه حمدى الظابط
تغير الملف المرفق بعد اضافة موديول 4 / 5 /6

[حمدى الظابط]

up

[حمدى الظابط]

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

فى نهاية الكود تخرج هذه الرسالة