How to pass variables into VBScript with array - vbscript

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), ",")

Related

Skip some text from line

I need to remove some text from lines:
strdir = "C:\texto.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFile = fso.OpenTextFile(strdir)
Dim arrTxt()
k = 0
Do Until objFile.AtEndOfStream
z = (k+1)
ReDim Preserve arrTxt(z)
line = objFile.ReadLine
arrTxt(k) = line
k = z
Loop
print Join(arrTxt, ",")
print (UBound(arrTxt) + 1)
My text file texto.txt:
name=test
correo=test#test.tst
I want remove "name=" and "correo=".
#Cid showcased how you can use the power of Split/Join to achieve what you want. I am going to demonstrate how you can harness the power of RegEx to achieve similar result without having to read one line at a time.
Assuming your text file looks like this
strdir = "C:\texto.txt"
Set objFSO = CreateObject("Scripting.filesystemobject")
Set objFile = objFSO.OpenTextFile(strdir)
strContent = objFile.ReadAll
objFile.Close
msgbox RemoveLines(strContent)
Function RemoveLines(str)
Dim objRegEx
Set objRegEx = New RegExp
With objRegEx
.Global = True
.Pattern = "^name=.*\n|^correo=.*\n"
.Multiline = True
End With
RemoveLines = objRegEx.Replace(str, "")
End Function
Output
I'd split each lines using = as delimiter and then, I'd check if the first element is name or correo.
strdir = "C:\texto.txt"
Set fso = createobject("Scripting.filesystemobject")
Set objFile = fso.OpenTextFile(strdir)
Dim arrTxt()
k = 0
Do until objFile.AtEndOfStream
z = (k+1)
ReDim preserve arrTxt(z)
line = objFile.ReadLine
myArray = Split(line, "=")
If (Not ((UBound(myArray) > 0) AND (myArray(0) = "name" OR myArray(0) = "correo"))) Then
arrTxt(k) = line
k = z
End If
loop
print Join(arrTxt,",")
print (Ubound(arrTxt) + 1)
With vba - The initial idea is to make the code understandable for a human - the code has the following 3 tasks:
Read from a file and save the input as a string;
Manipulate the string (e.g. replace the name= and correo=;
Write the manipulated string to a new file;
All these actions are noticeable in the TestMe():
Sub TestMe()
Dim readTxt As String
Dim filePath As String: filePath = "C:\text.txt"
readTxt = ReadFromFile(filePath)
readTxt = Replace(readTxt, "name=", "")
readTxt = Replace(readTxt, "correo=", "")
WriteToFile filePath, readTxt
End Sub
Once the bone above is ready, the two functions ReadFromFile and WriteToFile are quite handy:
Public Function ReadFromFile(path As String) As String
Dim fileNo As Long
fileNo = FreeFile
Open path For Input As #fileNo
Do While Not EOF(fileNo)
Dim textRowInput As String
Line Input #fileNo, textRowInput
ReadFromFile = ReadFromFile & textRowInput
If Not EOF(fileNo) Then
ReadFromFile = ReadFromFile & vbCrLf
End If
Loop
Close #fileNo
End Function
Sub WriteToFile(filePath As String, text As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = fso.CreateTextFile(filePath)
oFile.Write text
oFile.Close
End Sub

Read file names into an array or dictionary for use as a user input

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

vbscript - unable to extract a number from text file

I would like to check a txt file for a string.
If the string doesn't exist, it takes a number from key.txt and write it in another file. That part works fine.
But when the string is found, I would like to read the first five characters into a variable and take this variable to creating xml. When I run my script and the string is found.... the xml element Key is empty...
Anyone can help me? Thanks
Dim FSSys, Reference, corp, Account, intCorp, strPK, FS
Set FSSys = Wscript.CreateObject("Scripting.FileSystemObject")
Set Reference = FSSys.OpenTextFile("C:\corpreferenz.txt")
intCorp = Reference.ReadAll
Reference.Close
intCorp = intCorp + 1
Set corp = FSSys.CreateTextFile("C:\corpreferenz.txt")
corp.Write intCorp
corp.Close
Const FORREADING = 1
Const FORWRITING = 2
Const FORAPPENDING = 8
Dim sToSearch: sToSearch = "Test"
Dim sFileName: sFileName = "C:\Account.txt"
Dim sContent, Found, TxtFile
If Not FSSys.FileExists(sFileName) Then
MsgBox "File Not Found"
WScript.Quit 0
End If
Set TxtFile = FSSys.OpenTextFile(sFileName,FORREADING)
sContent = TxtFile.ReadAll
If InStr(sContent,sToSearch) Then
Found = True
while not TxtFile.AtEndOfStream
sTemp = TxtFile.ReadLine
If Instr(1,sTemp,sToSearch)>0 then
strPK = strPK + sTemp
FS = Left(strPK, 5)
End If
Wend
End If
Set TxtFile = Nothing
If Not Found Then
Set PKNumber = FSSys.OpenTextFile("C:\Key.txt")
intPKNumber = PKNumber.ReadAll
PKNumber.Close
intPKNumber = intPKNumber + 1
Set PKNum = FSSys.CreateTextFile("C:\Key.txt")
PKNum.Write intPKNumber
PKNum.Close
FS = intPKNumber
Set TxtFile = FSSys.OpenTextFile(sFileName,FORAPPENDING)
TxtFile.WriteLine intPKNumber & " " & sToSearch
End If
'Create XML
set xml = CreateObject("Microsoft.XMLDOM")
set encoding = xml.createProcessingInstruction("xml", "version='1.0'")
xml.insertBefore encoding, xml.childNodes.Item(0)
set foo = xml.createElement("XML")
set bar = xml.createElement("Table")
set corp = xml.createElement("Corp")
set cdata = xml.createCDATASection(intCorp)
set konto = xml.createElement("Key")
set cdata1 = xml.createCDATASection(FS)
corp.appendChild cdata
bar.appendChild corp
konto.appendChild cdata1
bar.appendChild konto
foo.appendChild bar
xml.appendChild(foo)
xmlSave xml, "C:BUP.xml"
'Function for XML
function xmlSave(xml, filename)
set rdr = CreateObject("MSXML2.SAXXMLReader")
set wrt = CreateObject("MSXML2.MXXMLWriter")
Set oStream = CreateObject("ADODB.STREAM")
oStream.Open
oStream.Charset = "ISO-8859-1"
wrt.indent = True
wrt.encoding = "ISO-8859-1"
wrt.output = oStream
Set rdr.contentHandler = wrt
Set rdr.errorHandler = wrt
rdr.Parse xml
wrt.flush
oStream.SaveToFile filename, 2
end function
After
sContent = TxtFile.ReadAll
you (the read pointer) are at the end of the file; TxtFile.AtEndOfStream is True and TxtFile.ReadLine won't be called/would fail. Evidence:
>> Set f = CreateObject("Scripting.FileSystemObject").OpenTextFile(WScript.ScriptFullName)
>> WScript.Echo 0, CStr(f.AtEndOfStream)
>> s = f.ReadAll()
>> WScript.Echo 1, CStr(f.AtEndOfStream)
>>
0 Falsch (False)
1 Wahr (True)
You could loop over the lines of the file (Split() sContent on vbCrLf), or - better - use a RegExp on sContent to extract the data needed.

Need to write values in Excel from an array using vbscript

I need to store values from excel into array using vbscript, I then need to write distinct values from this array to some other excel. From the below scipt I am able to write excel values into array and display it in message box, however I need to write it in another excel. I am getting the error- "Type Mismatch 'Join'" at line 31. Could someone please look into it and assist, Thanks in Advance.
Dim MyArray()
Dim UniqValues
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("D:\Read Excel.xls")
objExcel.Visible = True
objExcel.displayalerts = false
i = 1
x = 0
Do Until objExcel.Cells(i, 1).Value = ""
ReDim Preserve MyArray(x)
MyArray(x) = objExcel.Cells(i, 1).Value
i = i + 1
x = x + 1
Loop
Set objExcel2 = CreateObject("Excel.Application")
strPathExcel = "D:\file1.xls"
objExcel2.Workbooks.open strPathExcel
Set oSheet = objExcel2.ActiveWorkbook.Worksheets(1)
oSheet.Cells(1,1).Value = Join(UniqValues)
'WScript.Echo Join(MyArray)
UniqValues = uniqFE(MyArray)
'WScript.Echo Join(UniqValues)
Function uniqFE(fex)
Dim dicTemp : Set dicTemp = CreateObject("Scripting.Dictionary")
Dim xItem
For Each xItem In fex
dicTemp(xItem) = 0
Next
uniqFE = dicTemp.Keys()
End Function
objExcel.Save
objExcel.Quit
Your UniqValues is not initialized wheb you try to Join it:
>> Dim UniqValues
>> X = Join(UniqValues)
>>
Error Number: 13
Error Description: Type mismatch
Call uniqFE() before you assign/display it.

vbscript, find matches in filenames

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

Resources