I have code for creating new folder on users desktop. I would like to add more functionality to it. Before creating new folder it should check if folder already exists (it is doing it right now). Then if there is folder with the same name, code should create new folder with next available number 1,2,3...
So if there is already folder with name "T34-23, Quotation", code should create folder named "T34-23, Quotation 1". If there is "T34-23, Quotation 1" then create "T34-23, Quotation 2" etc.
Sub MakeMyFolder()
Dim fdObj As Object
Application.ScreenUpdating = False
Set fdObj = CreateObject("Scripting.FileSystemObject")
If fdObj.FolderExists(Environ$("USERPROFILE") & "\Desktop\" & ThisWorkbook.Sheets("Other Data").Range("AK2").Value & ", " & _
ThisWorkbook.Sheets("Other Data").Range("AK7").Value) Then
'MsgBox "Found it.", vbInformation, "Excel"
Else
fdObj.CreateFolder (Environ$("USERPROFILE") & "\Desktop\" & ThisWorkbook.Sheets("Other Data").Range("AK2").Value & ", " & _
ThisWorkbook.Sheets("Other Data").Range("AK7").Value)
'MsgBox "It has been created.", vbInformation, "Excel"
End If
Set fdObj = Nothing
Application.ScreenUpdating = True
End Sub
As #urderboy suggests, you should use some variables in this.
Function CheckAndSuffixFolder(strPathToCheck As String, _
Optional blnCreateFolder As Boolean = False) As String
Dim f As New Scripting.FileSystemObject
Dim l As Long
Dim s As String
s = strPathToCheck
l = 1
Do While f.FolderExists(s)
l = l + 1
s = strPathToCheck & l
Loop
If blnCreateFolder Then f.CreateFolder s
CheckAndSuffixFolder = s
End Function
Calling like so, I have Folder, FOlder1 and FOlder2.
CheckAndSuffixFolder("C:\Workspace\Training\Folder") Gives me Folder3
Can't test it out now, but I'm thinking the solution will require you to loop through numbers until there is one that value that returns False. If the file check returns True then the file exists increment up until you get to the number needed. untested code:
Dim createFile Boolean: createFile = False
Dim i as Integer: i = 1
Do while createFile = False
Dim strDir As String
strDir = folderDir & "T34-23, Quotation" & i & "\"
If Dir(strDir, vbDirectory) = "" Then
MkDir strDir
createFile = True
Else
i = i+1
End If
wend
Related
Sorry to bother you, but I'm at an impasse :(
To summarize my situation, I need to recover an entire sheet of all files in a folder. My macro goes through them one by one and picks it up.
The problem is that I can have "xlsm" files that show me a warning pop up because there are macros and "trust" etc... Pop up that I can't remove because it doesn't cannot be disabled.
(I also can't change my excel options for X reasons because I'm not the only one using the macro).
I would therefore like to convert my "xlsm" to "xlsx" without having to open it to avoid the pop up. A simple change of extension damages the file (obvious)
Do you have a solution for saveas without opening the file or opening it without having the pop-up?
Thanks in advance !
Make the macro to open the files as read-only, so the pop up doesn't apear regarding trust.
Set my_wb = Workbooks.Open(Filename:=file_path, ReadOnly:=True)
And make the make macro to save the files as xlsx
Application.DisplayAlerts = False
my_wb.SaveAs fileName:="myFileName.xlsx"
As I said in my above comment, adding the folder where the workbooks in discussion exist in Excel Trusted Locations can be a solution, to avoid warnings related to trustful workbooks. Adding the folder path, in code, can be done in the next way:
Private Function CreatePathInTrLoc(ByVal sPath As String, ByVal sDescription As String, Optional boolReplace As Boolean) As Boolean
Const HKEY_CURRENT_USER = &H80000001, sAppExe As String = "excel.exe", sApp As String = "Excel"
Dim oRegistry As Object, sAppVer As String, sParentKey As String, bAlreadyExists As Boolean
Dim arrChildKeys As Variant, sChildKey As Variant, sValue As String, sNewKey As String
Dim iLocCounter As Long, strReplace As String, sExtPath As String
Set oRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
sAppVer = GetAppVersion(sAppExe)
sAppVer = left(sAppVer, InStr(sAppVer, ".") - 1) & "." & Mid(sAppVer, InStr(sAppVer, ".") + 1, 1)
sParentKey = "Software\Microsoft\Office\" & sAppVer & "\" & sApp & "\Security\Trusted Locations"
iLocCounter = 0
oRegistry.EnumKey HKEY_CURRENT_USER, sParentKey, arrChildKeys
For Each sChildKey In arrChildKeys
oRegistry.GetStringValue HKEY_CURRENT_USER, sParentKey & "\" & sChildKey, "Description", sValue
If sValue = sDescription Then
If boolReplace Then
oRegistry.GetStringValue HKEY_CURRENT_USER, sParentKey & "\" & sChildKey, "Path", sExtPath
If sExtPath <> sPath Then
oRegistry.DeleteKey HKEY_CURRENT_USER, sParentKey & "\" & sChildKey
strReplace = sChildKey
GoTo OverDeleteKey
Else
bAlreadyExists = True
CreatePathInTrLoc = True
End If
Else
bAlreadyExists = True
CreatePathInTrLoc = True
End If
End If
If CInt(Mid(sChildKey, 9)) > iLocCounter Then
iLocCounter = CInt(Mid(sChildKey, 9))
End If
Next
OverDeleteKey:
If Not bAlreadyExists Then
sNewKey = sParentKey & IIf(strReplace <> "", "\" & strReplace, "\Location" & CStr(iLocCounter + 1))
oRegistry.CreateKey HKEY_CURRENT_USER, sNewKey
oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Path", sPath
oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Description", sDescription
oRegistry.SetDWORDValue HKEY_CURRENT_USER, sNewKey, "AllowSubFolders", 1
CreatePathInTrLoc = True
Debug.Print "Path """ & sPath & """ added in Trusted Locations."
Else
Debug.Print "Path """ & sPath & """ already exists..."
End If
End Function
Private Function GetAppVersion(sAppExe As String) As String 'extract application version
Const HKEY_LOCAL_MACHINE = &H80000002
Dim oRegistry As Object, oFSO As Object, sKey As String, sValue As String
Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//./root/default:StdRegProv")
Set oFSO = CreateObject("Scripting.FileSystemObject")
sKey = "Software\Microsoft\Windows\CurrentVersion\App Paths"
oRegistry.GetStringValue HKEY_LOCAL_MACHINE, sKey & "\" & sAppExe, "", sValue
GetAppVersion = oFSO.GetFileVersion(sValue)
Set oFSO = Nothing: Set oRegistry = Nothing
End Function
The above solution can be tested as:
Sub testCreatePathInTrLoc()
Debug.Print CreatePathInTrLoc("C:\temp", "TestLocation")
End Sub
The called Sub needs as parameters: folder path to be added, Trusted location name/description and a Boolean Optional parameter if you want replacing an existing trusted location.
I want to save all attachments from a specific Outlook folder (MyFolder) to a desktop folder (Test). It seems to only work half of the time or not on all messages.
My first thought would be that the macro is quicker than Windows saving the files causing it to "skip" Outlook messages.
The code, partially from Ron de Bruin's website.
Option Explicit
Sub SaveAttachmentsFromMyFolder()
'Arg 1 = Folder name of folder inside your Inbox
'Arg 2 = File extension, "" is every file
'Arg 3 = Save folder, "C:\Users\Ron\test" or ""
' If you use "" it will create a date/time stamped folder for you in your "Documents" folder
' Note: If you use this "C:\Users\Ron\test" the folder must exist.
SaveEmailAttachmentsToFolder "MyFolder", "C:\Documents\Test"
End Sub
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, DestFolder As String)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
I = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
'Create DestFolder if DestFolder = ""
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(DestFolder) Then
fs.CreateFolder DestFolder
End If
If Right(DestFolder, 1) <> "\" Then
DestFolder = DestFolder & "\"
End If
' Check each message for attachments and extensions
' Check flagstatus
For Each Item In SubFolder.Items
If Item.FlagStatus = olFlagComplete Then
Item.Delete
' build in a wait till file actually deleted?
Else
For Each Atmt In Item.Attachments
' missing code: extract date from file name, check if folder exists and create if not, save attachment in date-folder
FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
Atmt.SaveAsFile FileName
' build in a wait till file actually saved?
I = I + 1
Next Atmt
Item.FlagStatus = olFlagComplete
Item.Save
' build in a wait till file actually saved?
End If
Next Item
' Show this message when Finished
If I > 0 Then
MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub
Here is code I use to save attachments from selected e-mails. You should be able to alter the For loop to loop through a folder instead easily enough.
Public Sub SaveAttachmentsSelectedEmails()
Dim olItem As Outlook.MailItem
Dim olSelection As Outlook.Selection: Set olSelection = ActiveExplorer.Selection
Dim FilePath As String: FilePath = Environ("USERPROFILE") & "\Documents\Documents\Attachments"
If Dir(FilePath, vbDirectory) = "" Then
Debug.Print "Save folder does not exist"
Exit Sub
End If
For Each olItem In olSelection
SaveAttachments olItem, FilePath, RemoveAttachments:=False
Next olItem
End Sub
Private Function SaveAttachments(ByVal Item As Object, FilePath As String, _
Optional Prefix As String = "", _
Optional FileExtensions As String = "*", _
Optional Delimiter As String = ",", _
Optional RemoveAttachments As Boolean = False, _
Optional OverwriteFiles As Boolean = False) As Boolean
On Error GoTo ExitFunction
Dim i As Long, j As Long, FileName As String, Flag As Boolean
Dim Extensions() As String: Extensions = Split(FileExtensions, Delimiter)
If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
For j = LBound(Extensions) To UBound(Extensions)
With Item.Attachments
If .Count > 0 Then
For i = .Count To 1 Step -1
FileName = FilePath & Prefix & .Item(i).FileName
Flag = IIf(LCase(Right(FileName, Len(Extensions(j)))) = LCase(Extensions(j)), True, False)
Flag = IIf(FileExtensions = "*" Or Flag = True, True, False)
If Flag = True Then
If Dir(FileName) = "" Or OverwriteFiles = True Then
.Item(i).SaveAsFile FileName
Else
Debug.Print FileName & " already exists"
Flag = False
End If
End If
If RemoveAttachments = True And Dir(FileName) <> "" And Flag = True Then .Item(i).Delete
Next i
End If
End With
Next j
SaveAttachments = True
ExitFunction:
End Function
I am working on macro that takes the path from clipboard, goes through each folder and subfolder in this path, opens xlsm file in finance subfolder and deletes KPI sheet. Below you can find the folder structure in my path:
P:\main folder\project folder\finance subfolder\
P:\main folder\project folder\brief subfolder\
P:\main folder\project folder\production subfolder\
P:\main folder\project folder\delivery subfolder\
P:\main folder\project folder\feedback subfolder\
Basically, I copy "P:\main folder\" and my macro goes through all project folders and all subfolders. I want to optimise this process and write a code that goes through all project folders in main folder but then goes only to finance subfolder and looks for xlsm files. I've tried to use the code that was posted here but it works only if I put "P:\main folder\project folder\" path not if I put "P:\main folder\" path.
As far as I see the reason is that my macro is looking for finance subfolder not in project folder but in main folder but this is only my guess. Below you can find the code:
Sub test_macro()
Dim oLibrary As Object
Dim srcFolder As Object
Dim folderName As String
Dim clipboard As MSForms.DataObject
Dim CopiedText As String
Set clipboard = New MSForms.DataObject
clipboard.GetFromClipboard
CopiedText = clipboard.GetText
folderName = CopiedText
If StrPtr(folderName) = 0 Then
Exit Sub
End If
Set oLibrary = CreateObject("Scripting.FileSystemObject")
Merge_Rows oLibrary.GetFolder(folderName)
End Sub
Sub Merge_Rows(srcFolder As Object)
Dim srcSubFolder As Object
Dim srcFile As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each srcSubFolder In srcFolder.SubFolders
If Split(srcSubFolder, "\")(UBound(Split(srcSubFolder, "\"))) = "1_FINANCE" Then '<-- my guess is that here is the problem but not sure how to fix it
Merge_Rows srcSubFolder
End If
Next
For Each srcFile In srcFolder.Files
If LCase(srcFile.Name) Like "*.xlsm" Then
Set wbkSource = Workbooks.Open(srcFile)
On Error Resume Next
Application.DisplayAlerts = False
wbkSource.Sheets("KPI").Delete
Application.DisplayAlerts = True
wbkSource.Close SaveChanges:=True
End If
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
How can I change a code so it goes through each project folder but then goes only to finance subfolder and omits others?
Here is my idea, but it is done for 2 level subfolder (if I understood the task properly):
Sub Merge_Rows()
Dim srcFolder As Object
Dim srcSubFolder As Object
Dim srcSubSubFolder As Object
Dim srcFile As Object
Dim oLibrary As Object
' This is my testing vars
Dim FolderName As String
FolderName = "P:\"
'''''''''
' will need it as I'm not passing the folder to sub
Set oLibrary = CreateObject("Scripting.FileSystemObject")
Set srcFolder = oLibrary.getfolder(FolderName)
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' added for testing purposes
Dim fileCounter As Long
Debug.Print "-----------------" & "Source folder: " & FolderName & "--------------------------------"
Debug.Print Chr(10)
For Each srcSubFolder In srcFolder.Subfolders ' going to subfolders
' print the level 1 subfolder name, which should be a project folder
For Each srcSubSubFolder In srcSubFolder.Subfolders ' going to sub-subfolder
' print the level 2 subfolder name, which should be a project folder subfolder
Debug.Print "----------- Current SubFolder is: " & FolderName & srcSubFolder.Name & "-----------------"
If UCase(srcSubSubFolder.Name) Like "*FINANCE*" Then '<--!! put proper pattern
' go through it at once
For Each srcFile In srcSubSubFolder.Files
Debug.Print "----------------- Current SubSubFolder is: " & FolderName & srcSubFolder.Name & "\" & srcSubSubFolder.Name & "---------------------"
If LCase(srcFile.Name) Like "*.xlsm" Then
Debug.Print srcFile.Name
fileCounter = fileCounter + 1
' Your code here
End If
Next
End If
If Not fileCounter = 0 Then
Debug.Print "There were " & fileCounter & " .xlsm files in " & FolderName & srcSubFolder.Name & "\" & srcSubSubFolder.Name
fileCounter = 0
Else
Debug.Print "The search of .xlsm files in " & FolderName & srcSubFolder.Name & "\" & srcSubSubFolder.Name & " was not performed"
End If
Debug.Print "-----------------" & "End of current SubSubFolder: " & FolderName & srcSubFolder.Name & "\" & srcSubSubFolder.Name & "---------------------"
Next
Debug.Print "-----------------" & "End current SubFolder: " & FolderName & srcSubFolder.Name & "---------------------"
Debug.Print Chr(10) & Chr(10)
Next
Debug.Print "<-----------------" & "End Source Folder" & "--------------------->"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
And it looks like this
If it fits - you need to fix it for your solution, it's just a thoughts :)
Update per OPs comment
I've updated code with some more Debug.Print lines
Here the file tree that I've created for testing:
Each folder has a "Book3.xlsm" file in it.
Here is the result of the updated script:
Try to run at least one iteration of project folder and check the immediate window.
I have large number of .csv files in a folder and each file has few separation codes in them. Separation code usually will be 5 digit code eg: B82A6.
I have to copy files with a certain separation code and move them to a destination folder.
I am new to VBA. I've been searching for code to modify it to my use.
Sub Test()
Dim R As Range, r1 As Range
Dim SourcePath As String, DestPath As String, SeperationCode As String
SourcePath = "C:\Users\hr315e\Downloads\Nov_03_2019\"
DestPath = "C:\Users\hr315e\Downloads\Target\"
Set r1 = Range("A1", Range("A" & Rows.Count).End(xlUp))
For Each R In r1
SeperationCode = Dir(SourcePath & R)
Do While SeperationCode <> ""
If Application.CountIf(r1, SeperationCode) Then
FileCopy SourcePath & SeperationCode, DestPath & SeperationCode
R.Offset(0, 1).Value = SeperationCode
Else
MsgBox "Bad file: " & SeperationCode & " ==>" & SeperationCode & "<== "
End If
SeperationCode = Dir(SourcePath & "B82A6" & R.Value & "B82A6")
Loop
Next
End Sub
So, here's the code that should work for you.
As you can see, this is a version of code which I linked to you with small updates:
Sub GoThroughFilesAndCopy()
Dim BrowseFolder As String, DestinationFolder As String
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim TempFileName As String
Dim CheckCode As String
Application.ScreenUpdating = False
' selecting the folder with files
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder with files"
.Show
On Error Resume Next
Err.Clear
BrowseFolder = .SelectedItems(1)
If Err.Number <> 0 Then
MsgBox "You didn't select anything!"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
End With
' or you may hardcode it (data from your post):
'BrowseFolder = "C:\Users\hr315e\Downloads\Nov_03_2019\"
' selecting the destination folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the the destination folder"
.Show
On Error Resume Next
Err.Clear
DestinationFolder = .SelectedItems(1)
If Err.Number <> 0 Then
MsgBox "You didn't select anything!"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
End With
' or you may hardcode it (data from your post):
'DestinationFolder = "C:\Users\hr315e\Downloads\Target\"
CheckCode = "Some string" ' this is you check code
Set FSO = CreateObject("Scripting.FileSystemObject") ' creating filesystem object
Set oFolder = FSO.getfolder(BrowseFolder) ' creating folder object
For Each FileItem In oFolder.Files 'looking through each file in selected forlder
TempFileName = ""
If UCase(FileItem.Name) Like "*.CSV*" Then 'try opening only .csv files
TempFileName = BrowseFolder & Application.PathSeparator & FileItem.Name ' getting the full name of the file (with full path)
If CheckTheFile(TempFileName, CheckCode) Then ' if the file passes the checking function
If Dir(DestinationFolder & Application.PathSeparator & FileItem.Name) = "" Then 'if the file doesn't exist in destination folder
FileCopy Source:=TempFileName, Destination:=DestinationFolder & Application.PathSeparator & FileItem.Name ' it is copied to destination
Else ' otherwise, there are to options how to deal with it further
'uncomment the part you need below:
' this will Overwrite existing file
'FSO.CopyFile Source:=TempFileName, Destination:=DestinationFolder & Application.PathSeparator & FileItem.Name
' this will get new name for file and save it as copy
'FileCopy Source:=TempFileName, Destination:=GetNewDestinationName(FileItem.Name, DestinationFolder)
End If
End If
End If
Next
Application.ScreenUpdating = True
End Sub
'////////////////////////////////////////////////////////////////////////
Function CheckTheFile(File As String, Check As String) As Boolean
Dim TestLine As String
Dim TestCondition As String
TestCondition = "*" & Check & "*" ' this is needed to look for specific text in the file, refer to Like operator fro details
CheckTheFile = False
Open File For Input As #1 ' open file to read it line by line
Do While Not EOF(1)
Line Input #1, TestLine ' put each line of the text to variable to be able to check it
If TestLine Like TestCondition Then ' if the line meets the condition
CheckTheFile = True ' then function gets True value, no need to check other lines as main condition is met
Close #1 ' don't forget to close the file, beacuse it will be still opened in background
Exit Function ' exit the loop and function
End If
Loop
Close #1 ' if condiotion is not found in file just close the file, beacuse it will be still opened in background
End Function
'////////////////////////////////////////////////////////////////////////
Function GetNewDestinationName(File As String, Destination As String) As String
Dim i As Integer: i = 1
Do Until Dir(Destination & Application.PathSeparator & "Copy (" & i & ") " & File) = "" ' if Dir(FilePath) returns "" (empty string) it means that the file does not exists, so can save new file with this name
i = i + 1 ' incrementing counter untill get a unique name
Loop
GetNewDestinationName = Destination & Application.PathSeparator & "Copy (" & i & ") " & File ' return new file name
End Function
Basically, there is one sub, which is mostly copy-paste from linked topic, and two simple functions.
Trying to use the DIR function in a Macro to determine whether a folder exists. Have found the following code
Function FileOrFolderExistsOnMac(FileOrFolderstr As String) As Boolean
Ron de Bruin : 1-Feb-2019
Function to test whether a file or folder exist on a Mac in office 2011 and up
'Uses AppleScript to avoid the problem with long names in Office 2011,
'limit is max 32 characters including the extension in 2011.
Dim ScriptToCheckFileFolder As String
Dim TestStr As String
If Val(Application.Version) < 15 Then
ScriptToCheckFileFolder = "tell application " & Chr(34) & "System Events" & Chr(34) & _
"to return exists disk item (" & Chr(34) & FileOrFolderstr & Chr(34) & " as string)"
FileOrFolderExistsOnMac = MacScript(ScriptToCheckFileFolder)
Else
On Error Resume Next
TestStr = Dir(FileOrFolderstr & "*", vbDirectory)
On Error GoTo 0
If Not TestStr = vbNullString Then FileOrFolderExistsOnMac = True
End If
End Function
from
https://www.rondebruin.nl/win/s9/win003.htm
However, when the folder in the path location is empty, the function determines that the path directory does not exist.
Thank you for the post, it helped me identify the source of my problem.
I modified my often-used function to account for this quirk.
Here's a modified function that should work for empty folders (works on Windows, not tested on Macs).
Function directoryExists(ByVal dirPath As String) As Boolean
'amy#logicallytech.com
'7/15/2022
directoryExists = (Dir(dirPath) <> "")
If directoryExists Then Exit Function
'If folder is empty, above will show it does not exist, so just to confirm...
Dim strParentFolder As String
Dim strSubFolder As String
Dim myfso As Object
Dim parentFolder As Object
Dim subFolder As Object
If InStr(dirPath, "\") > 0 Then
If Right(dirPath, 1) = "\" Then dirPath = Left(dirPath, Len(dirPath) - 1)
strParentFolder = Left(dirPath, InStrRev(dirPath, "\", , vbTextCompare))
strSubFolder = Right(dirPath, Len(dirPath) - InStrRev(dirPath, "\", , vbTextCompare))
ElseIf InStr(dirPath, "/") > 0 Then
If Right(dirPath, 1) = "/" Then dirPath = Left(dirPath, Len(dirPath) - 1)
strParentFolder = Left(dirPath, InStrRev(dirPath, "/", , vbTextCompare))
strSubFolder = Right(dirPath, Len(dirPath) - InStrRev(dirPath, "/", , vbTextCompare))
End If
Set myfso = CreateObject("Scripting.FileSystemObject")
Set parentFolder = myfso.GetFolder(strParentFolder)
For Each subFolder In parentFolder.SubFolders
If LCase(Trim(subFolder.Name)) = LCase(Trim(strSubFolder)) Then
directoryExists = True
GoTo CleanUp
End If
Next subFolder
CleanUp:
Set subFolder = Nothing
Set parentFolder = Nothing
Set myfso = Nothing
End Function