Option Explicit
Public InboxWatcher As FolderEvents
Public Sub gazmoz17_RunOnce()
Const OUTLOOK_ROOTFOLDER As String = "\\emailallpst\Inbox\" ' <<< change to suit
Const DISK_ROOTFOLDER As String = "G:\My Drive\Outlook Subfolders\" ' <<< change to suit
Dim SubFolders As Variant, sf As Variant
Dim OutlFolder As String, DiskFolder As String
SubFolders = Array("P.O.'s", "ConfirmationNEW", "Delivery Note", "Invoices", "Statements")
For Each sf In SubFolders
OutlFolder = ProperPath(OUTLOOK_ROOTFOLDER) & sf
DiskFolder = ProperPath(DISK_ROOTFOLDER) & sf
Call SaveMultiEmailsAttachments(OutlFolder, DiskFolder, False)
Next sf
End Sub
Public Sub InitializeInboxWatcher()
Const OUTLOOK_ROOTFOLDER As String = "\\emailallpst\Inbox\" ' <<< change to suit
Const DISK_ROOTFOLDER As String = "G:\My Drive\Outlook Subfolders\" ' <<< change to suit
Dim SubFolders As Variant, sf As Variant, OutlFolder As String
Set InboxWatcher = New FolderEvents
InboxWatcher.Init GetAsOutlookFolder(OUTLOOK_ROOTFOLDER), DISK_ROOTFOLDER
SubFolders = Array("P.O.'s", "Confirmation", "Delivery Note", "Invoices", "Statements")
For Each sf In SubFolders
OutlFolder = ProperPath(OUTLOOK_ROOTFOLDER) & sf
InboxWatcher.Add GetAsOutlookFolder(OutlFolder)
Next sf
End Sub
Public Function ProperPath(ByVal argFolder As String) As String
ProperPath = IIf(Right(argFolder, 1) <> "\", argFolder & "\", argFolder)
End Function
Public Sub SaveSingleEmailAttachments(ByVal argMail As Outlook.MailItem, ByVal argDiskFolder As String)
Dim FSO As Object, Att As Outlook.Attachment, FullName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(argDiskFolder) Then
For Each Att In argMail.Attachments
FullName = ProperPath(argDiskFolder) & Att.FileName
If FSO.FileExists(FullName) Then
FullName = AddSuffix(FullName)
End If
Att.SaveAsFile FullName
Next Att
DoEvents
End If
Set FSO = Nothing
End Sub
Public Function GetAsOutlookFolder(ByVal FolderPath As String) As Outlook.Folder
Dim SubFolders As Outlook.Folders
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Long
On Error GoTo GetAsOutlookFolder_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
If Right(FolderPath, 1) = "\" Then
FolderPath = Left(FolderPath, Len(FolderPath) - 1)
End If
FoldersArray = Split(FolderPath, "\")
Set oFolder = Outlook.Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetAsOutlookFolder = Nothing
End If
Next
End If
Set GetAsOutlookFolder = oFolder
Exit Function
GetAsOutlookFolder_Error:
Set GetAsOutlookFolder = Nothing
Exit Function
End Function
Public Function AddSuffix(ByVal argFileName As String) As String
Dim oFSO As Object, lPos As Long, sFile As String, sResult As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
sResult = argFileName
lPos = InStrRev(sResult, ".")
If lPos = 0 Then
sResult = UpdateFileSuffix(sResult)
Else
sFile = Left(sResult, lPos - 1)
If Len(sFile) = 0 Then
sFile = UpdateFileSuffix(sResult)
Else
sFile = UpdateFileSuffix(sFile)
End If
sResult = sFile & "." & Right(sResult, Len(sResult) - lPos)
End If
If oFSO.FileExists(sResult) Then
AddSuffix = AddSuffix(sResult)
Else
AddSuffix = sResult
End If
End Function
Public Function UpdateFileSuffix(ByVal argFileName As String) As String
Dim sSfx As String, lPos As Long
If Not argFileName Like "*(*)" Then
UpdateFileSuffix = argFileName & "(1)"
Else
lPos = InStrRev(argFileName, "(") + 1
sSfx = Mid(argFileName, lPos, Len(argFileName) - lPos)
If IsNumeric(sSfx) Then
UpdateFileSuffix = Left(argFileName, lPos - 1) & (CLng(sSfx) + 1) & ")"
Else
UpdateFileSuffix = argFileName & "(1)"
End If
End If
End Function
Public Sub SaveMultiEmailsAttachments(ByVal argOutlookFolderPath As String, ByVal argDiskFolder As String, ByVal argSubject As Boolean, Optional ByVal argSearch As String = "")
Dim oFSO As Object
Dim Itms As Outlook.Items
Dim Itm As Outlook.MailItem
Dim Att As Outlook.Attachment
Dim sPath As String, sFullName As String, sSubject As String
Dim bSave As Boolean
On Error Resume Next
Set Itms = GetAsOutlookFolder(argOutlookFolderPath).Items
On Error GoTo 0
If Not Itms Is Nothing Then
If Itms.Count > 0 Then
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FolderExists(argDiskFolder) Then
For Each Itm In Itms
For Each Att In Itm.Attachments
If Len(argSearch) = 0 Then
bSave = True
ElseIf InStr(1, Att.FileName, argSearch, vbTextCompare) > 0 Then
bSave = True
Else
bSave = False
End If
If bSave Then
If argSubject Then
sSubject = ValidateFileName(Att.Parent.Subject) & " - "
End If
sFullName = ProperPath(argDiskFolder) & sSubject & Att.FileName
If oFSO.FileExists(sFullName) Then
sFullName = AddSuffix(sFullName)
End If
Att.SaveAsFile sFullName
DoEvents
End If
Next Att
Next Itm
End If
End If
End If
End Sub
Public Function ValidateFileName(ByVal argFileName As String) As String
Const cUnwanted As String = "<>""/:\|?*"
Dim sResult As String, i As Long
sResult = argFileName
For i = 1 To Len(cUnwanted)
sResult = Replace(sResult, Mid(cUnwanted, i, 1), "_")
Next
ValidateFileName = sResult
End Function
