Re: Hilfe bei EXCEL --> OUTLOOK
04.07.2002 12:51:42
ajk
Hallo Daniel,anbei der geänderte Code (habe Ihn miT "#") markiert!!
Sub HinweisMail()
Dim ol As New Outlook.Application
Dim ns As Outlook.NameSpace
Dim newMail As Outlook.MailItem
Dim name As String
Dim objNewAppt As AppointmentItem
Dim bereich As Range
Dim zelle As Range
Dim start As String
Dim erste As Boolean
Dim textbody
'######################################################################################################
Range("A4:F7").Select ' Hier wird DEIN Bereich definiert, Achtung Sprungmarke "aufbereiten" anpassen! ###
'######################################################################################################
'Flexibere Variante mit Inputbox
'Set bereich = Application.InputBox("Bitte zu mailenden Bereich wählen", "Benutzer: " & Application.UserName, , , , , , 8)
'If bereich. = False Then
'Exit Sub
'End If
GoSub aufbereiten
Set golApp = New Outlook.Application
'Return a reference to the MAPI layer.
Set ns = ol.GetNamespace("MAPI")
'Create a new mail message item.
Set newMail = ol.CreateItem(olMailItem)
With newMail
'Add the subject of the mail message.
.Subject = ActiveWorkbook.name
'Create some body text.
.body = "Achtung bitte kontrollieren!" & textbody
'Add a recipient and test to make sure that the
'address is valid using the Resolve method.
With .Recipients.Add("andreas.jabusch-karsten@nienburger-glas.de")
.Type = olTo
If Not .Resolve Then
MsgBox "Kann Mail-Adresse nicht auflösen.", vbInformation, "Benutzer:" & Application.UserName
Exit Sub
End If
End With
'With .Recipients.Add("weitere empfänger")
' .Type = olCC
' If Not .Resolve Then
' MsgBox "Kann Mail-Adresse nicht auflösen.", vbInformation, "Benutzer:" & Application.UserName
' Exit Sub
'End If
' End With
'Attach a file as a link with an icon.
'With .Attachments.Add _
(name, olByValue)
' .DisplayName = "Angezeigter Dateiname"
'End With
.Display
'Send the mail message.
.Send
End With
GoTo weiter
aufbereiten:
erste = False
'#########################################################################################
For Each zelle In Selection 'Selection durch bereich ersetzen, bei Flex-Variante##
'#########################################################################################
If erste = False Then
start = zelle.AddressLocal
erste = True
End If
If Left(zelle.AddressLocal, 3) <> Left(start, 3) Then
textbody = textbody & Chr(9) & zelle.Value
Else
textbody = textbody & Chr(13) & zelle.Value
End If
Next
Return
weiter:
'Release memory.
Set ol = Nothing
Set ns = Nothing
Set newMail = Nothing
End Sub
Gruß
AJK