Multiple Apps

Create a dir and save file into it then create two sub dirs

Ease of Use

Intermediate

Version tested with

2000, 2003 

Submitted by:

gibbo1715

Description:

When run, a directory is created where specified and a duplicate of the spreadsheet (If excel), Document (If Word) or Presentation if Powerpoint is saved into that directory. Two sub directories are then created to keep relevant files in. 

Discussion:

I use this as a template to manage my individual jobs, so I get a blank template with the sub directories. I always need to keep other documents relating to that job in one place along so this creates my sub directories without me having to manually create them every time. 

Code:

instructions for use 

			
Option Explicit 
 
Function GetFolderPath() As String 
    Dim oShell As Object 
    Set oShell = CreateObject("Shell.Application"). _ 
    BrowseForFolder(0, "Please select folder", 0, "c:\\") 
    If Not oShell Is Nothing Then 
        GetFolderPath = oShell.Items.Item.Path 
    Else 
        GetFolderPath = vbNullString 
    End If 
    Set oShell = Nothing 
End Function 
 
Sub Testxl() 
    Dim FName As String 
    Dim WbName As String 
    Dim Search As String 
    Dim Prompt As String 
    Dim Title As String 
    Dim MyDir1 As String 
    Dim MyDir2 As String 
    Dim Passed As Long 
     
    MyDir1 = "\TestDir1" 
    MyDir2 = "\TestDir2" 
     
     
On Error GoTo Err: 
     
    FName = GetFolderPath 
    If FName <> vbNullString Then 
        Prompt = "Please Select a Name?" 
        Title = "Name" 
        Search = InputBox(Prompt, Title) 
        If Search = "" Then Exit Sub 
    End If 
    FName = FName & "\" & Search 
    MkDir FName 
    ActiveWorkbook.SaveAs FName & "\" & Search & ".xls" 
     
    MkDir ActiveWorkbook.Path & MyDir1 
    MkDir ActiveWorkbook.Path & MyDir2 
     
     'Test for existence of new folders.files
    Passed = 1 
    GetAttr (FName) 
    Passed = 2 
    GetAttr (FName & "\" & Search & ".xls") 
    Passed = 3 
    GetAttr (ActiveWorkbook.Path & MyDir1) 
    Passed = 4 
    GetAttr (ActiveWorkbook.Path & MyDir2) 
     
     
    End 
     'Sheets("Sheet1").Range("B1").Value = Search **Add if you require the name to be recorded in your spreadsheet
Err: 
    Select Case Err 
    Case 53:           MsgBox "File/Folder not created. Failed at step " & Passed 
    Case 75:    MsgBox "Folder already exists" 
    End Select 
End Sub 
 
Sub Testwd() 
    Dim FName As String 
    Dim WbName As String 
    Dim Search As String 
    Dim Prompt As String 
    Dim Title As String 
    Dim MyDir1 As String 
    Dim MyDir2 As String 
    Dim Passed As Long 
     
    MyDir1 = "\TestDir1" 
    MyDir2 = "\TestDir2" 
     
     
On Error GoTo Err: 
     
    FName = GetFolderPath 
    If FName <> vbNullString Then 
        Prompt = "Please Select a name?" 
        Title = "Name" 
        Search = InputBox(Prompt, Title) 
        If Search = "" Then Exit Sub 
    End If 
     
    FName = FName & "\" & Search 
    MkDir FName 
    ActiveDocument.SaveAs FName & "\" & Search & ".doc" 
     
    MkDir ActiveDocument.Path & MyDir1 
    MkDir ActiveDocument.Path & MyDir2 
     
     'Test for existence of new folders.files
    Passed = 1 
    GetAttr (FName) 
    Passed = 2 
    GetAttr (FName & "\" & Search & ".doc") 
    Passed = 3 
    GetAttr (ActiveDocument.Path & MyDir1) 
    Passed = 4 
    GetAttr (ActiveDocument.Path & MyDir2) 
     
     
    End 
Err: 
    Select Case Err 
    Case 53:           MsgBox "File/Folder not created. Failed at step " & Passed 
    Case 75:    MsgBox "Folder already exists" 
    End Select 
End Sub 
 
Sub Testppt() 
     
    Dim FName As String 
    Dim WbName As String 
    Dim Search As String 
    Dim Prompt As String 
    Dim Title As String 
    Dim MyDir1 As String 
    Dim MyDir2 As String 
    Dim Passed As Long 
     
    MyDir1 = "\TestDir1" 
    MyDir2 = "\TestDir2" 
     
     
On Error GoTo Err: 
     
    FName = GetFolderPath 
    If FName <> vbNullString Then 
        Prompt = "Please Select a name for your enquiry?" 
        Title = "Enquiry Name" 
        Search = InputBox(Prompt, Title) 
        If Search = "" Then Exit Sub 
    End If 
    FName = FName & "\" & Search 
    MkDir FName 
    ActivePresentation.SaveAs FName & "\" & Search & ".ppt" 
     
    MkDir ActivePresentation.Path & MyDir1 
    MkDir ActivePresentation.Path & MyDir2 
     
     'Test for existence of new folders.files
    Passed = 1 
    GetAttr (FName) 
    Passed = 2 
    GetAttr (FName & "\" & Search & ".ppt") 
    Passed = 3 
    GetAttr (ActivePresentation.Path & MyDir1) 
    Passed = 4 
    GetAttr (ActivePresentation.Path & MyDir2) 
     
     
    End 
Err: 
    Select Case Err 
    Case 53:           MsgBox "File/Folder not created. Failed at step " & Passed 
    Case 75:    MsgBox "Folder already exists" 
    End Select 
End Sub

How to use:

  1. For Excel
  2. Open Microsoft Excel
  3. Copy the Function GetFolderPath code and Testxl Module
  4. Press Alt + F11 to open the Visual Basic Editor (VBE)
  5. Add a new standard module (Top Left)
  6. Paste code into the right pane
  7. Return to excel and call the Macro Testxl
  8. **********************************
  9. For Word
  10. Open Microsoft Word
  11. Copy the Function GetFolderPath code and Testwd Module
  12. Press Alt + F11 to open the Visual Basic Editor (VBE)
  13. Add a new standard module (Top Left)
  14. Paste code into the right pane
  15. Return to Word and call the Macro Testwd
  16. ***********************************
  17. For Powerpoint
  18. Open Microsoft Powerpoint
  19. Copy the Function GetFolderPath code and Testppt Module
  20. Press Alt + F11 to open the Visual Basic Editor (VBE)
  21. Add a new standard module (Top Left)
  22. Paste code into the right pane
  23. Return to Powerpoint and call the Macro Testppt
 

Test the code:

  1. Return to Excel, Word or Powerpoint and select run macros and run the sub called Testxl from withing Excel or run the sub textwd from within Word or run the sub Testppt from within Powerpoint to test the code
  2. When you click it you will get a file browser, select a save location.
  3. You will then be asked to name your workbook, Presentation or Document
  4. The workbook, Presentation or document will be saved into a new folder with the same name.
  5. Two sub directories are then created to keep relevant files in.
 

Sample File:

Savewithsubdirs.zip 32.77KB 

Approved by mdmackillop


This entry has been viewed 188 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express