EXCEL通过OUTLOOK2007自动发送邮件

EXCEL通过OUTLOOK2007自动发送邮件

Sub outlook发送()

'要预先对outlook进行配置，请先在VBA的<工具/引用>中引用microsoft outlook 9.0 objrct

Dim myOlApp As New Outlook.Application With myOlApp.CreateItem(olMailItem)

.Attachments.Add ThisWorkbook.FullName '附件 .To = \邮箱地址 .Subject = \请审批文件申请书\主题

.Body = \文件申请书已填写完毕，请审批\正文 .CC = \抄送 .ReadReceiptRequested = True .Importance = olImportanceHigh .Display

.Send '发送 End With

Set myOlApp = Nothing End Sub

Private Sub CommandButton1_Click() 'if CheckBox1.Value = True Then 'MsgBox (\'End If

Application.DisplayAlerts = False '在程序执行过程中使出现的警告框不显示 Application.ScreenUpdating = False '关闭屏幕刷新

Dim myOlApp As New Outlook.Application Call outlook发送

Application.ScreenUpdating = True '打开屏幕刷新

Application.DisplayAlerts = True '在程序执行过程中出现的警告框

End Sub

Private Sub CommandButton1_Click()

Dim objOL As Object

Dim itmNewMail As Object

'引用Microsoft Outlook 物件模型

Dim mytile As String Dim youname As String Dim mybody As String

Dim mysheet As Worksheet

Set mysheet = ThisWorkbook.Sheets(\发送邮件界面\Dim FasongName As String '发送人员名单 Dim myword As String Dim mychaos As String

Dim lastrow As Integer '定义最后一行

Dim i As Integer

lastrow = mysheet.[I65536].End(xlUp).Row For i = 5 To lastrow

FasongName = mysheet.Cells(i, 9)

mychaos = mysheet.Cells(i, 12) '抄送人员名单

Set objOL = CreateObject(\Set itmNewMail = objOL.CreateItem(olMailItem) mytile = mysheet.Cells(19, 2)

myword = mysheet.Cells(10, 2) & mysheet.Cells(i, 10) & Chr(10) & _

mysheet.Cells(11, 2) & Chr(10) & mysheet.Cells(12, 2) & mysheet.Cells(i, 11) & \

mysheet.Cells(13, 2) & Chr(10) & _ mysheet.Cells(14, 2) With itmNewMail

.Subject = mysheet.Cells(8, 2) '主旨

.Body = myword '本文

.To = FasongName '收件者 .CC = mychaos '抄送邮件

'.CC = \抄送邮件 '.BCC = \密件抄送 If mytile <> \

.Attachments.Add mytile End If

.Display '啟動視窗

.Send End With

'On Error GoTo continue SendEmail:

' AppActivate itmNewMail ' DoEvents

'SendKeys \ ' DoEvents

'AppActivate itmNewMail

' GoTo SendEmail '发送不成功誓不罢休 'continue:

' On Error GoTo 0 Set objOL = Nothing

Set itmNewMail = Nothing

Next i

参考下面的VBA代码

Sub Send_Email()

Dim i As Integer

Dim MyOutlookApp As Outlook.Application Dim MyFolder As Outlook.MAPIFolder Dim MyNewMail As Outlook.MailItem

Dim MyAttachments As Outlook.Attachments '附件

Set MyOutlookApp = New Outlook.Application

Set MyFolder = MyOutlookApp.GetNamespace( \\我的邮件文件夹 \

Set MyNewMail = MyOutlookApp.CreateItem(olMailItem) With MyNewMail

.To = \ '目标邮件地址

.Cc=\

.Subject = \ '标题

.HTMLBody = \ is red

.AlternateRecipientAllowed = True '此邮件可转发 .AutoForwarded = True '此邮件允许自动转发

.DeleteAfterSubmit = False '发送后保留副本

'发送之后移动到指定文件夹

.SaveSentMessageFolder = MyOutlookApp.GetNamespace( \

\备份文件夹 \

.ReadReceiptRequested = True 求收件人回执

'SaveSentMessageFolder End With '附件

Set MyAttachments = MyNewMail.Attachments MyAttachments.Add \ olByValue MyNewMail.Save '保存 MyNewMail.Send '发送

MyFolder.Display '显示office outlook End Sub

'要

本文来源：https://www.bwwdw.com/article/2axf.html