asked on

how to rename the subject without changing the creationtime

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

Open in new window

David Lee

Hi again, kafrin_1.

Are you talking about messages you've received or ones you're sending? For recieved messages changing the subject does not change the creation time.

kafrin_1

ASKER

ok it actually did work- my bad!
The above code runs for recieved emails. - how do i make it work for emails that are being sent?
I'm having trouble having the same macros run for the outgoing emails - ie i can check if an open (selected) email that has been recieved has a 6 digit number in the message, but not one being created.

That is, if the user creates an email, and the message subject does not have a 6 numbers in the subject (ie they have not put in a job number) when they try to send it, I want the user to be prompted by a msgbox to enter the job number, and they should not be able to send the email without putting the job number in the email subject.
Any ideas? thanks again.

ASKER CERTIFIED SOLUTION

David Lee

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

kafrin_1

ASKER

Thanks for that.
But when I try to run it, the if statement on line 3 doesn't pass - ie jumps over the code.
Is this because something is not declared ? probably obvious, but i'm pretty new as you know.if you could please advise me how to fix this issue i'd be grateful.

To find the job number, i've been deleting all characters from the subject in a loop and what's left over is only numbers. then i see if there are 6 numbers, and if there are, accept them as the job number - this is because otherwse FW and RE would get in the way - seems to be working like i want it - just thought i'd let you know that's how i did it.

ie for my outgoing messages i use the following code to find the jnum:

Dim myItem1, myItems1, myAttachment, MyAttachments As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = 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

strname = Replace(strname, ":", "")
strname = Replace(strname, ".", "")
strname = Replace(strname, "/", "")
strname = Replace(strname, "!", "")
strname = Replace(strname, ",", "")
strname = Replace(strname, "'", "")
strname = Replace(strname, "(", "")
strname = Replace(strname, ")", "")
strname = Replace(strname, "?", "")
strname = Replace(strname, "*", "")
strname = Replace(strname, " ", "_")
strname = Replace(strname, Chr(34), "")
strname = Replace(strname, Chr(9), "")
strname = Mid(strname, 1, 40)

If strname = "" Then
strname = "untitled"
End If

' check for job number
JNum = Replace(strname, " ", "")

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

kafrin_1

ASKER

ok,
i just took out that if/end if statement and it all works!
yay!
thanks for your help, you are such a lifesaver :)

David Lee

You're welcome!