Solved

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

Posted on 2006-11-16
18
229 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
Get your Disaster Recovery as a Service basics

Disaster Recovery as a Service is one go-to solution that revolutionizes DR planning. Implementing DRaaS could be an efficient process, easily accessible to non-DR experts. Learn about monitoring, testing, executing failovers and failbacks to ensure a "healthy" DR environment.

 

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

Efficient way to get backups off site to Azure

This user guide provides instructions on how to deploy and configure both a StoneFly Scale Out NAS Enterprise Cloud Drive virtual machine and Veeam Cloud Connect in the Microsoft Azure Cloud.

Question has a verified solution.

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

What does UTC stand for?  “Coordinated Universal Time” – Think of this as the true time on Planet Earth that never changes with the exception of minor leap seconds here and there to account for the changes in the planet's rotation.   What does th…
Finding original email is quite difficult due to their duplicates. From this article, you will come to know why multiple duplicates of same emails appear and how to delete duplicate emails from Outlook securely and instantly while vital emails remai…
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…
This is my first video review of Microsoft Bookings, I will be doing a part two with a bit more information, but wanted to get this out to you folks.

635 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