Consulting

Results 1 to 9 of 9

Thread: Code Change To Add An Additional Sub Folder Path When Saving Email

  1. #1

    Code Change To Add An Additional Sub Folder Path When Saving Email

    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

  2. #2
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,814
    Location
    bump
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  3. #3
    bump

  4. #4
    VBAX Mentor skatonni's Avatar
    Joined
    Jun 2006
    Posts
    347
    Location
    The easiest way would be to replace

    CreateFolders strPath & "\Correspondence" & "\Sent" 
        CreateFolders strPath & "\Correspondence" & "\Received" 
        CreateFolders strPath & "\Documents" & "\Documents Received" 
        CreateFolders strPath & "\Documents" & "\Documents Sent"

    with

    Start:
    strProjectLetter = InputBox("Enter project letter.")
        If Len(strProjectLetter) = 0 Then GoTo lbl_Exit
        
        If Len(strProjectLetter) <> 1 Then
            If IsNumeric(strProjectLetter) Then
                MsgBox "Enter a Letter!"
            End If
        
    GoTo Start:
        End If
        
        strPath = strPath & "\" & strProjectLetter
            
        CreateFolders strPath & "\Correspondence" & "\Sent"
        CreateFolders strPath & "\Correspondence" & "\Received"
        CreateFolders strPath & "\Documents" & "\Documents Received"
        CreateFolders strPath & "\Documents" & "\Documents Sent"
    Last edited by skatonni; 12-21-2017 at 12:18 PM.
    To debug, mouse-click anywhere in the code. Press F8 repeatedly to step through the code. http://www.cpearson.com/excel/DebuggingVBA.aspx

    If your problem has been solved in your thread, mark the thread "Solved" by going to the "Thread Tools" dropdown at the top of the thread. You might also consider rating the thread by going to the "Rate Thread" dropdown.

  5. #5
    Thank you skatonni,

    i'm not not back in work until January but i will test out your code as soon as i'm back.

    Thank you, from looking at your code i think it should work but cant test until back at work

  6. #6
    I have tried the code out eventually! and it doesn't quiet work correctly. the path that its creates is just the sub folder (IE - "A") and not the full required path (IE. "A1234-A"). the first 5 digits are from the following code "GetPath" which i think could be alternated to have an additional input box for the path. I have tried different ways to do this but i'm struggling to get the sub folder to work correctly.

    There will have to be 3 input boxes required 1. Customer 2. Job Number 3. Sub Job Number.

    One of the problems i can see is currently the code is only looking at the first 5 digits of the Job folder, but in reality the folder name will be "A1234 Train Station", the sub job number will on require the first 5 digits also so "A1234" and then the sub code "A". which will make it "A1234-A"

    (\\Server\Projects\drawings\Test (Customer Name Input)\ A1234 - Tran Station (Job Number Input) \ A1234-A (Job Number Input & Sub Job Input Combined )

    I hope this all makes sense.


    Public Sub Save()      
    'Last updated - 18 Aug 2017
        Dim olObj As Object
        Dim olMsg As MailItem
        Dim selCount As Long
        Dim j As Long
        Dim fPath1 As String, fPath2 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
        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

  7. #7
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,814
    Location
    'error on strRoot?
    Replace "strRoot" with your own "strPath"

    And you might as well replace "CStr(subFolder)" with
    "UCase(CStr(subFolder))"
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  8. #8
    I'm confused now SamT

  9. #9
    Any help further assistance before I cancel the thread?

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •