Serienmail + Fixer Absender + Anhang
06.07.2022 08:54:08
Simon
habe untenstehenden super Code gefunden und für mich modifiziert. Funktioniert so einwandfrei, aber:
Bitte um folgende 3 Tipps:
1. Ich habe mehrere Outlook-Konten (mit jeweils E-Mail-Adresse) und würde gerne eines im Code fix festlegen. Bisher werden die Mails immer mit dem falschen Konto zum Versand geöffnet.
2. Ich würde gerne 2 Anhänge mitschicken. Beide könnten in einem vordefinierten Ordner abgelegt werden.
Oder, noch besser wäre 2 Zellen zu definieren, in der der Pfad der Anhänge geschrieben wird und das Makro zieht die Anhänge des Pfads in die Mail.
3.
Habe mehrere Zellen definiert, da wenn ich nur eine nehme die Zeilenumbrüche (Alt+Enter) nicht übernommen werden.
Eine einzige Zelle wäre am besten, aber aktuell erscheint in der Mail dann alles als Fließtext..
4.
Besteht die Möglichkeit, dass Schrift einer Zelle auch fettgedruckt in die Mail übernommen wird?
Hat jemand Ideen?
Ganz vielen Dank im Voraus!!
Grüße,
Simon
_________________________
Option Explicit
#If VBA7 And Win64 Then
Private Declare PtrSafe
Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As LongPtr, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As LongPtr
#Else
Private Declare
Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
#End If
Sub SendEMail()
'update by Extendoffice 20160506
Dim xEmail As String
Dim xSubj As String
Dim xMsg As String
Dim xURL As String
Dim i As Integer
Dim k As Double
Dim xCell As Range
Dim xRg As Range
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count 2 Then
MsgBox " Regional format error, please check"
Exit Sub
End If
For i = 1 To xRg.Rows.Count
' Get the email address
xEmail = xRg.Cells(i, 1)
' Message subject
xSubj = Worksheets("Mail Text").Range("B1")
' Compose the message
xMsg = ""
xMsg = xMsg & xRg.Cells(i, 2) & vbCrLf & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B3") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B4") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B5") & vbCrLf & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B7") & vbCrLf & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B9") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B10") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B11") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B12") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B13") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B14") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B15") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B16") & vbCrLf & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B18") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B19") & vbCrLf & vbCrLf & vbCrLf & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B22") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B23") & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B26") & vbCrLf & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B28") & vbCrLf & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B30") & vbCrLf & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B31") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B32") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B33") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B34") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B35") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B36") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B37") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B38") & vbCrLf & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B40") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B41") & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B42") & vbCrLf & vbCrLf
xMsg = xMsg & Worksheets("Mail Text").Range("B44") & vbCrLf
' Replace spaces with %20 (hex)
xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
' Replace carriage returns with %0D%0A (hex)
xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
' Create the URL
xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
' Execute the URL (start the email client)
ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
' Wait two seconds before sending keystrokes
Application.Wait (Now + TimeValue("0:00:02"))
'Application.SendKeys "%s"
Next
End Sub