Hi,
i've got a macro that saves in a certain folder emails i select. It works pretty well exept for one thing. This macro has been programmed to name the file .eml according to the subject of the email. Therefore when i decide to save a forwarded email the outcome is someting like this: "I: subjectemail.eml"
I would like to remove the chars "I:"
Here is the code:
Option Explicit
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False
End Function
Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath, strFolderpath As String
Dim sName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
strFolderpath = BrowseForFolder("D:\test\mails\")
sPath = strFolderpath & "\"
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
ReplaceCharsForFileName sName, "-"
sName = sName & ".msg"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
Bookmarks