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 (http://www.vbaexpress.com/forum/member.php?54471-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.