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 >===================
|