呼叫outlook來發送郵件
阿新 • • 發佈:2021-07-08
背景
大批量的進行添附檔案和傳送郵件,如果一個一個操作的話比較慢,所以打算用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