06.08.2020, 20:51
Hallo,
Danke schon einmal im Voraus!
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.
