nathandavies
10-26-2017, 03:18 AM
Hi All,
I have this code which was developed by a user on here (G Mayor) and i now need to make a slight modification but i'm stuck as to how to make it.
The current code works like this: You input a company name, then you input the project number (5 digits) the code then looks through our server and saves the email in the correct folder location.
The New Code needs to work like this: You input a company name, then you input the project number (5 digits ie: A1234), then you input the sub project letter (1 letter ie: A) which is will create the sub folder from the project umber and the sub project letter (A1234-A). this will then create your folder path which will be like this (\\Server\Projects\drawings\Test\A1234 - Tran Station\A1234-A).
This is a copy of the current code. if anyone could help?
''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
I have this code which was developed by a user on here (G Mayor) and i now need to make a slight modification but i'm stuck as to how to make it.
The current code works like this: You input a company name, then you input the project number (5 digits) the code then looks through our server and saves the email in the correct folder location.
The New Code needs to work like this: You input a company name, then you input the project number (5 digits ie: A1234), then you input the sub project letter (1 letter ie: A) which is will create the sub folder from the project umber and the sub project letter (A1234-A). this will then create your folder path which will be like this (\\Server\Projects\drawings\Test\A1234 - Tran Station\A1234-A).
This is a copy of the current code. if anyone could help?
''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