Copy emails from specific folder in Outlook to a shared local folder

[feni1388]

Hello...

Does anyone have experience in copying emails in outlook to a shared local folder?
I tried looking for VBA code that similar to what I want but I still can't find the one.
If possible, I want to have VBA code that copy emails from several folders in outlook to a shared folder.

I have different folders in outlook for each customer, and I need to copy all emails coming in today to a shared folder (each customer has its own folder too here).
If possible, when it copies the message, I want to rename it as the folder's name along with date and time stamp when the email was received.

Please share if you have anything that is similar.

Thank you.

 

[feni1388]

I found a VBA code in the internet that is quite close to what I want to do.
If possible, it would be great if the user can enter the date they want to do search for and instead of selecting the emails, the user can just enter the date,
and it will automatically search and save the emails from that date to the designated personal folder.

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 = "\\obcsvr\Share\Law\Cust\PO\west\"           
                
       If olItem.Sender Like "*@apscnet.com" Then    'Replace with your domain           
                    
        fName = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _           
                Format(olItem.SentOn, "HH.MM") & Chr(32) & "APSC" & "PO"           
                            
                            
    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 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