Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]

Groups > microsoft.public.scripting.vbscript > #12161

Re: Change modified date of msg file to email recieved date

Show all headers | View raw

On Friday, January 18, 2008 at 2:55:43 PM UTC-6, strychtur wrote:
> 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

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

Back to microsoft.public.scripting.vbscript | Previous | Next — Next in thread | Find similar

Thread

Re: Change modified date of msg file to email recieved date kentbusselaw@gmail.com - 2019-07-16 12:07 -0700
  Re: Change modified date of msg file to email recieved date "Mayayana" <mayayana@invalid.nospam> - 2019-07-16 15:21 -0400

csiph-web