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.

Aus Excel E-Mails Verschicken (Outlook)
#1
Hallo,
 
ich habe eine Frage zu einem VBA Code in Excel (unten abgebildet). Aber erst einmal zur grundsätzlichen Idee:
 
Es sollen E-Mails an einzelne Personen verschickt werden (verschiedenen E-Mail-Adressen), mit Angaben zu einem gebuchten Zeitraum wie beispielsweise der Uhrzeit, dem Datum oder der Dauer. Diese Angaben bekomme ich in die Mail und ich kann diese auch versenden. Nur ist die Senden-Schaltfläche mit der kompletten Spalte T verknüpft. Es werden also an alle E-Mails in T, die Informationen der ersten Zeile verschickt. Ich möchte die E-Mails aber einzeln verschicken, sodass diese sich nacheinander löschen (schon im VBA Code eingebaut) und somit immer nur die Informationen zur jeweiligen E-Mail-Adresse (Zelle T1) verschickt werden. Fortführend wäre es natürlich noch super, wenn daraus ein Loop entstehen würde und man nicht mehr die Schalfläche ständig klicken müsste.
Anbei der VBA Code:
 
Code:
[align=justify]Option Explicit

'===================< 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 >
   
 
    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
     
    '----</ Send with Outlook >----
    '-------------</ Send_Email() >-------------
   
    ActiveSheet.Rows("1:1").Delete
   
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[/align]
[align=justify] [/align]
Bei Fragen gerne melden oder kommentieren.
 
Danke schon einmal im Voraus!
Antwortento top
#2
Hallöchen,


dass eine Schaltfläche mit einer Spalte verknüpft ist sehe ich leider nicht. Geht m.E. auch nicht, die kann eher mit einem Makro verknüpft sein.
Der Text scheint mir auch mit einer Textbox verknüpft zu sein und nicht mit einer Zeile: sEmail_Text_Template = Sheets("_Text").Shapes(1).TextFrame2.TextRange.Text
T1 dürfte sich dann dahinter verbergen: sColumn_Email_To = ActiveWorkbook.Names("varColumn_Email_To").RefersToRange.Value2

In der Schleife ermittelst Du sAddress_To und sendest die entsprechenden E-Mail. Am Text aus der Textbox ändert sich dann nix mehr, den hattest Du zuvor schon übernommen. Wenn Du mehrere texte in mehreren Textboxen hast und diese per Index der Zeile zugeordnet werden können, könntest Du die entsprechende Codezeile in die Schleife nehmen und statt der festen Nummer 1 dann den Schleifenzähler verwenden.
   \\\|///      Hoffe, geholfen zu haben.
   ( ô ô )      Grüße, André aus G in T  
 ooO-(_)-Ooo    (Excel 97-2016)
Antwortento top
#3
Hallo,

danke erst einmal für die Antwort. So wie du das alles beschrieben hast, stimmt das auch und dass der Text mit einer Textbox verknüpft ist, passt auch. Da habe ich mich wohl leider ein wenig falsch ausgedrückt!  Undecided

Dennoch verbirgt sich T1 leider nicht hinter "sColumn_Email_To = ActiveWorkbook.Names("varColumn_Email_To").RefersToRange.Value2" 

Es werden immer die E-Mail an alle Adressen aus der Spalte T geschickt. Wenn ich dann in meiner Arbeitsmappe in die Beschriftung Column = T1 eintrage, dann funktioniert das nicht. Es gehen leider immer nur ganze Spalten. Wie kann ich das ändern, dass wirklich nur Bezug auf die eine Zelle "T1" genommen wird?

Ich hoffe, ich habe es jetzt richtig und verständlich geschildert.

Danke schon einmal im Voraus! 
Antwortento top
#4
Hallöchen,

dann werden doch aber auch einzelne E-Mail gesendet? Die Zeilen werden ja in einer Schleife abgearbeitet und in jeder Zeile wird der Versand ausgeführt?
   \\\|///      Hoffe, geholfen zu haben.
   ( ô ô )      Grüße, André aus G in T  
 ooO-(_)-Ooo    (Excel 97-2016)
Antwortento top


Gehe zu:


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