Solved

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

Posted on 2006-11-16
18
192 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
 

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
Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 
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

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Sometimes Outlook might have problems sending a message. There may be various causes- corrupted PST, AV scanner etc. The message, instead of going to the Sent Items folder, sits in the Outbox indefinitely. To remove it you can use a free tool cal…
Follow this checklist to learn more about the 15 things you should never include in an email signature from personal quotes, animated gifs and out-of-date marketing content.
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…

744 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

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now