Change code to allow alternate directory to be picked and title entered.

i have this exisitng code in outlook 2003.

Sub SaveMessage()
    Dim olkMessage As Outlook.MailItem, _
        strMacroName As String, _
        strPathName As String, _
        strFileName As String, _
        bolError As Boolean, _
        objTemp As Object, _
        objFSO As Object, _
        intCount As Integer
    strMacroName = "Save Message to File System"
    Select Case TypeName(Application.ActiveWindow)
        Case "Explorer"
            Set objTemp = Application.ActiveExplorer.Selection(1)
        Case "Inspector"
            Set objTemp = Application.ActiveInspector.CurrentItem
        Case Else
            MsgBox "You must have a message open or selected to use this macro.", vbCritical + vbOKOnly, strMacroName
            bolError = True
    End Select
    If objTemp.Class = olMail Then
        Set olkMessage = objTemp
    Else
        MsgBox "A message was not selected.  Operation aborted.", vbInformation + vbOKOnly, strMacroName
        bolError = True
    End If
    If Not bolError Then
        'Edit the starting folder path on the next line as needed
        strPathName = GetFolderName("P:\projects\")
        If strPathName = "" Then
            MsgBox "No folder selected.  Operation aborted.", vbInformation + vbOKOnly, strMacroName
        Else
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            intCount = objFSO.GetFolder(strPathName).Files.Count + 1
            strFileName = PadZero(intCount, 4) & " - Email from " & olkMessage.SenderName & ".msg"
            Do While True
                If objFSO.FileExists(strPathName & strFileName) Then
                    intCount = intCount + 1
                    strFileName = PadZero(intCount, 3) & " - Email from " & olkMessage.SenderName & ".msg"
                Else
                    Exit Do
                End If
            Loop
            olkMessage.SaveAs strPathName & strFileName, olMSG
        End If
    End If
    Set objFSO = Nothing
    Set objTemp = Nothing
    Set olkMessage = Nothing
End Sub

Function GetFolderName(strStartingFolder As Variant) As String
    Const WINDOW_HANDLE = 0
    Const NO_OPTIONS = 0
    Dim objShell As Object, _
        objFolder As Object, _
        objFolderItem As Object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Select a folder:", NO_OPTIONS, strStartingFolder)
    If Not TypeName(objFolder) = "Nothing" Then
        Set objFolderItem = objFolder.self
        GetFolderName = objFolderItem.Path & "\"
    Else
        GetFolderName = ""
    End If
    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
End Function

Function PadZero(intValue As Integer, intLength As Integer) As String
    Dim intActual As Integer, _
        strTemp As String
    strTemp = Str(intValue)
    intActual = Len(Trim(intValue))
    If intActual < intLength Then
        PadZero = String(intLength - intActual, "0") & intValue
    Else
        PadZero = intValue
    End If
End Function

I was kindly helped with this from a original thread.
http://www.experts-exchange.com/Applications/MS_Office/Outlook/Q_21913428.html

Now i have developed a little problem in that everytime i save the file name is  in the format of      0078 - Email from Dibner Matthew GBGU.msg

It is incrementing correct but putting the name of the person rather than the message header text. It did work.

Question
1)can i have it so i can have the chance to alter the header text before it saves, sometimes emails are sent with poor message headers
2)can i have a button that allows other directories to be selected but puts P:\Projects up by default?

thanks in advance, vipa
 
vipa2000Asked:
Who is Participating?
 
David LeeConnect With a Mentor Commented:
> I may want 001_Enquiry relating to construction of building no1.
Do you mean that you want the ability to change the file name the message will be saved as after the folder is chosen?  If so, then replace each of these two lines

    strFileName = PadZero(intCount, 4) & " " & ReplaceIllegalCharacters(olkMessage.Subject) & ".msg"

with

    strFileName = InputBox("Enter a filename", "Save File - Select Filename", PadZero(intCount, 4) & " " & ReplaceIllegalCharacters(olkMessage.Subject) & ".msg")

> Tried the new line of code it states a message was not selected. Operation aborted.
Did you have a message selected at the time?  I ran the code and it worked perfectly.
0
 
David LeeCommented:
Hi, vipa.

Replace olkMessage.SenderName with olkMessage.Subject
0
 
vipa2000Author Commented:
still having problems

my code is now

