AW: Exceltabelle mit Outlook als Textdatei versenden
02.06.2012 21:52:31
fcs
Hallo Thomas,
ich hab die Makros etwas angepasst.
Das Blatt "Daten" wird jetzt innerhalb der Arbeitsmappe kopiert, dann alle Formeln durch Werte ersetzt. Diese Kopie ohne Formeln wird dann in eine neue Mappe verschoben und die Textdatei erzeugt.
Gruß
Franz
Sub MailVersenden()
Dim outl As Object
Dim Mail As Object
Dim strPfad As String, strTextFile As String
Dim wksDaten As Worksheet
On Error GoTo Fehler
'Verzeichnis und Name für Textdatei ggf. anpassen
strPfad = ThisWorkbook.Path
strTextFile = strPfad & Application.PathSeparator & "QMC_" & Format(Date, "YYYY-MM-DD") _
& ".txt"
'Kopie von Blatt "Daten erstellen und Formeln durch Werte ersetzen
Worksheets("Daten").Copy before:=ActiveWorkbook.Sheets(1)
Set wksDaten = ActiveWorkbook.Sheets(1)
With wksDaten.UsedRange
.Value = .Value
End With
'Fileformat für Textdatei und Anzeige für Warnungen ggf. anpassen
If fncMakeTextFile(wks:=wksDaten, strFileName:=strTextFile, _
lngFileFormat:=xlTextWindows, bolDisplayAlerts:=False, bolCopy:=False) = True Then
Application.DisplayAlerts = True
Set outl = CreateObject("Outlook.Application")
Set Mail = outl.CreateItem(0)
Mail.Subject = "QMC"
Mail.Body = "Hallo" & Chr(13) & _
"anbei QMC im aktuellen Monat " & _
" Mit freundlichen Grüßen" & Chr(13) & _
" TL "
Mail.Attachments.Add strTextFile, 1 ' 1 = olByValue
Mail.Display
Set outl = Nothing
Set Mail = Nothing
Else
MsgBox "Mail wurde nicht erstellt!", vbInformation + vbOKOnly, _
"Blatt ""Daten"" versenden"
End If
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Set wksDaten = Nothing
End Sub
Function fncMakeTextFile(wks As Worksheet, strFileName As String, _
Optional lngFileFormat As Long = xlTextWindows, _
Optional bolLocal As Boolean = True, _
Optional bolCopy As Boolean = True, _
Optional bolDisplayAlerts As Boolean = True) As Boolean
Dim wbTxt As Workbook
'bolLocal: True = Lokale Einstellungen für Trennzeichen verwenden (bei CSV)
'bolCopy: True = Kopie des Tabellenblattes wird in neuer Arbeitsmappe erstellt _
False = Tabellenblatt wird in neue Arbeitsmappe verschoben
'Werte für Parameter lngFileformat
'xlCSV = 6 CSV
'xlTextMac = 19 Macintosh-Text
'xlTextWindows = 20 Windows Text
'xlTextMSDOS = 21 MSDOS-Text
'xlCSVMac = 22 CSV (Macintosh)
'xlCSVWindows = 23 CSV (Windows)
'xlCSVMSDOS = 24 CSV (MSDOS)
'xlTextPrinter = 36 Druckertext
'xlUnicodeText = 42 Unicode Text
'xlCurrentPlatformText = -4158 Aktueller Plattformtext
On Error GoTo Fehler
'Tabellenblatt in neue Arbeitsmappe verschieben/kopieren
If bolCopy = True Then
wks.Copy
Else
wks.Move
End If
Set wbTxt = ActiveWorkbook
'Textdatei erstellen
Application.DisplayAlerts = bolDisplayAlerts
wbTxt.SaveAs Filename:=strFileName, FileFormat:=lngFileFormat, Local:=bolLocal
wbTxt.Close savechanges:=False
Application.DisplayAlerts = True
fncMakeTextFile = True
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
fncMakeTextFile = False
End Select
End With
End Function