How can I programmatically rename a Windows folder containing illegal characters? - vba

I would like to programmatically rename a Windows folder containing one or more illegal Windows characters using VBA. (The folder tree comes from a Mac/Linux environment).
The illegal character shows as a . in Windows/File Explorer, which can manipulate the folder OK.
Methods I have tried unsuccessfully include using the FileSystem Object and the VBA Name command.
Getting the actual name of the folder with the illegal char is the problem.
Doing dir /X shows the short (8.3 format) name of the folder but the full name appears in the command window with ? replacing the illegal char.
Supplying this name with the ? to various routines for folder operations (e.g. FileSystemObject GetFolder, VB Name function, GetShortName) results in the operation not finding the file to operate on.
Running Dir /X > Foldernames.txt produces an ASCII file which shows a ? replacing the illegal char, but examining the file in a binary editor (Frhed) shows 3 bytes for the illegal character in the full folder name. These are Chr(239), Chr(128) and Chr(162). Using this string to replace the illegal char the folder name still results in folder not found behaviour.
Using the actual illegal value (Chr (149))in the folder name also results in folder not found behaviour.
A short file name (8.3 format ) is shown in the Dir /X output and the folder can be accessed via this name. However, I can't see how to distinguish between short names for folders with different illegal chars in the same position, and shortname generation only occurs when the folder exists, so unless I can access the foldername with the illegal char directly it's not much help.
There is a unicode symbol for a placeholder (UxFFFD) which shows as a question mark in a black diamond which I have seen occasionally but not in in any Dir /X listings.

I suggest doing this via a batch-job.
Get the actual name of the file via a list.
You could use a batch like this:
dir "F:\batchs" > "F:\batchs\list.txt"
exit
If you found out the name copy it and replace "'inserthere'" in this code:
ren '_inserthere_' newname.txt
exit
and then run this as a batch job again. This might do the job.

