''Code complied by Graham Mayor!''
Option Explicit
Private Const strRoot As String = "\\NEWBENSON\Projects\Drawings\"
Public Sub Save()
'Last updated - 18 Aug 2017 - Gmayor
Dim olObj As Object
Dim olMsg As MailItem
Dim selCount As Long
Dim j As Long
Dim fPath1 As String, fPath2 As String, fPath3 As String
Dim strPath As String, strSavePath As String
selCount = ActiveExplorer.Selection.Count
If selCount = 0 Then GoTo lbl_Exit
fPath1 = InputBox("Enter the customer folder name in which to save the messages." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
fPath1 = Replace(fPath1, "\", "")
fPath2 = GetPath(fPath1)
If fPath2 = "" Then
MsgBox "The project number does not exist!"
'so end processing
GoTo lbl_Exit
End If
strPath = fPath2
CreateFolders strPath & "\Correspondence" & "\Sent"
CreateFolders strPath & "\Correspondence" & "\Received"
CreateFolders strPath & "\Documents" & "\Documents Received"
CreateFolders strPath & "\Documents" & "\Documents Sent"
For j = selCount To 1 Step -1
Set olObj = ActiveExplorer.Selection.Item(j)
If olObj.Class = olMail Then
If InStr(1, olObj.Categories, "Processed") = 0 Then
Set olMsg = olObj
SaveItem olItem:=olMsg, strPath:=strPath, bAttach:=True, bExcel:=False
olObj.Categories = "Processed" 'add this line
olObj.Save 'add this line
End If
End If
DoEvents 'add this line
Next j
lbl_Exit:
Exit Sub
End Sub
Private Function GetPath(strCustomer As String) As String
'Last updated - 18 Aug 2017 - Gmayor
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim bPath As Boolean
Dim strPath As String
Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer) 'error on strRoot?
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function
Private Sub SaveItem(olItem As MailItem, strPath As String, bAttach As Boolean, bExcel As Boolean)
'Last updated - 18 Aug 2017 - Gmayor
Dim fname As String
Dim strSavePath As String
If olItem.Sender Like "Nathan Davies" Then 'Looks for messages from you
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
strSavePath = strPath & "\Correspondence\Sent\"
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
strSavePath = strPath & "\Correspondence\Received\"
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, strSavePath, fname
If olItem.Sender Like "Nathan Davies" Then 'INSERT NAME HERE
If MsgBox("Save Attachments?", vbYesNo, "Save Attachments?") = vbYes Then
SaveAttachments olItem, strPath & "\Documents\Documents Sent\"
End If
Else
SaveAttachments olItem, strPath & "\Documents\Documents Received\"
'If bExcel = True Then
'CopyToExcel olItem, strPath
End If
lbl_Exit:
Exit Sub
End Sub
Private Sub SaveAttachments(olItem As MailItem, strSaveFolder As String)
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
On Error GoTo CleanUp
If olItem.Attachments.Count > 0 Then
strSaveFolder = strSaveFolder & Format(olItem.ReceivedTime, "yyyy-mm-dd") & Chr(92)
CreateFolders strSaveFolder
For j = olItem.Attachments.Count To 1 Step -1
Set olAttach = olItem.Attachments(j)
If Not olAttach.FileName Like "image*.*" Then
strFname = olAttach.FileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFolder, strFname, strExt)
olAttach.SaveAsFile strSaveFolder & strFname
'olAttach.Delete 'delete the attachment
End If
Next j
olItem.Save
End If
CleanUp:
Set olAttach = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function
Private Sub CreateFolders(strPath As String)
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lngPathSep = InStr(3, strPath, "\")
If lngPathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
If lngPathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lngPathSep = 0
If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
oFSO.CreateFolder Left(strPath, lngPathSep)
End If
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub
Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
'Debug.Print strPath & strFileName & ".msg"
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function
Private Function FileExists(filespec As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function
Private Function FolderExists(fldr As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function
Reply With Quote
