Msgbox timer and initial folder for an Outlook 2003 macro.

You say    ?  when the user saves the mail ?  

Do you mean attachements?

Hi, no I mean the entire mail in .msg format. I create a button linked to the maco, when the user click on that button, or when he answers YES to the msgbox when he sends a new mail, a "browse for folder" windows appears and he could choose a folder.

But we have several network drives, so I want to define for each user a specific initial network drive. For the moment it starts at My documents.

Well VBA does not have a Timer Control like VB but you can simulate one.
I have written and tested a solution to your problem using the files form this link.

http://vb.mvps.org/samples/TimerObj/
Go to Karl Peterson's site above and download the TimerOBJ.zip file.

Next add the CTimer Class and MSharedTimer Module to your Outlook VBA Macro Project.  (NOTE: Make sure to set the first line in the Module to #Const VBA = True)

Now you can simulate a Timer in VBA.  The Next thing you need to do is add a User Form to your VBA Project.  We will use this to simulate a MessageBox.  All you have to do is add two Command Buttons to the UserForm1 (  cmdYES  and   cmdNO )

Now Paste in the following code to the UserForm1

Option Explicit

Private WithEvents Timer1 As CTimer

Private Const defClockUpdate As Long = 500 'milliseconds

Private Sub UserForm_Initialize()

   Set Timer1 = New CTimer

   Timer1.Interval = 10000
   Timer1.Enabled = True
   
End Sub

Private Sub Timer1_Timer()

With Timer1
   If .Interval <> defClockUpdate Then
      .Interval = defClockUpdate
      Me.Tag = "NO"
      Me.Hide
      DoEvents
   End If
End With


End Sub

Private Sub cmdYES_Click()

Me.Tag = "YES"
Me.Hide

End Sub

Private Sub cmdNO_Click()

Me.Tag = "NO"
Me.Hide

End Sub

Select allOpen in new window

The last thing you need to do now is add the code to the Macro

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim FilePath As String
Dim FileName As String

ActiveInspector.WindowState = olMinimized

UserForm1.Show 1

If UserForm1.Tag = "YES" Then

    'your code here to set filepath and filename
    FilePath = "C:\Test\"
    FileName = "Testing123"


    Item.SaveAs FilePath & FileName & ".msg", olMSG

End If

Unload UserForm1

End Sub

Select allOpen in new window

You can set the FilePath above to which ever drive/folder you want by adding your own code and logic.

What all of the above code does is simulate a VB timer and MessageBox.  You can customize the message box as much as you like since the UserForm gives you a great deal of flexibility.    You can adjust the timer interval in the UserForm_Initialize event which is set to 10 seconds  (Timer1.Interval = 10000)

Wow just what I needed for the timer ! Thank you very much, very intersting !

The last thing I have to do is set the initial folder.

When I click yes I call my macro and I've a function in this macro that let the user browse directory :

Private Function GetFileDir() As String
    
    Const PROCNAME As String = "GetFileDir"

    On Error GoTo ErrorHandler

    Dim ret As String
    Dim lpIDList As Long
    Dim sPath As String
    Dim udtBI As BrowseInfo
    Dim RdStrings() As String
    Dim nNewFiles As Long

    'Show a browse-for-folder form:
    With udtBI
        .lpszTitle = lstrcat(EXM_016, "")
        .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_NEWDIALOGSTYLE + BIF_EDITBOX
    End With

    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList = 0 Then Exit Function
       
    'Get the selected folder.
    sPath = String$(MAX_PATH, 0)
    SHGetPathFromIDList lpIDList, sPath
    CoTaskMemFree lpIDList
    
    'Strip Nulls
    If (InStr(sPath, Chr$(0)) > 0) Then sPath = Left$(sPath, InStr(sPath, Chr(0)) - 1)

    'Return Dir
    GetFileDir = sPath

ExitScript:
    Exit Function
ErrorHandler:
    GetFileDir = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
    Resume ExitScript
End Function

Select allOpen in new window

In your code you force the folder you want to save the copy of the email but I need to let users choose and browse BUT I want to set an initial folder like a netwok drive to facilitate browsing. Can you help me ? I've read some things about callback function ..

Well to keep it real simple, just add a common dialog control to UserForm1 and have all of you directory/folder logic under the cmdYES event.

Private Sub cmdYES_Click()

CommonDialog1.InitDir = "C:\Temp"
CommonDialog1.ShowSave
Me.Hide

End Sub

Select allOpen in new window

(You can remove the following code from the Application_ItemSend Sub.)

If UserForm1.Tag = "YES" Then

    'your code here to set filepath and filename
    FilePath = "C:\Test\"
    FileName = "Testing123"


    Item.SaveAs FilePath & FileName & ".msg", olMSG

End If

Select allOpen in new window

Also you can remove all references to the Me.Tag property in the UserForm1.

This will allow you to deal with the 'YES' choice right inside UserForm1.  If the user select 'NO' or waits 10 seconds, the MessageBox (UserForm1) is closed and the file is not saved.

If you want to stick with the way you've been doing the Browse Dialog and still need to set the start path check out this EE article:

https://www.experts-exchange.com/Programming/System/Windows__Programming/A_1600-Browse-for-Folder-Advanced-Options.html

Any luck with this code?

Hey,
It seems to be the good solution but I do not manage to integrate it into my code correctly.

What part do you need help with?

When I use the script, here https://www.experts-exchange.com/Programming/System/Windows__Programming/A_1601-Browse-for-Folder-Advanced-Options-PART-TWO.html

it does not integrate into my outlook module

I suggested a working solution with a UserForm and Common Dialog Control above.

Simple to use and only a few lines of code.

If you are having difficulty doing it the hard way by trying to control the Browser with the SHBrowseForFolder API Call, why don't you try the easy way?

It sounds good but I don't know what I've to do exactly..
Create a UserForm in Outlook VB paste the exemple code from here :https://www.experts-exchange.com/Programming/System/Windows__Programming/A_1601-Browse-for-Folder-Advanced-Options-PART-TWO.html ??
Where I've to paste the common dialog control ?

here's my macro :

'-------------------------------------
'For browse folder
'-------------------------------------
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Const BIF_NEWDIALOGSTYLE As Long = &H40
Public Const BIF_EDITBOX As Long = &H10
Public Const BIF_USENEWUI As Long = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Private Type BROWSEINFO

    hwndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type


Public Sub MailToDrive()
    
    Const PROCNAME As String = "Mail Save Tool"
    
    On Error GoTo ErrorHandler
    
    Dim myExplorer As Outlook.Explorer
    Dim myfolder As Outlook.MAPIFolder
    Dim myItem As Object
    Dim olSelection As Selection
    Dim strBackupPath As String
    Dim intCountAll As Integer
    Dim intCountFailures As Integer
    Dim strStatusMsg As String
    Dim vSuccess As Variant
    Dim strTemp1 As String
    Dim strTemp2 As String
    Dim strErrorMsg As String
 
    '-------------------------------------
    'Get target drive
    '-------------------------------------
    If (EXM_OPT_USEBROWSER = True) Then
        strBackupPath = GetFileDir
        If Left(strBackupPath, 15) = "ERROR_OCCURRED:" Then
            strErrorMsg = Mid(strBackupPath, 16, 9999)
            Error 5004
        End If
    Else
        strBackupPath = EXM_OPT_TARGETFOLDER
    End If
    If strBackupPath = "" Then GoTo ExitScript
    If (Not Right(strBackupPath, 1) = "\") Then strBackupPath = strBackupPath & "\"
    
 
    '-------------------------------------
    'Process according to what is in the focus: an opened e-mail or a folder with selected e-mails.
    'Case 2 would also work for opened e-mail, however it does not always work (for instance if
    ' an e-mail is saved on the file system and being opened from there).
    '-------------------------------------
    
    Set myExplorer = Application.ActiveExplorer
    Set myfolder = myExplorer.CurrentFolder
    If myfolder Is Nothing Then Error 5001
    If Not myfolder.DefaultItemType = olMailItem Then GoTo ExitScript
   
    'Stop if more than x emails selected
    If myExplorer.Selection.Count > EXM_OPT_MAX_NO Then Error 5002
     
    'No email selected at all?
    If myExplorer.Selection.Count = 0 Then Error 5003
     
    Set olSelection = myExplorer.Selection
    intCountAll = 0
    intCountFailures = 0
    For Each myItem In olSelection
        intCountAll = intCountAll + 1
        vSuccess = ProcessEmail(myItem, strBackupPath)
        If (Not vSuccess = True) Then
            Select Case intCountFailures
                Case 0: strStatusMsg = vSuccess
                Case 1: strStatusMsg = "1x " & strStatusMsg & Chr(10) & "1x " & vSuccess
                Case Else: strStatusMsg = strStatusMsg & Chr(10) & "1x " & vSuccess
            End Select
            intCountFailures = intCountFailures + 1
        End If
    Next
    If intCountFailures = 0 Then
        strStatusMsg = intCountAll & " " & EXM_004
    End If
    
    'Final Message
    If (intCountFailures = 0) Then  'No failure occurred
        MsgBox strStatusMsg & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 64, EXM_018
    ElseIf (intCountAll = 1) Then   'Only one email was selected and a failure occurred
        MsgBox EXM_002 & Chr(10) & vSuccess & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_017
    Else    'More than one email was selected and at least one failure occurred
        strTemp1 = Replace(EXM_020, "[NO_OF_SELECTED_ITEMS]", intCountAll)
        strTemp1 = Replace(strTemp1, "[NO_OF_SUCCESS_ITEMS]", intCountAll - intCountFailures)
        strTemp2 = Replace(EXM_019, "[NO_OF_FAILURES]", intCountFailures)
        MsgBox strTemp1 & Chr(10) & Chr(10) & strTemp2 & Chr(10) & Chr(10) & strStatusMsg _
        & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_017
    End If


ExitScript:
    Exit Sub
ErrorHandler:
    Select Case Err.Number
    
    Case 5001:  'Not an email
        MsgBox EXM_010, 64, EXM_007
    Case 5002:
        MsgBox Replace(EXM_008, "[LIMIT_SELECTED_ITEMS]", EXM_OPT_MAX_NO), 64, EXM_007
    Case 5003:
        MsgBox EXM_009, 64, EXM_007
    Case 5004:
        MsgBox EXM_011 & Chr(10) & Chr(10) & strErrorMsg, 48, EXM_007
    Case Else:
        MsgBox EXM_011 & Chr(10) & Chr(10) _
        & Err & " - " & Error$ & Chr(10) & Chr(10) & EXM_012, 48, EXM_007
    End Select
    Resume ExitScript
End Sub

Private Function ProcessEmail(myItem As Object, strBackupPath As String) As Variant
    'Saves the e-mail on the drive by using the provided path.
    'Returns TRUE if successful, and FALSE otherwise.

    Const PROCNAME As String = "ProcessEmail"

    On Error GoTo ErrorHandler

    Dim myMailItem As MailItem
    Dim strDate As String
    Dim strSender As String
    Dim strReceiver As String
    Dim strSubject As String
    Dim strFinalFileName As String
    Dim strFullPath As String
    Dim vExtConst As Variant
    Dim vTemp As String
    Dim strErrorMsg As String
    
    If TypeOf myItem Is MailItem Then
         Set myMailItem = myItem
    Else
        Error 1001
    End If
    
    strSubject = myMailItem.Subject
    strDate = Format(myMailItem.ReceivedTime, EXM_OPT_FILENAME_DATEFORMAT)
    strSender = myMailItem.SenderName
    strReceiver = myMailItem.To 'All receiver, semikolon separated string
    If InStr(strReceiver, ";") > 0 Then strReceiver = Left(strReceiver, InStr(strReceiver, ";") - 1)

    'filname settings
    
    strDate = Format(myMailItem.SentOn, EXM_OPT_FILENAME_DATEFORMAT)
    strSender = myMailItem.SenderName
    strReceiver = myMailItem.To 'All receiver, semikolon separated string
    If InStr(strReceiver, ";") > 0 Then strReceiver = Left(strReceiver, InStr(strReceiver, ";") - 1)
    strSubject = myMailItem.Subject
    strFinalFileName = EXM_OPT_FILENAME_BUILD
    strFinalFileName = Replace(strFinalFileName, "<DATE>", strDate)
    strFinalFileName = Replace(strFinalFileName, "<SENDER>", strSender)
    strFinalFileName = Replace(strFinalFileName, "<RECEIVER>", strReceiver)
    strFinalFileName = Replace(strFinalFileName, "<SUBJECT>", strSubject)
    strFinalFileName = CleanString(strFinalFileName)
    If Left(strFinalFileName, 15) = "ERROR_OCCURRED:" Then
        strErrorMsg = Mid(strFinalFileName, 16, 9999)
        Error 1003
    End If
    strFinalFileName = IIf(Len(strFinalFileName) > 251, Left(strFinalFileName, 251), strFinalFileName)
    strFullPath = strBackupPath & strFinalFileName
    'Save as msg or txt?
    Select Case UCase(EXM_OPT_MAILFORMAT)
        Case "MSG":
            strFullPath = strFullPath & ".msg"
            vExtConst = olMSG
        Case Else:
            strFullPath = strFullPath & ".txt"
            vExtConst = olTXT
    End Select
    'File already exists?
    If CreateObject("Scripting.FileSystemObject").FileExists(strFullPath) = True Then
        Error 1002
    End If
    
    'Save file
    myMailItem.SaveAs strFullPath, vExtConst
    
    'Return true as everything was successful
    ProcessEmail = True

ExitScript:
    Exit Function
ErrorHandler:
    Select Case Err.Number
    Case 1001:  'Not an email
        ProcessEmail = EXM_013
    Case 1002:
        ProcessEmail = EXM_014
    Case 1003:
        ProcessEmail = strErrorMsg
    Case Else:
        ProcessEmail = "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
    End Select
    Resume ExitScript
End Function


Private Function CleanString(strData As String) As String

    Const PROCNAME As String = "CleanString"

    On Error GoTo ErrorHandler

    'Instantiate RegEx
    Dim objRegExp As Object
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = True

    'Cut out strings we don't like
    objRegExp.Pattern = EXM_OPT_CLEANSUBJECT_REGEX
    strData = objRegExp.Replace(strData, "")

    'Replace and cut out invalid strings.
    strData = Replace(strData, Chr(9), "_")
    strData = Replace(strData, Chr(10), "_")
    strData = Replace(strData, Chr(13), "_")
    objRegExp.Pattern = "[/\\*]"
    strData = objRegExp.Replace(strData, "-")
    objRegExp.Pattern = "[""]"
    strData = objRegExp.Replace(strData, "'")
    objRegExp.Pattern = "[:?<>\|]"
    strData = objRegExp.Replace(strData, "")
    
    'Replace multiple chars by 1 char
    objRegExp.Pattern = "\s+"
    strData = objRegExp.Replace(strData, " ")
    objRegExp.Pattern = "_+"
    strData = objRegExp.Replace(strData, "_")
    objRegExp.Pattern = "-+"
    strData = objRegExp.Replace(strData, "-")
    objRegExp.Pattern = "'+"
    strData = objRegExp.Replace(strData, "'")
            
    'Trim
    strData = Trim(strData)
    
    'Return result
    CleanString = strData
  
  
ExitScript:
    Exit Function
ErrorHandler:
    CleanString = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
    Resume ExitScript
End Function

Private Function GetFileDir() As String
    
    Const PROCNAME As String = "GetFileDir"

    On Error GoTo ErrorHandler

    Dim ret As String
    Dim lpIDList As Long
    Dim sPath As String
    Dim udtBI As BROWSEINFO
    Dim RdStrings() As String
    Dim nNewFiles As Long

    'Show a browse-for-folder form:
    With udtBI
        .lpszTitle = lstrcat(EXM_016, "")
        .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_NEWDIALOGSTYLE + BIF_EDITBOX
    End With

    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList = 0 Then Exit Function
       
    'Get the selected folder.
    sPath = String$(MAX_PATH, 0)
    SHGetPathFromIDList lpIDList, sPath
    CoTaskMemFree lpIDList
    
    'Strip Nulls
    If (InStr(sPath, Chr$(0)) > 0) Then sPath = Left$(sPath, InStr(sPath, Chr(0)) - 1)

    'Return Dir
    GetFileDir = sPath

ExitScript:
    Exit Function
ErrorHandler:
    GetFileDir = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
    Resume ExitScript
End Function

Select allOpen in new window

how do you call your macro when a user 'sends' an email?

On ThisOutlookSession :

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim FilePath As String
Dim FileName As String

ActiveInspector.WindowState = olMinimized

UserForm1.Show 1

If UserForm1.Tag = "YES" Then

Call Macro.MailToDrive

    'Item.SaveAs FilePath & FileName & ".msg", olMSG

End If

Unload UserForm1

End Sub

Select allOpen in new window

But I've got another button in Outlook interface corresponding to the macro and allowing users to save selected mails by the same way.

Get rid of your macro and start a new Outlook Project.

Put this code in your 'ThisOutlookSession' :

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

ActiveInspector.WindowState = olMinimized

UserForm1.Show 1

Select Case UserForm1.CommonDialog1.FilterIndex
    Case 1: Item.SaveAs UserForm1.CommonDialog1.FileName, olMSG
    Case 2: Item.SaveAs UserForm1.CommonDialog1.FileName, olTXT
End Select

Unload UserForm1
DoEvents

End Sub

Select allOpen in new window

Save the following four (4) files to a test directory and then import them into your Outlook

and then add these three files using , File Menu -> Import File...

CTimer.cls
MSharedTimer.bas
UserForm1.frm

This has been tested and works...
CTimer.cls
MSharedTimer.bas
UserForm1.frm
UserForm1.frx

Ok I'm ready to test your solution but when I try to import the UserForm1.frm file I get a system error &H80004005 (-2147467259) and a dialog box insuffisant memory and the log file says that the "property of OleObjectBlob  in UserForm1 could not be define"...

OK, forget the UserForm and make your own.

Click Menu INSERT --> UserForm to add a new User Form1 to your Project.

Click Menu VIEW --> Toolbox to show the controls

Add two (2) Command Buttons  to UserForm1.
   Click CommandButton1 once and press F4 (this will hightlight the (Name) property.
   Change
                      (Name)                --> cmdYes
                      Accelerator         --> y
                      Caption               --> Yes

   for CommandButton2 set these properties
                      (Name)                --> cmdNo
                      Accelerator         --> n
                      Caption               --> No


Add one (1)  Common Dialog to UserForm1.  

Your form should look like the picture above.

Now open the code windows for UserForm1 and paste in the following code.

Option Explicit

Private WithEvents Timer1 As CTimer

Private Const defClockUpdate As Long = 500 'milliseconds

Private Sub UserForm_Initialize()

   Set Timer1 = New CTimer

   Timer1.Interval = 10000
   Timer1.Enabled = True

   With CommonDialog1
        .Filter = "MSG File (*.msg)|*.msg|Text file (*.txt)|*.txt|"
        .DefaultExt = ".msg"
        .DialogTitle = "Save Email Message?"
        .Flags = cdlOFNOverwritePrompt + cdlOFNPathMustExist
   End With
   
End Sub

Private Sub Timer1_Timer()

With Timer1
   If .Interval <> defClockUpdate Then
      .Interval = defClockUpdate
      Me.Hide
      DoEvents
   End If
End With


End Sub

Private Sub cmdYES_Click()

CommonDialog1.InitDir = "C:\Temp"
CommonDialog1.FileName = "Set_File_Name_Here"
CommonDialog1.ShowSave
Me.Hide


End Sub

Private Sub cmdNO_Click()

Me.Hide

End Sub

Select allOpen in new window

Ok after some struggle with the ms commondialog ocx, it works.

But I have 3 questions :

* first : Is it possible to fix an initial folder? I don't really need to remember the last folder

* second : Is it possible to fix the name of the .msg like <date(yyyy-mm-dd_hh-nn-ss)>-<sender>-<receiver>-<object>.msg ?

* third : Is it possible to put a button in the outlook interface to click and save one or more mail from the interface just by selecting it ? Like I do with my actual macro

 Thank you very much for your help and support.

1) Yes.  The first line under Sub cmdYes_Click()  set the initial Folder.

CommonDialog1.InitDir = "C:\Temp"

2) Yes.  Under the Private Sub Application_ItemSend(Item As Object)

Item.SaveAs Item.SenderName & Format(NOW, "MM_DD_YY"), olMSG

The Item Object is the MailItem being sent.  See this link for all properties of the MailItem that can be used.  http://msdn.microsoft.com/en-us/library/office/aa210946(v=office.11).aspx

3) Yes.  To add a custom macro button to Outlook see this link
                    http://www.howto-outlook.com/howto/macrobutton.htm

             To cycle thought selected mail use something like:

