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

E-Mail aus Excel mit Anhang versenden

E-Mail aus Excel mit Anhang versenden
11.04.2013 09:09:49
Jens
Guten morgen,
ich würde gern aus Excel ein E-Mail erzeugen. Habe im Forum dazu auch schon einen Code gefunden, der soweit auch nach meinen Wünschen funktioniert. Was mir aber noch fehlt ist, ich hätter gern das entweder der Bereich ("D5:At46") als Excel Dokument angehängt wird und den Namen aus Feld D7 erhält oder das eine vorher gespeicherte Datei angehängt wird (für das Speichern habe ich bereits einen Code), nur wie ich das zusammen bekomme, da komme ich leider nicht weiter.
Code zum Versenden:
Sub Excel_Serial_Mail()
Dim MyOutApp As Object, MyMessage As Object
Dim i As Long
' Dim ClpObj As DataObject
'Set VBEObj = Application.VBE.ActiveVBProject.References
'VBEObj.AddFromFile "MSPPT.OLB" 'das ist die Powerpoint Library
'VBEObj.AddfromFile "Std0le2.tlb"
'VBEObj.AddFromFile "Fm20.dll"
For i = 1 To 1
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
'  Set ClpObj = New DataObject
' Range("D5:At46").Select
' Bereich wird in die Zwischenablage kopiert
' Selection.Copy
With MyMessage
'Die Empfänger stehen in Spalte A ab Zeile 1
.To = Cells(52, 6) 'E-Mail Adresse
.cc = Cells(53, 6) 'CC
.Subject = Cells(54, 6) 'Betreffzeile
.Body = Cells(56, 6) & vbCrLf & Cells(57, 6) & vbCrLf & Cells(58, 6)
& vbCrLf & Cells(59, 6) & vbCrLf & Cells(60, 6)
& vbCrLf & Cells(61, 6) & vbCrLf & Cells(62, 6)
& vbCrLf & Cells(63, 6) & vbCrLf & Cells(64, 6)
'Zwischenablage wird eingefügt
' ClpObj.GetFromClipboard
'.Body = ClpObj.GetText(1)
'Hier wird die Mail angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'.Send
End With
'Objectvariablen leeren
Set MyOutApp = Nothing 'CreateObject("Outlook.Application")
Set MyMessage = Nothing 'MyOutApp.CreateItem(0)
'Sendepause einschalten
'Outlook kann die Aufträge nicht schnell genug verarbeiten
Application.Wait (Now + TimeValue("0:00:05"))
Next i
End Sub
Code zum Speichern:
Sub Schaltfläche2_Klicken()
Dim strPath$, intFormat%, strName$, strExt$
strPath = "\\sstr102f.str.daimlerchrysler.com\estr_shr002\estr_te_sv\5 Abteilung\"
With ThisWorkbook
intFormat = .FileFormat 'Fileformat
strExt = Mid$(.Name, InStrRev(.Name, "."), Len(.Name)) 'Extension
strName = ActiveSheet.Name & "_" & Cells(7, 4) & strExt 'Name neue Datei
.ActiveSheet.Copy 'neue Datei erstellen durch kopieren
End With
With ActiveWorkbook
Range("A1:AU500").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1:B500").Select
Selection.ClearContents
Range("e51:ar90").Select
Selection.ClearContents
Range("e51:ar90").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A1").Select
.SaveAs strPath & strName, FileFormat:=intFormat
.Close 'schließen
End With
End Sub

Vielen herzlichen Dank.
Jens

29
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: E-Mail aus Excel mit Anhang versenden
11.04.2013 09:18:08
Klaus
Hallo Jens,
dein Save-Code ist ja schrecklich, bereinige den doch mal von den ganzen unnötigen selects!
Wie auch immer - zu deinem Problem:
Der Save-Code wird um folgendes erweitert (natürlich vor dem Close !!!)
     With ActiveWorkbook
        Dim AWS As String
AWS = .FullName
.Close
End With
Jetzt steht im String "AWS" dein Dateiname inklusive Pfadangabe.
In deinen Outlook-Code fügst du jetzt ein dass die Datei "AWS" angehängt wird:
      With MyMessage
'add attachement
.Attachments.Add AWS
.body = sMailBody
'Hier wird die Mail angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'.Send
End With
natürlich musst du die Variable AWS entweder PUBLIC machen oder von deinem Speichern-Code an deinen Outlook-Code übergeben.
Alternativ dürfte auch die Zeile
.Attachments.Add "C:\Pfad\Pfad\Datename.xlsx"
funktionieren, aber natürlich weniger flexibel.
Grüße,
Klaus M.vdT.

