Code:
' This code written by Timothy Brigham ' May 2006 and distributed in the public domain Set objOutlook = CreateObject("Outlook.Application") Set objNamespace = objOutlook.GetNamespace("MAPI") Set objFolder = objNamespace.PickFolder() Set colItems = objFolder.Items Dim SaveFolder Set FSO = CreateObject("Scripting.FileSystemObject") Dim UserName SaveFolder = InputBox("Please Enter Save Path") if fso.FolderExists(SaveFolder) = false then FSO.CreateFolder(SaveFolder) end if WScript.Echo "There are " & colItems.Count & " items to be evaluated." for each Item in colItems ' read each item in the folder WScript.Echo "Reading " & Item.Subject ' Not needed, but good to see what is going on. WScript.Echo " Attachments: " & Item.Attachments.Count Set Attachments = Item.Attachments if Attachments.Count > 0 then ' Add a statement about removing the file here Item.HTMLBody = Item.HTMLBody & vbVr & _ "<p> <p>" ' TODO: Add a statement about moving the files Item.Save end if Dim AttachmentsCount AttachmentsCount=Attachments.Count for index = AttachmentsCount To 1 Step -1 Set Attachment = Attachments(index) WScript.Echo " Saving " & Attachment.FileName ' Again not needed, just to see what is going on. Dim SaveName Dim TmpName Dim Name TmpName = FSO.GetTempName ' This helps avoid clobering files with the same name ' but really there should be a filesystemobject check to be 100% sure. Name = TmpName & "__" & Attachment.FileName SaveName = SaveFolder & Name Attachment.SaveAsFile SaveName Attachment.Delete Dim Body Body = Item.HTMLBody & vbVr & "<a href='"&SaveName&"'>" & SaveName & "</a><br>" Item.HTMLBody=Body Item.Save ' If you want to simply delete the attachments you can axe the SaveAsFile ' and all the changes made to the Body.HTMLBody On Error Resume Next next On Error Resume Next next