I've found an issue with adobes bates numbering tool, where file names are messing up the order in which they are numbered. I was hoping to write a script that users would be able to click on and add the folder extension for all the files. Then the script would prepend all the file names within the folder with a 000001filename.pdf, 000002filename.pdf, etc.
I've never combined scripts before but I've found scripts that either rename OR prepend, and I couldn't find anything that would rename sequentially with preceding 0s.
This is what I have so far:
Dim iloop As Integer
Dim iFileNumber As Integer
Dim sPrefix As String
Dim sNewFileName As String
Dim arr() As String
'Get array of all pdfs from the selected directory
arr = System.IO.Directory.GetFiles(strPath, "*.PDF")
'loop through the array
For iloop = 0 To UBound(arr)
'Create a prefix for each file
iFileNumber = iloop + 1
Select Case iFileNumber
Case 0 To 9 : sPrefix = "00000" & iFileNumber
Case 10 To 99 : sPrefix = "0000" & iFileNumber
Case 100 To 999 : sPrefix = "000" & iFileNumber
Case 1000 To 9999 : sPrefix = "00" & iFileNumber
Case 10000 To 99999 : sPrefix = "0" & iFileNumber
Case Else : sPrefix = iFileNumber
End Select
Dim arr2() As String
'split the path by the / symbol to get the filename
arr2 = Split(arr(iloop),"\")
'Add the prefix to the front of the filename, filename will be the last item in the array.
arr2(uBound(arr2)) = sPrefix & arr2(uBound(arr2))
'Put the new path and filename back together
sNewFileName = Join(arr2,"\")
'Rename the file with the new filename
System.IO.File.Move(arr(iloop),sNewFileName)
Next
A VBScript solution for renaming PDF files in a given folder by prefixing them with a running number, left-padded with zeroes, could look like this:
fldr = "..."
Set fso = CreateObject("Scripting.FileSystemObject")
i = -1
For Each f In fso.GetFolder(fldr).Files
If LCase(fso.GetExtensionName(f)) = "pdf" Then
Do
i = i + 1
newname = Right("0000" & i, 5) & f.Name
Loop While fso.FileExists(fso.BuildPath(f.ParentFolder, newname))
f.Name = newname
End If
Next
Related
In one folder I have 10000 files and the the names of files is structured like this:
File1_0, File1_1, File1_2, File1_3
File2_0, File2_1, File2_2
File3_0, File3_1, File3_2, File3_3
...
File1000_0, File1000_1
I like to delete previous revisions of the files and to stay with the last one. Above files to become like this:
File1_3
File2_2
File3_3
....
File1000_1
I am trying the following: Put the name without _xx in an array then to remove the duplicates. But I don't think this is correct and for the moment I am stuck in the logic of the way I should do this.
This is the code:
Option Explicit
Dim fso, folder, sourcefolder, file
Dim b : b = Array()
Dim i
Dim x
Dim z
Dim y
sourcefolder = "C:\test"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(sourcefolder)
i = 0
For Each file In folder.Files
i = i + 1
x = fso.GetBaseName(file)
ReDim Preserve b(UBound(b) + 1) : b(UBound(b)) = Left(x, Len(x)-2)
y = y & b(i-1) & "#"
Next
z = RemoveDuplicates(y)
For i=0 To UBound(z)-1
WScript.Echo i+1 & " " & z(i)
Next
Function RemoveDuplicates(str)
Dim d
Dim elem
If Trim(str) = "" Then
RemoveDuplicates = Array()
Exit Function
End If
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'make dictionary case-insensitive
For Each elem In Split(str, "#")
d(elem) = True
Next
RemoveDuplicates = d.Keys
End Function
One way to approach your problem is to build a dictionary that maps the basenames of the files to the highest revision number:
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare
For Each f In fso.GetFolder(sourcefolder)
basename = fso.GetBaseName(f.Name)
a = Split(basename, "_")
revision = Int(a(UBound(a)))
prefix = a(0)
if d(prefix) < revision Then
d(prefix) = revision
End If
Next
Then run a second loop to remove all files whose basename doesn't have that revision:
For Each f In fso.GetFolder(sourcefolder)
basename = fso.GetBaseName(f.Name)
a = Split(basename, "_")
revision = Int(a(UBound(a)))
prefix = a(0)
If d.Exists(prefix) And revision < d(prefix) Then
f.Delete
End If
Next
Note that this code assumes that the underscore separating prefix and revision is the only one in the basename. If you have filenames containing more than one underscore (like foo_bar_1.txt) you'll need to adjust the extraction of prefix and revision to take care of that.
With that said, I strongly recommend against doing revision management in filenames. Use a revision control system (Git, Mercurial, Subversion, ...). That's what they were invented for.
Option Explicit
' Folder to process
Dim sourceFolder
sourceFolder = "."
Dim fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' Regular expresion used to separate base name and sequence
Dim re
Set re = New RegExp
re.Pattern = "^(.*)_([0-9]+)$"
' Dictionary to store data for each sequence
Dim fileSequences
Set fileSequences = WScript.CreateObject("Scripting.Dictionary")
' fileSequences will use the base name of the files as key and
' hold as data an array with the higher sequence number and the
' associated file full path.
Dim f, colMatches, baseName, sequence
For Each f In fso.GetFolder(sourceFolder).Files
' Try to separate base name and sequence
Set colMatches = re.Execute( fso.GetBaseName(f.Name) )
' Only handle serialized files, those whose name match the regular expresion
If colMatches.Count > 0 Then
' base name and sequence are stored in the Submatches collection
' file extension is included in the base name to avoid handling separate series as one
baseName = LCase( colMatches.Item(0).SubMatches(0) & "." & fso.GetExtensionName( f.Name ) )
' Get the numeric sequence value - This should also handle zero prefixed sequence numbers
sequence = CLng( colMatches.Item(0).SubMatches(1) )
Select Case True
Case Not fileSequences.Exists( baseName )
' New sequence found - store current sequence value and the associated file path
fileSequences.Add baseName, Array( sequence, f.Path )
Case sequence < fileSequences.Item( baseName )(0)
' File with a lower sequence number found - Remove
f.Delete
Case sequence > fileSequences.Item( baseName )(0)
' File with a higher sequence number found - Remove previous one
fso.DeleteFile fileSequences.Item( baseName )(1)
' Update sequence information with new higher value and the associated file path
fileSequences.Item(baseName) = Array( sequence, f.Path )
End Select
End If
Next
I would like to have a script that reads a specific folder and extracts the base file names, removes the last two characters and then uses the result to populate the text of an inputbox. The user then selects from the given options and the remainder of the script searches and replaces text in a second folder with the selected text.
Example file names in the initial target folder:
ABFA1
ABFA3
ABFA4
HVA1
HVA3
HVA4
ITALA1
ITALA3
ITALA4
Obviously, once the last 2 characters are removed, I am left with duplicates which I will need to remove.
Here is part of the script I have so far:
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFilePath = objFSO.BuildPath(objFSO.GetAbsolutePathName("."), "\dwgs\logos")
If Not objFSO.FolderExists(strFilePath) Then
wscript.echo("Folder does not exist, script exiting")
wscript.quit
End if
'
Set objFolder = objFSO.GetFolder (strFilePath)
For Each objFile In objFolder.Files
strFile = objFSO.GetBaseName(objFile.Name)
strFile = LEFT(strFile, (LEN(strFile)-2))
' wscript.echo(strFile)
Next
'delete all duplicate files names and add result to dictionary (or array?)
'create an inputbox and present a number of choices populated by the dictionary/array
user1 = InputBox("Select a Logo:"&(chr(13))&(chr(13))&(*array/dict*)), "Logo Replacement Script")
' Set arguments
strFilePath2 = objFSO.BuildPath(objFSO.GetAbsolutePathName("."), "\dwgs")
FindString = "dwgs\logos\"
ReplaceStringWith = "dwgs\logos\"&(user1)
' Find and replace function
I am able to get the base file names with the last 2 characters removed, but I dont know how to weed out the duplicates and then use the result in an inputbox? (I'm imagining text within the inputbox of a number followed by a choice and the user enters the number to signify which option to use)
My first thought was to use an array, but after some reading, it would seem a dictionary approach might be better. Unfortunately, I haven't been able to figure out how to incorporate it into the script.
Any help would be much appreciated.
Updated script incorporating input from Ekkehard:
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFilePath = objFSO.BuildPath(objFSO.GetAbsolutePathName("."), "\dwgs\logos")
'
Function ShowFilesInFolder(strFolderPath)
Set oFolder = objFSO.GetFolder(strFolderPath)
Set oFileCollection = oFolder.Files
For Each oTempFile in oFileCollection
strTemp = strTemp & oTempFile.name
strTemp = LEFT(strTemp, (LEN(strTemp)-6))
Next
ShowFilesInFolder = strTemp
End Function
x = ShowFilesInFolder(strFilePath)
'
Function mkDic(aK, aV)
Dim tmp : Set tmp = CreateObject("Scripting.Dictionary")
Dim i
For i = 0 To UBound(aK)
tmp(aK(i)) = aV(i)
Next
Set mkDic = tmp
End Function
'
Dim a : a = Split (x)
WScript.Echo Join(mkDic(a, a).Keys)
For some reason I cant get the mkDic Function to split the input from the ShowFilesInFolder Function?
Is there an easier way to go about it than what I have come up with?
The VBScript tool for uniqueness is The Dictionary. This demo (cf. here)
Option Explicit
' based on an Array 2 Dictionary function from
' !! https://stackoverflow.com/a/45554988/603855
Function mkDic(aK, aV)
Dim tmp : Set tmp = CreateObject("Scripting.Dictionary")
Dim i
For i = 0 To UBound(aK)
' tmp(aK(i)) = aV(i)
tmp(Mid(aK(i), 1, Len(aK(i)) - 2)) = aV(i)
Next
Set mkDic = tmp
End Function
Dim a : a = Split("ABFA1 ABFA3 ABFA4 HVA1 HVA3 HVA4 ITALA1 ITALA3 ITALA4")
WScript.Echo Join(a)
WScript.Echo Join(mkDic(a, a).Keys), "=>", Join(mkDic(a, a).Items)
output:
cscript 45590698.vbs
ABFA1 ABFA3 ABFA4 HVA1 HVA3 HVA4 ITALA1 ITALA3 ITALA4
ABF HV ITAL => ABFA4 HVA4 ITALA4
shows, how to de-duplicate an array and how to stringify the (unique) keys for concatenating into a prompt.
I managed to get a working script, but couldn't figure out how to do it without using a couple of temporary text files to pass the data on.
I thought I would post the code in case it may be of help to someone.
Const ForReading = 1, ForWriting = 2, ForAppending = 8, N = 0
Set fso = CreateObject("Scripting.FileSystemObject")
strFilePath = fso.BuildPath(fso.GetAbsolutePathName("."), "\dwgs\logos")
If Not fso.FolderExists(strFilePath) Then
wscript.echo("The LOGO Folder Does Not Exist - Exiting Script")
wscript.quit
End if
'
Set f = fso.OpenTextFile("xtempLogos.txt", ForWriting, True)
Set objShell = CreateObject ("Shell.Application")
Set objFolder = objShell.Namespace (strFilePath)
For Each strFileName in objFolder.Items
a = objFolder.GetDetailsOf (strFileName, N)
a = LEFT(a, (LEN(a)-6))
f.Writeline (a)
Next
f.Close
'
Set f = fso.OpenTextFile("xtempLogos.txt", ForReading)
TheFile = f.ReadAll
f.Close
'
Function mkDic(aK, aV)
Dim tmp : Set tmp = CreateObject("Scripting.Dictionary")
Dim i
For i = 0 To UBound(aK)
tmp(aK(i)) = aV(i)
Next
Set mkDic = tmp
End Function
'
Set f = fso.OpenTextFile("xtempLogos.txt", ForWriting, True)
Dim a : a = Split(TheFile,vbcrlf)
a = Join(mkDic(a, a).Keys)
f.Writeline (a)
f.Close
'
Set f = fso.OpenTextFile("xtempLogos2.txt", ForWriting, True)
Set f = fso.OpenTextFile("xtempLogos.txt", ForReading)
theFile = f.ReadAll
number = 1
myArray = Split(theFile)
for i = 0 to Ubound(MyArray)-1
Set f = fso.OpenTextFile("xtempLogos2.txt", ForAppending, True)
If number < 10 then f.Writeline (number) & ".........." & myArray(i)
If number >=10 then f.Writeline (number) & "........." & myArray(i)
f.Writeline ""
Set f = fso.OpenTextFile("xtempLogos.txt", ForReading, True)
number=number+1
Next
f.Close
'
Set f = fso.OpenTextFile("xtempLogos2.txt", ForReading)
TheFile = f.ReadAll
f.Close
'
user1 = InputBox("WHICH LOGO DO YOU WANT TO ADD?"&(chr(13))&(chr(13))&(chr(13))& (theFile), "Add Logo Script", 11)
choice = (user1) - 1
wscript.echo myArray(choice)
'
Set f = fso.GetFile("xtempLogos.txt")
f.Delete
Set f = fso.GetFile("xtempLogos2.txt")
f.Delete
I am trying to pass folder location as variable to a VBScript which has array to consume the location as a parameter. I don't know how to pass it, could some one please help me?
I am trying to pass following location as a variable "C:\New","C:\New1" to the below code, the script is working fine when I directly give the location, but when I tired to pass it as variable it is not working.
Code given below:
Set oParameters = WScript.Arguments
folderlocation = oParameters(0)
Dim folderarray
Dim WshShell, oExec
Dim wow()
Set objShell = CreateObject("WScript.Shell")
Dim oAPI, oBag
Dim fso, folder, file
Dim searchFileName, renameFileTo, day
Dim i
folderarray = Array(folderlocation)
ii = 0
day = WeekDay(Now())
If day = 3 Then
aa = UBound(folderarray)
f = 0
j = 0
x = 0
Y = 0
For i = 0 To aa
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderarray(i))
For Each file In folder.Files
If InStr(file.Name, name) = 1 Then
ii = 1
strid = file.Name
Set re = New RegExp
re.Pattern = ".*myfile.*"
If re.Test( strid ) Then
'msgbox "File exist and the file name is """ & strid & """"
x = x+1
Else
'msgbox "file not found"
End If
Set re = Nothing
End If
Next
If x = 0 Then
ReDim Preserve wow(f)
wow(f) = folderarray(i)
f = f+1
j = j+1
Else
x = 0
End If
Next
End If
If J > 0 Then
ReDim Preserve wow(f-1)
value = Join(wow, ",")
MsgBox "Files not found in the following location(s) :" & value
Else
MsgBox "fine"
End If
To fill an array from a list of arguments you'd call the script like this:
your.vbs "C:\New" "C:\New1"
and fill the array in your.vbs like this:
size = WScript.Arguments.Unnamed.Count - 1
ReDim folderarray(size)
For i = 0 To size
folderarray(i) = WScript.Arguments.Unnamed.Item(i)
Next
If for some reason you must pass the folder list as a single argument you'd call the script like this:
your.vbs "C:\New,C:\New1"
and populate the array in your.vbs like this:
folderarray = Split(WScript.Arguments.Unnamed.Item(0), ",")
I have a folder with massive number of files, i need to make some folders and put them in to that folders (below 50 of each), Folder names can be any thing. I thought folder name to be numbers( 1,2,3.. etc )
here what i done, but doesn't work
Set fso=CreateObject("Scripting.FileSystemObject")
inputFldr =".\myFolder"
Set fldr=fso.getFolder(inputFldr)
dim i
i=0
fName = 0
for each file in fldr.files
i = i+1
If Not fso.FolderExists(fName) Then fso.CreateFolder(fName)
fso.MoveFile file, fName
if i>50 then
fName = fName + 1
i = 0
end if
next
wscript.echo done
Try this:
Dim i, fName, inputFldr, TmpFdr
Set fso = CreateObject("Scripting.FileSystemObject")
inputFldr = Replace(wscript.scriptfullname,wscript.scriptname,"myFolder")
Set fldr = fso.getFolder(inputFldr)
i = 0
fName = 0
wscript.echo "Input Folder: " & fldr.path
For Each file In fldr.Files
i = i + 1
TmpFdr = inputFldr & "\" & fName & "\"
if Not fso.FolderExists(TmpFdr) Then fso.CreateFolder (TmpFdr)
file.move TmpFdr
If i > 50 Then
fName = fName + 1
i = 0
End If
Next
set fldr=nothing
set fso=nothing
I'm new to vbscripting and I just received a task that requires me to find 6 files with matching strings in the filename so that I can move these files to a different directory. I am using the regex pattern "\d{8}-\d{6}" to locate all of the strings within the filenames.
How would I go about in doing a search in a directory and checking to see if there are 6 files with matching strings in their filenames so that I can store them into an array and then move the files to another directory?
The script I have written so far:
Set objFS = CreateObject("Scripting.FileSystemObject")
strShareDirectory = "in\"
strDumpStorageDir = "out\"
Set objFolder = objFS.GetFolder(strShareDirectory)
Set colFiles = objFolder.Files
Set re = New RegExp
re.Global = True
re.IgnoreCase = False
re.Pattern = "-\d{8}-\d{6}"
Dim curFile, matchValue
Dim i: i = 0
For Each objFile in colFiles
bMatch = re.Test(objFile.Name)
curFile = objFile.Name
If bMatch Then
ReDim preserve matches(i)
Matches(i) = curFile
i = (i + 1)
For Each objFile1 in colFiles
If objFile1.Name <> objFile.Name Then
For each match in re.Execute(objFile1.Name)
matchValue = match.Value
Exit For
Next
If (Instr(curFile, matchValue) > 0) Then
matchCount = 1
For Each match1 in re.Execute(objFile1.Name)
curFile1 = objFile1.Name
matchValue1 = match1.Value
Exit For
'If Then
Next
'msgbox(curFile1)
End If
End If
Next
End If
Next
Here is what my sample directory that I am working with looks like.
As #KekuSemau's proposal does not address the (sub)problem of grouping the files, dweebles does not give the full story (Why the array? Why the insistence on having a full (sub)set of files?), and the numbers (group of 6, 3/4 parts in a file name) aren't really relevant to the basic task - distribute a set files into folders based on parts of the file name - I claim that the way to solve the task is to get rid of all the array, dictionary, and regexp fancies and to keep it simple:
Before:
tree /A /F ..\data
+---in
| B-2
| B-1
| A-3
| A-2
| B-3
| A-1
|
\---out
Code:
Const csSrc = "..\data\in"
Const csDst = "..\data\out"
Dim f, n, d
For Each f In goFS.GetFolder(csSrc).Files
n = Split(f.Name, "-")
If 1 = UBound(n) Then
d = goFS.BuildPath(csDst, n(1))
If Not goFS.FolderExists(d) Then goFS.CreateFolder d
f.Move goFS.BuildPath(d, f.Name)
End If
Next
After:
tree /A /F ..\data
+---in
\---out
+---3
| A-3
| B-3
|
+---1
| B-1
| A-1
|
\---2
B-2
A-2
P.S.
This problem can be solved using the same approach.
Ah, now I understand.
So: you need all file names that match the pattern IF there are at least 6 files with the same matching sub string. Okay. Then, yes, I understand that you can get strangled up in nested for..next loops. If that happens, I would recommend to put some code into extra functions.
In this solution, I use dictionaries to do some work much easier (every call to 'exists' is another nested iteration over all its elements for example, and every assignment as well).
This example would ignore multiple matches within one file name.
option explicit
dim objFS : dim strShareDirectory : dim strDumpStorageDir : dim objFolder : dim colFiles : dim re : dim objFile
dim dictResults ' dictionary of [filename] -> [matching substring]
dim dictResultsCount ' dictionary of [matching substring] -> [count]
dim dictResultsFinal ' only the valid entries from dictResults
dim keyItem
dim strMatch
set dictResultsFinal = CreateObject("Scripting.Dictionary")
set dictResults = CreateObject("Scripting.Dictionary")
set dictResultsCount = CreateObject("Scripting.Dictionary")
Set objFS = CreateObject("Scripting.FileSystemObject")
strShareDirectory = "in\"
strDumpStorageDir = "out\"
Set objFolder = objFS.GetFolder(strShareDirectory)
Set colFiles = objFolder.Files
Set re = New RegExp
re.Global = True
re.IgnoreCase = False
re.Pattern = "-\d{8}-\d{6}"
Dim curFile, matchValue
Dim i: i = 0
For Each objFile in colFiles
' test if the filename matches the pattern
if re.test(objFile.Name) then
' for now, collect all matches without further checks
strMatch = re.execute(objFile.Name)(0)
dictResults(objFile.Name) = strMatch
' and count
if not dictResultsCount.Exists(strMatch) then
dictResultsCount(strMatch) = 1
else
dictResultsCount(strMatch) = dictResultsCount(strMatch) +1
end if
end if
next
' for testing: output all filenames that match the pattern
msgbox join(dictResults.keys(), vblf)
' now copy only the valid entries into a new dictionary
for each keyItem in dictResults.keys()
if dictResultsCount.Exists( dictResults(keyItem) ) then
if dictResultsCount( dictResults(keyItem) ) >= 6 then
dictResultsFinal(keyItem) = 1
end if
end if
next
' test output the final result
msgbox join(dictResultsFinal.keys(), vblf)
--- my first answer
Well I should probably ask what have you tried but... here's your example ^^.
This should give you enough to start from (I ignored that '6' requirements you mentioned). Ask if you need more explanations.
Option explicit
dim a
a = findFiles("G:\", "\d{8}-\d{6}")
msgbox join(a, vblf)
function findFiles(path, pattern)
dim rx
dim fso
dim fsoFolder
dim fsoFiles
dim results
dim item
set rx = new regexp
rx.pattern = pattern
set results = CreateObject("Scripting.Dictionary")
set fso = CreateObject("Scripting.FileSystemObject")
set fsoFolder = fso.GetFolder(path)
set fsoFiles = fsoFolder.Files
for each item in fsoFiles
if rx.test(item.name) then results(item.name) = 1
next
set fso = nothing
set fsoFolder = nothing
set fsoFiles = nothing
findFiles = results.keys()
end function