/build/static/layout/Breadcrumb_cap_w.png

VBScript to extract emails save as .msg & attachments

Hi,
Please Help me, I need a VBScript to run on a system to extract emails, rename them and save them in a folder, also if possible save their attachments in the same format, I have:

Sub SaveMsg()
Dim msg As MailItem
Const strPath As String = "C:\Documents and Settings\Transfer\"
If Inspectors.Count > 0 Then
Set msg = ActiveInspector.currentItem
Else
Set msg = ActiveExplorer.Selection(1)
End If
Dim strFileName As String, intCounter As Integer
strFileName = Trim(Replace(msg.subject, ":", ";"))
strFileName = Replace(strFileName, "<", "(")
strFileName = Replace(strFileName, ">", ")")
strFileName = Replace(strFileName, """", "'")
For intCounter = 1 To Len(strFileName)
If InStr(1, "/|*?", Mid(strFileName, intCounter, 1)) > 0 Then
Mid(strFileName, intCounter, 1) = "-"
End If
Next
s
trFileName = Format(msg.SentOn, "yyyymmdd-") & msg.SenderName & "-" & strFileName & Format(msg.SentOn, "-Pers") & ".msg"
msg.SaveAs Path:=strPath & strFileName, Type:=olMSG
Set msg = Nothing
End Sub

Which works fine on one system, but the other system I can't run MACROs on outlook so NEED VBScript, I have:

CONST SAVE_LOCATION = "c:\Documents and Settings\Desktop\"
dim objOutlookApp : set objOutlookApp = CreateObject("Outlook.Application")
wscript.echo objOutlookApp.Explorers.Count
if objOutlookApp.Explorers.count then
dim objExplorer : set objExplorer = objOutlookApp.Explorers.Item(1)
end if
if objExplorer.CurrentFolder = "Inbox" then
wscript.echo "Inbox found"
dim objSelection : set objSelection = objExplorer.Selection
dim objMailItem : set objMailItem = objSelection.item(1)
dim strMsgSubject : strMsgSubject = objMailItem.Subject
dim strNewFileName : strNewFileName = CorrectNamingConvention(strMsgSubject)
objMailItem.SaveAs SAVE_LOCATION & strNewFileName & ".msg"
end if
Function CorrectNamingConvention(argSubject)
 'Write code here to check strMsgSubject for correct naming convention 
 'if it is fine, just pass argSubject as the return value as below, else change it and
 'pass the new name as the return value.
CorrectNamingConvention = argSubject
End function

Which is okay, but will only do the "inbox" (I have several sub folders) and returns an error if the email is a RE: ... or FW:...

Like I say above it has to be VBScript and ideally save emails as:
{DATE} - {Sender} - {Email Title} - {Security Marker}

Also can the security marker be a select type of affair? like select - Personal (Pers), Not for release (NFR) etc.

Anyway, any help would be greatly appreciated.

Rob

 


0 Comments   [ + ] Show comments

Answers (0)

Be the first to answer this question

 
This website uses cookies. By continuing to use this site and/or clicking the "Accept" button you are providing consent Quest Software and its affiliates do NOT sell the Personal Data you provide to us either when you register on our websites or when you do business with us. For more information about our Privacy Policy and our data protection efforts, please visit GDPR-HQ