ohne Outlook mit CDO.Message Mail senden
16.03.2014 13:42:17
Tino
Hallo,
hier noch eine Version ohne Outlook.
Hier habe ich zwar Google verwendet aber Yahoo dürfte in etwa gleich sein.
Die Felder für Yahoo und Deinem Konto entsprechend anpassen!
Ich gehe davon aus, das die Daten wie von dir beschrieben auf der Tabelle1 stehen.
In Zeile 1 die Überschrift und die Daten ab Zeile 2.
Quelle:
http://msdn.microsoft.com/en-us/library/ms526453%28v=exchg.10%29.aspx
Sub EMail_Senden_Ohne_Outlook()
Dim objNachricht As Object, objKonfig As Object
Dim sPath$, MailAdresse$, strBody$, tmpHTTP$
Dim n&
'Tabelle evtl. anpassen
With Tabelle1
'Mail Adressen *****************************
n = .Cells(.Rows.Count, 1).End(xlUp).Row
If n < 2 Then Exit Sub 'keine Daten, ab Zeile 2
If n = 2 Then
MailAdresse = .Cells(n, 6).Value
Else
MailAdresse = Join(Application.Transpose(.Range("F2", .Cells(n, 6)).Value2), ";")
End If
Do While InStr(MailAdresse, ";;") > 0
MailAdresse = Replace(MailAdresse, ";;", ";")
Loop
'keine Mailadressen? (keine Plausibilitätsprüfung)
If MailAdresse = "" Then Exit Sub
'Body - Text aus Textfeld in der Tabelle1 mit dem Namen Textfeld 1
strBody = .Shapes("Textfeld").DrawingObject.Text
End With
'Pfad wo die PDF liegt mit "\" am ende
sPath = ThisWorkbook.Path & IIf(Right$(ThisWorkbook.Path, 1) <> "\", "\", "")
'Pfad und Dateiname
sPath = sPath & "Test.pdf"
'Konfigurieren *************************************
Set objKonfig = CreateObject("CDO.Configuration")
tmpHTTP = "http://schemas.microsoft.com/cdo/configuration/"
With objKonfig
.Load -1
With .Fields
.Item(tmpHTTP & "sendusername") = "Mustermann@Musterproviter.com" 'Deine E-Mail-Adresse o. Username
.Item(tmpHTTP & "sendpassword") = "xxxxxx" 'Passwort angeben
.Item(tmpHTTP & "smtpserver") = "smtp.gmail.com" 'Postausgangsserver
.Item(tmpHTTP & "smtpusessl") = True 'SSL Verschlüsselung aktivieren
.Item(tmpHTTP & "smtpauthenticate") = 1 'SMTP Authentifizierung
.Item(tmpHTTP & "sendusing") = 2 'SMTP-Servers 1 = lokaler; 2 = extern
.Item(tmpHTTP & "smtpserverport") = 465 'SMTP-Port
.Item(tmpHTTP & "smtpconnectiontimeout") = 60 'Timeout
.Update
End With
End With
'Mail senden
Set objNachricht = CreateObject("CDO.Message")
With objNachricht
Set .Configuration = objKonfig
.To = MailAdresse 'Empfänger
.CC = "" 'Zur Kenntnis
.BCC = "" '.BCC nicht sichtbare Empfänger
.ReplyTo = ""
.Sender = "Absender@googlemail.com" 'Von
.From = """Mein Name"" " 'Absendername
.Subject = "Test Sende Pdf-File" 'Betreffzeile
.TextBody = strBody 'Nachricht
.AddAttachment sPath 'Anlage Pfad und Dateiname
.Send
End With
Set objNachricht = Nothing: Set objKonfig = Nothing
End Sub
Gruß Tino