Option Explicit On
'===================< Region: Email >===================
Public Sub Send_Email()
'-------------< Send_Email() >-------------
'*Runs trough List and creates single Emails
'-< init >-
'*Input fields page 1
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
Dim sColumn_Email_To As String
sColumn_Email_To = ActiveWorkbook.Names("varColumn_Email_To").RefersToRange.Value2
'-</ init >-
'< Text >
Dim sEmail_Text_Template As String
sEmail_Text_Template = Sheets("_Text").Shapes(1).TextFrame2.TextRange.Text
'</ Text >
'< get Datasheet >
Dim sheet_Datalist As Worksheet
Set sheet_Datalist = ThisWorkbook.Sheets("DataList")
'</ get Datasheet >
'----< 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 >
'----< @Loop: all List-Rows >----
Dim iRow_Sending As Integer
For iRow_Sending = 1 To sheet_Datalist.UsedRange.Rows.Count
'< get Email Address >
Dim sAddress_To As String
sAddress_To = sheet_Datalist.Range(sColumn_Email_To & iRow_Sending).Value
'< check end >
If sAddress_To Like "" Then Exit For
'</ check end >
'</ get Email Address >
If sAddress_To Like "*@*.*" Then
'----< Email_To is OK >----
'-< Replace all Placeholders >-
Dim sText As String
sText = sEmail_Text_Template
Dim iCol As Integer
For iCol = 1 To sheet_Datalist.UsedRange.Columns.Count
'< check_done >
If InStr(1, sText, "[", vbTextCompare) < 0 Then Exit For
'</ check_done >
Dim sColumnName As String
sColumnName = Convert_Number_To_Letter(iCol)
'< replace >
If sText Like "*[" & sColumnName & "]*" Then
Dim sValue As String
sValue = sheet_Datalist.Range(sColumnName & iRow_Sending).Value2
sValue = Trim(sValue)
sText = Replace(sText, "[" & sColumnName & "]", 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, "")
'<</ send >>
'--</ Send Email >--
'----</ Email_To is OK >----
End If
Next
'----</ @Loop: all List-Rows >----
'< Abschluss >
Set objEmail = Nothing
Set app_Outlook = Nothing
'</ Abschluss >
MsgBox "Done", vbInformation, "Done"
'----</ 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 >===================
Public Function Convert_Number_To_Letter(ByVal Column_Number As Integer)
'Umwandeln einer Excel-Spalten-Nummer in einen Buchstaben, der Spalte
Convert_Number_To_Letter = Split(Cells(1, Column_Number).Address, "$")(1)
End Function
|