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 = "albert.chen@https://www.wendangku.net/doc/0210289711.html," '邮箱地址
.Subject = "请审批文件申请书" '主题
.Body = "文件申请书已填写完毕，请审批" '正文
.CC = "albert.chen@https://www.wendangku.net/doc/0210289711.html," '抄送
.ReadReceiptRequested = True
.Importance = olImportanceHigh
.Display
.Send '发送
End With
Set myOlApp = Nothing
End Sub
Private Sub CommandButton1_Click()
'if CheckBox1.Value = True Then
'MsgBox ("xuanzhong")
'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("Outlook.Application")
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 = "tanweiming001@https://www.wendangku.net/doc/0210289711.html," '抄送邮件
'.BCC = "tanweiming001@https://www.wendangku.net/doc/0210289711.html," '密件抄送
If mytile <> "" Then
.Attachments.Add mytile
End If
.Display '啟動視窗
.Send
End With
'On Error GoTo continue
SendEmail:
' AppActivate itmNewMail
' DoEvents
'SendKeys "%s", Wait:=True
' 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( "MAPI ").GetDefaultFolder(olFolderInbox).Folders( "我的邮件文件夹")
Set MyNewMail = MyOutlookApp.CreateItem(olMailItem)
With MyNewMail
.To = "YourFridentMail@https://www.wendangku.net/doc/0210289711.html, "
'目标邮件地址
.Cc="aaa@https://www.wendangku.net/doc/0210289711.html,"
.Subject = "test "
'标题
.HTMLBody = "
This is red
".AlternateRecipientAllowed = True '此邮件可转发
.AutoForwarded = True
'此邮件允许自动转发
.DeleteAfterSubmit = False '发送后保留副本
'发送之后移动到指定文件夹
.SaveSentMessageFolder =
MyOutlookApp.GetNamespace( "MAPI
").GetDefaultFolder(olFolderInbox).Folders( "备份文件夹")
.ReadReceiptRequested = True '要求收件人回执
'SaveSentMessageFolder
End With
'附件
Set MyAttachments = MyNewMail.Attachments
MyAttachments.Add "c:\win\abc.txt ", olByValue
MyNewMail.Save '保存
MyNewMail.Send '发送
MyFolder.Display '显示office outlook
End Sub