Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Get.Inspector Serienbrief
#1
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:


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
Antworten Top
#2
Hallöchen,

objEmail.GetInspector.Display geht nicht?
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Antworten Top
#3
Servus,

das kann gut sein dass es funktioniert. Aber ich habe ehrlich gesagt keinen Plan an welcher Stelle das einzubauen wäre :20: 

Beste Grüße
Leo
Antworten Top
#4
Hallöchen,

ich würde es in der Function Send_Email_to_Address ziemlich weit unten platzieren, eventuell nach
sAutosend = ActiveWorkbook.Names("varEmail_Autosend").RefersToRange.Text
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Antworten Top
#5
Hallo Schauan,

habe es an jeder möglichen Stelle nach (sAutosend = ActiveWorkbook…) eingesetzt. Leider tut sich nichts =(
Antworten Top
#6
Hallöchen,

es kommt auch kein Fehler? Kannst Du mal in der neuen Codezeile einen Haltepunkt setzen und schauen, ob das Programm überhaupt dort ankommt?
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Antworten Top
#7
Servus,

es kommt kein Fehler. Habe den Haltepunkt mal in der neuen Zeile gesetzt und das Programm kommt dort offensichtlich auch an.


Angehängte Dateien Thumbnail(s)
   
Antworten Top
#8
Hallo,

so einfach ist das mit GetInspector nun auch nicht. Sleepy

Der Inspector funktioniert, so weit ich das weiß, nur mit HTMLBody ... Leonhard hat aber nur einen normalen Text-Body.
Außerdem überschreibt der Inspector den HTMLBody ... wieso auch immer ... deshalb musst du diese zwischenspeichern und am Schluss wieder einfügen.

... alles nur blanke Theorie ... ich verwende kein Outlook ... habe das aber mal gelesen.

EDIT:
Lies dir mal den Link durch ... ist auch Beispielcode dabei ...
"http://www.office-loesung.de/ftopic481498_0_0_asc.php"
VG Sabina

bei mir läuft Win 7 32-Bit - Office 2010 Pro Plus 32-Bit und Office 2016 Pro Plus 32-Bit
Wer auch weiter Hilfe erwartet, sollte sich nicht zu schade sein, ein kurzes Feedback zu geben.
Antworten Top
#9
Hi,

erstmal Danke für deine Antwort. Leider habe ich keine Ahnung wie ich das von dir beschriebene auf den vorhandenen Code übertragen kann =(
Ich würde gerne alle aktuellen Funktionen des Tools beibehalten, hätte auch kein Problem damit den Text der Mail als HTML zu modellieren. Das Problem ist leider nur das ich es nicht hinbekomme, versuche seit Stunden aus Foreneinträgen schlau zu werden und diese auf den Code anzupassen aber es will nicht gelingen.
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste