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