Ich habs mal so gelöst, musste mal schauen obs geht, pass aber auf das Du beim Outlook 2000 nicht SR2 installiert hast!!!So gehts mit Netscape
Mit Outlook
~begin~
Private Sub form_abschicken_Click()
If EmailAdr.Value = "" Then
MsgBox ("Bitte wählen Sie die Mail Adresse aus," & Chr(13) & "an die Sie das Formular schicken wollen!")
ElseIf betreff.Value = "" Then
MsgBox ("Bitte tragen Sie Sie einen Betreff ein")
Else
'Änderungen ausschalten
Application.ScreenUpdating = False
If IstMappeOffen("Daten_senden.XLS") = False Then
Workbooks.Open ThisWorkbook.Path & "\Daten_senden.xls"
Workbooks("Daten_senden.xls").Sheets("Auswertung Art").Range("B7:R286").Value = Workbooks("Steuerung.xls").Sheets("Auswertung Art").Range("B7:L286").Value
Workbooks("Daten_senden.xls").Sheets("Auswertung Art").Range("D2").Value = Benutzer.Value
Workbooks("Daten_senden.xls").Save
Workbooks("Daten_senden.xls").Close
ElseIf IstMappeOffen("Daten_senden") = True Then
Windows("Daten_senden").Activate
Workbooks("Daten_senden.xls").Sheets("Auswertung Art").Range("B7:R286").Value = Workbooks("Steuerung.xls").Sheets("Auswertung Art").Range("B7:L286").Value
Workbooks("Daten_senden.xls").Sheets("Auswertung Art").Range("D2").Value = Benutzer.Value
Workbooks("Daten_senden.xls").Save
Workbooks("Daten_senden.xls").Close
Else
End If
Dim Textfuellen As String
Textfuellen = Chr(13) & "Sehr geehrte Damen und Herren," & Chr(13) & Chr(13) & "anbei erhalten Sie die Datei für die " & Chr(13) & Chr(13) & Chr(13) & "Mit freundlichen Grüßen" & Chr(13) & Chr(13) & Benutzer.Value & Chr(13) & Chr(13) & Chr(13)
Dim Anmerkung As String
Anmerkung = "Anmerkung: " & body.Value & Chr(13) & Chr(13)
'Mail senden
If body.Value = "Raum für Zusatzinfos" Then
Outlook_Mail EmailAdr.Value, betreff.Value, Textfuellen, ThisWorkbook.Path & "\Daten_senden.xls" 'body.Value & Chr(13) & " " & Chr(13)'
Else
Outlook_Mail EmailAdr.Value, betreff.Value, Textfuellen & Anmerkung, ThisWorkbook.Path & "\Daten_senden.xls" 'body.Value & Chr(13) & " " & Chr(13)'
End If
'Formular schliessen
Unload Me
'Änderungen einschalten
Application.ScreenUpdating = True
gesendet = MsgBox("Nachricht wurde erfolgreich gesendet", vbInformation, "Emailversand")
End If
End Sub
'------------------------------------------------------------------------------
Sub Outlook_Mail(EmailEmpfänger As String, EmailBetreff As String, _
Optional EmailMsg As String, Optional EmailAnlage As String)
'------------------------------------------------------------------------------
Dim myOlApp, olMailItem, MailItem, myRecipient, myAttachments
'Outlook wird geöffnet
Set myOlApp = CreateObject("Outlook.Application")
'Fenster für neue Mail wird geöffnet
Set MailItem = myOlApp.CreateItem(olMailItem) ' opens new email
'On Error GoTo ErrorHandler
'Empfänger der Mail wird in das Adressfeld "An:" geschrieben
Set myRecipient = MailItem.Recipients.Add(EmailEmpfänger)
'Betreff der Mail wird in das Feld "Betreff:" geschrieben
MailItem.Subject = EmailBetreff
'Der Text der Nachricht wird übertragen
MailItem.body = EmailMsg
'Wenn Anlage angehängt werden soll, in nächster Zeile
'das Apostroph entfernen.
If EmailAnlage <> "" Then Set myAttachments = MailItem.Attachments.Add(EmailAnlage)
MailItem.Send 'Email wird gesendet
Exit Sub
ErrorHandler:
MsgBox vbTab & "Eine E-Mail an die Adresse " & vbCrLf & vbCrLf & _
vbTab & EmailEmpfänger & vbCrLf & vbCrLf & _
"kann leider NICHT automatisch versendet werden."
End Sub
Private Sub UserForm_Initialize()
On Error GoTo ohne
Dim objOutlook As Outlook.Application
Dim objAddressList As Outlook.AddressList
Dim objAddressEntry As Outlook.AddressEntry
Dim arrAdressen() As String
Dim intCounter As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objAddressList = objOutlook.Session.AddressLists("Globales Adressbuch")
For Each objAddressEntry In objAddressList.AddressEntries
intCounter = intCounter + 1
Application.StatusBar = "Lese Adresse Nr. " & intCounter & " ein..."
ReDim Preserve arrAdressen(1 To 2, intCounter)
arrAdressen(1, intCounter) = objAddressEntry.Name
arrAdressen(2, intCounter) = objAddressEntry.Address
Next objAddressEntry
EmailAdr.Column = arrAdressen
Set objOutlook = Nothing
Application.StatusBar = False
'Benutzername eintragen
Benutzer.Value = Workbooks(ThisWorkbook.Name).Sheets("Übersicht").Range("C7").Value
'Betreff eintragen
betreff.Value = "Finanzierungsauswertung"
Exit Sub
ohne:
Adressbuch = MsgBox("Adressbuch konnte nicht gefunden werden!" & Chr(13) & Chr(13) & "Wenden Sie sich an Ihren Systemadministrator.", vbInformation, "Emailversand")
End Sub
~end~
Musste Dir mal das raussuchen was Du brauchst, beim zweiten Code mache ich dies über ne UF, beim Ersten starte ich bloß daraus!!!
Viel Spaß
Steffen