Hey Guys,


can you hepl me with macro below ?


I found macro somwhere on the internet, it is possible to upgrade it with foloowing function ?

  • open "Save as window" like when you Save As Excel file
  • The macro create sub-folder in the picked location from previous step. Folder name: yyyymmdd hh.mm senders name - mail subject
  • Open this subfolder and save Outlook msg file (already do this macro below)
  • Save email to PDF file
  • Save all email attachements




It is possible to upgrade this awesome macro ?


Option Explicit


Sub SaveMessage()
'An Outlook macro by Graham Mayor - www.gmayor.com
'Saves the currently selected message
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 SaveAllMessagesInFolder()
'An Outlook macro by Graham Mayor - www.gmayor.com
'Saves all the messages in a selected Outlook folder
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
    Set olItems = Session.PickFolder.Items
    For Each olItem In olItems
        SaveItem olItem
    Next olItem
    Set olItem = Nothing
    Set olItems = Nothing
lbl_Exit:
    Exit Sub
End Sub




Private Sub SaveItem(olItem As MailItem)
'An Outlook macro by Graham Mayor - www.gmayor.com
'The main macro called by the above macros.
'This macro can be used as a script to save the messages as they arrive
'provided you change fPath = to a fixed path, so you are not prompted each time a message arrives
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 saved mails\")
    CreateFolders fPath


    If olItem.Sender Like "*** Email address is removed for privacy ***" Then    '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
'Creates the full path 'strPath' if missing or incomplete
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
'Ensures that filenames are not overwritten
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