EXCEL通过OUTLOOK2007自动发送邮件

partydang

   过去自己一直想通过EXCEL调用OUTLOOK2003以上版本发送邮件。

但是由于outlook的安全性控制，一直没有办法实现。

后来很巧的机会终于解决。
特献上程序代码

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@pingan.com" '抄送邮件
        '.BCC = "tanweiming001@pingan.com" '密件抄送
        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

   
End Sub

SWUCIM

Set itmNewMail = objOL.CreateItem(olMailItem) 这个olMailItem参数有什么意义吗？谢谢！

qhz

谢谢楼主，学习学习。

風中的雨點

这个正用的上。

lvbohan

完全不用这么麻烦...Publisher绝对是自制EDM的神器

jack_fay

谢谢楼主，学习学习

firefly169

SWUCIM 发表于 2013-2-28 17:51
Set itmNewMail = objOL.CreateItem(olMailItem) 这个olMailItem参数有什么意义吗？谢谢！

我进来也是想看看这句话有啥意义