Attribute VB_Name = "OL_Makros"
Option Explicit

Sub SerienMail()
    'Ermöglicht das Aussenden von Serien-Mails an alle Empfänger einer
    'bestimmten Kategorie. Im Unterschied zur Verwendung von Verteilerlisten
    'erscheint nur eine einzelne Adresse im Empfänger-Feld. Darüber hinaus
    'generiert das Makro eine individuelle Anredeformel.
    '© 2000, Ralf Nebelo

    Dim objNameSpace As NameSpace
    Dim objKontaktOrdner As MAPIFolder
    Dim objKontakt As Object '"ContactItem" wäre korrekt, produziert aber Fehler bei Verteilerlisten
    Dim strKategorie As String
    Dim strBetreff As String
    Dim strAnrede As String
    Dim strText As String
    Dim strAnhang As String
    Dim intZähler As Integer

    Set objNameSpace = Outlook.Application.GetNamespace("MAPI")
    Set objKontaktOrdner = objNameSpace.GetDefaultFolder(olFolderContacts)
    
    With frmSerienMail
        .Show
        strKategorie = .txtKategorie.Text
        If strKategorie > "" Then
            strBetreff = .txtBetreff.Text
            strText = .txtText.Text
            If .txtAnhang.Text > "" And Dir(.txtAnhang.Text) > "" Then
                strAnhang = .txtAnhang.Text
            End If
            
            For Each objKontakt In objKontaktOrdner.Items
                'Verteilerlisten ausfiltern!!
                If objKontakt.Class = olContact Then
                    If InStr(objKontakt.Categories, strKategorie) > 0 And objKontakt.Email1Address > "" Then
                        intZähler = intZähler + 1
                        strAnrede = AnredeBilden(objKontakt.Title, objKontakt.LastName)
                        Call NachrichtSenden(objKontakt.Email1Address, strBetreff, strAnrede & strText, strAnhang)
                    End If
                End If
            Next
            MsgBox CStr(intZähler) & " Nachricht(en) verschickt.", , "SerienMail"
        End If
    End With
    
    Unload frmSerienMail
End Sub

Private Function AnredeBilden(Titel As String, Nachname As String) As String
    'Baut die Anredeformel für das Makro "SerienMail" zusammen.
    '© 2000, Ralf Nebelo
    
    Dim strTmp As String
    
    If Titel = "Herr" Then
        strTmp = "Sehr geehrter Herr " & Nachname
    ElseIf Titel = "Frau" Then
        strTmp = "Sehr geehrte Frau " & Nachname
    Else
        strTmp = "Sehr geehrte Damen und Herren"
    End If
    
    AnredeBilden = strTmp & "," & vbCr & vbCr
End Function

Private Sub NachrichtSenden(Adresse As String, Betreff As String, Text As String, Anhang As String)
    'Übernimmt das Versenden der einzelnen Mails im Auftrag des
    'Makros "SerienMail".
    '© 2000, Ralf Nebelo
    
    Dim objNachricht As MailItem
    Set objNachricht = Application.CreateItem(olMailItem)

    With objNachricht
        .Recipients.Add Adresse
        .Subject = Betreff
        .Body = Text & vbCr & vbCr
        If Anhang > "" Then
            .Attachments.Add Source:=Anhang, Position:=Len(Text) + 20
        End If
        .Send
    End With
End Sub
