邮件群发-不同邮件发不同人(从excel,利用notes)
Sub 保存到草稿箱()
Dim noSession As Object, noDatabase As Object 'noSession ?? noDatabase ??
Dim noDocument As Object, noAttachment As Object 'noDocument ?? noAttachment ??
Dim I%, FileSelf$, j As Integer 'stMsg$, 'I=邮件数量 stMsg=.Body 邮件信体 FileSelf j
Dim vaRecipient() As String 'vaRecipient=.sendto 邮件地址
Dim vaFiles() As String 'vaFiles 附件地址和路径
Dim stMsg() As String '修改原程序，将邮件信体设置为字符串数组
Dim stSubject() As String '修改原程序，将邮件标题设置为字符串数组
Dim sh As Shape 'sh
' stMsg = "Best & Regards" & vbCrLf & _
' https://www.360docs.net/doc/1713501411.html,erName & vbCrLf & _
' vbCrLf & _
' "--------------------------------------------------------------------------" & vbCrLf & _
' "(重要文件，因涉及个人奖金评价，请重视。)" & vbCrLf & _
' "(填写完毕后，请及时上交给我，谢谢。)"
'**** 取消原程序用窗体控件的部分，改为用特征字列
' I = 0
' ReDim vaRecipient(ActiveSheet.Shapes.Count - 1) As String '邮件地址数组的大小=活动勾选框-1
' ReDim vaFiles(ActiveSheet.Shapes.Count - 1) As String '附件地址和路径数据数组的大小=活动勾选框-1
' ReDim stMsg(ActiveSheet.Shapes.Count - 1) As String '邮件信体数组的大小=活动勾选框-1
' ReDim stSubject(ActiveSheet.Shapes.Count - 1) As String '邮件主题数据的大小=活动勾选框-1
'
' For Each sh In ActiveSheet.Shapes
' If sh.Type = msoFormControl Then 'msofromcontrol=窗体控件
' If sh.FormControlType = xlCheckBox Then 'xlcheckbox=复选框
' If sh.ControlFormat.Value = 1 Then '找出勾选的邮件地址
' vaRecipient(I) = sh.BottomRightCell.Offset(0, 1) '勾选框右边第一列为邮件地址
' vaFiles(I) = sh.BottomRightCell.Offset(0, 2) '勾选框右边第二列为附件地址和路径
' stSubject(I) = sh.BottomRightCell.Offset(0, 3) '勾选框右边第三列为邮件标题
' stMsg(I) = vbCrLf & sh.BottomRightCell.Offset(0, 4) & vbCrLf '勾选框右边第四列为邮件信体
' I = I + 1
' End If
' End If
' End If
' Next
lastrow = Range("A65536").End(xlUp).Row '查找范围
erow = 0
For I =
1 To lastrow '计算发送邮件的有效数量
If Cells(I, "A") = "发送" Then erow = erow + 1
Next
ReDim vaRecipient(erow - 1) As String '邮件地址数组的大小=有效数量-1
ReDim vaFiles(erow - 1) As String '附件地址和路径数据数组的大小=有效数量-1
ReDim stMsg(erow - 1) As String '邮件信体数组的大小=有效数量-1
ReDim stSubject(erow - 1) As String '邮件主题数据的大小=有效数量-1
I = 0
For j = 1 To lastrow
If Cells(j, "A") = "发送" Then
vaRecipient(I) = Cells(j, "B") '邮件地址
vaFiles(I) = Cells(j, "C") '附件地址和路径
stSubject(I) = "" & Cells(j, "D") '邮件标题
stMsg(I) = vbCrLf & Cells(j, "E") '邮件内容
I = I + 1
End If
Next
If I = 0 Then MsgBox "没有邮件需要发送": Exit Sub '没有勾选，结束程序
'ReDim Preserve vaRecipient(I - 1) As String '原程序就已注释掉
'vaFiles = Application.GetOpenFilename(FileFilter:="File Filer (*.*),*.*", Title:="Attach files for outgoing E_Mail ", MultiSelect:=True) '原程序就已注释掉
'If Not IsArray(vaFiles) Then Exit Sub '原程序就已注释掉
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
For j = 0 To I - 1 '循环发送
Set noDocument = noDatabase.CreateDocument
Set noAttachment = noDocument.CreateRichTextItem("Body1") '
With noAttachment
.EmbedObject EMBED_ATTACHMENT, "", vaFiles(j) '添加附件
End With
With noDocument
.Form = "Memo"
.sendto = vaRecipient(j) '添加邮件地址
.Subject = stSubject(j) '添加邮件标题
.Body = stMsg(j) '添加邮件信体
' .SaveMessageOnSend = True '发送保存
' .PostedDate = Now() '立即发送？？
' .Send 0 '立即发送？？
Call noDocument.Save(True, False)
End With
Set noDocument = Nothing
Next j
Set noDatabase = Nothing
Set noSession = Nothing
AppActivate "Microsoft Excel"
MsgBox "邮件保存完毕", vbInformation
End Sub
Sub 直接发送()
Dim noSession As Object, noDatabase As Object 'noSession ?? noDatabase ??
Dim noDocument As Object, noAttachment As Object 'noDocument ?? noAttachment ??
Dim I%, FileSelf$, j As Integer 'stMsg$, 'I=邮件数量 stMsg=.Body 邮件信体 FileSelf j
Dim vaRecipient() As String 'vaRecipient=.sendto 邮件地址
Dim vaFiles() As String 'vaFiles 附件地址和路径
Dim stMsg() As String '修改原程序，将邮件信体设置为字符串数组
Dim stSubject() As String '修改原程序，将邮件标题设置为字符串数组
Dim sh As Shape 'sh
' stMsg = "Best & Regards" & vbCrLf & _
' https://www.360docs.net/doc/1713501411.html,erName & vbCrLf & _
' vbCrLf & _
' "--------------------------------------------------------------------------" & vbCrLf & _
' "(重要文件，因涉及个人奖金评价，请重视。)" & vbCrLf & _
' "(填写完毕后，请及时上交给我，谢谢。)"
'**** 取消原程序用窗体控件的部分，改为用特征字列
' I = 0
' ReDim vaRecipient(ActiveSheet.Shapes.Count - 1) As String '邮件地址数组的大小=活动勾选框-1
' ReDim vaFiles(ActiveSheet.Shapes.Count - 1) As String '附件地址和路径数据数组的大小=活动勾选框-1
' ReDim stMsg(ActiveSheet.Shapes.Count - 1) As String '邮件信体数组的大小=活动勾选框-1
' ReDim stSubject(ActiveSheet.Shapes.Count - 1) As String '邮件主题数据的大小=活动勾选框-1
'
' For Each sh In ActiveSheet.Shapes
' If sh.Type = msoFormControl Then 'msofromcontrol=窗体控件
' If sh.FormControlType = xlCheckBox Then 'xlcheckbox=复选框
' If sh.ControlFormat.Value = 1 Then '找出勾选的邮件地址
' vaRecipient(I) = sh.BottomRightCell.Offset(0, 1) '勾选框右边第一列为邮件地址
' vaFiles(I) = sh.BottomRightCell.Offset(0, 2) '勾选框右边第二列为附件地址和路径
' stSubject(I) = sh.BottomRightCell.Offset(0, 3) '勾选框右边第三列为邮件标题
' stMsg(I) = vbCrLf & sh.BottomRightCell.Offset(0, 4) & vbCrLf '勾选框右边第四列为邮件信体
' I = I + 1
' End If
' End If
' End If
' Next
lastrow = Range("A65536").End(xlUp
).Row '查找范围
erow = 0
For I = 1 To lastrow '计算发送邮件的有效数量
If Cells(I, "A") = "发送" Then erow = erow + 1
Next
ReDim vaRecipient(erow - 1) As String '邮件地址数组的大小=有效数量-1
ReDim vaFiles(erow - 1) As String '附件地址和路径数据数组的大小=有效数量-1
ReDim stMsg(erow - 1) As String '邮件信体数组的大小=有效数量-1
ReDim stSubject(erow - 1) As String '邮件主题数据的大小=有效数量-1
I = 0
For j = 1 To lastrow
If Cells(j, "A") = "发送" Then
vaRecipient(I) = Cells(j, "B") '邮件地址
vaFiles(I) = Cells(j, "C") '附件地址和路径
stSubject(I) = Cells(j, "D") '邮件标题
stMsg(I) = vbCrLf & Cells(j, "E") '邮件内容
I = I + 1
End If
Next
If I = 0 Then MsgBox "没有邮件需要发送": Exit Sub '没有勾选，结束程序
'ReDim Preserve vaRecipient(I - 1) As String '原程序就已注释掉
'vaFiles = Application.GetOpenFilename(FileFilter:="File Filer (*.*),*.*", Title:="Attach files for outgoing E_Mail ", MultiSelect:=True) '原程序就已注释掉
'If Not IsArray(vaFiles) Then Exit Sub '原程序就已注释掉
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
For j = 0 To I - 1 '循环发送
Set noDocument = noDatabase.CreateDocument
Set noAttachment = noDocument.CreateRichTextItem("Body1") '
With noAttachment
.EmbedObject EMBED_ATTACHMENT, "", vaFiles(j) '添加附件
End With
With noDocument
.Form = "Memo"
.sendto = vaRecipient(j) '添加邮件地址
.Subject = stSubject(j) '添加邮件标题
.Body = stMsg(j) '添加邮件信体
.SaveMessageOnSend = True '发送保存
.PostedDate = Now() '立即发送？？
.Send 0 '立即发送？？
' Call noDocument.Save(True, False)
End With
Set noDocument = Nothing
Next j
Set noDatabase = Nothing
Set noSession = Noth
ing
AppActivate "Microsoft Excel"
MsgBox "邮件发送完毕", vbInformation
End Sub