كود ارسال ايميلات

[yara ahmed]

اخواتى حبايبى

انا مش عارفة هل الموضوع ده متاح فى الاكسيل

انا عايزة ارسل ايميلات بالاسم والرقم المحلى والرقم القومى والمبلغ الى ايميل 

بحيث اضغط زر يرسل الايميلات مهما كان عددها

مع حبى وشكرى

ارسال ايميلات.xlsb

[عبدالفتاح في بي اكسيل]

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

sub sendemail
If MsgBox("Are you sure you would like to send this data?", vbYesNo) = vbNo Then Exit Sub

Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object
Dim rng As Range

  Application.ScreenUpdating = False

  Set rng = Range("E2:E100")

  ActiveSheet.Sort.SortFields.Clear

  rng.Sort Key1:=rng.Cells(1), Order1:=xlAscending, Header:=xlNo
   


Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)


With newEmail
    .To = "Myemail.com"
    .CC = ""
    .BCC = ""
    .Subject = ""
    .Body = "Please see the report . Thanks"
    .Display
   
    Set xInspect = newEmail.GetInspector
    Set pageEditor = xInspect.WordEditor
   
    Sheet1.Range("a2:d100").Copy
   
    pageEditor.Application.Selection.Start = Len(.Body)
    pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
    pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)
    .Display
    .Send
    Set pageEditor = Nothing
    Set xInspect = Nothing
   
    MsgBox "Your Orders Have Been Sent"
End With
End Sub

   

[yara ahmed]

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

مع الشكر

[عبدالفتاح في بي اكسيل]

اعلميني  بالكودين ماذا يحدث  معك  قد  استفيد منه بالمستقبل   وباقي  الاعضاء 

هذا  تحديث  اخر  على  حسب  بياناتك 

Public Sub SendMails()

    Dim olApp       As Object
    Dim newEmail    As Object
    Dim sMsg        As String
    Dim rng         As Range
    Dim c           As Range

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
    End If

    With ThisWorkbook.Sheets("Sheet1")
        Set rng = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With

    For Each c In rng
        sMsg = c.Value2 & vbCrLf & _
               c.Offset(, 1).Value2 & vbCrLf & _
               c.Offset(, 2).Value2 & vbCrLf & _
               c.Offset(, 3).Value2 & vbCrLf
        
        Set newEmail = olApp.CreateItem(0)
        With newEmail
            .To = c.Offset(, 4).Text
            .CC = ""
            .BCC = ""
            .Subject = "Subject"
            .Body = "Dear customer," & vbCrLf & vbCrLf & sMsg & vbCrLf & "Regards"
            .Display
            .Send
        End With
    Next c
End Sub

 

[عبدالفتاح في بي اكسيل]

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

[yara ahmed]

اشكرك مستر عبدالفتاح في بي اكسيل

عند الضغط على ارسال تظهر شاشة ارسال ايميل التى بها To

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

وفجأة تختفى واقوم بفحص الميل لااجد الرسالة 

مشكور للاهتمام بارك الله فيك

[عبدالفتاح في بي اكسيل]

اخت  يارا  اقترح  عليك  ان تقومي  بهذه الخطوات 

1- من المفترض أن تمر عبر الكود باستخدام المفتاح F8 أو (أفضل) لتعيين نقطة توقف على السطر السفلي الثاني (المؤشر في Next c متبوعًا بالضغط على المفتاح F9 ، متبوعًا بالضغط على المفتاح F5)

2- تصوير مراحل  تطبيق  الكود  واعطائي النتيجة النهائية لاخر صورة  

حتى يتسنى معرفة كيفية المعالجة