Solved

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

Posted on 2006-11-16
18
209 Views
Last Modified: 2008-02-01
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
 
0
Comment
Question by:vipa2000
  • 11
  • 7
18 Comments
 
LVL 76

Expert Comment

by:David Lee
ID: 18015068
Hi, vipa.

Replace olkMessage.SenderName with olkMessage.Subject
0
 

Author Comment

by:vipa2000
ID: 18017769
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
 
LVL 76

Expert Comment

by:David Lee
ID: 18018111
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
Windows Server 2016: All you need to know

Learn about Hyper-V features that increase functionality and usability of Microsoft Windows Server 2016. Also, throughout this eBook, you’ll find some basic PowerShell examples that will help you leverage the scripts in your environments!

 

Author Comment

by:vipa2000
ID: 18031079
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
 
LVL 76

Expert Comment

by:David Lee
ID: 18033984
Change these lines

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

to

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

Author Comment

by:vipa2000
ID: 18044807
thank you. all working again. Is it too hard to be able to pick another directory apart from P:\projects?
0
 
LVL 76

Expert Comment

by:David Lee
ID: 18050872
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
 

Author Comment

by:vipa2000
ID: 18066921
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
 

Author Comment

by:vipa2000
ID: 18066925
Oh and the last bit i asked for, can i amaend the file name before it saves?
0
 
LVL 76

Expert Comment

by:David Lee
ID: 18075657
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
 

Author Comment

by:vipa2000
ID: 18075969
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
 

Author Comment

by:vipa2000
ID: 18075987
Tried the new line of code it states a message was not selected. Operation aborted.
0
 

Author Comment

by:vipa2000
ID: 18075989
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
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 18081947
> 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
 

Author Comment

by:vipa2000
ID: 18159574
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
 

Author Comment

by:vipa2000
ID: 18245245
managed to resolve the problem regards vipa
0
 
LVL 76

Expert Comment

by:David Lee
ID: 18248481
vipa,

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

Happy New Year!
0
 

Author Comment

by:vipa2000
ID: 18249948
Happy new year, thanks again.
0

Featured Post

Live: Real-Time Solutions, Start Here

Receive instant 1:1 support from technology experts, using our real-time conversation and whiteboard interface. Your first 5 minutes are always free.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Find out what you should include to make the best professional email signature for your organization.
Many people use more than one email account and so it becomes difficult for them to manage them when they use separate accounts,  so, in this article, I have shared an easy way to add Other Mail Accounts in your Google Inbox. It helps to combine all…
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

776 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question