Using a loop for a function

Question

I want to use a loop for a function that i wrote.

I have a table tbl-planung with round about 65 entries and a listbox in my form named lstPlanung that displays all the entries.

Each entry got an ID a CompName and some mailadresses related to the company.

ID         Company            Mail

1          CompName           mail1@compname.com  
                              mail2@compname.com

2          CompName2          mail1@compname2.com
                              mail2@compname2.com
                              mail3@compname2.com

I wrote a function that is creating a mail and opens Outlook with all the recepients matching the CompName.

Private Sub SendKunde_Click()
    Call sendemailKunde
End Sub

Function

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: &quot;Arial&quot;,&quot;sans-serif&quot;;"">"
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: &quot;Arial&quot;,&quot;sans-serif&quot;;"" > "
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

Is it possible to wrap my function into a loop that i dont have to select every entry in my listbox manually?

I though about a button and a function sendemailAll thats opens automatically a new mail in Outlook for each id in my listbox.

At this moment i have to select every entry in the listbox, click a button and send the mail via outlook.

EDIT :

I thought about something like:

Mail1 

ID:1 CompName  TO:  mail1@compname.com;  mail2@compname.com    

Mail2

ID2: CompName2 TO:  mail1@compname2.com; mail2@compname2.com; mail3@compname2.com

The solution from R3uK looks like this:

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

thats what i want to do. i need a loop over the listbox entries in my form. I want to create a mail for each ID in my listbox including every recepient matching the ID. — rel0aded0ne, Feb 13 '17 at 11:17
well google the listbox msdn, google how to do this https://msdn.microsoft.com/en-us/library/bb243789(v=office.12).aspx for example or http://stackoverflow.com/questions/2933113/cycling-through-values-in-a-ms-access-list-box — Nathan_Sav, Feb 13 '17 at 11:20

R3uK · Accepted Answer · 2017-02-13T15:49:08.517

Yes you can, you'll just have to create another sub with 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

And the sub function, you might have to add zentral2 as an Argument or set it a Public variable to have the value in that sub :

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: &quot;Arial&quot;,&quot;sans-serif&quot;;"">"
    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: &quot;Arial&quot;,&quot;sans-serif&quot;;"" > "
    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

Another approach for the loops :

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

The loop is working but not correctly. Outlook is opening a new mail for every Recipient and not for every ID. I thought about a loop that creates one mail for each ID in my listbox. Right now outlook is opening 2 new mails. the first mail has one recepient and the second mail got 2 recpients. — rel0aded0ne, Feb 13 '17 at 11:00
@rel0aded0ne : I've added a test on the ID to compile mails before sending, you just might have to sort by ID in your query to make it work properly! — R3uK, Feb 13 '17 at 11:31
i dont get it. to me it looks like a faulty loop. Isnt it possible to create a loop like `for each entry of lstPlanung -> Call sendemailAll' to create my emails? — rel0aded0ne, Feb 13 '17 at 12:00
i tried a for loop: **For i = 0 To Me!lstPlanung.ListCount - 1 Call sendemailKUNDE Next i** this seems to work a little better but the function is creating the amount of mails only for my first listbox entry and not for every entry. Entry1 should be one Mail, Entry2 should be another mail and so on. — rel0aded0ne, Feb 13 '17 at 12:12
what do you mean with "IDCompName = d![ID]" ? i get runtime error: Run Time Error 3265 - Item not found in this collection. — rel0aded0ne, Feb 13 '17 at 13:51
@rel0aded0ne : `ID` was supposed to be your fields for `ID2: CompName2`, I don't know what it is excatly — R3uK, Feb 13 '17 at 13:53
Let us [continue this discussion in chat](http://chat.stackoverflow.com/rooms/135593/discussion-between-rel0aded0ne-and-r3uk). — rel0aded0ne, Feb 13 '17 at 13:54

Using a loop for a function

EDIT :

1 Answers1