Source="C:\\SourceDirectory"
Destination="C:\\DestinationDirectory"
pattern1="^"&"TestApp"&".*"&"zip"
Function RegExTest(pattern, stringToSearch)
Dim regEx ' Create variable.
Set regEx = New RegExp ' Create a regular expression.
regEx.Pattern = pattern ' Set pattern.
regEx.IgnoreCase = True ' Set case insensitivity.
regEx.Global = True ' Set global applicability.
Set Matches = regEx.Execute(stringToSearch) ' Execute search.q
IF Matches.count > 0 Then
RegExTest = True
End IF
End Function
Sub ProcessFile(Source, Destination)
Set Folder = FSO.GetFolder(Destination)
If Not (Right(Destination, 1) = "\") Then
Destination = Destination & "\"
End If
' Deal with Duplicate Files
Dim sourceArr, File
sourceArr = Split(Source, "\")
File = sourceArr(UBound(sourceArr))
If Not FSO.FileExists(Destination & File) Then
returnValue = True
For Each File In Folder.Files
if RegExTest(pattern1,File.Name) And returnValue = "True" Then
WScript.Echo("filename: "&File.Name&" filesize: "&File.Size)
End If
Next
FSO.MoveFile Source, Destination
End If
End Sub
I have only 3 TestApp.zip files but I'm getting 9 files which is resulting false file size in total, Folder structure is like this
Any help much appreciated!! Thanks in advance
Related
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
This is the middle of the code I'm trying to work with. Is there a way to make the file it's reading open and read from line 2 to line 97? Where I need the correction is starred (****). What I'm trying to do is get the data from lines 2 through 97 to compare to another file I'll have to open from the same lines. The beginning and ends of each file are different but the middle information should match thus I need these specific lines.
' Build Aliquot file name
strFile = aBarcodeExportDir & "A-" & yearStr & "-" & splitStr2(0) & ".csv"
'msgbox("open file: " & strFile)
If (objFS.FileExists(strFile)) Then
' Open A file
Set objFile = objFS.OpenTextFile(strFile)
' Build string with file name minus extension - used later to determine EOF
strFileNameNoExtension = "A-" & yearStr & "-" & splitStr2(0)
' Create dictionary to hold key/value pairs - key = position; value = barcode
Set dictA = CreateObject("Scripting.Dictionary")
' Begin processing A file
Do Until objFile.AtEndOfStream(*****)
' Read a line
strLine = objFile.ReadLine(*****)
' Split on semi-colons
splitStr = Split(strLine, ";")
' If splitStr array contains more than 1 element then continue
If(UBound(splitStr) > 0) Then
' If barcode field is equal to file name then EOF
If(splitStr(6) = strFileNameNoExtension) Then
' End of file - exit loop
Exit Do
Else
' Add to dictionary
' To calculate position
' A = element(2) = position in row (1-16)
compA = splitStr(2)
' B = element(4) = row
compB = splitStr(4)
' C = element(5.1) = number of max positions in row
splitElement5 = Split(splitStr(5), "/")
compC = splitElement5(0)
' position = C * (B - 1) + A
position = compC * (compB - 1) + compA
barcode = splitStr(6) & ";" & splitStr(0) & ";" & splitStr(1) & ";" & splitStr(2)
'msgbox(position & ":" & barcode)
' Add to dictionary
dictA.Add CStr(position), barcode
End If
End If
Loop
' Close A file
objFile.Close
To give the exact answer, we may have to look at your text files(I mean with all the split functions you are using). But, If you just want to compare lines 2-97 of two text files, you can get a hint from the following piece of code:
strPath1 = "C:\Users\gr.singh\Desktop\abc\file1.txt" 'Replace with your File1 Path
strPath2 = "C:\Users\gr.singh\Desktop\abc\file2.txt" 'Replace with your File2 Path
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFile1 = objFso.OpenTextFile(strPath1,1)
Set objFile2 = objFso.OpenTextFile(strPath2,1)
blnMatchFailed = False
Do Until objFile1.AtEndOfStream
If objFile1.Line=1 Then
objFile1.SkipLine() 'Skips the 1st line of both the files
objFile2.SkipLine()
ElseIf objFile1.Line>=2 And objFile1.Line<=97 Then
strFile1 = objFile1.ReadLine()
strFile2 = objFile2.ReadLine()
If StrComp(strFile1,strFile2,1)<>0 Then 'textual comparison. Change 1 to 0, if you want binary comparison of both lines
blnMatchFailed = True
intFailedLine = objFile1.Line
Exit Do 'As soon as match fails, exit the Do while Loop
Else
blnMatchFailed = False
End If
Else
Exit Do
End If
Loop
If blnMatchFailed Then
MsgBox "Comparison Failed at line "&intFailedLine
Else
MsgBox "Comparison Passed"
End If
objFile1.Close
objFile2.Close
Set objFile1 = Nothing
Set objFile2 = Nothing
Set objFso = Nothing
I know there are a lot questions similar to this one but i couldn't find the right answer for me. I need to replace all phrases in xml file that starts and ends with % (e.g. %TEST% or %TEST-NEW% )
So far i have these tryouts:
This was my test one that works in the console but has only 1 line of string
zone = "<test>%TEST%</test>"
MsgBox zone
'Setting the regex and cheking the matches
set regex = New RegExp
regex.IgnoreCase = True
regex.Global = True
regex.Pattern = "%.+%"
Set myMatches = regex.execute(zone)
For each myMatch in myMatches
Wscript.echo myMatch
result = Replace(zone,myMatch,"")
next
MsgBox result
but when i try to do the same from a file with this...
Dim objStream, strData, fields
Set objStream = CreateObject("ADODB.Stream")
objStream.CharSet = "utf-8"
objStream.Open
objStream.LoadFromFile("C:\test\test.xml")
strData = objStream.ReadText()
Wscript.echo strData
set regex = New RegExp
regex.IgnoreCase = True
regex.Global = True
regex.Pattern = "%.+%"
Set myMatches = regex.execute(strData)
For each myMatch in myMatches
Wscript.echo myMatch
result = Replace(strData,myMatch,"")
next
Wscript.echo result
...the first echo returns correctly the contains of the file and then the second echo in the loop echoes all the matches that i need to replace , but the last echo return the same result as the first (nothing is being replaced)
The xml looks like this (just for example):
<script>%TEST%</script>
<value>%VALUE%</value>
<test>%TEST%</test>
P.S. I need to loop through xml files in a specific folder and replace the phrase from above. Can anyone help?
The final script that works for me(big thanks to Tomalak):
Option Explicit
Dim path, doc, node, placeholder,srcFolder,FSO,FLD,fil
Set placeholder = New RegExp
placeholder.Pattern = "%[^%]+%"
placeholder.Global = True
srcFolder = "C:\test"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FLD = FSO.GetFolder(srcFolder)
For each fil In FLD.Files
if LCase(FSO.GetExtensionName(fil.Name)) = "xml" Then
path = "C:\test\" & fil.Name
' 1. parse the XML into a DOM
Set doc = LoadXmlDoc(path)
' 2. select and modify DOM nodes
For Each node In doc.selectNodes("//text()|//#*")
node.nodeValue = SubstitutePlaceholders(node.nodeValue)
Next
' 3. save modified DOM back to file
doc.save path
End If
Next
' --------------------------------------------------------------------------
Function LoadXmlDoc(path)
Set LoadXmlDoc = CreateObject("MSXML2.DomDocument.6.0")
LoadXmlDoc.async = False
LoadXmlDoc.load path
If LoadXmlDoc.parseError.errorCode <> 0 Then
WScript.Echo "Error in XML file."
WScript.Echo LoadXmlDoc.parseError.reason
WScript.Quit 1
End If
End Function
' --------------------------------------------------------------------------
Function SubstitutePlaceholders(text)
Dim match
For Each match In placeholder.Execute(text)
text = Replace(text, match, GetReplacement(match))
Next
SubstitutePlaceholders = text
End Function
' --------------------------------------------------------------------------
Function GetReplacement(placeholder)
Select Case placeholder
Case "%TEST%": GetReplacement = "new value"
Case "%BLA%": GetReplacement = "other new value"
Case Else: GetReplacement = placeholder
End Select
End Function
' --------------------------------------------------------------------------
Never use regular expressions on XML files, period.
Use an XML parser. It will be simpler, the code will be easier to read, and most importantly: It will not break the XML.
Here is how to modify your XML document in the proper way.
Option Explicit
Dim path, doc, node, placeholder
Set placeholder = New RegExp
placeholder.Pattern = "%[^%]+%"
placeholder.Global = True
path = "C:\path\to\your.xml"
' 1. parse the XML into a DOM
Set doc = LoadXmlDoc(path)
' 2. select and modify DOM nodes
For Each node In doc.selectNodes("//text()|//#*")
node.nodeValue = SubstitutePlaceholders(node.nodeValue)
Next
' 3. save modified DOM back to file
doc.save path
' --------------------------------------------------------------------------
Function LoadXmlDoc(path)
Set LoadXmlDoc = CreateObject("MSXML2.DomDocument.6.0")
LoadXmlDoc.async = False
LoadXmlDoc.load path
If LoadXmlDoc.parseError.errorCode <> 0 Then
WScript.Echo "Error in XML file."
WScript.Echo LoadXmlDoc.parseError.reason
WScript.Quit 1
End If
End Function
' --------------------------------------------------------------------------
Function SubstitutePlaceholders(text)
Dim match
For Each match In placeholder.Execute(text)
text = Replace(text, match, GetReplacement(match))
Next
SubstitutePlaceholders = text
End Function
' --------------------------------------------------------------------------
Function GetReplacement(placeholder)
Select Case placeholder
Case "%TEST%": GetReplacement = "new value"
Case "%BLA%": GetReplacement = "other new value"
Case Else: GetReplacement = placeholder
End Select
End Function
' --------------------------------------------------------------------------
The XPath expression //text()|//#* targets all text nodes and all attribute nodes. Use a different XPath expression if necessary. (I will not cover XPath basics here, there are plenty of resources for learning it.)
Of course this solution uses regular expressions, but it does that on the text values that the XML structure contains, not on the XML structure itself. That's a crucial difference.
I have text files that are approximately 6MB in size. There are some lines that contain the NULL (Chr(0))character that I would like to remove.
I have two methods to do this: using Asc()=0 but this takes approximately 50s to complete, the other method uses InStr (line, Chr(0)) =0 (fast ~ 4sec)but the results remove vital info from the lines which contain the NULL characters.
First line of text file as example:
##MMCIBN.000NULL7NULL076059NULL7653NULL1375686349NULL2528NULL780608NULL10700NULL\NULL_NC_ACT.DIR\CFG_RESET.INI
First method (works but VERY slow)
function normalise (textFile )
Set fso = CreateObject("Scripting.FileSystemObject")
writeTo = fso.BuildPath(tempFolder, saveTo & ("\Output.arc"))
Set objOutFile = fso.CreateTextFile(writeTo)
Set objFile = fso.OpenTextFile(textFile,1)
Do Until objFile.AtEndOfStream
strCharacters = objFile.Read(1)
If Asc(strCharacters) = 0 Then
objOutFile.Write ""
nul = true
Else
if nul = true then
objOutFile.Write(VbLf & strCharacters)
else
objOutFile.Write(strCharacters)
end if
nul = false
End If
Loop
objOutFile.close
end function
The output looks like this:
##MMCIBN.000
7
076059
7653
1375686349
2528
780608
10700
\
_NC_ACT.DIR\CFG_RESET.INI
Second method code:
filename = WScript.Arguments(0)
Set fso = CreateObject("Scripting.FileSystemObject")
sDate = Year(Now()) & Right("0" & Month(now()), 2) & Right("00" & Day(Now()), 2)
file = fso.BuildPath(fso.GetFile(filename).ParentFolder.Path, saveTo & "Output " & sDate & ".arc")
Set objOutFile = fso.CreateTextFile(file)
Set f = fso.OpenTextFile(filename)
Do Until f.AtEndOfStream
line = f.ReadLine
If (InStr(line, Chr(0)) > 0) Then
line = Left(line, InStr(line, Chr(0)) - 1) & Right(line, InStr(line, Chr(0)) + 1)
end if
objOutFile.WriteLine line
Loop
f.Close
but then the output is:
##MMCIBN.000\CFG_RESET.INI
Can someone please guide me how to remove the NULLS quickly without losing information. I have thought to try and use the second method to scan for which line numbers need updating and then feed this to the first method to try and speed things up, but quite honestly I have no idea where to even start doing this!
Thanks in advance...
It looks like the first method is just replacing each NULL with a newline. If that's all you need, you can just do this:
Updated:
OK, sounds like you need to replace each set of NULLs with a newline. Let's try this instead:
strText = fso.OpenTextFile(textFile, 1).ReadAll()
With New RegExp
.Pattern = "\x00+"
.Global = True
strText = .Replace(strText, vbCrLf)
End With
objOutFile.Write strText
Update 2:
I think the Read/ReadAll methods of the TextStream class are having trouble dealing with the mix of text and binary data. Let's use an ADO Stream object to read the data instead.
' Read the "text" file using a Stream object...
Const adTypeText = 2
With CreateObject("ADODB.Stream")
.Type = adTypeText
.Open
.LoadFromFile textFile
.Charset = "us-ascii"
strText = .ReadText()
End With
' Now do our regex replacement...
With New RegExp
.Pattern = "\x00+"
.Global = True
strText = .Replace(strText, vbCrLf)
End With
' Now write using a standard TextStream...
With fso.CreateTextFile(file)
.Write strText
.Close
End With
I tried this method (update2) for reading a MS-Access lock file (Null characters terminated strings in 64 byte records) and the ADODB.Stream didn't want to open an already in use file. So I changed that part to :
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(Lfile)
z = f.Size
set ts = f.OpenAsTextStream(ForReading, 0) 'TristateFalse
strLog = ts.Read(z)
ts.Close
set f = nothing
' replace 00 with spaces
With New RegExp
.Pattern = "\x00+"
.Global = True
strLog = .Replace(strLog, " ")
End With
' read MS-Access computername and username
for r = 1 to len(strLog) step 64
fnd = trim(mid(strLog,r, 32)) & ", " & trim(mid(strLog,r+32, 32)) & vbCrLf
strRpt = strRpt & fnd
next
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