|
Option Explicit On
Private Const iColumn_Senden As Integer = 2
Private Const iColumn_Anhang As Integer = 5
'===================< Region: Email
>===================
Public Sub Send_Email()
'-------------< Send_Email() >-------------
'*Runs
trough List and creates single Emails
'-< init >-
'*Eingabe Felder Blatt-Header
Dim sSubject0 As String
sSubject0 =
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
'------< RTF in HTML umwandeln
>--------
Dim sHTML As String
'sTemplate = Sheets("_Text").Shapes(1).TextFrame2.TextRange.Text
'Dim
iLenHTML As Long
'iLenHTML =
Sheets("_Text").Shapes(1).TextFrame2.TextRange.Characters.Length
sHTML =
""
Dim
bChange As Boolean
Dim
intColor As Long
intColor = 0
Dim
intRed As Long, intGreen As Long, intBlue As Long
Dim
sFontName As String
sFontName = ""
Dim
sFontSize As String
sFontSize = ""
Dim
sUnderline As String
sUnderline = ""
Dim
bBold As Integer
bBold =
0
'------< @Loop: Characters >------
Dim varChar
For
Each varChar In Sheets("_Text").Shapes("TextBox
3").TextFrame2.TextRange.Characters
'----< Character >----
bChange = False
'< get Character >
Dim
char_Text As String
char_Text = varChar.Text
Dim char_FontName As String
char_FontName = varChar.Font.Name
Dim
char_FontSize As String
char_FontSize = varChar.Font.Size
Dim
char_Underline As String
char_Underline = varChar.Font.UnderlineStyle
Dim
char_RGB As Long
char_RGB = varChar.Font.Fill.ForeColor.RGB
Dim
char_Bold As Integer
char_Bold = varChar.Font.Bold
'</ get Character >
'< Font >
If
Not sFontName Like char_FontName Then
bChange = True
sFontName = char_FontName
End
If
'</ Font >
'< FontSize >
If
Not sFontSize Like char_FontSize Then
bChange = True
sFontSize = char_FontSize
End
If
'</ FontSize >
'< Underline >
If
Not sUnderline Like char_Underline Then
bChange = True
sUnderline = char_Underline
End
If
'</ Underline >
'< Color >
If
Not intColor Like char_RGB Then
bChange = True
intColor = char_RGB
intRed = (intColor And &HFF) \ 256 ^ 0 ' &HFF hexadecimal = 255 decimal
intGreen = (intColor And &HFF00&) \ 256 ^ 1 ' &HFF00& hexadecimal = 65280
decimal
intBlue = intColor \ 256 ^ 2
End
If
'</ Color >
'< Bold >
If
Not bBold Like char_Bold Then
bChange = True
bBold = char_Bold
End
If
'</ Bold >
'< Korrekturen >
char_Text = Replace(char_Text, vbCrLf, "<br>")
char_Text = Replace(char_Text, vbLf, "<br>")
'</ Korrekturen >
'< Formatierung HTML >
If bChange Then
sHTML = sHTML & "</span>"
sHTML = sHTML & vbCrLf &
"<span style="""
sHTML = sHTML & " font-family:" & sFontName &
";"
sHTML = sHTML & " font-size:" & sFontSize &
"pt;"
If Not sUnderline Like "0" Then
sHTML = sHTML & " text-decoration:underline;"
End If
sHTML = sHTML & " color:rgb(" & intRed &
"," & intGreen & "," & intBlue & ")
;"
If bBold <> 0 Then
sHTML = sHTML & " font-weight:font-weight: bold;"
Else
sHTML = sHTML & "
font-weight:font-weight: normal;"
End If
sHTML = sHTML & """>"
End
If
'</ Formatierung HTML >
'< Text_anfuegen >
sHTML = sHTML & char_Text
'</ Text_anfuegen >
'----</ Character >----
Next
'------</ @Loop: Characters >------
'<
Korrektur >
sHTML =
sHTML & "</span>"
'</
Korrektur >
'sTemplate =
Sheets("_Text").Shapes(1).TextFrame2.TextRange.Characters.Text '(1, iLenHTML)
'sTemplate
= Sheets("_Text").Shapes(1).TextFrame.Text
'sHTML
= "<html><body>" & vbCrLf & sHTML & vbCrLf
& "</body></htmll>"
'</ Text >
'------</ RTF in HTML umwandeln
>--------
Dim sAttachment_Files_default As String
sAttachment_Files_default =
ActiveWorkbook.Names("varFiles").RefersToRange.Value2
'-</
init >-
Dim ws
As Worksheet
Set ws
= ActiveSheet 'with button
'----< Send with Outlook >----
'*bei
Verwendung von Outlook
'Dim
app_Outlook As Outlook.Application
'Set
app_Outlook = New Outlook.Application
'Dim
objEmail As Outlook.MailItem
'<#
Optional: Late-Binding >
'*bei Verwendung von anderen
Email-Programmen
'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
'----< Row >----
Dim
xSenden As String
xSenden = tblEmails.Range(iRow, iColumn_Senden).Value
If
xSenden Like "X" Then
'---< Senden >---
'< 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 >
'< check_end >
If sAddress_To Like "" Then Exit For
'</ check_end >
If sAddress_To Like "*@*.*" Then
'----< Email_To is OK >----
'-< Replace all Placeholders >-
Dim sText As String
sText = sHTML '*VorlageText aus _Text
Dim sTitle As
String
sTitle = sSubject0 '*Titel aus
Zelle C2
Dim iCol As Integer
For iCol = 1 To tblEmails.ListColumns.Count
Dim sPlaceholder As String
sPlaceholder =
tblEmails.Range(1, iCol)
sPlaceholder =
Trim(sPlaceholder)
Dim sValue As String
sValue =
tblEmails.Range(iRow, iCol)
sValue = Trim(sValue)
'< replace >
If Not sPlaceholder Like
"" Then
sText =
Replace(sText, "[@" & sPlaceholder & "]", sValue,
, , vbTextCompare)
sTitle =
Replace(sTitle, "[@" & sPlaceholder & "]",
sValue, , , vbTextCompare)
End If
'</ replace >
Next
'-</ Replace All Placeholders >-
'< get_optional_Attachements >
Dim sAttachment As String
sAttachment = tblEmails.Range(iRow, iColumn_Anhang).Value
If sAttachment Like "" Then sAttachment =
sAttachment_Files_default
'</ get_optional_Attachements >
'--< Send Email >--
Dim status_Send As String
'?date
'<< send >>
status_Send = Send_Email_to_Address(sAddress_To, sTitle, sText,
sAddresses_CC, sAttachment)
'<</ send >>
'*show dtSend or error
tblEmails.Range(iRow, 1).Value =
status_Send
'--</ Send Email >--
'----</ Email_To is OK >----
End If
'---< Senden >---
End
If
Next
'----</ @Loop: all List-Rows >----
'< Abschluss >
'Set
objEmail = Nothing
'Set
app_Outlook = Nothing
'</ Abschluss >
MsgBox "Outlook hat die Mails
versand!", 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,
Optional ByVal sAddresses_CC As String, Optional sAttachment 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 >
'*Ohne Verweis,Outlook
versionsunabhaengig, Late Binding
Dim app_Outlook As Object
Set
app_Outlook = CreateObject("Outlook.Application")
Dim
objEmail As Object
Set
objEmail = app_Outlook.CreateItem(0)
'*Mit Verweis, bei Verwendung von Outlook
mit Verweis Early Binding
'Dim app_Outlook As Outlook.Application
'Set
app_Outlook = New Outlook.Application
'Dim
objEmail As MailItem
'Set
objEmail = app_Outlook.CreateItem(olMailItem)
'</ outlook
>
'--<
Send Email >--
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.BodyFormat = 2 '* 1=Text olFormatPlain, 2=olFormatHTML,
3=olFormatRichText
objEmail.HTMLBody = sText
'*.HTMLBody for HTML
'-<
Attach Files >-
Dim
arrFiles
arrFiles = Split(sAttachment, ";")
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 True
'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 = 440 Or Err.Number = -2147352567 Then
'< error >
MsgBox "File-Path of Attachment is wrong." & vbCrLf
& sAttachment, vbCritical, "Error on sending Attachement.."
Send_Email_to_Address = "no: " & Err.Description
'</ error >
ElseIf
Err.Number <> 0 Then
'< error >
MsgBox "Error on Email=" & sAddress_To & vbCrLf
& Err.Description & vbCrLf & "Check Syntax of Email-Address
" & sAddress_To & vbCrLf & " and Attachment "
& sAttachment, vbCritical, Err.Number & " 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 >===================
|