Anzeige
AW: E-Mail aus Excel mit Anhang versenden
11.04.2013 09:24:39
Klaus
Hi,
Hier der ganze Code überarbeitet:
Option Explicit
Sub Schaltfläche2_Klicken()
Dim strPath$, intFormat%, strName$, strExt$
Dim AWS As String
strPath = "\\sstr102f.str.daimlerchrysler.com\estr_shr002\estr_te_sv\5 Abteilung\"
With ThisWorkbook
intFormat = .FileFormat 'Fileformat
strExt = Mid$(.Name, InStrRev(.Name, "."), Len(.Name)) 'Extension
strName = ActiveSheet.Name & "_" & Cells(7, 4) & strExt 'Name neue Datei
.ActiveSheet.Copy 'neue Datei erstellen durch kopieren
End With
With ActiveWorkbook
.Range("A1:AU500").Value = .ReadOnly("A1:AU500").Value
.Range("A1:B500").ClearContents
With .Range("e51:ar90")
.ClearContents
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.SaveAs strPath & strName, FileFormat:=intFormat
AWS = .FullName
.Close 'schließen
End With
Call Excel_Serial_Mail(AWS)
End Sub
Sub Excel_Serial_Mail(sFileAttachedName As String)
Dim MyOutApp As Object, MyMessage As Object
Dim i As Long
For i = 1 To 1
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
'Die Empfänger stehen in Spalte A ab Zeile 1
.To = Cells(52, 6) 'E-Mail Adresse
.cc = Cells(53, 6) 'CC
.Subject = Cells(54, 6) 'Betreffzeile
.Body = Cells(56, 6) & vbCrLf & Cells(57, 6) & vbCrLf & Cells(58, 6) _
& vbCrLf & Cells(59, 6) & vbCrLf & Cells(60, 6) _
& vbCrLf & Cells(61, 6) & vbCrLf & Cells(62, 6) _
& vbCrLf & Cells(63, 6) & vbCrLf & Cells(64, 6)
'add attachement
.Attachments.Add sFileAttachedName
'Hier wird die Mail angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'.Send
End With
'Objectvariablen leeren
Set MyOutApp = Nothing 'CreateObject("Outlook.Application")
Set MyMessage = Nothing 'MyOutApp.CreateItem(0)
'Sendepause einschalten
'Outlook kann die Aufträge nicht schnell genug verarbeiten
Application.Wait (Now + TimeValue("0:00:05"))
Next i
End Sub

Bei VBA-GUT hättest du aber die .selects bereits selbst reduzieren müssen!
Grüße,
Klaus M.vdT.

Anzeige
intellisense ....
11.04.2013 09:28:57
Klaus
statt
.Range("A1:AU500").Value = .ReadOnly("A1:AU500").Value
natürlich
.Range("A1:AU500").Value = .Range("A1:AU500").Value
Grüße,
Klaus M.vdT.

AW: intellisense ....
11.04.2013 10:34:00
Jens
Vielen herzlichen Dank für die sofortige Hilfe. Gut ist wahrscheinlich bei Profis Definitionssache. Ich fand es gut, das ich soweit gekommen bin.
Leider bekomme ich genau bei der Zeile
.Range("A1:AU500").Value = .Range("A1:AU500").Value
eine Fehlermeldung. Dürft ich bitte hier nochmals um Hilfe bitten. Vielen Dank
Jens

AW: intellisense ....
11.04.2013 10:35:26
Klaus
.Range("A1:AU500").Value = .Range("A1:AU500").Value
ist korrekt. Kommt innerhalb von A1:AU500 ein Fehlerwert (Div/O, NA, usw) vor?
dann nimm das umständlichere und langsamere
.Range("A1:AU500").Copy
.Range("A1:AU500").pastespecial xlpastevalues

Grüße,
Klaus M.vdT.

Anzeige
AW: intellisense ....
11.04.2013 10:57:15
Jens
Vielen Dank, doch leider geht auch das nicht. Der Prozess bleibt auch dann bei
.Range("a1:AU500").Copy stehen.
Ich habe in dem Bereich ein paar spalten ausgeblentet, kann es daran liegen?
Gruuß Jens

doofer Feher von mir, sorry ....
11.04.2013 11:05:25
mir,
Hi,
ändere diesen falschen Teil
    With ActiveWorkbook
.Range("A1:AU500").Value = .ReadOnly("A1:AU500").Value
folgendermaßen ab:
    With ActiveWorkbook.Activesheet
