saveMsg of outlook

Attribute VB_Name = "saveMsg"
Public Sub SaveAtt()

Dim msg As MailItem
Dim exp As Explorer
Dim att As Attachment
Dim attpath As String
Dim htmlname As String
Dim htmlpath As String
Dim folder As String
Dim msgdate As Date
Dim msgday As String
Dim charArray As Variant
Dim tmpChar As Variant
Dim changeTo As String

Set exp = Application.ActiveExplorer
charArray = Array("?", "/", "\", ":", "*", """", "<", ">", ",", "&", "#", "~", "%", "{", "}", "+")

' the folder to save files; must ends with slash
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "select a folder...", 0, 0)
If objFolder Is Nothing Then
    MsgBox "No folder is selected. Aborted!"
    Exit Sub
Else
    folder = objFolder.self.path + "\"
    'MsgBox folder
    'Exit Sub
End If
Set objFolder = Nothing
Set objShell = Nothing


For Each msg In exp.Selection
    'msg reception date for index
    msgdate = msg.ReceivedTime
    msgday = Day(msgdate)

    htmlname = CStr(msg.Subject)
    ' remove illegal characters in subject
    For Each tmpChar In charArray
        Select Case tmpChar
        Case "&"
            changeTo = " and "
        Case ":"
         changeTo = "-"
        Case Else
            changeTo = " "
        End Select
        htmlname = Replace(htmlname, tmpChar, changeTo)
     Next

    htmlpath = folder + CStr(msgday) + "_" + htmlname + ".html"
    msg.SaveAs htmlpath, olHTML

    If msg.Attachments.Count > 0 Then
        For Each att In msg.Attachments
            attpath = folder + CStr(msgday) + "_" + att.FileName
            att.SaveAsFile attpath
        Next
    End If

Next

End Sub