Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1888to1892
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Serienmail + Fixer Absender + Anhang

Serienmail + Fixer Absender + Anhang
06.07.2022 08:54:08
Simon
Hallo zusammen,
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

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Serienmail + Fixer Absender + Anhang
07.07.2022 14:59:15
Heli
Hi,
das geht meiner Meinung nach nur wenn Du das Mailprogramm direkt ansprichst (über Application...) und nicht per Shell-Befehl, bin da aber kein Experte.
VG, Heli
AW: Serienmail + Fixer Absender + Anhang
18.07.2022 12:00:14
Simon
Keiner eine Idee?
LG, Simon
Anzeige

183 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige