Und dann Blatt als Mail schicken:
08.05.2014 15:12:39
EtoPHG
Hallo Christian,
Gesamter Code ersetzen.
Konstante cMailReceiver anpassen, und los:
Option Explicit
Private Sub Wochenauswertung_Click()
Const cThisRange As String = "A1:F32"
Const cMailReceiver As String = "deine.email@adresse.de"
Dim bCheckWSExists As Boolean
Dim sName As String
Dim OutApp As Object
Dim OutMail As Object
sName = Str(Date + 1) ' Neuer Blattname
On Error Resume Next ' Wird überprüft, ob er bereits vorkommt
bCheckWSExists = Not ThisWorkbook.Worksheets(sName) Is Nothing
On Error GoTo 0
If bCheckWSExists Then
MsgBox "Die Daten für " & sName & " wurden bereits kopiert!", vbExclamation, "Copy"
Else
With Worksheets.Add(Before:=Me)
.Name = sName
Worksheets("Auswertung").Range(cThisRange).Copy
.Cells(1, 1).PasteSpecial Paste:=xlPasteAll
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Range(.Cells(1, 7), .Cells(1, .Columns.Count)).EntireColumn.Hidden = True
.Range(.Cells(33, 1), .Cells(.Rows.Count, 1)).EntireRow.Hidden = True
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cMailReceiver
.Subject = "Neue Auswertung " & sName
.HTMLBody = RangetoHTML(Worksheets(Me.Index - 1).Range(cThisRange))
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End With
End If
Application.CutCopyMode = False
End Sub
' Source: http:// _
msdn.microsoft.com/en-us/library/ff519602(office.11).aspx
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Gruess Hansueli