.Range("A1:AU500").Value = .Range("A1:AU500").Value
da hab ich mich beim tippen verhaspelt, sorry.
Grüße,
Klaus M.vdT.

Anzeige
AW: doofer Feher von mir, sorry ....
11.04.2013 11:25:43
mir,
Erneut vielen Dank für die schnelle Antwort. Leider komme ich über diesen Punkt nicht hinaus, er bleibt hängen. Ich habe versucht die Formatierung erst einmal weg zu lassen. Aber dann bleibt er leider wieder hängen und zwar bei
AWS = .FullName
Option Explicit
Sub Excel_Serial_Mail_1()
Dim strPath$, intFormat%, strName$, strExt$
Dim AWS As String
strPath = "\\sstr102f.str.daimlerchrysler.com\estr_shr002\estr_te_sv\5 Abteilung\TE-SVR\2  _
Planung_JA\2.6 2013\2.6.5 Kufri\Kufri 04\"
With ThisWorkbook
intFormat = .FileFormat 'Fileformat
strExt = Mid$(.Name, InStrRev(.Name, "."), Len(.Name)) 'Extension
strName = ActiveSheet.Name & "_" & Cells(7, 4) & strExt 'Name neue Datei
.ActiveSheet.Copy 'neue Datei erstellen durch kopieren
End With
With ActiveWorkbook.ActiveSheet
.SaveAs strPath & strName, FileFormat:=intFormat
AWS = .FullName
.Close 'schließen
End With
Call Excel_Serial_Mail(AWS)
End Sub
ist bestimmt nur eine Kleinigkeit, aber dazu bin ich leider nicht gut genug.
Gruß Jens

Anzeige
AW: doofer Feher von mir, sorry ....
11.04.2013 11:34:41
mir,
Hi,
nochmal ganz von vorne und nicht immer in Häppchen.
So sollte es jetzt laufen!
Option Explicit
Sub Schaltfläche2_Klicken()
Dim strPath$, intFormat%, strName$, strExt$
Dim AWS As String
strPath = "\\sstr102f.str.daimlerchrysler.com\estr_shr002\estr_te_sv\5 Abteilung\"
With ThisWorkbook
intFormat = .FileFormat 'Fileformat
strExt = Mid$(.Name, InStrRev(.Name, "."), Len(.Name)) 'Extension
strName = ActiveSheet.Name & "_" & Cells(7, 4) & strExt 'Name neue Datei
.ActiveSheet.Copy 'neue Datei erstellen durch kopieren
End With
With ActiveWorkbook
With .ActiveSheet
.Range("A1:AU500").Value = .Range("A1:AU500").Value
.Range("A1:B500").ClearContents
With .Range("e51:ar90")
.ClearContents
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
End With
.SaveAs strPath & strName, FileFormat:=intFormat
AWS = .FullName
.Close 'schließen
End With
Call Excel_Serial_Mail(AWS)
End Sub
Sub Excel_Serial_Mail(sFileAttachedName As String)
Dim MyOutApp As Object, MyMessage As Object
Dim i As Long
For i = 1 To 1
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
'Die Empfänger stehen in Spalte A ab Zeile 1
.To = Cells(52, 6) 'E-Mail Adresse
.cc = Cells(53, 6) 'CC
.Subject = Cells(54, 6) 'Betreffzeile
.Body = Cells(56, 6) & vbCrLf & Cells(57, 6) & vbCrLf & Cells(58, 6) _
& vbCrLf & Cells(59, 6) & vbCrLf & Cells(60, 6) _
& vbCrLf & Cells(61, 6) & vbCrLf & Cells(62, 6) _
& vbCrLf & Cells(63, 6) & vbCrLf & Cells(64, 6)
'add attachement
.Attachments.Add sFileAttachedName
'Hier wird die Mail angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'.Send
End With
'Objectvariablen leeren
Set MyOutApp = Nothing 'CreateObject("Outlook.Application")
Set MyMessage = Nothing 'MyOutApp.CreateItem(0)
'Sendepause einschalten
'Outlook kann die Aufträge nicht schnell genug verarbeiten
Application.Wait (Now + TimeValue("0:00:05"))
Next i
End Sub

Anzeige
AW: doofer Feher von mir, sorry ....
11.04.2013 11:42:47
mir,
Super, genau so soll es laufen. Ein toller Code und tut genau das was ich möchte.
Herzlichen Dank.
Jens

Danke für die Rückmeldung! Aber ...
11.04.2013 11:45:47
Klaus
... bleib nochmal im anderen Zweit bei "mumpels" Code dran.
Es schadet ja nicht, statt dem erstbesten lauffähigen Code (meinem) lieber einen eleganten und gut geschriebenen (mumpel) zu nehmen!
Grüße,
Klaus M.vdT.

AW: intellisense ....
11.04.2013 11:23:25
mumpel
Hallo!
Hier mal ein "sauberes" Makro, ohne "Selection" und "Activate".
Wenn Du den Inhalt in den Mailbody möchtest dann Word und Excel: Als Emailanhang
Gruß, René

Anzeige
.display oder .send?
11.04.2013 11:25:23
Klaus
Hallo Mumpel,
irre ich mich, oder hast du mit
.display / .send
den wichtigsten Punkt vergessen?
Grüße,
Klaus M.vdT.

AW: .display oder .send?
11.04.2013 11:31:38
Jens
Vielen Dank für den tollen Code, leider geht er hier nicht weiter
AWS = Environ("JensK20") & "\Desktop\" & ThisWorkbook.Sheets("Tabelle1").Range("D7").Value & ".xlsx"
Sorry Jens

AW: .display oder .send?
11.04.2013 11:33:55
Hajo_Zi
ich hätte ja
Environ("UserName") geschrieben ich glaube die Eigenschaft "JensK20" kennt Excel nicht.

AW: .display oder .send?
11.04.2013 11:34:11
mumpel
"Environ("JensK20")" ist falsch. Die Umgebungsvariable muss "USERPROFILE" heissen. Also die Umgebungsvariable bitte nicht ändern. Environ("USERPROFILE") verweist immer auf das aktualle Benutzerprofil.

Anzeige
AW: .display oder .send?
11.04.2013 11:36:44
Jens
Die Fehlermeldung lautet dann, "index außerhab des gültigen Bereichs"
was muß ich denn da noch ändern.
Vielen Dank
Jens

AW: .display oder .send?
11.04.2013 11:37:56
mumpel
Den Tabellennamen angepasst?

AW: .display oder .send?
11.04.2013 13:38:54
Jens
Hallo Mumpel,
habe ich gemacht, dann passt es super.
Hast du noch eine Idee wie ich den Bereich so in das neue Dokument bekomme, das ausgeblendetet Spalten auch in der erstellten Datei ausgeblendet sind. Geht so etwas auch.
Vielen Dank
Jens

AW: .display oder .send?
11.04.2013 11:32:14
mumpel
Nein, habe ich nicht. Ich nutze gleich am Anfang ".GetInspector.Display". Damit wird sichergestellt, dass auch die Signatur angehängt wird. Ein weiteres ".Display" ist nicht erforderlich.

Anzeige
OT: Signatur AW: .display oder .send?
11.04.2013 11:44:32
Klaus
Damit wird sichergestellt, dass auch die Signatur angehängt wird.
Hallo Mumpel,
du hast mir gerade bei einem anderem Projekt wahnsinnig weiter geholfen, vielen dank!! Ich trau mich kaum das zuzugeben, aber ich habe die Signatur bisher mit einer "SendKeys"-Kette eingefügt oder direkts in den VBA-Code geschrieben.
Grüße,
Klaus M.vdT.

OT: Signatur AW: .display oder .send?
11.04.2013 12:24:20
mumpel
Das mit SendKeys ist ein alter Hut, der immer wieder propagiert wird. Stammt wohl noch aus einer Zeit, in der es den Outlook.Inspector noch nicht gab. SendKeys ist aber genauso unsinnig wie zwei Objekte für das Erstellen der email. Wenn Du Dir meinen Code ansiehst wirst Du feststellen, dass es nur ein Objekt gibt, und nicht zwei eigenständige für Outlook und für die Mail wie in anderen Beispielcodes. In VBA genügt ein Objekt, also nur ein "Set". In OOo/LibreOffice (Starbasic) ist das jedoch anders, da muss man zwingend zwei Objekte nutzen.

Nachtrag
11.04.2013 12:27:12
mumpel
Im Beispielcode des TO siehst Du auch zwei Objekte, nämlich "MyOutApp As Object" und "MyMessage As Object". Aber es genügt "MyOutApp", siehe mein Beispielcode (olApp As Object).

AW: Nachtrag
11.04.2013 12:35:28
Jens
der zweite Code funktioniert noch besser, da nun auch die Signatur mit gnommen wird. Vielen Dank.
Es war tatsächlich nur der Tabllenname an zwei Stellen zu ändern.
Vielen herzlichen Dank.
Jens

AW: Nachtrag
11.04.2013 13:06:00
Jens
Hallo Mumpel,
gibt es noch eine Möglichkeit, die Formate aus dem Ausgangsblatt mit zu übertragen. Die fehlen nämlich. Das wäre super.
Vielen Dank
Jens

AW: Nachtrag
11.04.2013 13:33:36
Klaus
Hi Jens,
diesen Block
Rem In neue Arbeitsmappe einfügen
With ActiveWorkbook
.Sheets("Tabelle1").Range("A1").PasteSpecial xlPasteValues
.SaveAs Filename:=AWS, FileFormat:=xlOpenXMLWorkbook
.Close
End With
so aktualisieren:
Rem In neue Arbeitsmappe einfügen
With ActiveWorkbook
.Sheets("Tabelle1").Range("A1").PasteSpecial xlPasteValues
.Sheets("Tabelle1").Range("A1").PasteSpecial xlPasteFormats
.SaveAs Filename:=AWS, FileFormat:=xlOpenXMLWorkbook
.Close
End With

AW: Nachtrag
11.04.2013 13:48:08
Jens
Super, danke.
Eine Frage hab ich noch, kann man die Daten auch noch so einfügen, das die ausgeblendetet Spalten aus der Ursprungsdatei auch in der neuen ausgeblendet sind.
Vielen Dank.
Jens

ausgeblendete Spalten
11.04.2013 13:56:28
Klaus
Hallo Jens,
statt die Spalten einzeln auf sichtbarkeit zu prüfen (kompliziert), kopiere einfach nur die sichtbaren spalten.
Diesen Block:
Rem Tabellenbereich in neue Arbeitsmappe
ThisWorkbook.Sheets("Tabelle1").Range("D5:AT46").Copy

so ändern:
Rem Tabellenbereich in neue Arbeitsmappe
ThisWorkbook.Sheets("Tabelle1").Range("D5:AT46").SpecialCells(xlCellTypeVisible).Copy

Grüße,
Klaus M.vdT.

AW: intellisense ....
11.04.2013 13:22:06
Klaus
Hallo Mumpel,
danke für deine vielen Ausführungen zum Outlook-Objekt! Ich habe mir daraus einen neuen Standardcode gebaut, den ich ab jetzt einsetzen werde.
Das ganze hat mir sehr geholfen!
Fürs Archiv der Code:
Option Explicit
'Module to send Excel-Sheet directly 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
Sub SendExample()
'give variables to send-Makro like this!
Dim wkbThisBook As Workbook
Dim sSheet As String
Dim sText As String
Dim sTo As String
Dim sCC As String
Dim sSubject As String
Set wkbThisBook = ActiveWorkbook
sSheet = "Sheet1"
sTo = "Frank Farmer ; Karl Ransaier "
sCC = ""
sText = "Dear Colleages 
find mail attached
sSubject = "Todays File" Call SendSheetOutlook(wkbThisBook, sSheet, sSubject, sTo, sCC, sText) 'CALL possible in one line! 'Call SendSheetOutlook(ActiveWorkbook, "Sheet1", "Todays File", "Frank Farmer ; Karl Ransaier ", "", "Dear Colleages
find mail attached
") End Sub Private Sub SendSheetOutlook(wkbOld As Workbook, wksOld As String, sSubject As String, sTo As _ String, sCC As String, sText As String) Dim olApp As Object Dim AWS As String Dim olSheetsCount As Integer Dim olOldBody As String 'define temporary Path and Filename AWS = wkbOld.Path & "\" & Format(Date, "YYYYMMDD") & "_" & Format(Time, "hhmmss") & "_" & _ wkbOld.Name 'remember ammount of tables for new sheet olSheetsCount = Application.SheetsInNewWorkbook 'set ammount of tables to one, so new file will not have 3-x empty tables Application.SheetsInNewWorkbook = 1 'add new empty workbook. Will be in FOCUS from now on! Workbooks.Add 'restore ammount of tables to old value Application.SheetsInNewWorkbook = olSheetsCount 'copy entire sheet wkbOld.Sheets(wksOld).Cells.Copy 'paste into new sheet as values, save sheet and close sheet under TEMP filename With ActiveWorkbook .Sheets(1).Range("A1").PasteSpecial xlPasteValues .SaveAs Filename:=AWS, FileFormat:=xlOpenXMLWorkbookMacroEnabled .Close End With '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 'remove TEMP file Kill AWS End Sub

307 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige