Hallo zusammen,

ich habe ein Problem bei dem ich nicht weiter komme. Ich hab eine Excel Datei für das versenden vom Serienmails, in dem Fall Geburtstagsmails für einen Verein.

Mit hilfe des Forums ist es nun soweit dass ich die Mitglieder die anzumailen sind korrekt in ene Liste übertragen bekomme um die nötigen Daten in ein vorbereitetes Mail Template zu übertragen. Der Teil ist im Makro Modul 2 soweit ok  (denke ich). Ich habe das Extra voneinander trennen wollen da ich da nicht rum fuhrwerken wollte.

Die Funktion zum generieren und versenden versteckt sich im Makro Modul1. Diese hat ein Sicherheitsnetz eingebaut das mir die Mail entweder vorher anzeigen oder ohne Anzeige raus senden kann. Das Modul gibt mir nun in beiden Modi einen, offenbar abgefangenen, Fehler aus.

Da ich das Modul nicht selbst geschieben habe. sehe ich nicht das Problem, da hier auch nichts geändert wurde.

Der Fehler wird, laut Einzelschritt, an folgendem Punkt generiert:  '*show dtSend or error

Folgender Fehler wird im Sendestatus in der Mailing Liste ausgeworfen: no: Array-Index außerhalb des zulässigen Bereichs.

Das das ein sehr langer Code ist und meine VBA Kenntnisse eher minimalistischer Natur sind, brauche ich etwas hilfe beim review.

Die Excel Datei lade ich mal an geeigneter stelle hoch, damit wird eher klar was ich zu erreichen versuche.

Danke im Voraus

Mathias

File: https://gofile.io/?c=IrxWD9

Der Code des betreffenden Moduls sieht so aus:

Option Explicit

'===================< Region: Email >===================

Public Sub Send_Email()
    '-------------< Send_Email() >-------------
    '*Runs trough List and creates single Emails
    '-< init >-
    '*Eingabe Felder Blatt-Header
    Dim sTitle As String
    sTitle = ActiveWorkbook.Names("varTitle").RefersToRange.Value2
    Dim sEmail_From As String
    sEmail_From = ActiveWorkbook.Names("varEmail_From").RefersToRange.Value2
    Dim sName_From As String
    sName_From = ActiveWorkbook.Names("varName_From").RefersToRange.Value2
    
    
    '< Text >
    Dim sTemplate As String
    sTemplate = Sheets("_Text").Shapes(1).TextFrame2.TextRange.Text
    '</ Text >
    '-</ init >-
    
    Dim ws As Worksheet
    Set ws = ActiveSheet    'with button
    
    
    '----< Send with Outlook >----
    Dim app_Outlook As Outlook.Application
    Set app_Outlook = New Outlook.Application
    Dim objEmail As Outlook.MailItem
   
    '<# Optional: Late-Binding >
    'Dim app_Outlook
    'Set app_Outlook = CreateObject("Outlook.Application")
    'Dim objEmail
    '</# Optional: Late-Binding >
   
    '--< Email einstellen >--
    
    '< get Table with Emails >
    Dim tblEmails As ListObject   'active Excel-Table with emails
    Set tblEmails = ws.ListObjects("tblEmails")
    '</ get Table with Emails >
    
    '-< get Headers >-
    Dim sHeaders As String
    sHeaders = ""
    Dim iColumn As Integer
    For iColumn = 1 To tblEmails.ListColumns.Count
        Dim sHeader As String
        sHeader = tblEmails.Range(1, iColumn).Value
        sHeaders = sHeaders & ";" & sHeader
    Next
    sHeaders = Replace(sHeaders, ";", "", 1, 1)
    Dim arrHeaders
    arrHeaders = Split(sHeaders, ";")
    '-</ get Headers >-
    
    Dim iCol_Email_To As Integer
    iCol_Email_To = get_Column("Email_To")
    Dim iCol_Email_Cc As Integer
    iCol_Email_Cc = get_Column("Emails_Cc")
    
    '----< @Loop: all List-Rows >----
    Dim iRow As Integer
    For iRow = 2 To tblEmails.ListRows.Count
            '< get Email Address >
            Dim sAddress_To As String
            sAddress_To = tblEmails.Range(iRow, iCol_Email_To).Value
            Dim sAddresses_CC As String
            sAddresses_CC = tblEmails.Range(iRow, iCol_Email_Cc).Value
            '</ get Email Address >
            
            If sAddress_To Like "*@*.*" Then
                '----< Email_To is OK >----
                '-< Replace all Placeholders >-
                Dim sText As String
                sText = sTemplate
                
                Dim iCol As Integer
                For iCol = 1 To tblEmails.ListColumns.Count
                    Dim sPlaceholder As String
                    sPlaceholder = tblEmails.Range(1, iCol)
                    Dim sValue As String
                    sValue = tblEmails.Range(iRow, iCol)
                    '< replace >
                    If Not sPlaceholder Like "" Then
                        sText = Replace(sText, "[@" & sPlaceholder & "]", sValue, , , vbTextCompare)
                    End If
                    '</ replace >
                Next
                '-</ Replace All Placeholders >-
                
                '--< Send Email >--
                Dim status_Send As String '?date
                '<< send >>
                status_Send = Send_Email_to_Address(sAddress_To, sTitle, sText, sAddresses_CC)
                '<</ send >>
                '*show dtSend or error
                tblEmails.Range(iRow, 1).Value = status_Send
                '--</ Send Email >--
                
                '----</ Email_To is OK >----
            End If
            
    Next
    '----</ @Loop: all List-Rows >----
    
    '< Abschluss >
    Set objEmail = Nothing
    Set app_Outlook = Nothing
    '</ Abschluss >
    
    MsgBox "Fertig", vbInformation, "Fertig"
    
    '----</ Send with Outlook >----
    '-------------</ Send_Email() >-------------
