VBA Outlook - Create New Fold on Hard Drive - Based on the first 5 Characters of .xls

[brian1988]

I found this code online, which works great for moving all excel files from my outlook subfolder, into a folder I have already have created on my C drive.

I was wondering if there is a way to create a new folder on my C Drive based on the excel files in my subfolder.

If the excel files in my Outlook subfolder "DataExtract" have the same first 5 characters to the excel document "?????.xls" then it will create a new folder on my C drive (with the folder name being the first 5 characters) and will save all of the excel files with the first 5 characters into the new file created on the C Drive.

Any help would be greatly appreciated!!

Option Explicit
Const FolderPath = "c:\Folder\"
Sub GetSpreadSheets()
On Error Resume Next
Dim ns As NameSpace
Set ns = GetNamespace("MAPI")
Dim Inbox As MAPIFolder
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
  
Dim searchFolder As String
searchFolder = InputBox("Search for Reports?")


Dim Subfolder As MAPIFolder
  
Dim Item As Object
Dim Attach As Attachment
Dim FileName As String
Dim i As Integer


 
 
 If searchFolder <> "inbox" Then
Set Subfolder = Inbox.Folders(searchFolder)
            i = 0
            If Subfolder.Items.Count = 0 Then
               MsgBox "There are no messages in the Inbox.", vbInformation, _
                      "Nothing Found"
               Exit Sub
            End If
                    For Each Item In Subfolder.Items
                       For Each Attach In Item.Attachments
                            If Right(Attach.FileName, 3) = "xls" Then
                                FileName = "C:\Email Attachments\" & Attach.FileName
                                Attach.SaveAsFile (FolderPath & Attach.FileName)
                          
                          i = i + 1
                          End If
                       Next Attach
                    Next Item
                    
                    '==============================================================================
                    'to search specific type of file:
'                               'For Each Item In Inbox.Items
'                               For Each Atmt In Item.Attachments
'                                  If Right(Atmt.FileName, 3) = "xls" Then
'                                     FileName = "C:\Email Attachments\" & Atmt.FileName
'                                     Atmt.SaveAsFile FileName
'                                     i = i + 1
'                                  End If
'                               Next Atmt
'                            Next Item
                    '===============================================================================
                    
        Else
         i = 0
            If Inbox.Items.Count = 0 Then
               MsgBox "There are no messages in the Inbox.", vbInformation, _
                      "Nothing Found"
               Exit Sub
            End If
            On Error Resume Next
            For Each Item In Inbox.Items
               For Each Attach In Item.Attachments
                  FileName = FolderPath & Attach.FileName
                  Attach.SaveAsFile FileName
                  i = i + 1
               Next Attach
            Next Item
     End If
     
End Sub