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