29.11.2018, 14:43
Hallo zusammen,
ich habe im Netz ein super Tool zum Versenden von Serienbriefen aus Excel heraus gefunden (wirklich ein Traum :17: ). Ein Problem habe ich dabei leider, ich schaffe es absolut nicht .GetInspector einzubauen. Alle Versuche sind gescheitert =(
Falls sich jemand die Mühe machen will würde ich mich super freuen. Für alle interessierten, das Tool findet Ihr unter:
https://codedocu.de/Office-365/Excel/Vor...on-39?2675
Anbei der Code:
Beste Grüße
Leo
ich habe im Netz ein super Tool zum Versenden von Serienbriefen aus Excel heraus gefunden (wirklich ein Traum :17: ). Ein Problem habe ich dabei leider, ich schaffe es absolut nicht .GetInspector einzubauen. Alle Versuche sind gescheitert =(
Falls sich jemand die Mühe machen will würde ich mich super freuen. Für alle interessierten, das Tool findet Ihr unter:
https://codedocu.de/Office-365/Excel/Vor...on-39?2675
Anbei der Code:
Code:
Option Explicit On
'===================< 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 >===================Beste Grüße
Leo