I have found a very laborious way of accessing files and folders with illegal characters in them via their short (8.3) format names. Generating a short name from a path which does not exist is not possible - as the algorithm for generating short names is apparently subject to change and I could not find a reverse-engineer of it.
The only way to get the short name is to do a Dir /X listing for the folder with illegal char or containing a file name with an illegal char and send it to file, which can then be parsed. The long name of the file or folder in the file sometimes includes the illegal character (if it is a ?, which is commonest) so that can be searched for. VBA code for dealing with folders is below. Once the short name of the folder with the illegal char is found it can be easily renamed and returned as a ByRef parameter.
' Procedure : LegalPath
' Author : Simon
' Date : 11/12/2017
' Purpose : returns true if all path chars are legal and changes illegals to _ in sLegalPath if not
Public Function LegalPath(ByVal sPath As String, ByRef sLegalPath As String) As Boolean
Dim iColon As Long
Dim J As Long
Dim sIllegalChars As String
Dim sOutPath As String
On Error GoTo LegalPath_Error
LegalPath = False
sIllegalChars = ""
'If InStr(sPath, "\") <> 0 Then Exit Function
If InStr(sPath, "/") <> 0 Then sIllegalChars = sIllegalChars + "/"
iColon = InStr(sPath, ":") ' allow colon at loc 2
If iColon <> 0 And iColon <> 2 Then sIllegalChars = sIllegalChars + ":"
If InStr(sPath, "*") <> 0 Then sIllegalChars = sIllegalChars + "*"
If InStr(sPath, "?") <> 0 Then sIllegalChars = sIllegalChars + "?"
If InStr(sPath, "<") <> 0 Then sIllegalChars = sIllegalChars + "<"
If InStr(sPath, ">") <> 0 Then sIllegalChars = sIllegalChars + ">"
If InStr(sPath, "|") <> 0 Then sIllegalChars = sIllegalChars + "|"
' check for bullet code (149)
For J = 1 To Len(sPath)
If (asc(Mid(sPath, J, 1)) = 149) Then
sIllegalChars = sIllegalChars & Mid(sPath, J, 1)
End If
Next J
If (sIllegalChars <> "") Then
LegalPath = False
' replace with illegals with underscore
sOutPath = sLegalPath
For J = 1 To Len(sIllegalChars)
sOutPath = Replace(sOutPath, Mid(sIllegalChars, J, 1), "_")
Next J
sLegalPath = sOutPath
Dim sParentFolder As String
sParentFolder = GetFolderFromPath(TruncateR(sPath))
Call shell(GetDAFolder & "\ListDir.bat """ & sParentFolder & """ """ & GetDAFolder & "\ListDir.txt""")
Dim a As TextStream
Dim fs As New Scripting.FileSystemObject
Set a = fs.OpenTextFile(GetDAFolder & "\ListDir.txt", ForReading, False)
Dim sWindowsFolderName As String
Dim sWindowsShortName As String
Dim sLine As String
sWindowsFolderName = GetFileFromPath(TruncateR(sPath))
Do While a.AtEndOfStream <> True
sLine = a.ReadLine
If (Len(sLine) > 50) Then
If (Mid(sLine, 50) = sWindowsFolderName) Then
sWindowsShortName = Mid(sLine, 37, 8)
Name sParentFolder & "\" & sWindowsShortName As sLegalPath
Exit Function
End If
End If
Loop
Else
LegalPath = True
End If
End Function
For files with illegal names, the approach is very similar. Illegal chars are replaced by _. Note that Unicode characters are not flagged as illegal.
Public Function IsIllegalFileCharIN(ByRef sFileName As String, ByVal sFolder As String) As Boolean
Dim sRegex As String
Dim objRegExp As New RegExp
Dim sOut As String
sRegex = "[<>:""/\\|?*„]+"
With objRegExp
.Pattern = sRegex
.IgnoreCase = True
.Global = True
IsIllegalFileCharIN = .test(sFileName)
End With
If (IsIllegalFileCharIN) Then
Dim sLegalFileName As String
With objRegExp
.Pattern = sRegex
.IgnoreCase = True
.Global = True
sLegalFileName = .Replace(sFileName, "_")
End With
' find file short name
Call shell(GetDAFolder & "\ListDir.bat """ & sFolder & """ """ & GetDAFolder & "\ListDir.txt""")
Dim a As TextStream
Dim fs As New Scripting.FileSystemObject
Set a = fs.OpenTextFile(GetDAFolder & "\ListDir.txt", ForReading, False)
Dim sWindowsFolderName As String
Dim sWindowsShortName As String
Dim sLine As String
sWindowsFolderName = sFileName
Do While a.AtEndOfStream <> True
sLine = a.ReadLine
If (Len(sLine) > 50) Then
If (Mid(sLine, 50) = sWindowsFolderName) Then
sWindowsShortName = Mid(sLine, 37, 12)
Name sFolder & "\" & sWindowsShortName As sFolder & "\" & sLegalFileName
sFileName = sLegalFileName
Exit Function
End If
End If
Loop
End If
On Error GoTo 0
End Function
GetDAFolder is a dedicated folder. The batch file ListDir.Bat contains
dir /X %1 >%2

Related

VBA attempting to open file which name contains characters above high-ascii (256)

