How to read every 20 lines from a text file using vbscript? - vbscript

I have 180 lines in a text file and want to read every 20 lines (1-20, 21-40...)
Here is my current code:
Const ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile("C:\Bess_Automation\EditFiles\TSTVLD1.txt", ForReading)
'Reading the count of lines
objTextFile.ReadAll
strLinecount=objTextFile.Line
msgbox strLinecount
strnumoftimes=Round((strLinecount/20),0)
msgbox strnumoftimes

Here's how I'd approach the problem. This code sets the number of lines to be read at a time initially then opens the file for reading and sets up an array. While we're not finished reading the file, we add a line from it to myArray.
When we hit a multiple of 20 lines read, we report that and do whatever we need to with those 20 lines (in my case, I've just echoed them to the screen, separated by semicolons).
Then we reset the array to be empty again and repeat until all the file has been read, then output the final batch of lines (as otherwise they'd be ignored since we only do anything with batches of 20 in the example).
Option Explicit
Const LINES_TO_READ = 20
Dim iLines, iTotalLines
Dim oFso : Set oFso = CreateObject("Scripting.FileSystemObject")
Dim oFile : Set oFile = oFso.OpenTextFile("C:\temp\mytextfile.txt", 1)
Dim myArray()
ReDim myArray(0)
iLines = 0
iTotalLines = 0
While Not oFile.AtEndOfStream
myArray(UBound(myArray)) = oFile.ReadLine
iLines = iLines + 1
ReDim Preserve myArray(UBound(myArray)+1)
If iLines Mod LINES_TO_READ = 0 Then
WScript.Echo iLines & " read now."
' do anything you like with the elements of myArray here before we reset it to empty
WScript.Echo Join(myArray, ";")
' reset array to be totally empty again
ReDim myArray(0)
End If
Wend
WScript.Echo "Final Lines: " & Join(myArray, ";")
WScript.Echo "Total lines in file: " & iLines

Related

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

How to correct VBscript runtime error: input past end of file

I'm getting the following error for this code. Please could you advise where it is wrong? Line 71 is "urls2 = objInputFile.ReadAll".
Line 71
Character 1
Error: Input past end of file
Code: 800A003E
Source: Microsoft VBScript runtime error.
inputfile = "C:\Evernote.html"
outputfolder = "c:\"
msgbox("launched. press ok to continue")
'create urls1.txt
Set objFileSystem = CreateObject("Scripting.fileSystemObject")
Set objOutputFile = objFileSystem.CreateTextFile(outputfolder & "urls1.txt", TRUE)
'read inputfile (evernote exported html)
Set objFileSystem = CreateObject("Scripting.fileSystemObject")
Set objInputFile = objFileSystem.OpenTextFile(inputfile, 1)
html = objInputFile.ReadAll
objInputFile.Close
'split html var
html = Split(html, "<tr><td><b>Source:</b></td><td><a href=""")
'loop through html array and clean up the results so you get just the urls
'and write them to urls1.txt
For i = 1 To UBound(html)
checkA = InStr(html(i), """")
if checkA > 1 then
html(i) = Split(html(i), """")
urls = html(i)(0)
objOutputFile.WriteLine(urls)
end if
Next
'remove duplicates
'create urls2.txt
Set objFileSystem = CreateObject("Scripting.fileSystemObject")
Set objOutputFile = objFileSystem.CreateTextFile(outputfolder & "urls2.txt", TRUE)
'read urls1.txt and remove duplicates and write results to urls2.txt
Set objFS = CreateObject("Scripting.FileSystemObject")
strFile = outputfolder & "urls1.txt"
Set objFile = objFS.OpenTextFile(strFile)
Set d = CreateObject("Scripting.Dictionary")
Do Until objFile.AtEndOfStream
strLine = objFile.ReadLine
If Not InStr(strLine,"--------") >0 Then
If Not d.Exists(strLine) Then
d.Add strLine , 0
End If
End If
Loop
x=d.Items
For Each strKey In d.keys
objOutputFile.WriteLine(strKey)
Next
'sort alphabetically
'read urls2.txt and sort everything alphabetically
'read urls2.txt
Set objFileSystem = CreateObject("Scripting.fileSystemObject")
Set objInputFile = objFileSystem.OpenTextFile(outputfolder & "urls2.txt", 1)
urls2 = objInputFile.ReadAll
objInputFile.Close
'split each line into array
urls2 = Split(urls2, VBCrLf)
'sort urls2 array by alphabet with bubble sort method
For i = (UBound(urls2) - 1) to 0 Step -1
For j= 0 to i
If UCase(urls2(j)) > UCase(urls2(j+1)) Then
strHolder = urls2(j+1)
urls2(j+1) = urls2(j)
urls2(j) = strHolder
End If
Next
Next
'write the sorted version of urls2.txt in urlsfinal.txt
'create urlsfinal.txt
Set objFileSystem = CreateObject("Scripting.fileSystemObject")
Set objOutputFile = objFileSystem.CreateTextFile(outputfolder & "urlsfinal.txt", TRUE)
'write all sorted vars from urls2 array to urlsfinal.txt
For i = 0 to UBound(urls2)
objOutputFile.WriteLine(urls2(i))
next
msgbox("all done")
The problem is your source file urls2.txt is empty. The reason for this is you are not closing your files after you write to them. You need to add this after you have finished writing out to urls1.txt and urls2.txt.
objOutputFile.Close
Also, you don't need to continually recreate the instance of objFileSystem every time you access the files. You can instantiate it once at the top.
Be sure to be a good memory citizen and destroy all objects you set in your code.
Set objFileSystem = Nothing

Append text to text file if it already exists

I have a script which is working, to replace some characters in a fixed width file (starting from row 2 onward).
What want to avoid overwriting the target file if it already exists. Instead, if it exists, to append the rows (from row 2 onwards of the source file) to the end of the target file. I am struggling to find a thread with a proper suggestion. This is the current code:
Dim objFSO
dim objFile
dim thisLine
Set objFSO = CreateObject("Scripting.FileSystemObject")
If (objFSO.FileExists("C:\Users\Dimitar\Desktop\BPSDRC\PAYBOTH.dat")) Then
Set objFile = objFSO.GetFile("C:\Users\Dimitar\Desktop\BPSDRC\PAYBOTH.dat")
Else
WScript.Quit()
End If
If objFile.Size > 0 Then 'make sure the input file is not empty
Set inputFile = objFSO.OpenTextFile("C:\Users\Dimitar\Desktop\BPSDRC\PAYBOTH.dat", 1) 'Replace the filename here
set outputFile = objFSO.CreateTextFile("C:\Users\Dimitar\Desktop\BPSDRC\PAYIMP.dat", TRUE) 'replace it with output filename
' first line - leave it as it is
thisLine = inputFile.ReadLine
newLine = thisLine
outputFile.WriteLine newLine
'all remaining lines - read them and replace the middle part with 18 zeroes
do while not inputFile.AtEndOfStream
thisLine = inputFile.ReadLine ' Read an entire line into a string.
'the zeroes are to fix issue N1 (payment in other amt)
'the CDF are to fix issue N2 (payment in local amt)
newLine = mid(thisLine,1,47) & "000000000000000000" & mid(thisLine,66,121) & "CDF" & mid(thisLine,190)
outputFile.WriteLine newLine
loop
inputFile.Close
outputFile.Close
objFSO.DeleteFile "C:\Users\Dimitar\Desktop\BPSDRC\PAYBOTH.dat"
end if
Open the file for appending
Option Explicit
Const ForReading = 1, ForAppending = 8
Dim inputFileName, outputFileName
inputFileName = "C:\Users\Dimitar\Desktop\BPSDRC\PAYBOTH.dat"
outputFileName = "C:\Users\Dimitar\Desktop\BPSDRC\PAYIMP.dat"
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists( inputFileName ) Then
WScript.Quit
End If
If fso.GetFile( inputFileName ).Size < 1 Then
WScript.Quit
End If
Dim newFile, inputFile, outputFile
newFile = Not fso.FileExists( outputFileName )
Set inputFile = fso.OpenTextFile( inputFileName, ForReading )
Set outputFile = fso.OpenTextFile( outputFileName, ForAppending, True )
Dim lineBuffer
lineBuffer = inputFile.ReadLine()
If newFile Then
outputFile.WriteLine lineBuffer
End If
Do While Not inputFile.AtEndOfStream
lineBuffer = inputFile.ReadLine
lineBuffer = mid(lineBuffer,1,47) & "000000000000000000" & mid(lineBuffer,66,121) & "CDF" & mid(lineBuffer,190)
outputFile.WriteLine lineBuffer
Loop
inputFile.Close
outputFile.Close
fso.DeleteFile inputFileName

ASP/VB Classic clear a line from a file

I have a file that looks like this:
Alpha,25,SomeBrand,Info
Gamma,2039,Crisps,Foobar
Epic,240,Win,Post
And I want to clear a certain line in this file, say line 2, so that it looks like this:
Alpha,25,SomeBrand,Info
Epic,240,Win,Post
How can I efficiently do this? This file has over 18000 lines, and I've tried reading in the complete file and writing back, but it was way too slow.
I don't know what is your file size but i've written a script (asp) is executed within 2.5 seconds.
Text file size is 35 million bytes and it has 35,000 lines.
Here:
<%#Language = VBScript %>
<%
Option Explicit
Dim oFso, oFile, arrLns, arrLNums, strOut, e
arrLNums = Array(15) '15th [and nnth] line(s) will be cleared
Set oFso = CreateObject("Scripting.FileSystemObject")
Set oFile = oFso.OpenTextFile("C:\old.txt", 1)
strOut = Replace(oFile.ReadAll(), vbCr, "")
arrLns = Split(strOut, vbLf)
For Each e In arrLNums : arrLns(e - 1) = "" : Next
strOut = Join(arrLns, vbCrLf)
oFso.CreateTextFile("C:\cleared.txt", True)_
.Write(strOut) 'Saved
oFile.Close
Set oFile = Nothing
Set oFso = Nothing
%>
As you can't use file pointer moving tricks to change the file 'on disk' in VBScript, you'll have to re-write it. Did you test whether using .ReadAll() and .Write is 'fast enough' for you? If yes, we could discuss a way to do the modifying efficiently. First question: Do you want to delete the offending line, or should it be replaced with an empty one?
Next Step:
This VBScript code:
Dim goFS : Set goFS = CreateObject( "Scripting.FileSystemObject" )
Dim sDir : sDir = "..\testdata\editlargefile"
Dim sSrcFSpec : sSrcFSpec = goFS.BuildPath( sDir, "lines.txt" )
Dim nLine : nLine = 5
Dim nSize : nSize = goFS.GetFile( sSrcFSpec ).Size
WScript.Echo nSize, "bytes in", sSrcFSpec
ReDim aHead( nLine - 2 )
Dim oTS, nIdx, sTail
Set oTS = goFS.OpenTextFile( sSrcFSpec )
For nidx = 0 To UBound( aHead )
aHead( nIdx ) = oTS.ReadLine()
Next
oTS.ReadLine
sTail = oTS.ReadAll()
oTS.Close
WScript.Echo Left( Join( aHead, vbCrLf ) & vbCrLf & vbCrLf & Left( sTail, 100 ), 150 )
Set oTS = goFS.CreateTextFile( sSrcFSpec, True )
oTS.Write Join( aHead, vbCrLf )
oTS.Write vbCrLf & vbCrLf
oTS.Write sTail
oTS.Close
output:
20888896 bytes in ..\testdata\editlargefile\lines.txt
This is line 1
This is line 2
This is line 3
This is line 4
This is line 6
This is line 7
This is line 8
This is line 9
This is line 10
Thi
=====================================================
xplfs.vbs: Erfolgreich beendet. (0) [11.42188 secs]
demonstrates the fastest VBScript way I can think of. The pseudo code
for a language able to do file pointer tricks would be
Open the file in read+write mode
Loop over the head lines to keep
If Delete
Skip line to delete
Reset write file pointer to end of previous line
Block write to file pointer till end
Else
Fill line to delete with spaces
End
Close the file
What language do you plan to use?

how to read text file word by word in VB script?

how to read text file word by word in VB script? please give all possible functions.
This:
Dim sAll : sAll = readAllFromFile("..\data\wbw.txt")
WScript.Echo sAll
WScript.Echo "-----------------------"
Dim oRE : Set oRE = New RegExp
oRE.Global = True
oRE.Pattern = "\w+"
Dim oMTS : Set oMTS = oRE.Execute(sAll)
Dim oMT
For Each oMT In oMTS
WScript.Echo oMT.Value
Next
Output:
===============================================================================
How to read text file word by word in VB script?
Please give all possible functions.
First, read the file line-by-line into an array. Then, when you're reading
through the array, parse each line word-by-word. As such:
-----------------------
How
to
read
text
file
word
by
word
in
VB
script
Please
give
all
possible
functions
First
read
the
file
line
by
line
into
an
array
Then
when
you
re
reading
through
the
array
parse
each
line
word
by
word
As
such
===============================================================================
avoids all the atrocities of Zomgie's solution:
Not usable with Option Explicit
Useless Dim of fixed array of no size
Useless array of lines
Costly ReDim Preserve with extra counter
Useless variable inputText
Split on " " makes "First," a word
First, read the file line-by-line into an array. Then, when you're reading through the array, parse each line word-by-word. As such:
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("c:\file.txt", ForReading)
Const ForReading = 1
Dim arrFileLines()
i = 0
Do Until objFile.AtEndOfStream
Redim Preserve arrFileLines(i)
arrFileLines(i) = objFile.ReadLine
i = i + 1
Loop
objFile.Close
For Each strLine in arrFileLines
inputText = strLine
outputArray = Split(inputText)
For Each x in outputArray
WScript.Echo "Word: " & x
Next
Next

Resources