تعديل كود ارسال ايميلات من جيميل الى الاوتلوك في الexcel

[wejdan_1]

لدي كود يقوم بإرسال بطاقة تذكير للاشخاص الذين لم يكملون مهماتهم وعدا عليها اكثر من 30 يوما الكود فعال على الجيميل ولكن انا اريده للاوتلوك 

هل يوجد طريقة لتعديل من جيميل الى الاوتلوك بدلا من كتابة كود جديد ؟ 

كود تفعيل المطلوب في جيميل 

 Dim objEmail
    Const cdoSendUsingPort = 2  ' Send the message using SMTP
    Const cdoBasicAuth = 1      ' Clear-text authentication
    Const cdoTimeout = 100      ' Timeout for SMTP in seconds
     mailServer = "smtp.gmail.com"
     SMTPport = 465     '25 'SMTPport = 465
            
     mailusername = Sheets("Remind").Range("K10").Value
     mailpassword = Sheets("Remind").Range("K11").Value
     ''''''''
      n = Application.WorksheetFunction.CountA(Sheets("Search").Range("n:n")) - 1
      m = Sheets("Search").Range("M4").Value - 30
    
      For i = 1 To n

     If Sheets("Search").Range("r6").Offset(i, 0).Value = m Then ' Sheets("Search").Range("M5").Value
         
     Sheets("Remind").Range("g4").Value = Sheets("Search").Range("h6").Offset(i, 0).Value
      Sheets("Remind").Range("g6").Value = Sheets("Search").Range("m6").Offset(i, 0).Value
      Sheets("Remind").Range("g13").Value = Sheets("Search").Range("n6").Offset(i, 0).Value
       Sheets("Remind").Range("g15").Value = Sheets("Search").Range("o6").Offset(i, 0).Value
            
     mailto = Sheets("Search").Range("n6").Offset(i, 0).Value & "@gmail.com"
     mailSubject = Sheets("Remind").Range("J4").Value
     mailBody = Sheets("Remind").Range("f4").Value & " - " & Sheets("Remind").Range("G4").Value & " / " & Sheets("Remind").Range("f6").Value & " - " & Sheets("Remind").Range("G6").Value _
     & " / " & Sheets("Remind").Range("F13").Value & " - " & Sheets("Remind").Range("G13").Value & " / " & Sheets("Remind").Range("F15").Value & " - " & Sheets("Remind").Range("G15").Value
    
     Set objEmail = CreateObject("CDO.Message")
    Set objConf = objEmail.Configuration
    Set objFlds = objConf.Fields

    With objFlds
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = mailServer
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPport
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = cdoTimeout
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasicAuth
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = mailusername
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = mailpassword
    .Update
    End With
       
      ''المرفقات'''
 
       
       ThisWorkbook.Sheets("Remind").[tbl].ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & Sheets("Search").Range("h6").Offset(i, 0).Value, OpenAfterPublish:=False


    attach = Sheets("Remind").Range("K13").Value & "\" & Sheets("Search").Range("h6").Offset(i, 0).Value & ".Pdf"
       
         'MsgBox attach
 
    objEmail.To = mailto
    objEmail.From = mailusername
    objEmail.Subject = mailSubject
    objEmail.TextBody = mailBody
       objEmail.AddAttachment attach
      objEmail.CC = Sheets("Remind").Range("L7").Value
    objEmail.BCC = Sheets("Remind").Range("L8").Value
    objEmail.Send
    Set objFlds = Nothing
    Set objConf = Nothing
    Set objEmail = Nothing
                              
    End If
    Next i
    MsgBox "تم ارسال الايميلات الجديدة", vbInformation, "ايميلات"
End Sub

مشاركة مكررة ... تم بالفعل حذف المشاركة الأخرى , انتبه من فضلك لذلك

[مهند محسن]

وعليكم السلام -تجنباً لإهدار الوقت وبما انه لا يمكن العمل على التخمين .. فعليك رفع ملف مدعوم بشرح كافى عن المطلوب