What I'd like to achieve is opening a file from the previously-stored variable. The problem is the filename sometimes contains characters like ŰŐ. VBA environment changes them to the closest one UO. So I'm unable to open a workbook included with "special" characters. What I have tried so far:
Sub open_last_modified()
Dim fso As New FileSystemObject
Dim files, folder, lmfile As String
Dim lmdate As Date
' a file previously created on desktop ( like őőőűűű.xlsx)
' with a proper filename, both method works very well
folder = ("C:\Users\szidzse\Desktop\")
files = Dir(folder & "*.*", vbNormal)
Do While files <> ""
On Error Resume Next 'if it contains non
If FileDateTime(folder & files) > lmdate Then
lmdate = FileDateTime(folder & files)
lmfile = files 'the last modified file what i'd like to open even if it has non-ascii characters.
End If
files = Dir
Loop
Set a = Workbooks.Open(folder & lmfile, ReadOnly:=True) 'does nothing when filename is not proper.
fso.CopyFile Source:=folder & lmfile, Destination:=folder & "temp.xlsx" 'file not found (I've tried to copy and rename it to a proper name.)
End Sub
I've also tried StrConv(string, vbFromUnicode or vbUnicode) without success.
Any help will be appreciated.
Please, test the next function. It should replace the non ASCII characters with similar ones:
Function replaceNonASCIICh(x As String) As String
Dim i As Long
For i = 1 To Len(x)
If AscW(Mid(x, i, 1)) <> Asc(Mid(x, i, 1)) Then
x = Replace(x, Mid(x, i, 1), Chr(Asc(Mid(x, i, 1))))
End If
Next i
replaceNonASCIICh = x
End Function
I tested it on the two not ASCII characters we could see/copy, in the next way:
Sub testReplaceNonASCII()
Dim x As String, result As String
x = ChrW(368) & ChrW(79) 'the string containing the characters you show us
result = replaceNonASCIICh(x)
ActiveCell.Offset(1).Value = result 'in Immediate Window non ASCII characters cannot be seen as they are...
End Sub
I do not know what other characters should be involved. Please, test it on your cases and send some feedback.
Now, supposing that Dir returns all files from the folder, even if their name contain non ASCII characters, you should firstly iterate between all of them and change their names, using the above function (and Name function). If it looks complicated, but if Dir returns them, I will show you how to proceed...
If you share such a file (supposing it is not confidential) I can try testing the code I posted, only supposing that it should work...
Edited:
I copied the workbook you sent in a folder named "InvalidCharacters", like subfolder of the one running the code. Then, I (manually) changed its name adding a suffix and copy it again (keeping the non ASCII characters). Please, do the same and test the following code:
Sub changeNonASCIIFileName()
Dim FSOLibrary As Object, fldObj As Object, fsoFile As Object
Dim foldPath As String, fileName As String, newName As String
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
foldPath = ThisWorkbook.path & "\InvalidCharacters\"
Set fldObj = FSOLibrary.GetFolder(foldPath)
For Each fsoFile In fldObj.files
On Error Resume Next 'if no characters to be replaced you cannot rename the file...
fsoFile.Name = replaceNonASCIICh(fsoFile.Name)
On Error GoTo 0
Next
End Sub
It uses the above function. Please, take care to be there!
I would like to receive some feedback after testing it...
#FaneDuru sorry for my late response.
Your code works, for me, it returns uo instead of űő. But gives File not found. when attempting to open. In my special case for opening a file, putting a question mark where the invalid character is doing the trick.
Workbooks.Open("C:\Users\User\invalid??.xlsx") opens successfully the file named: invalidűő.xlsx
Getting that file's last modified date is a bit trickier,if I tried to store as string it runs into error, file not found, so it must be done via FSO and a lot of mess with the strings, and telling the editor that "Hey this is from Middle European code table!!" so in my case:
Chr(254) is ő in the mid-euro table. If your string contains this char in the editor it handles as the following.
Chr(254) is õ in the western table.
Setting the string with the specified Unicode hex code here ChrW$(&H151) is the key. (Accented o letter). While Chr(254) is (o letter with tilde, or without).
Sub lmfile_check2()
Dim files As String
Dim folder As String
Dim lmdate As Date
Dim lmfile As String
files = Empty
For i = 1 To 11
folder = ThisWorkbook.Sheets(1).Cells(i, 2).Value
files = Dir(folder & "*.*", vbNormal)
Do While files <> ""
On Error Resume Next
If FileDateTime(folder & files) = Empty Then GoTo 2
On Error GoTo 2
lmdate_2:
If FileDateTime(folder & files) > lmdate Or lmdate2 > lmdate Then
If IsEmpty(FileDateTime(folder & files)) Then
GoTo ende
End If
lmfile = files '
If lmdate2 > lmdate And lmdate <> Empty Then
lmdate = lmdate2
Else
lmdate = FileDateTime(folder & files)
End If
End If
GoTo ende
2:
If InStr(1, files, "hétfo") > 0 Then 'this section is for known invalid character
Set fs = CreateObject("Scripting.FileSystemObject")
files2 = Replace(files, "hetfo", "hetf" & ChrW$(&H151), 1, -1, vbTextCompare)
l = Len(files2)
files2 = Left(files2, l - 5)
Set f = fs.GetFile(folder & files2 & ChrW$(&H151) & ".xls")
lmdate2 = f.DateLastModified
If lmdate2 > lmdate Then
lmdate = lmdate2
lmfile = Replace(files, "hetfo", "hetf" & "?", 1, -1, vbTextCompare)
GoTo vege
End If
End If
GoTo lmdate_2
ende:
files = Dir
Loop
ThisWorkbook.Sheets(1).Cells(i, 1) = folder & lmfile
ThisWorkbook.Sheets(1).Cells(i, 4) = lmdate
Set f = Nothing
lmdate = Empty
lmfile = Empty
Next i
For i = 1 To 11
ThisWorkbook.Sheets(1).Cells(i, 1) = Replace(ThisWorkbook.Sheets(1).Cells(i, 1), "hétfo", "hétf" & "?", 1, -1, vbTextCompare)
Next i
MsgBox "Vertig"
End Sub

