AW: Nicht nachvollziehbar....
05.11.2003 09:51:39
Burgy
Hi,anbei der code
Gruß,
Burgy.
Option Explicit
Option Base 1
Dim temp As New Collection
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i As Integer
For i = 1 To 3 ' Zelle J1 - J3 enthält die Email Adressen
If Cells(i, 10) <> "" Then
temp.Add Cells(i, 10).Value
Else
End If
Next i
Call SendOutlMail
End Sub
Private Sub SendOutlMail()
Dim OOutlook As Object
Dim OOutlookMsg As Object
Dim OOutlookRecip As Object
Dim OOutlookNameSpace As Object
Dim iOCount As Integer
Dim OOutlookAnhang As String
Dim TempFileName As String
On Error GoTo msgerror
Set OOutlook = CreateObject("Outlook.Application")
Set OOutlookMsg = OOutlook.CreateItem(0)
Set OOutlookNameSpace = OOutlook.GetNamespace("MAPI")
'aus Tabelle eine Mappe erstellen
Worksheets("Tabelle1").Copy
'temporär speichern
TempFileName = Date & Format(Now, "hh-mm-ss")
'TempFileName = Date & Now
ThisWorkbook.SaveAs Filename:=TempFileName
OOutlookAnhang = ThisWorkbook.FullName
With OOutlookMsg '.ThisWorkbook
For iOCount = 1 To temp.Count
Set OOutlookRecip = .Recipients.Add(temp(iOCount))
Next iOCount
.Subject = Range("A1").Value
.body = "Test" & Chr$(13)
.attachments.Add OOutlookAnhang
.Importance = 1 '0=niedrig, 1=normal, 2=hoch
'.display ' so wird die mail nochmal angezeigt
.send
End With
OOutlookRecip.Resolve
Set OOutlookRecip = Nothing
Set OOutlookMsg = Nothing
Set OOutlook = Nothing
'Temporäre Datei schliessen und löschen
Workbooks(TempFileName & ".xls").Close
Kill TempFileName & ".xls"
'Workbooks(TempFileName).Close
'Kill TempFileName
Exit Sub
msgerror:
MsgBox Err.Number & Chr$(13) & Err.Description, vbCritical + vbOKOnly, "Error"
End Sub