Change modified date of msg file to email recieved date

Discussion:

(too old to reply)

strychtur

2008-01-18 20:55:43 UTC

I have a VB script that changes the name of a msg file to Sender -
Subject. Now I am looking to change the modified date to be the
received date of the email. I thought the following code should do it,
but it does not. The name changes but date does not. Any help would be
great.
Cheers
Strychtur

' VBScript source code
On Error Resume Next

Dim olkApp, olkMessage, objFSO, objFile, varFile, varNewFileName, Dir

Set olkApp = GetObject(,"Outlook.Application")

If TypeName(olkApp) <> "Application" Then
Set olkApp = CreateObject("Outlook.Application")
End If

Set objFSO = CreateObject("Scripting.FileSystemObject")

For Each varFile In WScript.Arguments
Set olkMessage = olkApp.CreateItemFromTemplate(varFile)
varNewFileName = ReplaceIllegalCharacters(olkMessage.SenderName &
"-" & olkMessage.Subject) & ".msg"
Set objFile = objFSO.GetFile(varFile)
objFile.Name = varNewFileName
Call ModFileDT (objFile.Drive, objFile.Name,
olkMessage.ReceivedTime)
Next
Set objFile = Nothing
Set objFSO = Nothing
Set olkMessage = Nothing
Set olkApp = Nothing
WScript.Quit

