Copy und per Email senden

Private Sub CommandButton3_Click() Worksheets("Drucken").Range("A1:AJ57").CopyPicture xlScreen, xlBitmap Dim oApp As Object Set oApp = CreateObject("Outlook.Application") On Error Resume Next With oApp.CreateItem(0) Application.Wait 1 .To = "Mail@mail.de" .Subject = "Test" & "_" & ThisWorkbook.Worksheets("Drucken").Range("BH31") .Body = "Testmail" .Display SendKeys "{END}", True SendKeys "~", True SendKeys "^v", True SendKeys "~", True .GetInspector 'fügt die Standart-Signatur an End With On Error GoTo 0 Set oApp = Nothing End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub CommandButton3_Click() Worksheets("Drucken").Range("A1:AJ57").CopyPicture xlScreen, xlBitmap Dim oApp As Object Set oApp = CreateObject("Outlook.Application") On Error Resume Next With oApp.CreateItem(0) Application.Wait 1 .To = "Mail@mail.de" .Subject = "Test" & "_" & ThisWorkbook.Worksheets("Drucken").Range("BH31") .Body = "Testmail" .Display Dim wordDoc As Word.Document Set wordDoc = outMail.GetInspector.WordEditor wordDoc.Range.PasteAndFormat wdChartPicture .GetInspector 'fügt die Standart-Signatur an End With On Error GoTo 0 Set oApp = Nothing End Sub

Hallo zum naechsten,
also wie gesagt. Nicht so ganz unkompliziert. Ich verstehe doch richtig, dass du den Bereich als Bild in die Email einfuegen willst?
Dann bitte den nachfolgenden Code in ein Modul kopieren:

Sub email_with_range()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
On Error Resume Next
Set xRg = Worksheets("Drucken").Range("A1:AJ57")
If xRg Is Nothing Then Exit Sub
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "Testmail

" _
& "

" _
With xOutMail
.Subject = "Test" & "_" & ThisWorkbook.Worksheets("Drucken").Range("BH31")
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = "Mail@mail.de"
.Display
.GetInspector
End With
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic. _
Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub

Und den Code fuer deinen Button beschraenken auf:

Call email_with_range

Lass mich wissen, obs funktioniert. Bei mir hat es.

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Copy und per Email senden

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread