Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1404to1408
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

Makro erweitern für Aufruf zum Mailprogramm

Makro erweitern für Aufruf zum Mailprogramm
22.01.2015 09:18:57
Wolfgang.
Hallo Excelgemeinde,
mit meinem Makro kann ich nun aus einer Exceldatei die aktive Tabelle versenden. Das funktioniert einwandfrei, aber ich würde gerne, dass das Standard-Mailprogramm vor dem Versenden aufgerufen wird und ich noch einen Text schreiben könnte.
Mit dem Makrorekorder finde ich keine Lösung.
Hier mal das Makro:
Sub TabelleSenden()
'Definition der Variablen
Dim Adr As String
Dim Subj As String
Dim Cell As Range
Dim x As Byte
'Dialogbox erstellen
x = MsgBox("Sollen Sie die Formeln durch die Zahlenwerte ersetzt werden?", vbYesNoCancel, " _
Formelbezüge entfernen ...")
If x = vbCancel Then
'Wenn ABBRECHEN gedrückt beenden
Exit Sub
ElseIf x = vbYes Then
'Erstellen der Kopie
ActiveWorkbook.ActiveSheet.Copy
'Wenn JA gedrückt alle Zellen mit Formeln markieren
Selection.SpecialCells(xlCellTypeFormulas).Select
'Formeln durch Werte ersetzen
For Each Cell In Selection
Cell.Value = Cell.Value
Next Cell
Else
'Wenn NEIN: Nur Erstellen der Kopie
ActiveWorkbook.ActiveSheet.Copy
End If
'Inputbox zum Abfragen der E-Mail-Adresse
Adr = InputBox("Bitte geben Sie die E-Mail-Adressen an!", "E-Mail-Adressen")
'Inputbox zum Abfragen des Betreffs
Subj = InputBox("Bitte geben Sie den Betreff an!", "Betreff")
'Senden der E Mail
ActiveWorkbook.SendMail Recipients:=Adr, Subject:=Subj
'Schließen der temporären Mappe ohne Speichern
ActiveWorkbook.Close savechanges:=False
End Sub
Vielleicht hat jemand eine Ahnung ...
Danke schon mal im voraus.
Wolfgang.

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro erweitern für Aufruf zum Mailprogramm
22.01.2015 10:56:55
Klaus
Hallo Wolfgang,
ich hätte eine Lösung, aber nur wenn dein Mailprogramm "Outlook" ist:
Sub TabelleSenden()
'Definition der Variablen
Dim Adr As String
Dim Subj As String
Dim Cell As Range
Dim x As Byte
Dim oldPath As String
Dim MyPath As String
oldPath = ActiveWorkbook.Path
'Dialogbox erstellen
x = MsgBox("Sollen Sie die Formeln durch die Zahlenwerte ersetzt werden?", vbYesNoCancel, " _
Formelbezüge entfernen ...")
If x = vbCancel Then
'Wenn ABBRECHEN gedrückt beenden
Exit Sub
ElseIf x = vbYes Then
'Erstellen der Kopie
ActiveWorkbook.ActiveSheet.Copy
'Wenn JA gedrückt alle Zellen mit Formeln markieren
Selection.SpecialCells(xlCellTypeFormulas).Select
'Formeln durch Werte ersetzen
For Each Cell In Selection
Cell.Value = Cell.Value
Next Cell
Else
'Wenn NEIN: Nur Erstellen der Kopie
ActiveWorkbook.ActiveSheet.Copy
End If
'Inputbox zum Abfragen der E-Mail-Adresse
Adr = InputBox("Bitte geben Sie die E-Mail-Adressen an!", "E-Mail-Adressen")
'Inputbox zum Abfragen des Betreffs
Subj = InputBox("Bitte geben Sie den Betreff an!", "Betreff")
'Senden der E Mail
'ActiveWorkbook.SendMail Recipients:=Adr, Subject:=Subj
MyPath = oldPath & "\Mailanhang.xlsx"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=MyPath, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'Schließen der temporären Mappe (gelöscht wird spaeter)
ActiveWorkbook.Close True
Call SendSheetOutlook(Subj, Adr, "", "", MyPath)
End Sub
'Module to send Mail from Excel with Outlook
'April 2013 by Klaus M.vdT.
'original Code by mumpel / www.herber.de / 11.04.2013 11:23:25
'https://www.herber.de/forum/messages/1308295.html
Private Sub SendSheetOutlook(sSubject As String, sTo As String, sCC As String, sText As String,  _
Aws As String)
Dim olApp         As Object
Dim olOldBody     As String
'Make Email
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.GetInspector.Display
olOldBody = .htmlBody
.To = sTo
.cc = sCC
.Subject = sSubject
.htmlBody = sText & olOldBody
.Attachments.Add Aws
End With
'delete attached file
Kill Aws
End Sub
Grüße,
Klaus M.vdT.
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige