Sub AddAttachment()
    Dim str1 As String
    str1 = Application.GetOpenFilename(Title:="選擇附件")
    If str1 = "False" Or str1 = "" Then Exit Sub
    ActiveSheet.Range("B5") = str1
End Sub

Sub SendMailViaOutlook()
    Dim strMail As String, strSubject As String
    Dim strBody As String, strAtt As String
    With ActiveSheet
        strMail = .Range("B2")
        strSubject = .Range("B3")
        strBody = .Range("B4")
        strAtt = .Range("B5")
    End With
    SendEmail strMail, strSubject, strBody, strAtt
    MsgBox "發(fā)送郵件完畢！", vbInformation + vbOKOnly, "提示"
End Sub
   
Function SendEmail(ByVal sMail As String, ByVal sSubject As String, ByVal sBody As String, sAtt As String)
    Dim olApp As Object
    Dim olNameSpace As Object
    Dim olFolder As Object
    Dim olMail As Object
    Set olApp = CreateObject("Outlook.Application")
    Set olNameSpace = olApp.GetNamespace("MAPI")
   
    Set olFolder = olNameSpace.GetDefaultFolder(6)
    Set olMail = olApp.CreateItem(0)
    With olMail
        .subject = sSubject
        .Recipients.Add sMail
        .Body = sBody
        .Attachments.Add sAtt
        .Send
    End With
   
End Function

多個(gè)郵件地址

Sub sendmail()
    Dim emailArr()
    Dim r As Long, subject As String
   
    r = Worksheets("mail").Range("A1").End(xlDown).Row - 1
    If r <= 0 Then
        MsgBox "請?jiān)凇癕ail”工作表中輸入郵件地址！", vbCritical + vbOKOnly, "警告"
        Exit Sub
    End If
    ReDim emailArr(1 To r)
    For i = 2 To r + 1   '收件人地址
        emailArr(i - 1) = Worksheets("mail").Cells(i, 1)
    Next
    subject = Worksheets("CPE3").Range("A1") '郵件主題
    ActiveWorkbook.sendmail emailArr, subject '發(fā)送郵件
   
End Sub