End Sub


    
Public Function Send_Email_to_Address(ByVal sAddress_To As String, ByVal sTitle As String, ByVal sText As String, ByVal sAddresses_CC As String) As String
    '-------------< Send_Email_to_Address() >-------------
    '*sends a single email
    '*uses: outlook
    '< init >
    On Error Resume Next
    '< check >
    If sAddress_To Like "" Then
        Send_Email_to_Address = "no: [Email_To] is empty"
        Exit Function
    End If
    '</ check >
    
    
    
    '< outlook >
    Dim app_Outlook As Object
    Set app_Outlook = CreateObject("Outlook.Application")
   '</ outlook >
   
    Dim sFiles As String
    sFiles = ActiveWorkbook.Names("varFiles").RefersToRange.Value2
   

    '--< Send Email >--
    Dim objEmail As Object
    Set objEmail = app_Outlook.CreateItem(0)
    objEmail.To = sAddress_To
    If Not sAddresses_CC Like "" Then
        objEmail.CC = sAddresses_CC
        '*via address;addess is ok
'        Dim arrAddresses() As String
'        arrAddresses = Split(sAddresses_CC, ";")
'        Dim Address_CC
'        For Each Address_CC In arrAddresses
'            objEmail.CC.Add Address_CC
'        Next
    End If

    objEmail.Subject = sTitle
    objEmail.Body = sText       '*.body for Text, Richtext
    'objEmail.HTMLBody = sHTML  '*.HTMLBody for HTML
    
    '-< Attach Files >-
    Dim arrFiles
    arrFiles = Split(sFiles, ";")
    Dim sFile
    For Each sFile In arrFiles
        If Not sFile Like "" Then
            If Not sFile Like "*:*" Then
                sFile = ActiveWorkbook.Path & "\" & sFile
            End If
            objEmail.Attachments.Add sFile
        End If
    Next
    '-</ Attach Files >-
    
    
    '< send >
    Dim sAutosend As String
    sAutosend = ActiveWorkbook.Names("varEmail_Autosend").RefersToRange.Text
    If sAutosend Like "*Sofort*" Then
        objEmail.Display False
        objEmail.Send
    Else
        objEmail.Display False
        'objEmail.Display bVisible   '*no visible=true because of : wait on outlook
    End If
    '</ send >
    '--</ create Email >--

    '< Abschluss >
    Set objEmail = Nothing
    Set app_Outlook = Nothing
    '</ Abschluss >
    
    If Err.Number <> 0 Then
        '< error >
        'MsgBox "Error on Email=" & sAddress_To & vbCrLf & Err.Description & vbCrLf & "Check Syntax of Email-Address ", vbCritical, "Error on sending.."
        Send_Email_to_Address = "no: " & Err.Description
        '</ error >
    Else
        '< ok >
        '*return dtSend
        Send_Email_to_Address = "ok: " & Now
        '</ ok >
    End If
    
    '-------------</ Send_Email_to_Address() >-------------
