Bild von Excel in E - Mail kopieren

Sub copyTopPicture() ' 07/07/2004 by Tobias Keller ' This Function copies each picture, which has less distance then 200 from the top ' of the border into a new e-mail Dim bild As Shape Dim olApp As Outlook.Application Dim olNS As Outlook.NameSpace Dim olFolder As Outlook.MAPIFolder Dim olMailItem As Outlook.MailItem Set olApp = CreateObject("Outlook.Application") Set olNS = olApp.GetNamespace("MAPI") Set olFolder = olNS.GetDefaultFolder(olFolderInbox) Set olMailItem = olFolder.Items.Add("IPM.Note") With Workbooks("Bericht 05_2004final.xls").Worksheets("Überblick Grafik") For Each bild In .Shapes If bild.Name Like "Picture*" Then If bild.Top < 200 Then olMailItem.Display With olMailItem .ReadReceiptRequested = True .Subject = " test" .To = "humer@web.de" .BodyFormat = olFormatHTML .HTMLBody = bild End With End If End If Next bild End With End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Tobias!
Ich habe mal vor dem Problem gestanden, von einem Excel-Tabellenbereich einen Screenshot zu machen und den über Lotus-Notes wegzumailen, weil der Empfänger kein Excel hatte. Das "Foto" wurde als .gif angelegt (Code ist zu 99% nicht mein geistiges Eigentum).
Vielleicht kommst du da ja ein wenig mit weiter. Mail-Code zum Schluss auf Outlook anpassen.
Viele Grüße,
Jens
****************************************************************************************
Dim container As Chart
Dim containerbok As Workbook
Dim Obnavn As String
Dim Sourcebok As Workbook
Function SelectArea() As String
Dim Internrange As Range
On Error GoTo Brutt
Set Internrange = Brutt
'für manuelles Auswählen des Bereichs:
'Set Internrange = Application.InputBox("Select " _
& "range to be photographed:", "Picture Selection", _
Selection.AddressLocal, Type:=8)
SelectArea = Internrange.Address
Exit Function
Brutt:
SelectArea = "A1:k39"
End Function
Function sShortname(ByVal Orrginal As String) As String
Dim iii As Integer
sShortname = ""
For iii = 1 To Len(Orrginal)
If Mid(Orrginal, iii, 1) " " Then _
sShortname = sShortname & Mid(Orrginal, iii, 1)
Next
End Function


Private Sub ImageContainer_init()
Workbooks.Add (1)
ActiveSheet.Name = "GIFcontainer"
Charts.Add
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Worksheets(1).Range("A1")
ActiveChart.Location Where:=xlLocationAsObject, _
Name:="GIFcontainer"
ActiveChart.ChartArea.ClearContents
Set containerbok = ActiveWorkbook
Set container = ActiveChart
End Sub

Sub MakeAndSizeChart(ih As Integer, iv As Integer)
Dim Hincrease As Single
Dim Vincrease As Single
Obnavn = Mid(ActiveChart.Name, Len(ActiveSheet.Name) + 1)
Hincrease = ih / ActiveChart.ChartArea.Height
ActiveSheet.Shapes(Obnavn).ScaleHeight Hincrease, _
msoFalse, msoScaleFromTopLeft
Vincrease = iv / ActiveChart.ChartArea.Width
ActiveSheet.Shapes(Obnavn).ScaleWidth Vincrease, _
msoFalse, msoScaleFromTopLeft
End Sub
Public Sub GIF_Snapshot()
Dim varReturn As Variant
Dim MyAddress As String
Dim SaveName As Variant
Dim MySuggest As String
Dim Hi As Integer
Dim Wi As Integer
Dim Suffiks As Long
Dim Maildb As Object
Dim MailDbName As String
Dim MailDoc As Object
Dim session As Object
Dim Recipient As String
Dim e As String
Dim EmbedObj As Object
Dim AttachME As Object
'Application.ScreenUpdating = False
Workbooks.Open "K:\Matthiessen\Unternehmensanleihen.xls", UpdateLinks:=False
'Dim Pause
'Pause = 15
'Start = Timer
'Do While Timer 'Loop
Set Sourcebok = ActiveWorkbook
MySuggest = sShortname(ActiveSheet.Name)
ImageContainer_init
Sourcebok.Activate
MyAddress = SelectArea
If MyAddress "A1" Then
SaveName = MySuggest '& ".gif" 'automatisches Speichern
'für manuelles Abspeichern:
'SaveName = Application.GetSaveAsFilename( _
initialfilename:=MySuggest _
& ".gif", fileFilter:="Gif Files (*.gif), *.gif")
Range(MyAddress).Select
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
If SaveName = False Then
GoTo Avbryt
End If
If InStr(SaveName, ".") Then SaveName _
= Left(SaveName, InStr(SaveName, ".") - 1)
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
Hi = Selection.Height + 4 'adjustment for gridlines
Wi = Selection.Width + 6 'adjustment for gridlines
containerbok.Activate
ActiveSheet.ChartObjects(1).Activate
MakeAndSizeChart ih:=Hi, iv:=Wi
ActiveChart.Paste
ActiveChart.Export Filename:=LCase("K:\Matthiessen\" & SaveName) & _
".gif", FilterName:="GIF"
ActiveChart.Pictures(1).Delete
Sourcebok.Activate
End If
Avbryt:
On Error Resume Next
Application.StatusBar = False
containerbok.Saved = True
containerbok.Close
Workbooks("Unternehmensanleihen.xls").Close savechanges:=False
'jetzt Übergang zum Mailen
Set session = CreateObject("Notes.NotesSession")
Set Maildb = session.CURRENTDATABASE
'On Error Resume Next
Set MailDoc = Maildb.CREATEDOCUMENT
e = InputBox("Bitte Mailempfänger (Notes-Namen ohne Zusatz) eingeben:")
If e = "" Then MsgBox "Vorgang abgebrochen!"
If e = "" Then Exit Sub
On Error Resume Next
MailDoc.Form = "Memo"
Recipient = e
MailDoc.sendto = Recipient
MailDoc.CopyTo = "Jens ...xxx"
MailDoc.Subject = "Übersicht Unternehmensanleihen"
MailDoc.body = "Hallo, hier die gewünschte Tabelle:" & Chr(10) & "Auf den Anhang mit der rechten Maustaste klicken und als 'Ansicht' öffnen ..." & Chr(10) & Chr(10) & "Viele Grüße" & Chr(10) & "Zentrale Anlageberatung"
MailDoc.SAVEMESSAGEONSEND = True
Set AttachME = MailDoc.CREATERICHTEXTITEM("K:\Matthiessen\vwd.gif")
Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", "K:\Matthiessen\vwd.gif")
MailDoc.CREATERICHTEXTITEM ("K:\Matthiessen\vwd.gif")
MailDoc.PostedDate = Now()
MailDoc.SEND 0, Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set session = Nothing
Set EmbedObj = Nothing
'Application.ScreenUpdating = True
MsgBox "Mail an " & e & " versandt!" & Chr(10) & "(Bitte ggf. prüfen unter 'Gesendet')"
End Sub

Beliebteste Forumthreads (12 Monate)

Bild von Excel in E - Mail kopieren

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bild von Excel in E - Mail kopieren

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread