Outlook Save Mail

Sub SaveMail_InternalMemo()
  SaveMail "P:\811\31350 Oiltanking EPCM\02. Correspondence and reports\2.05 Internal memos\", "Oiltanking saved"
End Sub

Sub SaveMail_EmailFromClient()
  SaveMail "P:\811\31413 PWN Waterleidingbedrijf\00\02. Correspondence and reports\2.01 From Client\2.01.01 E-mails", "Oiltanking saved"
End Sub

Sub SaveMail_EmailToClient()
  SaveMail "P:\811\31413 PWN Waterleidingbedrijf\00\02. Correspondence and reports\2.02 To Client\2.02.04 FPO", "Oiltanking saved"
End Sub

Sub SaveMail_ToVendor()
  SaveMail "P:\811\31350 Oiltanking EPCM\02. Correspondence and reports\2.04 From and To Third parties\2.04.01 E-mails\", "Oiltanking saved"

End Sub

Sub SaveMail(myLocation, myDestFolderVar As String)
On Error GoTo errorhandler

    Dim myItem As Object

    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection

    Set myItem = myOlSel.Item(1)


    strDateprefix = Format(myItem.ReceivedTime, "yymmdd HhNn")

    strname = myItem.Subject

    strname = Replace(strname, ":", " ")
    strname = Replace(strname, "/", " ")
    strname = Replace(strname, "\", " ")
    strname = Replace(strname, "*", " ")
    strname = Replace(strname, "<", " ")
    strname = Replace(strname, ">", " ")
    strname = Replace(strname, "?", " ")
    strname = Replace(strname, "|", " ")
    strname = Replace(strname, """", " ")

    strfilename = myLocation & strDateprefix & " " & strname & ".msg"

    myItem.SaveAs strfilename, olMSG

    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myDestFolder = myInbox.Folders(myDestFolderVar)
    myItem.Move myDestFolder

errorhandler:
    Exit Sub

End Sub

'back-up van originele code
'Sub SaveMail(myLocation, myDestFolderVar As String)
'On Error GoTo errorhandler

'    Dim myItem As Object
'
'    Dim myOlApp As New Outlook.Application
'    Dim myOlExp As Outlook.Explorer
'    Dim myOlSel As Outlook.Selection
'    Set myOlExp = myOlApp.ActiveExplorer
'    Set myOlSel = myOlExp.Selection
'
'    Set myItem = myOlSel.Item(1)
'
'    strDateprefix = Format(myItem.ReceivedTime, "yymmdd HhNn")
'
'
'    strname = myItem.Subject
'
'
'    strname = Replace(strname, ":", " ")
'    strname = Replace(strname, "/", " ")
'    strname = Replace(strname, "\", " ")
'    strname = Replace(strname, "*", " ")
'    strname = Replace(strname, "<", " ")
'    strname = Replace(strname, ">", " ")
'    strname = Replace(strname, "?", " ")
'    strname = Replace(strname, "|", " ")
'    strname = Replace(strname, """", " ")
'
'    strfilename = myLocation & strDateprefix & " " & strname & ".msg"
'
'
'    myItem.SaveAs strfilename, olMSG
'
'    Set myNameSpace = myOlApp.GetNamespace("MAPI")
'    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
'    Set myDestFolder = myInbox.Folders(myDestFolderVar)
'    myItem.Move myDestFolder
'
'errorhandler:
'    Exit Sub
'
'End Sub