Sub SaveMessage()
    Dim olkMessage As Outlook.MailItem, _
        strMacroName As String, _
        strPathName As String, _
        strFileName As String, _
        bolError As Boolean, _
        objTemp As Object, _
        objFSO As Object, _
        intCount As Integer
    strMacroName = "Save Message to File System"
    Select Case TypeName(Application.ActiveWindow)
        Case "Explorer"
            Set objTemp = Application.ActiveExplorer.Selection(1)
        Case "Inspector"
            Set objTemp = Application.ActiveInspector.CurrentItem
        Case Else
            MsgBox "You must have a message open or selected to use this macro.", vbCritical + vbOKOnly, strMacroName
            bolError = True
    End Select
    If objTemp.Class = olMail Then
        Set olkMessage = objTemp
    Else
        MsgBox "A message was not selected.  Operation aborted.", vbInformation + vbOKOnly, strMacroName
        bolError = True
    End If
    If Not bolError Then
        'Edit the starting folder path on the next line as needed
        strPathName = GetFolderName("P:\projects\")
        If strPathName = "" Then
            MsgBox "No folder selected.  Operation aborted.", vbInformation + vbOKOnly, strMacroName
        Else
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            intCount = objFSO.GetFolder(strPathName).Files.Count + 1
            strFileName = PadZero(intCount, 4) & " - Email from " & olkMessage.Subject & ".msg"
            Do While True
                If objFSO.FileExists(strPathName & strFileName) Then
                    intCount = intCount + 1
                    strFileName = PadZero(intCount, 3) & " - Email from " & olkMessage.Subject & ".msg"
                Else
                    Exit Do
                End If
            Loop
            olkMessage.SaveAs strPathName & strFileName, olMSG
        End If
    End If
    Set objFSO = Nothing
    Set objTemp = Nothing
    Set olkMessage = Nothing
End Sub

Function GetFolderName(strStartingFolder As Variant) As String
    Const WINDOW_HANDLE = 0
    Const NO_OPTIONS = 0
    Dim objShell As Object, _
        objFolder As Object, _
        objFolderItem As Object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Select a folder:", NO_OPTIONS, strStartingFolder)
    If Not TypeName(objFolder) = "Nothing" Then
        Set objFolderItem = objFolder.self
        GetFolderName = objFolderItem.Path & "\"
    Else
        GetFolderName = ""
    End If
    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
End Function

Function PadZero(intValue As Integer, intLength As Integer) As String
    Dim intActual As Integer, _
        strTemp As String
    strTemp = Str(intValue)
    intActual = Len(Trim(intValue))
    If intActual < intLength Then
        PadZero = String(intLength - intActual, "0") & intValue
    Else
        PadZero = intValue
    End If
End Function


When i save this message entitled
Comment Added: Change code to allow alternate directory to be picked and title entered.

i get       0006 - Email from Comment Added        and no msg extension created in the directory

regards vipa
0
Introducing Cloud Class® training courses

Tech changes fast. You can learn faster. That’s why we’re bringing professional training courses to Experts Exchange. With a subscription, you can access all the Cloud Class® courses to expand your education, prep for certifications, and get top-notch instructions.

 
David LeeCommented:
Add the function that appears below to the code you have now.  Replace each of the two lines that contain

     " - Email from " & olkMessage.Subject & ".msg"

with

     " - Email from " & ReplaceIllegalCharacters(olkMessage.Subject) & ".msg"

If you don't want the "Email from" portion of the file name, then remove it.

Function ReplaceIllegalCharacters(strSubject As String) As String
    Dim strBuffer As String
    strBuffer = Replace(strSubject, ":", "")
    strBuffer = Replace(strBuffer, "\", "")
    strBuffer = Replace(strBuffer, "/", "")
    strBuffer = Replace(strBuffer, "?", "")
    strBuffer = Replace(strBuffer, Chr(34), "'")
    strBuffer = Replace(strBuffer, "|", "")
    ReplaceIllegalCharacters = strBuffer
End Function
0
 
vipa2000Author Commented:
thank for that i am nearly there. I tried to get rid of the email from bit and i can't get the code to work in the sense i get no space between the email no given and the email text. code as below

Sub SaveMessage()
    Dim olkMessage As Outlook.MailItem, _
        strMacroName As String, _
        strPathName As String, _
        strFileName As String, _
        bolError As Boolean, _
        objTemp As Object, _
        objFSO As Object, _
        intCount As Integer
    strMacroName = "Save Message to File System"
    Select Case TypeName(Application.ActiveWindow)
        Case "Explorer"
            Set objTemp = Application.ActiveExplorer.Selection(1)
        Case "Inspector"
            Set objTemp = Application.ActiveInspector.CurrentItem
        Case Else
            MsgBox "You must have a message open or selected to use this macro.", vbCritical + vbOKOnly, strMacroName
            bolError = True
    End Select
    If objTemp.Class = olMail Then
        Set olkMessage = objTemp
    Else
        MsgBox "A message was not selected.  Operation aborted.", vbInformation + vbOKOnly, strMacroName
        bolError = True
    End If
    If Not bolError Then
        'Edit the starting folder path on the next line as needed
        strPathName = GetFolderName("P:\projects\")
        If strPathName = "" Then
            MsgBox "No folder selected.  Operation aborted.", vbInformation + vbOKOnly, strMacroName
        Else
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            intCount = objFSO.GetFolder(strPathName).Files.Count + 1
            strFileName = PadZero(intCount, 4) & ReplaceIllegalCharacters(olkMessage.Subject) & ".msg"
            Do While True
                If objFSO.FileExists(strPathName & strFileName) Then
                    intCount = intCount + 1
                    strFileName = PadZero(intCount, 3) & ReplaceIllegalCharacters(olkMessage.Subject) & ".msg"
                Else
                    Exit Do
                End If
            Loop
            olkMessage.SaveAs strPathName & strFileName, olMSG
        End If
    End If
    Set objFSO = Nothing
    Set objTemp = Nothing
    Set olkMessage = Nothing
End Sub

Function GetFolderName(strStartingFolder As Variant) As String
    Const WINDOW_HANDLE = 0
    Const NO_OPTIONS = 0
    Dim objShell As Object, _
        objFolder As Object, _
        objFolderItem As Object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Select a folder:", NO_OPTIONS, strStartingFolder)
    If Not TypeName(objFolder) = "Nothing" Then
        Set objFolderItem = objFolder.self
        GetFolderName = objFolderItem.Path & "\"
    Else
        GetFolderName = ""
    End If
    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
End Function

Function PadZero(intValue As Integer, intLength As Integer) As String
    Dim intActual As Integer, _
        strTemp As String
    strTemp = Str(intValue)
    intActual = Len(Trim(intValue))
    If intActual < intLength Then
        PadZero = String(intLength - intActual, "0") & intValue
    Else
        PadZero = intValue
    End If
End Function
Function ReplaceIllegalCharacters(strSubject As String) As String
    Dim strBuffer As String
    strBuffer = Replace(strSubject, ":", "")
    strBuffer = Replace(strBuffer, "\", "")
    strBuffer = Replace(strBuffer, "/", "")
    strBuffer = Replace(strBuffer, "?", "")
    strBuffer = Replace(strBuffer, Chr(34), "'")
    strBuffer = Replace(strBuffer, "|", "")
    ReplaceIllegalCharacters = strBuffer
End Function

thanks upfront vipa
0
 
David LeeCommented:
Change these lines

    PadZero(intCount, 4) & ReplaceIllegalCharacters(olkMessage.Subject) & ".msg"

to

    PadZero(intCount, 4) & " " & ReplaceIllegalCharacters(olkMessage.Subject) & ".msg"
0
 
vipa2000Author Commented:
thank you. all working again. Is it too hard to be able to pick another directory apart from P:\projects?
0
 
David LeeCommented:
It's not difficult at all.  Change this line of code

    strPathName = GetFolderName("P:\projects\")

to

    strPathName = GetFolderName("C:\") 'or whatever drive you want to use

0
 
vipa2000Author Commented:
BlueDevilFan what i really wanted was is to have P:\Projects ae default, but be able to select a different path from the dialogue box? I have manually changed it in the code before but it is a pain.

regards Vipa  
0
 
vipa2000Author Commented:
Oh and the last bit i asked for, can i amaend the file name before it saves?
0
 
David LeeCommented:
Ok, try this

    strPathName = GetFolderName(InputBox("Enter the starting path.", "Starting Path", "P:\Projects\"))

> Oh and the last bit i asked for, can i amaend the file name before it saves?
I'm not sure what you mean.  Amend it how?

0
 
vipa2000Author Commented:
On the path i mean; Your code grabs the title of the email. some people do not put an appropriate email title. So for example message saves currently as 001_enquity.msg.  I may want 001_Enquiry relating to construction of building no1.

regards vipa
0
 
vipa2000Author Commented:
Tried the new line of code it states a message was not selected. Operation aborted.
0
 
vipa2000Author Commented:
Full amended code as follows

Sub SaveMessage()
    Dim olkMessage As Outlook.MailItem, _
        strMacroName As String, _
        strPathName As String, _
        strFileName As String, _
        bolError As Boolean, _
        objTemp As Object, _
        objFSO As Object, _
        intCount As Integer
    strMacroName = "Save Message to File System"
    Select Case TypeName(Application.ActiveWindow)
        Case "Explorer"
            Set objTemp = Application.ActiveExplorer.Selection(1)
        Case "Inspector"
            Set objTemp = Application.ActiveInspector.CurrentItem
        Case Else
            MsgBox "You must have a message open or selected to use this macro.", vbCritical + vbOKOnly, strMacroName
            bolError = True
    End Select
    If objTemp.Class = olMail Then
        Set olkMessage = objTemp
    Else
        MsgBox "A message was not selected.  Operation aborted.", vbInformation + vbOKOnly, strMacroName
        bolError = True
    End If
    If Not bolError Then
        'Edit the starting folder path on the next line as needed
        strPathName = GetFolderName(InputBox("Enter the starting path.", "Starting Path", "P:\Projects\"))
        If strPathName = "" Then
            MsgBox "No folder selected.  Operation aborted.", vbInformation + vbOKOnly, strMacroName
        Else
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            intCount = objFSO.GetFolder(strPathName).Files.Count + 1
            strFileName = PadZero(intCount, 4) & " " & ReplaceIllegalCharacters(olkMessage.Subject) & ".msg"

            Do While True
                If objFSO.FileExists(strPathName & strFileName) Then
                    intCount = intCount + 1
                    strFileName = PadZero(intCount, 4) & " " & ReplaceIllegalCharacters(olkMessage.Subject) & ".msg"

                Else
                    Exit Do
                End If
            Loop
            olkMessage.SaveAs strPathName & strFileName, olMSG
        End If
    End If
    Set objFSO = Nothing
    Set objTemp = Nothing
    Set olkMessage = Nothing
End Sub

Function GetFolderName(strStartingFolder As Variant) As String
    Const WINDOW_HANDLE = 0
    Const NO_OPTIONS = 0
    Dim objShell As Object, _
        objFolder As Object, _
        objFolderItem As Object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Select a folder:", NO_OPTIONS, strStartingFolder)
    If Not TypeName(objFolder) = "Nothing" Then
        Set objFolderItem = objFolder.self
        GetFolderName = objFolderItem.Path & "\"
    Else
        GetFolderName = ""
    End If
    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
End Function

Function PadZero(intValue As Integer, intLength As Integer) As String
    Dim intActual As Integer, _
        strTemp As String
    strTemp = Str(intValue)
    intActual = Len(Trim(intValue))
    If intActual < intLength Then
        PadZero = String(intLength - intActual, "0") & intValue
    Else
        PadZero = intValue
    End If
End Function
Function ReplaceIllegalCharacters(strSubject As String) As String
    Dim strBuffer As String
    strBuffer = Replace(strSubject, ":", "")
    strBuffer = Replace(strBuffer, "\", "")
    strBuffer = Replace(strBuffer, "/", "")
    strBuffer = Replace(strBuffer, "?", "")
    strBuffer = Replace(strBuffer, Chr(34), "'")
    strBuffer = Replace(strBuffer, "|", "")
    ReplaceIllegalCharacters = strBuffer
End Function
0
 
vipa2000Author Commented:
hi bluedeveilfan, apologies not being well. Did the tweak and very close. i can now change the file name. The file however always ends with filename..msg   i.e a double..

also I have put back in the....  enter a directory and everything is working fine. Can the directory be selected rather than typed or is this asking too much?

regards vipa
0
 
vipa2000Author Commented:
managed to resolve the problem regards vipa
0
 
David LeeCommented:
vipa,

Sorry, I lost track of this question.  Glad you got it working.

Happy New Year!
0
 
vipa2000Author Commented:
Happy new year, thanks again.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.