Sub QQ1722187970()
Dim oWk As Worksheet
Set oWk = Sheet12
Dim oRng As Range
Set oRng = oWk.Range("B2").CurrentRegion
Dim sPath As String
sPath = Excel.ThisWorkbook.Path & "\"
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 Like "工作*" Then
'一封邮件对象
Dim objMailItem As Outlook.MailItem
Set objMailItem = .CreateItem(olMailItem)
With objMailItem
'收件人,多个收件人用分号间隔
.To = "1722187970@qq.com"
'抄送人
.CC = "1722187970@qq.com"
'密件抄送人
.BCC = "1722187970@qq.com"
'邮件主题
.Subject = "New Test"
'邮件内容格式
.BodyFormat = olFormatRichText
'邮件的内容
.HTMLBody = Range2Html(oRng)
'要添加的附件
' .Attachments.Add sPath & "Test.xlsx"
objMailItem.SendUsingAccount = objAccount
' 显示对话框
.Display
'开始发送邮件
.Send
End With
End If
Next
End With
End Sub