Save file.msg to folder and test if exist

[jmaocubo]

Good afternoon,

I need help to complete a project.

The idea is to save the mail folder whose path is already set. So far already solved.

Problem:

1) If the name assign already exists, it replaces the existing one.
2) If I assign no name (blank) it saves without any name (blank - unnamed).
3) I have a list of all files in a listbox (userform). How do I after creating/save another file, the listbox update the list.

So far I have the following:

Sub SaveAsMSG()
 
' Gravar ficheiro na pasta
    Dim objItem As Outlook.MailItem
    Dim strPrompt As String, strname As String
    Dim sreplace As String, mychar As Variant, strdate As String
    Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
    If objItem.Class = olMail Then
       strname = UserForm1.TextBox3.Value
        
        myPath = UserForm1.TextBox2.Value & "/" & UserForm1.TextBox1.Value
        If myPath = False Then
            MsgBox "Não indicou nenhum caminho para guardar!!!", vbExclamation
     
        Else
            objItem.SaveAs myPath & "\" & strname & ".msg", olMSG
        End If
    End If
End Sub

thanks in advance

[gmayor]

You could employ a userform to get the path or you can create a VBA function to get it (see the BrowseForFolder function in my web site). The following method uses an Input box. The method below uses the date and the message subject to create the filename. No existing filenames are overwritten, if the intended path is missing, it is created and illegal filename characters are replaced.

Enter your domain name where indicated so that you can save sent messages as well as received messages. The Portuguese translations for the input box texts are courtesy of Google, so forgive me if they are not accurate.

Option Explicit

Sub SaveMessage()
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveItem olMsg
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub

Sub SaveItem(olItem As MailItem)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim fname As String
Dim fPath As String
    fPath = InputBox("Digite o caminho para salvar a mensagem." & vbCr & _
                     "O caminho será criado se ele não existir.", _
                     "Salvar mensagem", "C:\Path\")
    CreateFolders fPath

    If olItem.Sender Like "*@gmayor.com" Then    'Change to your domain name (for sent messages)
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
    End If
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, fPath, fname
lbl_Exit:
    Exit Sub
End Sub

Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
End Function

Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName)
    Do While FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    If oFSO.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
Set oFSO = Nothing
    Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    If (oFSO.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
Set oFSO = Nothing
    Exit Function
End Function

[jmaocubo]

Hi gmayor
I apologize for not responding sooner.
After analyzing your code I decided to create my own.
The only thing missing is to force test to determinate if the path exists. Any idea?
Below is the code. I take this opportunity to thank you for your help.

The purpose of the translation into Portuguese is correct!!!!

Sub SaveAsMSG()
' Gravar ficheiro na pasta
    Dim objItem As Outlook.MailItem
    Dim strname As String
    
    Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
        
    If objItem.Class = olMail Then
       strname = UserForm1.TextBox3.Value
         
        MyPath = UserForm1.TextBox2.Value & "/" & UserForm1.TextBox1.Value
        If MyPath = False Then
            MsgBox "Não indicou nenhum caminho para guardar!!!", vbExclamation
            
      ElseIf UserForm1.TextBox1.Value = "" Or UserForm1.TextBox3.Value = "" Then ' se não indicar nome ou pasta a colocar
            MsgBox "Tem de especificar a pasta e/ou nome do ficheiro"
      
      ElseIf dir(MyPath & "\" & strname & ".msg") <> "" Then
            MsgBox "FICHEIRO NÃO CRIADO: Já existe um ficheiro com esse nome!!!"
            GoTo a
     
     ElseIf dir(MyPath & "\", vbDirectory) = "" Then ' evita que o path seja uma pasta que não exista
            MsgBox "A pasta que indicou não existe. Por favor crie a mesma"
            GoTo a
     
     Else
            objItem.SaveAs MyPath & "\" & strname & ".msg", olMSG
                         
        End If
    End If
    
   UserForm1.TextBox3.Value = "" 'apaga o nome do ficheiro criado da textbox
   
 refresh
   
a:

    End Sub

Sub refresh()
     'refresh lista de ficheiros
     On Error Resume Next
    Dim FSO As Object, fld As Object, Fil As Object
    Dim SubFolderName As String
    Dim i As Integer
    Set FSO = CreateObject("Scripting.FileSystemObject")
    UserForm1.ListBox2.Clear
    SubFolderName = UserForm1.TextBox2.Value & "/" & UserForm1.TextBox1.Value & "\"
    Set fld = FSO.GetFolder(SubFolderName)
    For Each Fil In fld.Files
        i = i + 1
        UserForm1.ListBox2.AddItem Fil.Name
         
    Next Fil
End Sub

Thanks Again

Miguel

[gmayor]

My previous reply includes functions to test if a folder exists and to create it if it doesn't.