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

[hosslom]

السلام عليكم اخوتي الكرام

هل من الممكن تنفيذ 

كود ارسال جميع الملفات الموجوده في فولدر في مسار  محدد كمرفقات في رسالة إيميل واحدة

بدون اوتلوك

جزاكم الله كل خير 

[عمر ضاحى]

اعتقد صعب

لان لازم سخص مرسل وشخص مستقبل الايميل

حتى لو مش هيفتح الاوتلوك فهو هيعتمد على مكتبه الاوتلوك

ممكن تنظر لهذا الكود 

Option Compare Database





Private Sub cmdSendEmail_Click()
   Dim db As DAO.Database
    Dim rs As DAO.Recordset
    
    Dim emailTo As String
    Dim emailSubject As String
    Dim emailText As String

    Dim outApp As Outlook.Application
    Dim outMail As Outlook.MailItem
    Dim outlookStarted As Boolean
        
    
    On Error Resume Next
    Set outApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If outApp Is Nothing Then
        Set outApp = CreateObject("Outlook.Application")
        outlookStarted = True
    End If

    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT ArName, EnName, EmailAddress, EmailVIP " & _
                                " FROM QTSendEmail")
    Do Until rs.EOF

        emailTo = Trim(rs.Fields("ArName").Value & " " & rs.Fields("EnName").Value) & _
                    " <" & rs.Fields("EmailAddress").Value & ">"
                    
        emailSubject = Me.txtEmailTital
        If IsNull(rs.Fields("ArName").Value) Then
            emailSubject = emailSubject & " for " & _
                            rs.Fields("ArName").Value & " " & rs.Fields("EnName").Value
        End If
        
        emailText = Trim("Hi " & rs.Fields("ArName").Value) & "!" & vbCrLf
        
        If rs.Fields("EmailVIP").Value Then
            emailText = emailText & Me.txtEmailBody & vbCrLf
        End If
'
'        emailText = emailText & _
'                    "نص 1" & _
'                    "نص 2 " & _
'                    "نص 3 " & _
'                    "نص 4"

                    
        Set outMail = outApp.CreateItem(olMailItem)
        outMail.To = emailTo
        outMail.Subject = emailSubject
        outMail.Body = emailText
        outMail.Send

        rs.MoveNext
    Loop
    
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    
    If outlookStarted Then
        outApp.Quit
    End If
    
    Set outMail = Nothing
    Set outApp = Nothing
    
    MsgBox "تم ارسال الايميلات للجميع", vbInformation, "تأكيد"
End Sub

وجربه

هتحتاج ان تضيف الاضافة دي

 

تم تعديل سبتمبر 2, 2021 بواسطه عمر ضاحى

[د.كاف يار]

تختلف الطرق حسب طريقة الارسال

كيف تقوم بإرسال البريد الإلكتروني ؟

لكن في كل حال استخدم التالي للحصول على قائمة الملفات داخل المجلد

Dim fso As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim FilePath As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
 
Set oFolder = oFSO.GetFolder("مسار المجلد")
 
For Each oFile In oFolder.Files
 
    FilePath = FilePath & vbNewLine & oFile.Name
  
Next oFile

MsgBox FilePath

 

[أ / محمد صالح]

ربما يفيدك هذا الموضوع 

بالتوفيق 

[hosslom]

شكرا اخي الكريم

هل يمكن عرض الناتج في 

list box

 

[hosslom]

14 hours ago, د.كاف يار said:

تختلف الطرق حسب طريقة الارسال

كيف تقوم بإرسال البريد الإلكتروني ؟

لكن في كل حال استخدم التالي للحصول على قائمة الملفات داخل المجلد

Dim fso As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim FilePath As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
 
Set oFolder = oFSO.GetFolder("مسار المجلد")
 
For Each oFile In oFolder.Files
 
    FilePath = FilePath & vbNewLine & oFile.Name
  
Next oFile

MsgBox FilePath

 

جزاك الله كل خير اخي الكريم

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