需要vba中循环功能的帮助才能发送多封电子邮件
我有一个Excel VBA(Send_Mail)可以通过Lotus Notes发送电子邮件。它的工作很好,但我需要帮助发送个人电子邮件到多人在一次去 在我的excel表格中。单元格A7向下将是电子邮件地址,最多可达200多行,B7有主题行,单元格C7有电子邮件正文。(所有这些都将自动填充不同的宏)。然而,我的代码(Send_Mail)只向A7单元格中的地址发送了一封电子邮件。我需要您的帮助,将邮件发送到第A7栏及其相应主题(第B栏)和邮件正文(第C栏)中的所有电子邮件地址 下面是我的代码需要vba中循环功能的帮助才能发送多封电子邮件,vba,excel,email,Vba,Excel,Email,我有一个Excel VBA(Send_Mail)可以通过Lotus Notes发送电子邮件。它的工作很好,但我需要帮助发送个人电子邮件到多人在一次去 在我的excel表格中。单元格A7向下将是电子邮件地址,最多可达200多行,B7有主题行,单元格C7有电子邮件正文。(所有这些都将自动填充不同的宏)。然而,我的代码(Send_Mail)只向A7单元格中的地址发送了一封电子邮件。我需要您的帮助,将邮件发送到第A7栏及其相应主题(第B栏)和邮件正文(第C栏)中的所有电子邮件地址 下面是我的代码 Pub
Public TOID As String
Public CCID As String
Public SECT As String
Public ACCO As String
Public SUBJ As String
Sub Send_Mail()
Dim answer As Integer
answer = MsgBox("DO YOU HAVE LOTUS NOTES OPEN ?? Not WebLotus notes", vbYesNo + vbQuestion, "LOTUS NOTES")
If answer = vbNo Then
MsgBox "Please Open Notes and Try the Macro Again"
Exit Sub
Else
End If
Application.DisplayAlerts = False
Call Send
MsgBox "Mail Sent to " & (Range("L2").Value) & " " & "Recipents"
Application.DisplayAlerts = True
End Sub
Public Function Send()
SendEMail = True
Sheets("Main").Select
TOID = Range("A7").Value
CCID = ""
SUBJ = Range("B7").Value
'On Error GoTo ErrorMsg
Dim EmailList As Variant
Dim ws, uidoc, Session, db, uidb, NotesAttach, NotesDoc, objShell As Object
Dim RichTextBody, RichTextAttachment As Object
Dim server, mailfile, user, usersig As String
Dim SubjectTxt, MsgTxt As String
Set Session = CreateObject("Notes.NotesSession")
user = Session.UserName
usersig = Session.COMMONUSERNAME
mailfile = Session.GETENVIRONMENTSTRING("MailFile", True)
server = Session.GETENVIRONMENTSTRING("MailServer", True)
Set db = Session.GETDATABASE(server, mailfile)
If Not db.IsOpen Then
Call db.Open("", "")
Exit Function
End If
Set NotesDoc = db.CREATEDOCUMENT
With NotesDoc
.Form = "Memo"
.Subject = SUBJ 'The subject line in the email
.Principal = user
.sendto = TOID 'e-mail ID variable to identify whom email need to be sent
.CopyTo = CCID
End With
Set RichTextBody = NotesDoc.CREATERICHTEXTITEM("Body")
With NotesDoc
.COMPUTEWITHFORM False, False
End With
'==Now set the front end stuff
Set ws = CreateObject("Notes.NotesUIWorkspace")
If Not ws Is Nothing Then
Set uidoc = ws.EDITDOCUMENT(True, NotesDoc)
If Not uidoc Is Nothing Then
If uidoc.EDITMODE Then
'Mail Body
Sheets("Main").Select
Range("C7").Select
Dim rnBody1 As Range
Set rnBody1 = Selection
rnBody1.CopyPicture
'rnBody1.Copy
Call uidoc.GOTOFIELD("Body")
Call uidoc.Paste
End If
End If
End If
Call uidoc.Send
Call uidoc.Close
'close connection to free memory
Set Session = Nothing
Set db = Nothing
Set NotesAttach = Nothing
Set NotesDoc = Nothing
Set uidoc = Nothing
Set ws = Nothing
Sheets("Main").Select
End Function
我担心你会被太多的新细节弄糊涂,我必须承认我还没有测试过下面的代码,所以请不要认为这会彻底解决你的问题 下面让您了解如何按照要求使用循环。另请参见示例,该示例涵盖了可能需要批量发送的实例(诚然,链接用于Outlook),也是使用循环的示例 我在代码中包含了一些解释。如果没有更多的信息,很难对其进行适当调整,但我希望它能有所帮助
Option Explicit
Public TOID As String
Public CCID As String
Public SECT As String
Public ACCO As String
Public SUBJ As String
Public Sub Send_Mail()
Dim wb As Workbook
Dim ws1 As Worksheet
Set wb = ThisWorkbook 'These are assumptions
Set ws1 = wb.Worksheets("Sheet1") 'These are assumptions. You would change as necessary
Dim answer As Long 'Integer types changed to Long
answer = MsgBox("DO YOU HAVE LOTUS NOTES OPEN ?? Not WebLotus notes", vbYesNo + vbQuestion, "LOTUS NOTES")
If answer = vbNo Then
MsgBox "Please Open Notes and Try the Macro Again"
Exit Sub
'Else 'Not being used so consider removing
End If
Application.DisplayAlerts = False
Dim lRow As Long
Dim loopRange As Range
Dim currentRow As Long
Dim TOIDvar As String
Dim SUBJvar As String
With ws1
lRow = .Range("A7").End(xlDown).Row 'Assume no gaps in column A in the TOID range
Set loopRange = .Range("A7:A" & lRow)
For currentRow = 1 To loopRange.Rows.Count 'Loop range assigning values to arguments and call send sub with args
TOIDvar = loopRange.Cells(currentRow, 1)
SUBJvar = loopRange.Cells(currentRow, 1).Offset(0, 1) ' get column B in same row using Offset
Send TOIDvar, SUBJvar
Next currentRow
End With
'Commented out MsgBox at present as unsure what you will do when sending multiple e-mails
'MsgBox "Mail Sent to " & (ws1.Range("L2").Value) & " " & "Recipents" 'use explicit fully qualified Range references
Application.DisplayAlerts = True
End Sub
Public Sub Send(ByVal TOIDvar As String, ByVal SUBJvar As String) 'changed to sub using arguments
Dim SendEMail As Boolean 'declare with type
Dim wb As Workbook
Dim ws2 As Worksheet
Set wb = ThisWorkbook 'These are assumptions. Ensuring you are working with correct workbook
Set ws2 = wb.Worksheets("Main")
SendEMail = True
TOID = TOIDvar
CCID = vbNullString 'use VBNullString rather than empty string literals
SUBJ = SUBJvar
'On Error GoTo ErrorMsg
Dim EmailList As Variant 'declaration of separate lines and with their types
Dim ws As Object
Dim uidoc As Object
Dim Session As Object
Dim db As Object
Dim uidb As Object
Dim NotesAttach As Object
Dim NotesDoc As Object
Dim objShell As Object
Dim RichTextBody As Object
Dim RichTextAttachment As Object
Dim server As String
Dim mailfile As String
Dim user As String
Dim usersig As String
Dim SubjectTxt As String
Dim MsgTxt As String
Set Session = CreateObject("Notes.NotesSession")
user = Session.UserName
usersig = Session.COMMONUSERNAME
mailfile = Session.GETENVIRONMENTSTRING("MailFile", True)
server = Session.GETENVIRONMENTSTRING("MailServer", True)
Set db = Session.GETDATABASE(server, mailfile)
If Not db.IsOpen Then
db.Open vbNullString, vbNullString
Exit Sub
End If
Set NotesDoc = db.CREATEDOCUMENT
With NotesDoc
.Form = "Memo"
.Subject = SUBJ 'The subject line in the email
.Principal = user
.sendto = TOID 'e-mail ID variable to identify whom email need to be sent
.CopyTo = CCID
End With
Set RichTextBody = NotesDoc.CREATERICHTEXTITEM("Body")
With NotesDoc
.COMPUTEWITHFORM False, False
End With
'==Now set the front end stuff
Set ws = CreateObject("Notes.NotesUIWorkspace")
If Not ws Is Nothing Then
Set uidoc = ws.EDITDOCUMENT(True, NotesDoc)
If Not uidoc Is Nothing Then
If uidoc.EDITMODE Then
'Mail Body
With ws2.Range("C7")
Dim rnBody1 As Range
Set rnBody1 = .Value2
rnBody1.CopyPicture
'rnBody1.Copy
uidoc.GOTOFIELD "Body"
uidoc.Paste
End With
End If
End If
End If
uidoc.Send
uidoc.Close
'removed garbage collection
ws2.Activate ' swopped out .Select and used Worksheets collection held in variable ws2
End Sub
你可能想考虑这个问题。
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
宏将循环遍历“Sheet1”中的每一行,如果B列中有电子邮件地址
和C:Z列中的文件名。它将创建一封包含此信息的邮件并发送
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
子发送_文件()
“在Excel 2000-2016中工作
“有关提示,请参阅:http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp作为对象
将邮件变暗为对象
将sh设置为工作表
暗淡单元格作为范围
将文件单元设置为范围
变暗rng As范围
应用
.EnableEvents=False
.ScreenUpdate=False
以
设置sh=图纸(“图纸1”)
Set-OutApp=CreateObject(“Outlook.Application”)
对于sh.Columns(“B”).Cells.SpecialCells(xlCellTypeConstants)中的每个单元格
'在每行的C:Z列中输入路径/文件名
设置rng=sh.Cells(cell.Row,1).范围(“C1:Z1”)
如果单元格值像“*@*。?*”和_
Application.WorksheetFunction.CountA(rng)>0则
Set-OutMail=OutApp.CreateItem(0)
发邮件
.to=单元格.Value
.Subject=“Testfile”
.Body=“Hi”&单元格偏移量(0,-1).Value
对于rng.SpecialCells中的每个文件单元(xlCellTypeConstants)
如果修剪(文件单元)”,则
如果Dir(FileCell.Value)“,则
.Attachments.Add FileCell.Value
如果结束
如果结束
下一个文件单元
.Send'或use.Display
以
发送邮件=无
如果结束
下一个细胞
设置应用程序=无
应用
.EnableEvents=True
.ScreenUpdate=True
以
端接头
有关所有详细信息,请参阅此链接
我认为send函数可以是一个用参数调用的过程。这些参数可以是在A7向下范围的循环中指定的变量,例如,一个参数将把范围(“a”¤tRow)传递给sub,在sub中,将其分配给TOID,相同的B列和C列值(将这些值传递给当前行)。我认为这将是一个缓慢的过程。去掉。选择您正在使用的。看见使用option explicit并检查所有变量是否已声明和正确键入,例如Dim SendEmail为布尔值。您有很多变体,例如Dim ws,。。。。NotesAttach、NotesDoc、objShell作为对象,只有最后一个是对象。您还有一个空的Else子句。我认为在VBA中,你不需要在函数末尾进行垃圾收集,尽管其他人可能不同意。嗨,QHarr,我对这些代码非常陌生,不太了解。你能帮我清理这个代码和循环选项吗。谢谢你的帮助,我尝试运行代码,但在设置rnBody1=.Value2时出现运行时错误424如果您设置为单元格内的文本,则rbBody1应为字符串变量,此行应为rnBody1=.Value2,但我不确定,因为您正在执行rnBody1.CopyPicture。危险在于,这将成为一个扩展调试,以满足您的要求要求。也许只关注让循环部分工作,然后带着一个关于下一个需要解决的问题回来。