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