偶看新闻我们并非相逢在眼前:Excel VBA在EXCEL中调用OUTLOOK发送邮件
来源：百度文库 编辑：偶看新闻 时间：2024/05/03 09:45:23
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 "发送邮件完毕！", 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
多个邮件地址
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 "请在“Mail”工作表中输入邮件地址！", 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 '发送邮件
End Sub