|
|
大家好！
我有个问题，我有一个邮件组，还有一个本人的邮件账户，需要同时给好多人发邮件，而且每个人发送的附件也不一样，用了一个宏程序来实现了这个功能；但是每次发出去的邮件是都默认的我本人的邮箱，我想用邮件组的那个发件人来发送，不知道在程序中如何实现，谢谢大家！
以下是宏程序，来自网络，谢谢分享的朋友！
Sub EmailMergeWithAttachments()
'
' EmailMergeWithAttachments Macro
'
Dim Source As Document, Maillist As Document
Dim Datarange As Range
Dim Counter As Integer, i As Integer
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim mysubject As String, message As String, title As String
Set Source = ActiveDocument
'检测Outlook是否正在运行。如果没有运行则打开Outlook
On Error Resume Next
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
'开打需要合并的邮件列表Word文档。
With Dialogs(wdDialogFileOpen)
.Show
End With
Set Maillist = ActiveDocument
' 显示输入对话框，输入需要加入到邮件中的邮件主题。
message = "为要合并发送的邮件输入一个邮件主题。" ' 设置提示符。
title = " 输入邮件主题" ' 设置标题栏。
'显示提示符和标题栏
mysubject = InputBox(message, title)
' 根据邮件列表Word文档处理需要插入到邮件中的附件。
Counter = 1
While Counter <= Maillist.Tables(1).Rows.Count
Source.Sections.First.Range.Copy
Documents.Add
Selection.Paste
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.Subject = mysubject
.Body = ActiveDocument.Content
Set Datarange = Maillist.Tables(1).Cell(Counter, 1).Range
Datarange.End = Datarange.End - 1
.To = Datarange
For i = 2 To Maillist.Tables(1).Columns.Count
Set Datarange = Maillist.Tables(1).Cell(Counter, i).Range
Datarange.End = Datarange.End - 1
.Attachments.Add Trim(Datarange.Text), olByValue, 1
Next i
.Send
End With
Set oItem = Nothing
ActiveDocument.Close wdDoNotSaveChanges
Counter = Counter + 1
Wend
' Outlook如果其是由宏操作打开的，则关闭Outlook。
If bStarted Then
oOutlookApp.Quit
End If
'释放系统资源。
Set oOutlookApp = Nothing
Source.Close wdDoNotSaveChanges
Maillist.Close wdDoNotSaveChanges
End Sub |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-12-14 12:04