Function ReplaceIllegalCharacters(strSubject)
Dim strBuffer
strBuffer = Replace(strSubject, ":", "")
strBuffer = Replace(strBuffer, "\", "")
strBuffer = Replace(strBuffer, "/", "")
strBuffer = Replace(strBuffer, "?", "")
strBuffer = Replace(strBuffer, Chr(34), "'")
strBuffer = Replace(strBuffer, "|", "")
ReplaceIllegalCharacters = strBuffer
End Function

Function ModFileDT(strDir, strFileName, DateTime)
Dim objShell, objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(strDir)
objFolder.Items.Item(strFileName).ModifyDate = DateTime
End function

Pegasus (MVP)

2008-01-19 17:19:30 UTC

Permalink

Post by strychtur
I have a VB script that changes the name of a msg file to Sender -
Subject. Now I am looking to change the modified date to be the
received date of the email. I thought the following code should do it,
but it does not. The name changes but date does not. Any help would be
great.
Cheers
Strychtur
' VBScript source code
On Error Resume Next
Dim olkApp, olkMessage, objFSO, objFile, varFile, varNewFileName, Dir
Set olkApp = GetObject(,"Outlook.Application")
If TypeName(olkApp) <> "Application" Then
Set olkApp = CreateObject("Outlook.Application")
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each varFile In WScript.Arguments
Set olkMessage = olkApp.CreateItemFromTemplate(varFile)
varNewFileName = ReplaceIllegalCharacters(olkMessage.SenderName &
"-" & olkMessage.Subject) & ".msg"
Set objFile = objFSO.GetFile(varFile)
objFile.Name = varNewFileName
Call ModFileDT (objFile.Drive, objFile.Name,
olkMessage.ReceivedTime)
Next
Set objFile = Nothing
Set objFSO = Nothing
Set olkMessage = Nothing
Set olkApp = Nothing
WScript.Quit
Function ReplaceIllegalCharacters(strSubject)
Dim strBuffer
strBuffer = Replace(strSubject, ":", "")
strBuffer = Replace(strBuffer, "\", "")
strBuffer = Replace(strBuffer, "/", "")
strBuffer = Replace(strBuffer, "?", "")
strBuffer = Replace(strBuffer, Chr(34), "'")
strBuffer = Replace(strBuffer, "|", "")
ReplaceIllegalCharacters = strBuffer
End Function
Function ModFileDT(strDir, strFileName, DateTime)
Dim objShell, objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(strDir)
objFolder.Items.Item(strFileName).ModifyDate = DateTime
End function

Perhaps the format of "olkMessage.ReceivedTime" is incorrect.
By the way, if you want to increase the exposure of your posts,
use cross-posting. Multi-posting makes you unpopular because
it causes respondents to waste their time - see here:
http://www.blakjak.demon.co.uk/mul_crss.htm

strychtur

2008-01-20 18:53:12 UTC

Permalink

Post by Pegasus (MVP)

Thanks for the tip I 'll do that right away.

everett3rd

2008-01-25 17:40:40 UTC

Permalink

Post by Pegasus (MVP)

Thanks for the tip I 'll do that right away.- Hide quoted text -
- Show quoted text -

j***@lycos.com

2008-01-26 20:41:00 UTC

Permalink

Post by everett3rd

Post by Pegasus (MVP)

I have a VB script that changes the name of amsgfile to Sender -
Subject. Now I am looking to change the modified date to be the
received date of the email. I thought the following code should do it,
but it does not. The name changes but date does not. Any help would be
great.
Cheers
Strychtur
' VBScript source code
On Error Resume Next
Dim olkApp, olkMessage, objFSO, objFile, varFile, varNewFileName, Dir
Set olkApp = GetObject(,"Outlook.Application")
If TypeName(olkApp) <> "Application" Then
Set olkApp = CreateObject("Outlook.Application")
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each varFile In WScript.Arguments
Set olkMessage = olkApp.CreateItemFromTemplate(varFile)
varNewFileName = ReplaceIllegalCharacters(olkMessage.SenderName &
"-" & olkMessage.Subject) & ".msg"
Set objFile = objFSO.GetFile(varFile)
objFile.Name = varNewFileName
Call ModFileDT (objFile.Drive, objFile.Name,
olkMessage.ReceivedTime)
Next
Set objFile = Nothing
Set objFSO = Nothing
Set olkMessage = Nothing
Set olkApp = Nothing
WScript.Quit
Function ReplaceIllegalCharacters(strSubject)
Dim strBuffer
strBuffer = Replace(strSubject, ":", "")
strBuffer = Replace(strBuffer, "\", "")
strBuffer = Replace(strBuffer, "/", "")
strBuffer = Replace(strBuffer, "?", "")
strBuffer = Replace(strBuffer, Chr(34), "'")
strBuffer = Replace(strBuffer, "|", "")
ReplaceIllegalCharacters = strBuffer
End Function
Function ModFileDT(strDir, strFileName, DateTime)
Dim objShell, objFolder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(strDir)
objFolder.Items.Item(strFileName).ModifyDate = DateTime
End function

Thanks for the tip I 'll do that right away.- Hide quoted text -
- Show quoted text -

strychtur;
How is this script working out for you?
As luck would have it I am trying to do the exact same thing.
How are you executing it?
Does it run withinoutlookor from the command line?
-Everett3rd- Tekst uit oorspronkelijk bericht niet weergeven -
- Tekst uit oorspronkelijk bericht weergeven -

I tried it as well using such a script but gave up.
Our company now uses mailtofile (www.mailtofile.com) to archive msg
files. It works perfect!
Good luck

everett3rd

2008-01-27 05:23:56 UTC

Permalink

Post by j***@lycos.com

Post by everett3rd
strychtur;
How is this script working out for you?
As luck would have it I am trying to do the exact same thing.
How are you executing it?
Does it run within outlook or from the command line?
-Everett3rd-

I tried it as well using such a script but gave up.
Our company now uses mailtofile (www.mailtofile.com) to archive msg
files. It works perfect!
Good luck-

Well I spent some time reworking this script to suite my needs and
have it working quite well.

.MSG file are placed in one of several folders through out the day
based on project and content.
The script runs against the folders on a schedule renaming the files
as needed.

It turned out very nice. My Administrative Ladies just LOVE me
now.....

If anyon is interested I will post the code.

-Everett3rd

t***@gmail.com

2008-02-14 16:49:34 UTC

Permalink

Post by everett3rd

Post by j***@lycos.com

I tried it as well using such a script but gave up.
Our company now uses mailtofile (www.mailtofile.com) to archive msg
files. It works perfect!
Good luck-

Well I spent some time reworking this script to suite my needs and
have it working quite well.
.MSG file are placed in one of several folders through out the day
based on project and content.
The script runs against the folders on a schedule renaming the files
as needed.
It turned out very nice. My Administrative Ladies just LOVE me
now.....
If anyon is interested I will post the code.
-Everett3rd

I would love to see the code on this. This is quite the issue for me
right now....

everett3rd

2008-02-15 16:21:06 UTC

Permalink

Post by everett3rd
If anyon is interested I will post the code.
-Everett3rd

I would love to see the code on this. This is quite the issue for me
right now....

Here is the code I wrote.....VBscript
Feel free to ask any questions.
I have tried to comment everything enough for good reference.
It should be easy to modify for your situation.

I apologize for any code sloppiness, this is my 1st "production"
VBScript
There is some line wraping in the code below.

Let me know what you think.
My first full run against my server renamed 44976 messages with no
issues.
It took about 45 hours to go through 37000+ folders.

The "update runs" only take about 15-20 minutes to climb the entire
project tree and rename 50-100 messages per day.

Let me know what you think. If you come up with ways to make it
better, please share...

My next project is to write a script to move an email to the proper
folder based on the standardized subject.
Example...
Move and RFI email to the RFI folder, Move a PR email to the PR
Folder, and move Meeting Minutes to the Meeting Minutes folder. The
Ladies were kind enough to give me 43 different folders and codes to
evaluate for each email.

When I get this new one working I will be happy to share it as well.

-Everett

'*************************************************************************************************************
'***This script scans a folder tree and renames all .msg files to
comply with the
'***standard for project email retension as set forth in the E-File
standards document.
'***This Script was written by Everett E. Reilly III
'***Last Modified on: February 14, 2008
'***
'***
'*** to run this script open a command window and type "Email-
Efile.vbs" at the command prompt.
'*** this script generates a text log file
'***
'*************************************************************************************************************

'Declare object names
Dim olkApp, objFSO, ObjTextFile

set objFSO = CreateObject("Scripting.FileSystemObject")

'Set Counters: Mc = Message Counter
Mc = 0

On Error Resume Next
set olkApp = GetObject("Outlook.Application")
On Error GoTo 0

If TypeName(olkApp) <> "Application" Then
Set olkApp = CreateObject("Outlook.Application")
End If
'set logfile location and name
Set objTextFile = Objfso.CreateTextFile("\\ComputerName\folder
\logFile.txt", True)

'Script Begin Stamp
StrDTStampBegin = "Date: " & Date & " " & "Time: " & Time
Call LogOutput (objTextFile,
"********************************************")
Call LogOutput (objTextFile, "SCRIPT BEGIN: " & StrDTStampBegin)
Call LogOutput (objTextFile,
"............................................")
Call LogOutput (objTextFile, "...Renaming *.MSG files to DLR Group
Standards.")
Call LogOutput (objTextFile, "...Text Log Format:")
Call LogOutput (objTextFile,
"............................................")
Call LogOutput (objTextFile, "...Path OriginalFilename.msg")
Call LogOutput (objTextFile, "... NewFilename.MSG")
Call LogOutput (objTextFile,
"............................................")
Call LogOutput (objTextFile, " ")
Call LogOutput (objTextFile, " ")
Call LogOutput (objTextFile, " ")

'set root folder to begin processing, can use UNC Path here
Call ProcessFolder("\\ComputerName\folder\subfolder\")
'Script END Stamp
StrDTStampEnd = "Date: " & Date & " " & "Time: " & Time
Call LogOutput (objTextFile,
"............................................")
Call LogOutput (objTextFile, "SCRIPT END: " & StrDTStampEnd)
Call LogOutput (objTextFile, "Total messages processed: " &
Mc)
Call LogOutput (objTextFile,
"********************************************")
objTextFile.Close

'unload objects and terminate the script
set objFSO = Nothing
set olkApp = Nothing
WScript.Quit()

Sub ProcessFolder(path)
Dim objFolder, objFile

'insert new folder flag in log file
Call LogOutput (objTextFile,
"............................................")
Call LogOutput (objTextFile, "***** Processing: " & path)

'begin processing .msg files and skip file if already processed.
For Each objFile In objFSO.GetFolder(path).Files
Call ProcessFile(objFile)
Next

'process all subfolders recursively
For Each objFolder In objFSO.GetFolder(path).SubFolders
Call ProcessFolder(objFolder.Path)
Next
End Sub

Sub ProcessFile(objFile)
If objFile.Type = "Outlook Item" And Not
lcase(left(objFile.Name, 4)) = "eml_" Then
Call LogOutput (objTextFile,
"............................................")
Call LogOutput (objTextFile, objFile.path)
on error resume next
Set olkMessage =
olkApp.CreateItemFromTemplate(objFile.path)

'Cleanup Time stamp.
objTime = olkMessage.ReceivedTime
objTime = Replace(objtime, "/", "-")
objTime = Replace(objtime, ":", "-")
objTime = Replace(objtime, " ", "_")
on error goto 0

'Make sure file is an outlookmailItem, read receipts,
delivery receipts, and meeting requests are not processed
if not objTime = "" Then

'Cleanup Sender Name.
objSender = olkMessage.SenderName
objSender = Replace(objSender, ",", "")
objSender = Replace(objSender, " ", "")

'Cleanup Receiver Name.
'If no human readable receiver name then set
"objReceiver" to "Recv-NO-NAME"
on error resume next
If len(olkMessage.ReceivedByName) > 0 Then
objReceiver = olkMessage.ReceivedByName
Else
objReceiver = olkMessage.ReceivedOnBehalfOfName
End If

If len(olkMessage.ReceivedOnBehalfOfName) < 1 Then
objReceiver = "Recv-NO-NAME"
End If

objReceiver = Replace(objReceiver, ",", "")
objReceiver = Replace(objReceiver, " ", "")

'Cleanup subject text.
'If no Subject on Email set "objSubject" to "NO-
SUBJECT"
on error resume next
If len(olkMessage.Subject) < 1 Then
objSubject = "NO-SUBJECT"
Else
objSubject = left(olkMessage.Subject, 25)
End If

'remove restricted characters from subject string
objSubject = Replace(objSubject, ":", "-")
objSubject = Replace(objSubject, "\", "-")
objSubject = Replace(objSubject, "/", "-")
objSubject = Replace(objSubject, "?", "-")
objSubject = Replace(objSubject, Chr(34), "-")
objSubject = Replace(objSubject, "|", "-")
objSubject = Replace(objSubject, "*", "-")
objSubject = Replace(objSubject, "<", "-")
objSubject = Replace(objSubject, ">", "-")
objSubject = Replace(objSubject, ",", "_")
objSubject = Replace(objSubject, ".", "_")
objSubject = Replace(objSubject, "&", "-")
objSubject = Replace(objSubject, "(", "_")
objSubject = Replace(objSubject, ")", "_")
objSubject = Replace(objSubject, "^", "_")
objSubject = Replace(objSubject, "#", "_")
objSubject = Replace(objSubject, "@", "_")
objSubject = Replace(objSubject, "!", "_")
objSubject = Replace(objSubject, "~", "_")

'Create New File Name for each message file.
objNewMsgName = ("EML_" & objSender & "_" &
objReceiver & "_" & objSubject & "_" & objTime) & ".msg"
objName = objNewMsgName
Mc = Mc + 1

'Check for Duplicate file names Cn = Copy number
Cn = 1
Do While objfso.FileExists(objfile.parentfolder &
"\" & objName)
objName = objNewMsgName & "_COPY-" & Cn
Cn = Cn + 1
Loop
objFile.Name = objName
Call ModFileDT(objFile.ParentFolder, objFile.Name,
olkMessage.ReceivedTime)
Call LogOutput (objTextFile, vbtab & objfile.name)
End If

End If

End Sub

'Subrutine to apply new file name and properties to .MSG file.
Sub ModFileDT(strDir, strFileName, DateTime)
Dim objShell, objFolder, objFile
set objShell = CreateObject("Shell.Application")
set objFolder = objShell.NameSpace(CStr(strDir))
set objFile = objFolder.ParseName(CStr(strFileName))
objFile.ModifyDate = CStr(DateTime)
set objShell = Nothing
set objFolder = Nothing
set objFile = Nothing
End Sub

Sub LogOutput(ObjTextFile, Text)
Set File = ObjTextFile
wscript.echo(Text)
File.WriteLine(Text)
End Sub

w***@gmail.com

2014-11-17 17:20:35 UTC

Permalink

Dear Everett3rd,

I have the same problem as described and i am interest in using your script. however, I am a noob in all kind of programming. can you show me how to copy and create a file. or to run this script open a command window and type "Email-
Efile.vbs" at the command prompt.

Thanks,

k***@gmail.com

2019-07-16 19:07:32 UTC

Permalink

I use this almost daily to put messages into disk folders, reducing the size of the accumulating .pst file. Because messages are often threaded, the above code returns errors very frequently because of duplicate filenames. With some tweaking I modified the code as shown below. Now I almost never get an error message stop. Basically, I added a loop to produce a unique filename for repeating messages.

' VBScript source code

Dim olkApp, olkMessage, objFSO, objFile, varFile, varNewFileName, varNewFile

Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set olkApp = GetObject(,"Outlook.Application")

If TypeName(olkApp) <> "Application" Then
Set olkApp = CreateObject("Outlook.Application")
End If

For Each varFile In WScript.Arguments
If LCase(objFSO.GetExtensionName(varFile)) = "msg" Then
Set olkMessage = olkApp.CreateItemFromTemplate(varFile)
Set objFile = objFSO.GetFile(varFile)
IF objFSO.fileExists(varFile) THEN
End If
varNewFileName = ReplaceIllegalCharacters(Left(olkMessage.SenderName,6) & " - " & Replace(objFile.Name,".msg","")) & "-.msg"
varNewFile = Left(varFile, InstrRev(varFile, "\")) & varNewFileName
WHILE objFSO.FileExists(varNewFile)
varNewFileName = Replace(varNewFileName,".msg","-.msg")
varNewFile = Left(varFile, InstrRev(varFile, "\")) & varNewFileName
WEND
objFile.Name = varNewFileName ' this appears to do the renaming'
Call ModFileDT (objFile.ParentFolder, objFile.Name, olkMessage.ReceivedTime)
End If
Next
Set objFile = Nothing
Set objFSO = Nothing
Set olkMessage = Nothing
Set olkApp = Nothing
WScript.Quit

Function ReplaceIllegalCharacters(strSubject)
Dim strBuffer
strBuffer = Replace(strSubject, ":", "")
strBuffer = Replace(strBuffer, "\", "")
strBuffer = Replace(strBuffer, "/", "")
strBuffer = Replace(strBuffer, "?", "")
strBuffer = Replace(strBuffer, Chr(34), "'")
strBuffer = Replace(strBuffer, "|", "")
ReplaceIllegalCharacters = strBuffer
End Function

Sub ModFileDT(strDir, strFileName, DateTime)
Dim objShell, objFolder, objFile
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(CStr(strDir))
Set objFile = objFolder.ParseName( CStr(strFileName) )
objFile.ModifyDate= CStr(DateTime)
Set objShell = Nothing
Set objFolder = Nothing
Set objFile = Nothing
End Sub

Mayayana

2019-07-16 19:21:33 UTC

Permalink

You might want to get a real newsreaderand get off Google
Groups. you're replying to a post more than 11 years old!