如何在Outlook中使用宏发送邮件，并且使用已有签名？

在工作中有一些邮件是常常需要发送，但是模式却是比较类似。

例如：日报邮件

收件人，主题，签名基本一致，除了主题中的日期需要更改之外

其他都可以采用一个模板来实现。

干脆写一个VBA函数来完成这个任务。

实践发现outlook中是不支持宏的录制的，这样就带来了一些麻烦。

在网上搜来搜去，找到了VBA编程发邮件的代码如下：'新建邮件Set OutApp = CreateObject("Outlook.Application") '创建outlook对象

OutApp.Session.Logon '登录MAPI

Set OutMail = OutApp.CreateItem(olMailItem) '新建邮件对象

'设置邮件标题、收件人、等等

With OutMail

.To = strTo'收件人

.CC = strCC'抄送

.BCC = ""

.Subject = strSubject'主题

其中主题可以读取当前日期

mDate = Format(Now, "yyyy-MM-dd")

strSubject="[日报]" &mDate

这样执行这个宏时，一封带当前日期标题的邮件已经生成好了，等待发送

设置邮箱账号，就是设置电子邮箱地址格式。一般的电子邮箱格式是，用户名@邮箱域名.COM。如果您是qq邮箱，邮箱地址就是您qq的数字账号@qq.com,例如您的qq号码是：1234，邮箱地址是[email protected]。

QQ邮箱现在除了默认开通的数字账号邮箱地址以外，它还支持英文账号、foxmail.com的账号以及手机账号，这些账号都是通过一个邮箱来管理。

如需这些账号，需要到网页版邮箱，账号管理中开通相关邮箱即可，如果您已经开通这些账号，同样需要在设置邮箱账号中查看这些账号正确的邮箱地址再去填写。

条件:从当前用户桌面的Excel表获取数据源,Excel表数据源的名字从用户D盘的1.xls Sheet1!A1获取

运行第一个宏加载数据库必须先打开一个Excel表,否则会出错

运行第二个宏合并1-6条记录至桌面,并关闭

由于第一次写这种东东 好多地方还要优化,稍候在附上,后面将将实现一键实现从数据加载到合并至指定位置,简化大家的工作量

第一个宏编写:

Sub 加载数据库()

'

' 加载数据库 Macro

' 宏在 2011-6-11 由 雨林木风 录制

'

chan = DDEInitiate(app:="Excel", topic:="system") '打开一个DDE通道

DDEExecute channel:=chan, Command:="[open(" &Chr(34) &"D:\1.xls" &Chr(34) &")]" '在一个应用程序中执行打开.xls文件命令，需要指出的是，系统要求所需文件必须放在D盘。

DDETerminate channel:=chan '关闭DDE通道

chan = DDEInitiate(app:="Excel", topic:="D:\1.xls") '打开一个DDE通道

Dim s As String

Dim q As String

Dim y As String

s = DDERequest(channel:=chan, Item:="R1C1")

DDETerminateAll

Dim excelClose As Object

Set excelClose = GetObject(, "Excel.Application")

excelClose.workbooks("1.xls").Close False

y = Left(s, Len(s) - 1)

q = "C:\Documents and Settings\" &Environ("USERNAME") &"\桌面\" &y &".xls"

ActiveDocument.MailMerge.OpenDataSource Name:=q, _

ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _

AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _

WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _

Format:=wdOpenFormatAuto, Connection:= _

"Provider=Microsoft.Jet.OLEDB.4.0Password=""""User ID=AdminData Source=qMode=ReadExtended Properties=""HDR=YESIMEX=1""Jet OLEDB:System database=""""Jet OLEDB:Registry Path=""""Jet OLEDB:Data" _

, SQLStatement:="SELECT * FROM `Sheet1$`", SQLStatement1:="", SubType:= _

wdMergeSubTypeAccess

End Sub

第二个宏已经变相的实现:多谢这个帖子:http://club.excelhome.net/thread-729315-1-1.html

下面是代码:

Sub 保存至桌面()

'主文档的类型为信函

'合并全部数据记录

'假设主文档已链接好数据源，可以进行正常的邮件合并

Dim myMerge As MailMerge, i As Integer, myname As String

Application.ScreenUpdating = False

Set myMerge = ActiveDocument.MailMerge

With myMerge.DataSource

If .Parent.State = wdMainAndDataSource Then

.ActiveRecord = wdFirstRecord

.FirstRecord = 1

.LastRecord = 6

.Parent.Destination = wdSendToNewDocument

'取得数据源第1个和第2个字段（合并域）的当前数据字符串，用以命名文件，根据需要增减修改

myname = .DataFields(9).Value &" （" &.DataFields(35).Value &"Km" &"）"

.ActiveRecord = wdNextRecord

.Parent.Execute '每次合并一个数据记录

With ActiveDocument

.Content.Characters.Last.Previous.Delete '删除分节符

.SaveAs "C:\Documents and Settings\" &Environ("USERNAME") &"\桌面\" &myname &".doc" '假设生成的各文档保存于c盘桌面

.Close '关闭生成的文档（已保存）

End With

End If

End With

End Sub

---