End Function
'===================</ Region: Email >===================


'===================< Region: Helper-Functions >===================
Private Function get_Column(sFind_Header As String) As Integer
    '-------------< get_Column() >-------------
    '*find Column with Header
    Dim tblEmails As ListObject   'active Excel-Table with emails
    Set tblEmails = ActiveSheet.ListObjects("tblEmails")
    
    Dim iReturn
    iReturn = -1
    
    Dim iColumn As Integer
    For iColumn = 1 To tblEmails.ListColumns.Count
        Dim sHeader As String
        sHeader = tblEmails.Range(1, iColumn).Value
        If sHeader Like sFind_Header Then
            iReturn = iColumn
            Exit For
        End If
    Next
    
    get_Column = iReturn
    '-------------</ get_Column() >-------------
End Function





'*Reference Microsoft Scripting Runtime    http://www.microsoft-programmierer.de/Details?d=1076
Public Sub Select_File()
    '-----------< Select_File() >-----------

    '------< Select_File() >------
    '--< File-Dialog >--
    Dim objFiledialog As FileDialog
    Set objFiledialog = Application.FileDialog(msoFileDialogFilePicker)
    objFiledialog.AllowMultiSelect = True
    objFiledialog.ButtonName = "->Select Files"
    objFiledialog.Filters.Add "Add Files", "*.*"
    objFiledialog.Title = "Select Files.."
    objFiledialog.InitialView = msoFileDialogViewTiles
    objFiledialog.InitialFileName = ActiveWorkbook.Path
    objFiledialog.AllowMultiSelect = True
    If Not objFiledialog.Show() = True Then
        Exit Sub
    End If
    '--< File-Dialog >--

    '-< check >-
    '</ Ordner ist leer >
    If objFiledialog.SelectedItems().Count = 0 Then
        Exit Sub
    End If
    '</ Ordner ist leer >
    '-</ check >-
    
    Dim sFilename As String
    Dim sFiles As String
    sFiles = ""
    '----< @Loop: Files >----
    Dim iFile As Integer
    For iFile = 1 To objFiledialog.SelectedItems.Count
        '------< Loop.Item  >------
        DoEvents

        '< get selection >
        sFilename = objFiledialog.SelectedItems(iFile)
        '</ get selection >
            
        '< correct >
        sFilename = Replace(sFilename, ActiveWorkbook.Path & "\", "", 1, 1, vbBinaryCompare)
        '</ correct >
        
        
        '< add >
        sFiles = sFiles & ";" & sFilename
        '</ add >
    Next
    '----</ @Loop: Files >----
    '< correct >
    sFiles = Replace(sFiles, ";", "", 1, 1, vbBinaryCompare)
    '</ correct >
    
    
    '< write_into_cell >
    ActiveWorkbook.Names("varFiles").RefersToRange.Value2 = sFiles
    '</ write_into_cell >
    '-----------</ Select_File() >-----------
End Sub
'===================</ Region: Helper-Functions >===================