save selected emails on my hard drive with many option

[Mbelahcen]

Hello
I got this code (attached zip file)from a frien, it works with Outlook 2007, I want to use it in Outlook 2016, but I m not able.
can you help me.Im a beginner in VB
Many Thanks!

[gmayor]

As you have no doubt gathered the code doesn't work, not least of which because you (and I) don't have all the elements it calls upon. The following should save the selected messages to a named folder. Change the domain to your domain (or if a common domain, your e-mail address) so that you may save messages from the Sent folder; and, if you wish, the default path to your choice of default path.

Option Explicit

Sub SaveSelected()
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim olItem As MailItem
For Each olItem In Application.ActiveExplorer.Selection
If olItem.Class = OlObjectClass.olMail Then
SaveItem olItem
End If
Next olItem
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub

Private Sub SaveItem(olItem As MailItem)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim fName As String
Dim fPath As String
fPath = InputBox("Enter the path to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message", "C:\Outlook Message Backup\")
CreateFolders fPath

If olItem.Sender Like "*@gmayor.com" Then 'Replace with your domain
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
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Set oFSO = Nothing
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
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
lngF = 1
lngName = Len(strFileName)
Do While fso.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

[Mbelahcen]

Hello Graham
Thank you for your reply .

Here are the results of your macro
20161104 01.00 VBA Express Forum - Reply to thread 'save selected emails on my hard drive with many option'.msg
Is it possible to have a result like the following
161104 01.00 GMayor to MBelahcen Express Forum- 'save selected emails on my hard drive with'.msg , less than 100 caracters


Many thanks!

[gmayor]

The format is set by the lines

If olItem.Sender Like "*@gmayor.com" Then 'Replace with your domain
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 so perhaps something like:

If olItem.Sender Like "*@gmayor.com" Then 'Replace with your domain
fName = Format(olItem.SentOn, "yymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & _
" to " & olItem.To & " - " & olItem.subject
Else
fName = Format(olItem.ReceivedTime, "yymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & _
" to " & olItem.To & " - " & olItem.subject
End If
The string can be limited to 100 characters with

fName = Left(fName, 100)Add it before

SaveUnique olItem, fPath, fName

[Mbelahcen]

Thanks Graham

I'm able now to save email as I ask,
Exemple: 2016-11-05 052151-VBA Express Forum to Belahcen Mohammed-Reply to thread save selected emails on my hard drive with ma.msg

but I need to know how can i execute my macro by bypassing image #1 ,please see attached doc1.docx.
and how to execute my code by clicking a new button on my Outlook
Thanks a lot !