Code problem with a format of files which the loop goes over

I have a problem with a VBA code. The macro below is suppose to go to the destination folder which contains only Excel file but with different extension (xls, xlsx, xlsm) and loop over the exising files to find the larges number within the names of the files (the exaples of current files are DelKra 2021-()-162.xls; DelKra 2021-()-163.xls; DelKra 2021-()-164.xlsm).
The macro run smoothly only when the destination folder contains xls Excel files but crashes whenever another type of Excel file is saved in the folder. The command the macro crashes at is:
"CurrentNum = Mid(FileName, Len(FileName) - 6, 3)".
Please help me to fix my macro.*
Sub ConfirmAndSaveDel()
DestinationFolder = "\\oscwawfs01.kingfisherasia.com.hk\common\FINANCE\Public\BUSINESS
TRIPS\Business Trip Delegacje\2021\Domestic\"
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
Dim LastNum As Integer
Dim CurrentNum As Integer
Dim Numerek As String
Dim whereTrip As String
Dim purposeTrip As String
Dim whoTrip As String
Dim startTrip As Date
Dim endTrip As Date
Dim LastRow As Integer
LastNum = 0
FileCount = 0
FileName = Dir(DestinationFolder)
'Loop searching all files
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
'Take from the file name numbers 6,5 i 4 counting from the right
CurrentNum = Mid(FileName, Len(FileName) - 6, 3)
'If it is larger than the current one remember it
If CurrentNum > LastNum Then
LastNum = CurrentNum
End If
'Debug.Print FileName
FileName = Dir()
Loop
'Add 1 to the largest number found
LastNum = LastNum + 1
'Debug.Print LastNum
'Change the numer to string and add as many zeros at the beginning of the number to have it as the three digit number
If Len(Trim(CStr(LastNum))) = 1 Then
Numerek = "00" & CStr(LastNum)
ElseIf Len(Trim(CStr(LastNum))) = 2 Then
Numerek = "0" & CStr(LastNum)
ElseIf Len(Trim(CStr(LastNum))) = 3 Then
Numerek = CStr(LastNum)
End If
'Combine the whole name of the new file
NazwaPliku = "DelKra 2021-" & "(" & Range("FRIFAR").Value & ")-" & Numerek
Try using such a function:
Function extractNumber(strName As String) As Long
Dim arr: arr = Split(strName, "-")
extractNumber = Split(arr(Ubound(arr)), ".")(0)
End Function
Copy the above function in the same module and call it as:
CurrentNum = extractNumber(fileName)
I mean, replace CurrentNum = Mid(FileName, Len(FileName) - 6, 3) with the above way. It is independent of extension number of characters.
And besides that, please replace all declarations As Integer with As Long. In VBA that way of declaring does not bring any benefit in terms of memory handling or from any other point of view... It is good to cultivate such a habit in all cases. But if you like your way, please adapt the function to return As Integer...
The following function will extract the part of the filename between the last dash and the last dot of the filename. If it is numeric, it will return that number, else (or if the filename doesn't follow the pattern) 0.
Function getFileNumber(filename As String) As Long
Dim pDash As Long, pDot As Long
pDash = InStrRev(filename, "-")
pDot = InStrRev(filename, ".")
If pDash = 0 Or pDot = 0 Or pDot < pDash Then Exit Function
Dim suffix As String
suffix = Mid(filename, pDash + 1, pDot - pDash- 1)
If IsNumeric(suffix) Then
getFileNumber = Val(suffix)
End If
End Function

Can't write to zip File if using a string or variant in Shell.Application Copyhere

I am having troubles with NameSpace CopyHere function. I am trying to create a zip file containing a bunch of logs. I can create the zip file just fine, but when using the NameSpace.CopyHere, if I use a string or a variant containing a string, it won't write the file to the zip archive.
For example, I have a file located at P:\test2.txt .
If I use those lines :
objApp.Namespace(sZipArchive).CopyHere sFile
objApp.Namespace(sZipArchive).CopyHere vLogs(i)
where sFile = vLogs(i) = "P:\test2.txt
the file test2.txt won't be copied in the zip archive.
However, if I use this line :
objApp.Namespace(sZipArchive).CopyHere "P:\test2.txt"
Then, the file gets copied in the zip file.
If I put a check to see if the sFile or vLog(i) is = "P:\test2.txt", I can see that they are the same thing.
Is there something I am missing here on why the first 2 lines don't work, but the third one does?
Thank you for your time.
Full sub :
Private Sub BtnSaveToZip_Click()
Dim bEndRow, bTest As Boolean
Dim iRow, iCount As Integer
Dim sZipArchive, sDate, sFolderExists, sFile As String
Dim vLogs, vFilename As Variant
Dim objApp As Object
sDate = Date
sDate = Replace(sDate, "/", "") ' set date format to DDMMYYYY instead of DD/MM/YYYY
sZipArchive = LblLogArchive + "\" + sDate
sFolderExists = Dir(sZipArchive)
If sFolderExists = "" Then
CreateDir (sZipArchive) ' if the subfolder with the date does not exists, create it
End If
sZipArchive = sZipArchive + "\" + wsContacts.Range("B7").Value + " Logs_" + sDate + ".zip"
'Check if file is open
If FileLocked(sZipArchive) Then
MsgBox sZipArchive + " already open. Please close the archive."
Exit Sub
End If
'Creating the zip file from Ron de Bruin
NewZip (sZipArchive)
'filling the zip file
Set objApp = CreateObject("Shell.Application")
bEndRow = False
iRow = gFirstData
Do While bEndRow = False
If Not IsEmpty(wsLogs.Cells(iRow, gTestCase).Value) Then
If Not IsEmpty(wsLogs.Cells(iRow, gLog).Value) Then
vLogs = Split(wsLogs.Cells(iRow, gLog).Value, ";")
For i = 0 To UBound(vLogs) - 1
sFile = vLogs(i) ' Debug only
If sFile = "P:\test2.txt" Then 'Debug only
objApp.Namespace(sZipArchive).CopyHere vLogs(i) ' if I put "P:\test2.txt", it works correctly
'Keep script waiting 5s for debug purpose
Application.Wait (Now + TimeValue("00:00:05"))
End If
Next
End If
iRow = iRow + 1
Else
bEndRow = True
End If
Loop
MsgBox "Zip successfully created"
Set objApp = Nothing
End Sub
If this works
objApp.Namespace(sZipArchive).CopyHere "P:\test2.txt"
and sFile and vLogs(i) appears to be the same as P:\test2.txt then I believe it could be a leading or trailing space problem. Try this
objApp.Namespace(sZipArchive).CopyHere Trim(sFile)
or
objApp.Namespace(sZipArchive).CopyHere Trim(vLogs(i))
The other way to check if sFile and vLogs(i) contains a valid path is by using DIR
One more way of debugging is to step through your code and then type this in the Immediate window
?=vLogs(i)="P:\test2.txt"
?=sFile="P:\test2.txt"
You should get a true in both cases. If you don't then there is your problem :)

Passing a result from Dir to function, then trying to get next Dir result -- Getting invalid procedure call or argument

This code uses Dir to get sub-dirs. Each sub-dir needs to have its xls files processed. After it finishes processing the first batch of xls, I get invalid procedure call or argument. I am guessing when I pass dirLook to the function it creates a copy? Please assist. I need to move on to the next sub-dir.
dirLook = dir(strDir, vbDirectory)
Do While dirLook <> ""
If dirLook <> "." And dirLook <> ".." Then
If (GetAttr(strDir & adir) And vbDirectory) = vbDirectory Then
'Perform action on folder here
loopXls (dirLook)
Debug.Print dirLook
End If
End If
dirLook = dir
Loop
loopXls:
Function loopXls(dirStr As String)
Dim count As Integer
Dim strFilename As String
Dim strPath As String
Dim wbkTemp As Workbook
strPath = "C:\Users\pmevi\Documents\L7\L7_Master_Book\Input\" & dirStr & "\"
strFilename = dir(strPath & "*.xls")
Do While Len(strFilename) > 0
Set wbkTemp = Workbooks.Open(strPath & strFilename)
'
' do your code with the workbook
'
' save and close it
wbkTemp.Close True
count = count + 1
strFilename = dir
Loop
Debug.Print (count)
End Function
EDIT2
I am attemping to load each dir into an array, but for some reason when I loop through array I only see 3 folders instead of 5.
Dim dirs(5) As String
Dim i As Integer
Dim endNum As Integer
endNum = 4
dirLook = dir(strDir, vbDirectory)
For i = 0 To endNum
dirs(i) = dirLook
dirLook = dir
Next i
For i = 0 To endNum
Debug.Print (dirs(i))
Next i
output:
3-10-14
3-11-14
3-12-14
expected:
3-10-14
3-11-14
3-12-14
3-13-14
3-14-14
Edit3
Found issue to array. 2 indexes are used for "." and ".."
It's not exactly clear from the code, but if the code above is in the loopXls method, making this a recursive function then the problem is that you cannot use the Dir function recursively, as stated here, towards the bottom.
The answer here include shows an example class for recursing with the Dir function.

How do I open a file if I only know part of the file name?

I need to open a file whose full filename I do not know.
I know the file name is something like.
filename*esy
I know definitely that there's only one occurrence of this file in the given directory.
filename*esy is already a "shell ready" wildcard & if thats alway the case you can simply;
const SOME_PATH as string = "c:\rootdir\"
...
Dim file As String
file = Dir$(SOME_PATH & "filename*esy" & ".*")
If (Len(file) > 0) Then
MsgBox "found " & file
End If
Just call (or loop until empty) file = Dir$() to get the next match.
There is an Application.FileSearch you can use (see below). You could use that to search for the files that match your pattern. This information taken from here.
Sub App_FileSearch_Example()
With Application.FileSearch
.NewSearch
.LookIn = "c:\some_folder\"
.FileName = "filename*esy"
If .Execute(SortBy:=msoSortByLastModified, SortOrder:=msoSortOrderDescending) > 0 Then
For i1 = 1 To .FoundFiles.Count
' do something with matched file(s)
Next i1
End If
End With
End Sub
If InStr(sFilename, "filename") > 0 and InStr(sFilename, "esy") > 0 Then
'do somthing
end if
Or you can use RegEx
Dim RE As Object, REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = "filename(.*)esy"
End With
Set REMatches = RE.Execute(sFilename)
REMatches(0) 'find match
I was trying this question as a function. This is the solution that ended up working for me.
Function fileName(path As String, sName As String, ext As String) As Variant
'path is Full path from root. Can also use path = ActiveWorkbook.path & "\"
'sName is the string to search. ? and * are wildcards. ? is for single char
'example sName = "book?" or sName ="March_*_2014*"
'ext is file extention ie .pdf .xlsm .xls? .j*
Dim file As Variant 'Store the next result of Dir
Dim fname() As String 'Dynamic Array for result set
ReDim fname(0 To 0)
Dim i As Integer ' Counter
i = 0
' Use dir to search and store first result
fname(i) = path & Dir(path & "\" & sName & ext)
i = i + 1
'Load next result
file = Dir
While file <> "" 'While a file is found store that file in the array
ReDim Preserve fname(0 To i) As String
fname(i) = path & file
file = Dir
Wend
fileName = Application.Transpose(fname) 'Print out array
End Function
This works for me as a single or array function.
If you know that no other file contains "filename" and "esy" in that order then you can simply use
Workbooks.Open Filename:= "Filepath\filename*esy.*"
Or if you know the number of missing characters then (assuming 4 characters unknown)
Workbooks.Open Filename:= "Filepath\filename????esy.*"
I use this method to run code on files which are date & timestamped to ignore the timestamp part.