troubleshooting Question

how to rename the subject without changing the creationtime

Avatar of kafrin_1
kafrin_1Flag for Australia asked on
Outlook
6 Comments1 Solution583 ViewsLast Modified:
I wish to rename the email subject under certain conditions. however, when i do this, the creationtime is modified.
The code below is a combination of macros from over the web as awell as my own mods. Essentially, for an open email, it scans the subject for a  6 digit number, JNum, and if it does not exist prompts the user for it. I wish for the new job number to be affixed to the beginning of the subject line so that when the message is reopened from the saved file the job number is listed as part of the subject. (The code where i rename the subject is between the ****************'s and is commented out. I does work, but the creation time is reset.
It then time stamps the file and saves the email as a .msg.

thanks for the help...
Sub Save_MSG()
    Dim myItem As Outlook.Inspector
    Dim objItem As Object
    Set myOlApp = CreateObject("Outlook.Application")
    Set myItem = myOlApp.ActiveInspector
    If Not TypeName(myItem) = "Nothing" Then
        Set objItem = myItem.CurrentItem
        esubject = objItem
        'Prompt the user for confirmation
        Dim strPrompt As String
        Dim JNum As String
        Dim j As Integer
        Dim Filename As String
        ' restructure string name to get rid of formatting
         
        esubject = Replace(esubject, ":", "")
        esubject = Replace(esubject, ".", "")
        esubject = Replace(esubject, "/", "")
        esubject = Replace(esubject, "!", "")
        esubject = Replace(esubject, ",", "")
        esubject = Replace(esubject, "'", "")
        esubject = Replace(esubject, "(", "")
        esubject = Replace(esubject, ")", "")
        esubject = Replace(esubject, "?", "")
        esubject = Replace(esubject, "*", "")
        esubject = Replace(esubject, " ", "_")
        esubject = Replace(esubject, Chr(34), "")
        esubject = Replace(esubject, Chr(9), "")
        esubject = Mid(esubject, 1, 40)
       
        If esubject = "" Then
        esubject = "untitled"
        End If
        
        ' check for job number
         JNum = Replace(esubject, " ", "")
      
        For j = 32 To 255 ' get rid of everything except 6 numbers
        If j <= 47 Or j >= 58 Then
        JNum = Replace(JNum, Chr(j), "")
        End If
      Next j
                        
      JNum = Left(JNum, 6)
      'JNum is less than 6 digits, ask the user to enter the job number for a particular subject of an email
       j = 10
       If Len(JNum) < 6 Then
          j = 2000
          JNum = InputBox("No Job Number Found", "Enter Job Number:", "")
          
       End If
        
       ' set up the filename as 'jnum_datetime_subject.msg'
       
         '''''''''''''''''''
             'Filename = "C:\katplay\" & JNum & "\" &
             Filename = "C:\katplay\" & _
                               Format(objItem.CreationTime, "yyyymmdd_hhnnss_") & JNum & "_" & esubject & ".msg"
                               'creation time is more accurate/appropriate that recieved time
               ''''
                Existing = Dir(Filename)
               'If the file exists Dir returns the file name so you could then say
                If Existing = "" Then
                
                'On Error Resume Next
                ''Create destination if it does not exist - errors at the moment 'missing object'- also the folder must exist or else program errors.
                 'If Not MyFolder.FolderExists(FilePath1) Then
                 'MyFolder.CreateFolder (FilePath1)
                 'End If
                
                objItem.SaveAs Filename, olMSG
         
                 ' the following code renames the message subject, but is commented out as it changes the creationtime parameter
          ' ********
                ' If j = 2000 Then
                ' myItem.CurrentItem = JNum & "_" & esubject
                ' End If
            '**********
                 Else
                 MsgBox " A message with this File Name already exists"
          
                End If
         ''''''''''''''''''''
        
        'strPrompt = "Are you sure you want to save the item? If a file with the same name already exists, it will be overwritten with this copy of the file."
        'If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
           ' Shell """C:\Program Files\Adobe\Reader 8.0\Reader\acrord32.exe"" /h /p """ + FileName + """", vbHide
          '  objItem.Delete
        'End If
    Else
            MsgBox "There is no current active inspector."
    End If
End Sub
Join the community to see this answer!
Join our exclusive community to see this answer & millions of others.
Unlock 1 Answer and 6 Comments.
Join the Community
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 6 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros