我想为我编写的函数使用循环。
我有一个表tbl-planung，其中有大约65个条目，我的表单中有一个名为lstPlanung的列表框，显示所有条目。
每个条目都有一个ID CompName和一些与公司相关的mailadresses。
ID Company Mail
1 CompName mail1@compname.com
mail2@compname.com
2 CompName2 mail1@compname2.com
mail2@compname2.com
mail3@compname2.com
我编写了一个创建邮件的函数，并打开所有与CompName匹配的收件人的Outlook。
Private Sub SendKunde_Click()
Call sendemailKunde
End Sub
功能
Sub sendemailKunde()
'Empfänger werden ausgelesen und an Outlook übergeben
Dim ThisDB As DAO.Database
Set ThisDB = CurrentDb
Dim d As DAO.Recordset
Dim q As String
q = "SELECT DISTINCT [tbl-apartner].[EMail] FROM [tbl-apartner] WHERE [tbl-apartner].[HID] = " & "'" & hid2 & "'" 'sql query
Set d = ThisDB.OpenRecordset(q, dbOpenDynaset)
Dim Result As String
Result = ""
If d.EOF = False Or d.BOF = False Then 'if-else clause
d.MoveFirst
Do While Not d.EOF
If Result <> "" Then Result = Result & "; "
Result = Result & d!EMail
d.MoveNext
Loop
End If
d.Close
'MsgBox Result 'Testausgabe
'Empfänger auslesen beendet (Variable Result beinhaltet alle Mailadressen zum Kunden)
Dim strHTML
Dim strHTMLDZ
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
On Error Resume Next 'verhindert Error 429 Outlook nicht geöffnet
Err.Clear
Set oOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set oOutlook = New Outlook.Application
End If
' Mail für Zentrale Systeme
strHTML = "<html>"
strHTML = strHTML & " <head>"
strHTML = strHTML & " </head>"
strHTML = strHTML & " <body>"
strHTML = strHTML & " <span style=""font-size: 12pt; font-family: "Arial","sans-serif";"">"
strHTML = strHTML & " MAILTEXT-1"
strHTML = strHTML & " </span>"
strHTML = strHTML & " </body>"
strHTML = strHTML & "</html>"
' Mail für dezentrale Systeme
strHTMLDZ = strHTMLDZ & "<html>"
strHTMLDZ = strHTMLDZ & "<head>"
strHTMLDZ = strHTMLDZ & "</head>"
strHTMLDZ = strHTMLDZ & "<body>"
strHTMLDZ = strHTMLDZ & " <span style=""font-size: 12pt; font-family: "Arial","sans-serif";"" > "
strHTMLDZ = strHTMLDZ & " MAILTEXT-2"
strHTMLDZ = strHTMLDZ & " </span>"
strHTMLDZ = strHTMLDZ & " </body>"
strHTMLDZ = strHTMLDZ & "</html>"
Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
'.CC = "TEST@TEST.de" <- optional
'.To = Me.mail2 <- Empfänger = TextBox mail2
.SentOnBehalfOfName = "MAIL@DOM.DE"
.To = Result
.Subject = "SAP Patche - " & sid2 & " am: " & datum2 & " um: " & uhr2 & " Uhr"
If zentral2 < 0 Then
.HTMLBody = strHTML
Else
.HTMLBody = strHTMLDZ
End If
.Display
End With
Set oEmailItem = Nothing
Set oOutlook = Nothing
End Sub
是否可以将我的函数包装到一个循环中，我不必手动选择列表框中的每个条目？
我虽然关于一个按钮和一个函数sendemailAll，它会在我的列表框中为每个id自动打开Outlook中的新邮件。
此时我必须选择列表框中的每个条目，单击按钮并通过outlook发送邮件。
我想到了类似的东西：
Mail1
ID:1 CompName TO: mail1@compname.com; mail2@compname.com
Mail2
ID2: CompName2 TO: mail1@compname2.com; mail2@compname2.com; mail3@compname2.com
R3uK的解决方案如下：
Mail1
ID:1 CompName TO: mail1@compname.com
Mail2
ID:1 CompName TO: mail1@compname.com; mail2@compname.com
Mail3
ID2: CompName2 TO: mail1@compname2.com
Mail4
ID2: CompName2 TO: mail1@compname2.com; mail2@compname2.com
Mail5
ID2: CompName2 TO: mail1@compname2.com; mail2@compname2.com; mail3@compname2.com
答案 0 :(得分：1)
是的，你可以，你只需要创建另一个带有Arguments的子
Sub sendemailKunde()
'Empfänger werden ausgelesen und an Outlook übergeben
Dim ThisDB As DAO.Database
Set ThisDB = CurrentDb
Dim d As DAO.Recordset
Dim q As String
Dim Result As String
Dim IDCompName As String
q = "SELECT [tbl-apartner].[EMail], [tbl-apartner].[SID] FROM [tbl-apartner] WHERE [tbl-apartner].[HID] = " & "'" & hid2 & "'" & " ORDER BY [tbl-apartner].[SID]" 'sql query
Set d = ThisDB.OpenRecordset(q, dbOpenDynaset)
Result = vbNullString
If d.EOF = False Or d.BOF = False Then 'if-else clause
d.MoveFirst
IDCompName = d!SID
Do While Not d.EOF
If IDCompName <> d!SID Then
'''Send the mail here
If Len(Result) > 2 Then
Result = Left(Result, Len(Result) - 2)
Send_Mail_for_loop Result
Else
End If
'''Prep result for the next ID
Result = d!Email & "; "
IDCompName = d!SID
Else
Result = Result & d!Email & "; "
End If
d.MoveNext
Loop
End If
d.Close
'MsgBox Result 'Testausgabe
End Sub
对于子函数，您可能必须将zentral2添加为参数或将其设置为Public变量以使该子函数具有该值：
Private Sub Send_Mail_for_loop(ByVal RecipientsMail As String)
'Empfänger auslesen beendet (Variable Result beinhaltet alle Mailadressen zum Kunden)
Dim strHTML As String
Dim strHTMLDZ As String
Dim oOutlook As Outlook.Application
Dim oEmailItem As Outlook.MailItem
On Error Resume Next 'verhindert Error 429 Outlook nicht geöffnet
Err.Clear
Set oOutlook = GetObject(, "Outlook.Application")
If oOutlook Is Nothing Then Set oOutlook = New Outlook.Application
On Error GoTo 0
' Mail für Zentrale Systeme
strHTML = "<html>"
strHTML = strHTML & " <head>"
strHTML = strHTML & " </head>"
strHTML = strHTML & " <body>"
strHTML = strHTML & " <span style=""font-size: 12pt; font-family: "Arial","sans-serif";"">"
strHTML = strHTML & " MAILTEXT-1"
strHTML = strHTML & " </span>"
strHTML = strHTML & " </body>"
strHTML = strHTML & "</html>"
' Mail für dezentrale Systeme
strHTMLDZ = strHTMLDZ & "<html>"
strHTMLDZ = strHTMLDZ & "<head>"
strHTMLDZ = strHTMLDZ & "</head>"
strHTMLDZ = strHTMLDZ & "<body>"
strHTMLDZ = strHTMLDZ & " <span style=""font-size: 12pt; font-family: "Arial","sans-serif";"" > "
strHTMLDZ = strHTMLDZ & " MAILTEXT-2"
strHTMLDZ = strHTMLDZ & " </span>"
strHTMLDZ = strHTMLDZ & " </body>"
strHTMLDZ = strHTMLDZ & "</html>"
Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
'.CC = "TEST@TEST.de" <- optional
'.To = Me.mail2 <- Empfänger = TextBox mail2
.SentOnBehalfOfName = "MAIL@DOM.DE"
.To = RecipientsMail
.Subject = "SAP Patche - " & sid2 & " am: " & datum2 & " um: " & uhr2 & " Uhr"
If zentral2 < 0 Then
.HTMLBody = strHTML
Else
.HTMLBody = strHTMLDZ
End If
.Display
End With
Set oEmailItem = Nothing
Set oOutlook = Nothing
End Sub
循环的另一种方法：
Sub sendemailKunde()
'Empfänger werden ausgelesen und an Outlook übergeben
Dim ThisDB As DAO.Database
Set ThisDB = CurrentDb
Dim d As DAO.Recordset
Dim q As String
Dim d2 As DAO.Recordset
Dim q2 As String
Dim Result As String
Dim IDCompName As String
q = "SELECT DISTINCT [tbl-apartner].[SID] FROM [tbl-apartner] " & _
"WHERE [tbl-apartner].[HID] = " & "'" & hid2 & "' " & _
"ORDER BY [tbl-apartner].[SID]" 'sql query
Set d = ThisDB.OpenRecordset(q, dbOpenDynaset)
If d.EOF = False Or d.BOF = False Then 'if-else clause
d.MoveFirst
Do While Not d.EOF
Result = vbNullString
q2 = "SELECT DISTINCT [tbl-apartner].[EMail] FROM [tbl-apartner] " & _
"WHERE [tbl-apartner].[HID] = " & "'" & hid2 & "' " & _
"AND [tbl-apartner].[SID] = '" & d!SID & _
"' ORDER BY [tbl-apartner].[SID]"
Set d2 = ThisDB.OpenRecordset(q2, dbOpenDynaset)
If d2.EOF = False Or d2.BOF = False Then
d2.MoveFirst
Do While Not d2.EOF
Result = Result & d2!Email & "; "
d2.MoveNext
Loop
End If
d2.Close
If Len(Result) > 2 Then
Result = Left(Result, Len(Result) - 2)
Send_Mail_for_loop Result
Else
End If
d.MoveNext
Loop
End If
d.Close
'MsgBox Result 'Testausgabe
End Sub