Sub 全自動發送郵件()
Dim myOlApp As Object
Dim myitem As Object
Dim i As Integer, j As Integer
Dim strg As String
Dim atts As Object
Dim mycc As Object
Dim myfile As String
Set myOlApp = CreateObject("Outlook.Application")
'設定對Sheet1作業表進行操作，可自行修改
With Sheets("Sheet1")
i = 2
Do While .Cells(i, 2) <> ""
'設定呼叫Outlook來發送郵件
Set myitem = myOlApp.CreateItem(0)
Set atts = myitem.Attachments
'收件人郵箱地址呼叫了第3列郵箱的資料
myitem.To = .Cells(i, 3)
'郵件標題呼叫了第2列姓名 第4列標題的資料
myitem.Subject = .Cells(i, 2) & "老師，" & .Cells(i, 4)
'郵件正文，呼叫第2列即B列的姓名和第4列即D列的郵件標題
myitem.Body = .Cells(i, 2) & "老師，你好！" & vbNewLine & vbNewLine & vbNewLine & .Cells(i, 4) & "，具體請看附件 " & vbNewLine & vbNewLine & vbNewLine & "祝暑假愉快！"
'在本作業薄的根目錄下找出附件，且附件的檔案名是收件人的名字
myfile = Dir(ThisWorkbook.Path & "" & .Cells(i, 2) & ".*")
'下面是個添加一個到多個附件的回圈 如果沒找到對應人名的附件，則發無附件郵件
Do Until myfile = ""
myitem.Attachments.Add ThisWorkbook.Path & "" & myfile, 1
myfile = Dir
Loop
'下面一句適用于只添加一個附件用的，可以替換上面的回圈 如果要用請取消掉前面的注釋符 '
'If myfile <> "" Then myitem.Attachments.Add ThisWorkbook.Path & "" & myfile, 1
'預覽，如果想直接發送，把.display改為.send
myitem.send
i = i + 1
strg = ""
Loop
End With
Set myitem = Nothing
End Sub
uj5u.com熱心網友回復：
也就是說如何添加附件的路徑？轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/23380.html
標籤：VBA