-
Feb 21st, 2018, 03:23 AM
#1
Thread Starter
Lively Member
Remove special characters from folder file path by VBA
Hi Everyone,
I have a large amount of folder with sub folders, the folder name contains some special characters (@,#,%,_,-) Like that.
I have to find the folder by Main folder name,then replace it with alphabets for all sub folders
for example
& - AND
#- NUMBER
%-PERCENTAGE
Is that possible to do with VBA on excel, when i select the file path this will replace all the special characters with alphabet (name of the special characters).
Please anyone help me on this.
Thanks in advance
-
Feb 21st, 2018, 12:11 PM
#2
Re: Remove special characters from folder file path by VBA
You can try getting the folder names using Dir and then renaming them after substituting the characters with words to create the new name.
Possibly useful links:
https://msdn.microsoft.com/en-us/vba...s/dir-function
http://www.vbforums.com/showthread.p...ough-excel-vba
-
Feb 21st, 2018, 03:23 PM
#3
Re: Remove special characters from folder file path by VBA
you can try like
Code:
Dim afind, areplace
afind = Array("@", "#", "%", "_")
areplace = Array("AT", "NUMBER", "PERCENT", "UNDERSCORE")
mypath = "c:\temp\aqw\a@dd%ff#"
newpath = mypath
For I = 0 To UBound(afind)
newpath = Replace(newpath, afind(I), areplace(I))
Next
Name mypath As newpath
add any additional characters to be replaced into the arrays
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Feb 21st, 2018, 05:34 PM
#4
New Member
Re: Remove special characters from folder file path by VBA
Hello gmmdinesh,
Here is another way that will let you choose the parent folder and set the depth of the Subfolders to be searched. I have set the macro (CleanFolderPaths) to search all folders and subfolders under the chosen parent.
Copy and paste this code into a new VBA Module in your workbook.
Code:
Global NewPath As String
Global oShell As Object
Global SpecChars As Variant
Function RenameFolders(ByVal FolderPath As Variant, Optional ByVal SubfolderDepth As Long)
Dim Folder As Object
Dim n As Long
Dim Subfolder As Object
Dim Subfolders As Object
If oShell Is Nothing Then
Set oShell = CreateObject("Shell.Application")
End If
Set Folder = oShell.Namespace(FolderPath)
NewPath = Folder.Self.Path
For n = 1 To UBound(SpecChars, 1)
NewPath = Replace(NewPath, SpecChars(n, 1), SpecChars(n, 2))
Next n
Name Folder.Self.Path As NewPath
Set Subfolders = Folder.Items
Subfolders.Filter 32, "*"
If SubfolderDepth <> 0 Then
For Each Subfolder In Subfolders
Call RenameFolders(Subfolder, SubfolderDepth - 1)
Next Subfolder
End If
End Function
Sub CleanFolderPaths()
Dim FolderPath As Variant
With Application.FileDialog(msoFileDialogFolderPicker)
.Filters.Clear
If .Show Then FolderPath = .SelectedItems(1) Else Exit Sub
End With
ReDim SpecChars(1 To 4, 1 To 2)
' Special Characters and replacement strings.
SpecChars(1, 1) = "&": SpecChars(1, 2) = "And"
SpecChars(2, 1) = "%": SpecChars(2, 2) = "Percentage"
SpecChars(3, 1) = "#": SpecChars(3, 2) = "Number"
SpecChars(4, 1) = "@": SpecChars(4, 2) = "At"
' -1 = Clean all folders, subfolders, and subfolders of subfolders.
' 0 = The parent folder only
' 1 = Subfolders of the parent
' 2 = Subfolders of the subfolders of the parent.
' 3 = Subfolders of subfolders of subfolders of the parent, etc.
Call RenameFolders(FolderPath, -1)
End Sub
-
Feb 22nd, 2018, 03:10 AM
#5
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
Thank you so much for provide the Links,
@ westconn, Leith ross, your code is working perfectly, Thank you so much for your Time.
I have a Workbook with list of parent folder name with A column, I need to select the row and run this macro, it will automatically getting the folder name from A column cell and find the folder from Directory, then replace the all sub folder name on the path.
Thank again.
-
Feb 22nd, 2018, 12:32 PM
#6
New Member
Re: Remove special characters from folder file path by VBA
Hello
Thanks for the feedback. I have modified the macro to look at "A1" down to the last entry in the column. If the column is empty then the macro simply exits with no message.
Replace the code you have with this code. Call "CleanFolderPaths" either by using the Macro Dialog (Alt+F8) or add a button to the worksheet to call the macro.
Code:
' Thread: http://www.vbforums.com/showthread.php?859343-Remove-special-characters-from-folder-file-path-by-VBA
' Poster: gmmdinesh
Public NewPath As String
Public oShell As Object
Public SpecChars As Variant
Function RenameFolders(ByVal FolderPath As Variant, Optional ByVal SubfolderDepth As Long)
Dim Folder As Object
Dim n As Long
Dim Subfolder As Object
Dim Subfolders As Object
If oShell Is Nothing Then
Set oShell = CreateObject("Shell.Application")
End If
Set Folder = oShell.Namespace(FolderPath)
NewPath = Folder.Self.Path
For n = 1 To UBound(SpecChars, 1)
NewPath = Replace(NewPath, SpecChars(n, 1), SpecChars(n, 2))
Next n
Name Folder.Self.Path As NewPath
Set Subfolders = Folder.Items
Subfolders.Filter 32, "*"
If SubfolderDepth <> 0 Then
For Each Subfolder In Subfolders
Call RenameFolders(Subfolder, SubfolderDepth - 1)
Next Subfolder
End If
End Function
Sub CleanFolderPaths()
Dim Cell As Range
Dim FolderPath As Variant
Dim Rng As Range
Dim RngBeg As Range
Dim RngEnd As Range
Dim Wks As Worksheet
Set Wks = ActiveSheet
Set RngBeg = Wks.Range("A1")
Set RngEnd = Wks.Cells(Rows.Count, "A").End(xlUp)
ReDim SpecChars(1 To 4, 1 To 2)
' Special Characters and replacement strings.
SpecChars(1, 1) = "&": SpecChars(1, 2) = "And"
SpecChars(2, 1) = "%": SpecChars(2, 2) = "Percentage"
SpecChars(3, 1) = "#": SpecChars(3, 2) = "Number"
SpecChars(4, 1) = "@": SpecChars(4, 2) = "At"
' -1 = Clean all folders, subfolders, and subfolders of subfolders.
' 0 = The parent folder only
' 1 = Subfolders of the parent
' 2 = Subfolders of the subfolders of the parent.
' 3 = Subfolders of subfolders of subfolders of the parent, etc.
If RngEnd.Row < RngBeg.Row Then
Exit Sub
Else
Set Rng = Wks.Range(RngBeg, RngEnd)
End If
For Each Cell In Rng
Call RenameFolders(Cell.Value, -1)
Next Cell
End Sub
-
Feb 25th, 2018, 11:48 PM
#7
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
Hello Leith Ross
Sorry for the delay and Thanks for your Code,
I have checked your code and I got a Debug Error as below.
I have a work book with folder names on A Column and attached the same, and the folder located on E drive. Please look that the attached Workbook.
Book.zip
Thanks again.
-
Feb 26th, 2018, 04:36 AM
#8
Re: Remove special characters from folder file path by VBA
folderpath needs to b the full path of the folder, not just the folder name
as your workbook only contains the folder name, you need to append the path to the parent folder within the code
something like
Code:
mypath = "c:\temp\" 'change to suit
For Each Cell In Rng
Call RenameFolders(mypath & Cell.Value, -1)
Next Cell
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Feb 26th, 2018, 11:09 PM
#9
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
folderpath needs to b the full path of the folder
Yes these listed folders are placed on E:\Temp\ Path, but i don't know, where i have to put the path in VBA,
mypath = "c:\temp\" 'change to suit
For Each Cell In Rng
Call RenameFolders(mypath & Cell.Value, -1)
Next Cell
Where i have to paste this code.?
Please help me ..
-
Feb 27th, 2018, 04:03 AM
#10
Re: Remove special characters from folder file path by VBA
Where i have to paste this code.?
it was just a small edit to the existing code, only one line added and one slightly changed
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Mar 7th, 2018, 03:18 PM
#11
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
Hi Westconn
I got a "Type Mismatch" Error on this Line
-
Mar 8th, 2018, 02:26 AM
#12
Re: Remove special characters from folder file path by VBA
post the entire code, or better post the workbook, zip first
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Mar 8th, 2018, 05:04 PM
#13
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
This is the code i have used,
Code:
Sub Test()
Dim afind, areplace
afind = Array("@", "#", "%", "_")
areplace = Array("AT", "NUMBER", "PERCENT", "UNDERSCORE")
mypath = "c:\temp\" 'change to suit
For Each Cell In Rng
Call RenameFolders(mypath & Cell.Value, -1)
Next Cell
NewPath = mypath
For I = 0 To UBound(afind)
NewPath = Replace(NewPath, afind(I), areplace(I))
Next
Name mypath As NewPath
End Sub
-
Mar 9th, 2018, 02:04 AM
#14
Re: Remove special characters from folder file path by VBA
maybe post #10 was misleading, the small change was to the code in post #6, not the code sample i posted previously
try like
Code:
Sub Test()
Dim afind, areplace
afind = Array("@", "#", "%", "_")
areplace = Array("AT", "NUMBER", "PERCENT", "UNDERSCORE")
mypath = "c:\temp\" 'change to suit
For Each Cell In range("a:a")
if isempty(cell) then exit for ' finish on first empty cell, or change range to suit
NewPath = mypath & cell
For I = 0 To UBound(afind)
NewPath = Replace(NewPath, afind(I), areplace(I))
Next
Name mypath & cell As NewPath
Next Cell
End Sub
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Mar 10th, 2018, 02:19 PM
#15
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
Hi Westconn
Sorry for the misunderstanding, I have tested both the codes as you posted, but i got error on it.
Please look the attached file.
Test.zip
-
Mar 10th, 2018, 06:01 PM
#16
Re: Remove special characters from folder file path by VBA
as this sample demonstrates that the full path is in the cell
try like
Code:
Sub Test()
Dim afind, areplace
afind = Array("@", "#", "%", "_")
areplace = Array("AT", "NUMBER", "PERCENT", "UNDERSCORE")
'mypath = "c:\temp\" 'not required
For Each Cell In range("a:a")
if isempty(cell) then exit for ' finish on first empty cell, or change range to suit
NewPath = cell
For I = 0 To UBound(afind)
NewPath = Replace(NewPath, afind(I), areplace(I))
Next
Name cell As NewPath
Next Cell
End Sub
this should rename all the folders in column A of the worksheet
remember once the code has been run the folder name, as in the cell, no longer exists, no error would occur until the name statement
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Mar 11th, 2018, 05:42 PM
#17
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
Hi Westconn
I got a "File not found Error" on this line , even i have a correct folder names and path as mentioned in A column.
-
Mar 11th, 2018, 10:24 PM
#18
Re: Remove special characters from folder file path by VBA
as i said above,
if you run the code once, all the folders would be renamed, on any subsequent runs of the code you would get that error as the folders would no longer exist in the file system, even though they would still be in your workbook
to avoid the error, you could call DIR to ensure that the folder exists, before trying to rename it
ideally you would possibly remove the folders from the workbook as they are successfully renamed
if the error is happening for any other reason i can not really see why
Code:
Dim afind, areplace
afind = Array("@", "#", "%", "_")
areplace = Array("AT", "NUMBER", "PERCENT", "UNDERSCORE")
'mypath = "e:\temp\" 'change to suit
For Each Cell In Range("a:a")
If IsEmpty(Cell) Then Exit For ' finish on first empty cell, or change range to suit
If Len(Dir(Cell, vbDirectory)) > 0 Then ' directory exists in filesystem, else no need
NewPath = Cell
For I = 0 To UBound(afind)
NewPath = Replace(NewPath, afind(I), areplace(I))
Next
Name Cell As NewPath
End If
Next Cell
while this will prevent any error it may be wasting some time with a list of invalid folders
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Mar 13th, 2018, 10:16 AM
#19
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
Hey I got same error again..I don't know why the error is coming.
I did call DIR it shows path exist, but VBA not changed the path.
Anyway Thanks for your effort, Much Appreciated.
Thanks again.
-
Mar 14th, 2018, 02:54 AM
#20
Re: Remove special characters from folder file path by VBA
i did do a test when i posted the original code sample, after creating a folder with a name containing some of the special characters the folder was renamed appropriately, it would appear that the problem is that you path has multiple level or folders to be renamed
you can only rename one folder at a time, not all the folders in a path, so, for your sample, you would need to rename the last folder and the parent in separate calls, the code posted in post #6 would do that recursively, but that might not be best suited for your requirement, you can try like
Code:
Dim afind, areplace
afind = Array("@", "#", "%", "_")
areplace = Array("AT", "NUMBER", "PERCENT", "UNDERSCORE")
For Each cell In Range("a:a")
If IsEmpty(cell) Then Exit For ' finish on first empty cell, or change range to suit
If Len(Dir(cell, vbDirectory)) = 0 Then
MsgBox "folder in row " & cell.Row & " is not a valid path"
Else
newpath = cell
farray = Split(cell, "\")
oldpath = farray(0)
For f = 1 To UBound(farray)
newpath = oldpath
oldpath = oldpath & "\" & farray(f)
tmp = farray(f)
For I = 0 To UBound(afind)
tmp = Replace(tmp, afind(I), areplace(I))
Next
newpath = newpath & "\" & tmp
If Not newpath = oldpath Then Name oldpath As newpath
Next
End If
Next cell
i have not tested this as the need to create multiple folders with ugly names just to test seemed a bit excessive
Last edited by westconn1; Mar 14th, 2018 at 03:25 AM.
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Mar 14th, 2018, 09:32 AM
#21
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
Yes, You are correct westconn, we can rename only one folder at a time.
This was worked when i placed the path upto one folder,
Thank you so much.
-
Mar 14th, 2018, 03:29 PM
#22
Re: Remove special characters from folder file path by VBA
when i was in bed i realized there were some errors in the code as posted
if there is more than one subfolder in a folder that needs to be renamed, that folder would be renamed the first time so dir would fail on any calls to that renamed folder
newpath = oldpath, should in fact have been
Code:
Dim afind, areplace
afind = Array("@", "#", "%", "_")
areplace = Array("AT", "NUMBER", "PERCENT", "UNDERSCORE")
For Each cell In Range("a:a")
If IsEmpty(cell) Then Exit For ' finish on first empty cell, or change range to suit
farray = Split(cell, "\")
newpath = farray(0)
For f = 1 To UBound(farray)
oldpath = newpath
oldpath = oldpath & "\" & farray(f)
tmp = farray(f)
For I = 0 To UBound(afind)
tmp = Replace(tmp, afind(I), areplace(I))
Next
newpath = newpath & "\" & tmp
If Len(Dir(oldpath, vbDirectory)) And Not newpath = oldpath Then Name oldpath As newpath
Next
If Not Len(Dir(newpath, vbDirectory)) Then MsgBox "path in " & cell.Address & " not changed"
Next cell
tested with one folder with subfolder only
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Mar 15th, 2018, 05:01 AM
#23
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
I got the File/Path Access Error on this
Then Name oldpath As newpath
code.
-
Mar 15th, 2018, 05:14 AM
#24
Re: Remove special characters from folder file path by VBA
If Len(Dir(oldpath, vbDirectory)) And Not newpath = oldpath Then Name oldpath As newpath
as it checks that oldpath is a valid folder i do not understand why it should fail
check the values of the 2 variables and post them for comparison
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Mar 17th, 2018, 11:03 AM
#25
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
Hey Westconn
Can you please tell me,Which 2 variables i have to check.
-
Mar 17th, 2018, 04:40 PM
#26
Re: Remove special characters from folder file path by VBA
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Mar 18th, 2018, 09:41 AM
#27
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
Hello Westconn
I have tested again the code you posted on post #22. now it's working perfectly.
I have placed full path in A1 and A2 cell, (A1 Cell Path: E:\temp\123456\a@ujhguy\a@v%bv\@#%
A2 Cell Path: E:\temp\a@ss\a#k@m_d\@#_%)
VBA replaced symbols in full path for which i placed in A1 Cell, but A2 Cell path not changed and i got same error File/Path access error again. while trying to change A2 Cell Path.
Thanks.
-
Mar 18th, 2018, 03:25 PM
#28
Re: Remove special characters from folder file path by VBA
no idea!!
i ran some test, i got the same error on the first level folder rename
i was able to rename the folder to someother name then rename it to newpath, back to oldpath then it would rename from to newpath without error
the 2nd and 3rd level renames both worked ok first time
some error handling may be able to fix the problem you have, by doing some of the above steps, but that would be trial and error, and that or similar errors may require different methods on in different circumstances, another possibility that may work would be to try FSO to rename the folder
the code samples posted do not contain any error handling, including checking to see if newpath already exists, or any invalid characters in the file path, despite the effort i put i to make sure that any folder should be renamed, any other error could occur, like the current one
one small edit required in the code, change to
Code:
If Not Len(Dir(newpath, vbDirectory)) > 0 Then MsgBox "path in " & cell.Address & " not changed"
else the message box is likely to show even when the folder is successfully renamed
Last edited by westconn1; Mar 18th, 2018 at 03:41 PM.
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Mar 21st, 2018, 11:30 AM
#29
Thread Starter
Lively Member
Re: Remove special characters from folder file path by VBA
Hi Westconn
Thank you so much for your help.
Now it's working perfectly.
I have placed two different path in A1 and A2 cell, code was replaced special character in both the path.
Thank you so much
-
Mar 21st, 2018, 01:24 PM
#30
Re: Remove special characters from folder file path by VBA
Ah, already solved?
Damn, i wanted to take a "Hardcore"-Stab at it, consisting of 6 Windows-API-Functions
Last edited by Zvoni; Tomorrow at 31:69 PM.
----------------------------------------------------------------------------------------
One System to rule them all, One Code to find them,
One IDE to bring them all, and to the Framework bind them,
in the Land of Redmond, where the Windows lie
---------------------------------------------------------------------------------
People call me crazy because i'm jumping out of perfectly fine airplanes.
---------------------------------------------------------------------------------
Code is like a joke: If you have to explain it, it's bad
-
Mar 21st, 2018, 03:38 PM
#31
Re: Remove special characters from folder file path by VBA
Damn, i wanted to take a "Hardcore"-Stab at it
go for it i would like to see a better solution
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Mar 22nd, 2018, 08:34 AM
#32
Re: Remove special characters from folder file path by VBA
Here we go.
My "Hardcore"-Stab at it
For those of you interested:
"201 Folders of & 201 Folders renamed in 3,198 seconds"
was my result on a 8 year old machine
EDIT: I'm an Idiot.
strCSpn is doing exactly what it's supposed to do. There is no strange Behaviour.
After rereading the Description of the Function it hit me like a Ton of Bricks.
strCSpn doesn't return the Position of the first occurence of the character(s) i'm looking for.
It returns the number of characters READ BEFORE the occurence.
So it's correct, that i have to add +1 to the result to get the position (or change arrReplace to a zero-based array).
It would probably explain why i'm having so much trouble with a project i'm working on.... *GNARF*
vb Code:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Function StrCSpn Lib "SHLWAPI" Alias "StrCSpnW" (ByVal lpStr As Long, ByVal lpSet As Long) As Long Private Declare Function GetTickCount Lib "kernel32" () As Long Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long '###### Declares for SHFileOperation Const FO_COPY = &H2 Const FO_DELETE = &H3 Const FO_MOVE = &H1 Const FO_RENAME = &H4 Const FOF_ALLOWUNDO = &H40 Const FOF_SILENT = &H4 Const FOF_NOCONFIRMATION = &H10 Const FOF_RENAMEONCOLLISION = &H8 Const FOF_NOCONFIRMMKDIR = &H200 Const FOF_FILESONLY = &H80 Private Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAborted As Boolean hNameMaps As Long sProgress As String End Type '####### Declares for FindFirst, FindNext, FindClose Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Const MAX_PATH As Long = 259& Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20& Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800& Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10& Const FILE_ATTRIBUTE_HIDDEN As Long = &H2& Const FILE_ATTRIBUTE_NORMAL As Long = &H80& Const FILE_ATTRIBUTE_READONLY As Long = &H1& Const FILE_ATTRIBUTE_SYSTEM As Long = &H4& Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100& Const PATH_DEL As String = "\" Private SHFileOp As SHFILEOPSTRUCT Private lngTime As Double Private EndTime As Double Private FD As WIN32_FIND_DATA Private CountFolders As Long Private CountRenamed As Long Private IllegalChars As String Private arrReplace(1 To 10) As String Private colFolders() As String Sub main() Dim i As Long Dim Levels As Long Dim arrFolders() As String Dim StartFolder As String 'Setup initial conditions 'Order of IllegalChars and Array arrReplace must be the same IllegalChars = "#-~()[]&$ยง" arrReplace(1) = "HASH" arrReplace(2) = "MINUS" arrReplace(3) = "TILDE" arrReplace(4) = "POPEN" arrReplace(5) = "PCLOSE" arrReplace(6) = "BOPEN" arrReplace(7) = "BCLOSE" arrReplace(8) = "AND" arrReplace(9) = "DOLLAR" arrReplace(10) = "PARA" StartFolder = "C:\Temp\TestFolder" 'Setting Attributes FD.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY SHFileOp.wFunc = FO_RENAME SHFileOp.fFlags = FOF_SILENT + FOF_NOCONFIRMATION 'Start Time lngTime = GetTickCount CountRenamed = 0 Levels = UBound(Split(StartFolder, "\")) ReDim colFolders(1 To 2, 1 To 1) CountFolders = CollectFolders(StartFolder) i = RenameFolder(colFolders, Levels) 'Ending Timecount EndTime = (GetTickCount - lngTime) / 1000 Debug.Print CountRenamed & " Folders of & " & CountFolders & " Folders renamed in " & EndTime & " seconds" End Sub Private Function CollectFolders(ByVal FolderName As String) As Long Dim i As Long Dim File As String Dim hFile As Long Static CountFound As Long hFile = FindFirstFile(FolderName & PATH_DEL & "*.", FD) Do File = Left(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1) If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then If File <> "." And File <> ".." Then 'Recursive call to CollectFolders before collecting the PathName 'That way it collects it backwards, from the "deepest" Level back i = CollectFolders(FolderName & PATH_DEL & File) CountFound = CountFound + 1 ReDim Preserve colFolders(1 To 2, 1 To CountFound) colFolders(1, CountFound) = FolderName & PATH_DEL & File colFolders(2, CountFound) = FolderName & PATH_DEL & File End If End If Loop While FindNextFile(hFile, FD) FindClose (hFile) CollectFolders = CountFound End Function Private Function RenameFolder(colFolders As Variant, ByVal Levels As Long) As Long Dim ch As Integer Dim i As Long Dim j As Long Dim x As Long Dim NewFile As String Dim pIllegal As Long Dim pFile As Long Dim ErrorCode As Long Dim arrFolders() As String Dim CurLevel As Long For i = 1 To UBound(colFolders, 2) 'Split the complete path in its Elements (==> FolderNames per Level) arrFolders = Split(colFolders(1, i), "\") 'We only change the FolderName in the Topmost Level of our Collection-Element CurLevel = UBound(arrFolders) NewFile = arrFolders(CurLevel) 'Just for checking if we're still inside the correct Level 'e.g. our Startfolder "c:\Temp\TestFolder" is 2 Levels deep If CurLevel - Levels > 0 Then Do 'Get Pointers to String "IllegalChars" and the FolderName pIllegal = StrPtr(IllegalChars) pFile = StrPtr(NewFile) 'Scans pFile for the first occurrence of any of the characters that are part of pIllegal, 'returning the number of characters of pFile read before this first occurrence. j = StrCSpn(pFile, pIllegal) If j < Len(NewFile) Then 'Cutting out the illegal Character from the FileName CopyMemory ch, ByVal pFile + 2 * j, 2 'Now looking the other way round 'Scans the IllegalChars for the first occurence of our illegal character 'STRANGE BEHAVIOUR: I have to add 1 to the result! No Idea why j = StrCSpn(pIllegal, StrPtr(Chr(ch))) + 1 If j < Len(IllegalChars) Then 'Using the Result of our second StrCSpn-Call (Remember: +1) as the Index of our Replacement-Array NewFile = Replace(NewFile, Chr(ch), arrReplace(j)) End If End If Loop Until j > Len(IllegalChars) 'Assign new Filename back to our temp. array arrFolders(CurLevel) = NewFile 'Construct the new Path NewFile = Join(arrFolders, "\") 'Back into array colFolders(2, i) = NewFile End If Next For i = 1 To UBound(colFolders, 2) SHFileOp.pFrom = colFolders(1, i) SHFileOp.pTo = colFolders(2, i) ErrorCode = SHFileOperation(SHFileOp) If Not ErrorCode Then CountRenamed = CountRenamed + 1 Next End Function
Last edited by Zvoni; Mar 29th, 2018 at 02:57 PM.
Last edited by Zvoni; Tomorrow at 31:69 PM.
----------------------------------------------------------------------------------------
One System to rule them all, One Code to find them,
One IDE to bring them all, and to the Framework bind them,
in the Land of Redmond, where the Windows lie
---------------------------------------------------------------------------------
People call me crazy because i'm jumping out of perfectly fine airplanes.
---------------------------------------------------------------------------------
Code is like a joke: If you have to explain it, it's bad
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|