Dim SelectedItems As Selection
Set SelectedItems = Outlook.ActiveExplorer.Selection
For Each Item In SelectedItems

	strTargetPath = Mid$(UserForm1.CommonDialog1.FileName, 1, InStrRev (UserForm1.CommonDialog1.FileName, "\"))
	strTargetFilename =  Format(Item.ReceivedTime, "yyyy_mm_dd_hhnnss") + "_" + Item.SenderName

	Item.SaveAs strTargetPath + strTargetFilename + ".msg", olMSG
Next Item

Select allOpen in new window

Ok for 1)

For 2) you mean like that :
ThisOutlookSession :

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

ActiveInspector.WindowState = olMinimized

UserForm1.Show 1

Select Case UserForm1.CommonDialog1.FilterIndex
  
    Case 1: Item.SaveAs Item.SenderName & Format(NOW, "MM_DD_YY"), olMSG
    Case 2: Item.SaveAs UserForm1.CommonDialog1.FileName, olTXT
    
End Select

Unload UserForm1
DoEvents

End Sub

Select allOpen in new window

In the module you have :

CommonDialog1.FileName = "FileName"

Select allOpen in new window

For 3) I know how t create the button but there's no macro available when I want to create the button. Do I have to create a module and put the code in ?

For 2

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

ActiveInspector.WindowState = olMinimized

