i Tried this but with error:
Option Explicit
Sub SaveMSGandATTACHEMENTS()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
' ============================== save function start =========================
Dim xShell As Object
Dim xFolder As Object
Dim strStartingFolder As String
Dim xFolderItem As Object
Dim xFileName As String
Dim objOL As Outlook.Application
Set xShell = CreateObject("Shell.Application")
On Error Resume Next
' Bypass error when xFolder is nothing on Cancel
Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, strStartingFolder)
' Remove error bypass as soon as the purpose is served
On Error GoTo 0
If Not TypeName(xFolder) = "Nothing" Then
Set xFolderItem = xFolder.self
xFileName = xFolderItem.Path
' missing path separator
If Right(xFileName, 1) <> "\" Then xFileName = xFileName & "\"
Else
xFileName = ""
Exit Sub
End If
' ============================== save function end =========================
SaveAttachments olMsg
SaveMessageAsMsg olMsg
lbl_Exit:
Exit Sub
End Sub
Public Sub SaveAttachments(olItem As MailItem)
'Graham Mayor -
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long, lng_Index As Long
Dim arrInvalid() As String
Dim xFileName As String
arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
On Error Resume Next
If olItem.Attachments.Count > 0 Then
For j = 1 To olItem.Attachments.Count
Set olAttach = olItem.Attachments(j)
'If Not olAttach.fileName Like "image*.*" Then
strFname = olItem.Subject & "_" & olAttach.FileName
For lng_Index = 0 To UBound(arrInvalid)
strFname = Replace(strFname, Chr(arrInvalid(lng_Index)), Chr(95))
Next lng_Index
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(xFileName, strFname, strExt)
olAttach.SaveAsFile xFileName & strFname
'End If
Next j
olItem.Save
End If
lbl_Exit:
Set olAttach = Nothing
Set olItem = Nothing
Exit Sub
End Sub
Public Sub SaveMessageAsMsg(olItem As MailItem)
'Update by Extendoffice 2018/3/5
Dim xMail As Outlook.MailItem
Dim xObjItem As Object
Dim xPath As String
Dim xDtDate As Date
Dim xName, xFileName As String
Dim xSender As String
Dim xFileName As String
On Error Resume Next
For Each xObjItem In Outlook.ActiveExplorer.Selection
If xObjItem.Class = olMail Then
Set xMail = xObjItem
xName = Left(CleanFileName(xMail.Subject), 40)
xSender = CleanFileName(xMail.senderName)
xDtDate = xMail.ReceivedTime
xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(xDtDate, "-hhnn", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & xSender & "-" & xName & ".msg"
xPath = xFileName + xName
xMail.SaveAs xPath, olMsg
End If
Next
End Sub
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'Graham Mayor - https://www.gmayor.com - Last updated - 22 Jul 2019
Dim lngF As Long
Dim lngName As Long
Dim fso As Object
lngF = 1
Set fso = CreateObject("Scripting.FileSystemObject")
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While fso.FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Set fso = Nothing
Exit Function
End Function
Public Function CleanFileName(strFileName As String) As String
Dim Invalids
Dim e
Dim strTemp As String
Invalids = Array("?", "*", ":", "|", "<", ">", "[", "]", """", "/")
strTemp = strFileName
For Each e In Invalids
strTemp = Replace(strTemp, e, " ")
'strTemp = Replace(strTemp, e, "")
Next
CleanFileName = strTemp
End Function
Private Function CreateFolders(strPath As String) As Boolean
'Graham Mayor
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) & "\"
On Error GoTo Err_Handler
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
CreateFolders = True
lbl_Exit:
Exit Function
Err_Handler:
MsgBox "The path " & strPath & " is invalid!"
CreateFolders = False
Resume lbl_Exit
End Function