调用outlook来发送邮件

背景

大批量的进行添附文件和发送邮件，如果一个一个操作的话比较慢，所以打算用VBA来调用，进行发送邮件。

 

subject：发送邮件的主题

body：发送邮件的内容

outlook指定アドレス：outlook可以登入多个邮件的账号，是指定用哪一个邮件进行发送

环境：指定用测试环境还是真正的环境来进行测试。

テストアドレス：是利用哪一个邮件进行测试

 

 

需要引用outlook library

   

 

 

全局常量定义

Public Const sendMailAddresRow As Integer = 17
Public Const sendMailAddresMaxRow As Integer = 10000

　　

クリアのクリックイベント

Sub clear_Click()
    
    Dim sht As Object
    Set sht = ActiveSheet
    sht.Range("B17:E10000").Clear
End Sub

アドレス取得

Sub getMailInfo_Click()

    Dim sht As Object
    Set sht = ActiveSheet
    Dim filepath As String
    filepath = sht.Range("C3")
   
    Dim arr()
    arr = Array(CStr(sht.Range("C4").Value), CStr(sht.Range("C5").Value))
    
    
    
    Dim index As Integer
    index = 17
    
    For j = 0 To UBound(arr)
        If arr(j) = "" Then
            Exit For
        End If
        Dim wb As Workbook
        Set wb = Workbooks.Open(filepath + "\" + arr(j))
        For Each Sheet In wb.Sheets
            For i = 2 To 100000
                If Sheet.Range("A" & i) = "" Then
                    Exit For
                End If
                If Sheet.Range("F" & i) <> "" Then
                    sht.Range("B" & index) = index - 16
                    sht.Range("C" & index) = Sheet.Range("A" & i)
                    sht.Range("D" & index) = Sheet.Range("F" & i)
                    index = index + 1
                End If
            Next
        Next
        wb.Close
    Next
    
    
    Range("B17:D" & index - 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    MsgBox "完了"
End Sub
　

发送邮件

Sub openOutlook_Click()
    
    Dim sht As Object
    Set sht = ActiveSheet
    
    Dim filepath As String
    filepath = sht.Range("C6")
    Dim attachFileArr()
    attachFileArr = Array(CStr(sht.Range("C7").Value), CStr(sht.Range("C8").Value))
    
   
    Dim subject As String
    subject = sht.Range("I3")
    
    
    
    
    Dim address As String
    address = sht.Range("I7")
    
    
On Error GoTo OpenOutlook_Error
    For i = sendMailAddresRow To sendMailAddresMaxRow
        If sht.Range("E" & i) = "乑" Then
            
            Dim objOutlookApp As Outlook.Application
            Set objOutlookApp = New Outlook.Application
            Dim objAccount As Account
            '邮件附件对象

            Dim objAttachment As Outlook.Attachment
            With objOutlookApp
                For Each objAccount In .Session.Accounts
                    If objAccount.AccountType = olPop3 And objAccount.DisplayName = address Then
                        
                        Dim outlookApp As Outlook.Application
                        Dim outlookItem As Outlook.MailItem
                        
                        Set outlookApp = New Outlook.Application
                        Set outlookItem = outlookApp.CreateItem(olMailItem)
                        
                        body = readText(ThisWorkbook.Path & "\" & sht.Range("I5"))
                        body = sht.Range("C" & i) & Chr(10) & "扴摉幰孠" & Chr(10) & Chr(10) & body
                        
                        
                        
                        Dim toAddres As String
                        If sht.Range("I9") = "dev" Then
                            toAddres = sht.Range("I11")
                        Else
                            toAddres = sht.Range("D" & i)
                        End If
                        
                        
                        With outlookItem
                            .To = toAddres
                            .subject = subject
                            .body = body
                             For j = 0 To UBound(attachFileArr)
                                If attachFileArr(j) <> "" Then
                                    .Attachments.Add filepath + "\" + attachFileArr(j)
                                End If
                                
                             Next
                            '.Attachments.Add "C:\Users\Desktop\aa\XXX.pdf"
                            '.Attachments.Add "C:\Users\JDesktop\aa\FFF.pdf"
                            '.Send  因为不直接发送邮件所以此处注释掉，如果注释掉则是直接发送邮件
                        End With
                        outlookItem.Display ' 显示outlook的发送邮件的界面
                    End If
                Next
            End With
            
        End If
    Next
        
SendMail_Exit:
    Exit Sub

OpenOutlook_Error:
    MsgBox Err.Description
    Resume SendMail_Exit
End Sub


Function readText(filepath As String) As String
    Dim fso
    Dim f
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.OpenTextFile(filepath)
    readText = f.ReadAll
End Function

 

效果