UserForm1.Show 1

Select Case UserForm1.CommonDialog1.FilterIndex
  
    Case 1
	strTargetPath = Mid$(UserForm1.CommonDialog1.FileName, 1, InStrRev (UserForm1.CommonDialog1.FileName, "\"))
	strTargetFilename =  Format(Item.ReceivedTime, "yyyy_mm_dd_hhnnss") + "_" + Item.SenderName

	Item.SaveAs strTargetPath + strTargetFilename + ".msg", olMSG

    Case 1
	strTargetPath = Mid$(UserForm1.CommonDialog1.FileName, 1, InStrRev (UserForm1.CommonDialog1.FileName, "\"))
	strTargetFilename =  Format(Item.ReceivedTime, "yyyy_mm_dd_hhnnss") + "_" + Item.SenderName

	Item.SaveAs strTargetPath + strTargetFilename + ".msg", olTXT

End Select

Unload UserForm1
DoEvents

Select allOpen in new window

3) Read the link I sent you.  It shows how to setup Button for Macro.

Ok I paste it on thisoutlooksession, it works but the file name is still the same name specified in the userform1 code under :

Private Sub cmdYES_Click()
CommonDialog1.InitDir = "L:"
CommonDialog1.FileName = "name_of_the_file"
CommonDialog1.ShowSave
Me.Hide
End Sub

Select allOpen in new window

For the button I know how to create it but I can't choose any macros because the list is empty.

For memory I've got ThisOutlookSession, UserForm1, MsSharedTimer module, and CTimer class module.

If I can I will give you more points as a christmass gift for your patience !

I've requested that this question be closed as follows:

Accepted answer: 500 points for shorvath's comment #a38666053

for the following reason:

This question has been classified as abandoned and is closed as part of the Cleanup Program. See the recommendation for more details.

Thanks shorvath, you really help me.

Thank you