I'm experimenting with bitmaps in VBScript, writing them to file and opening them with the default application. See https://github.com/antonig/vbs/tree/master/VBScript_graphics
The slowest part is in writing the pixels from an array to a byte string then to the file. I'm presently using this classic snippet to convert long values to 4 byte strings:
function long2str(byval k)
Dim s
for i=1 to 4
s= chr(k and &hff)
k=k\&h100
next
End function
I wondered if I could make the conversion faster using just two chrw() in the place of the four chr(). To my dismay i learned chrw takes a signed short integer. Why so??. So the code has to deal with the highest bits separately. This is what I tried but it does'nt work:
function long2wstr(byval x)
dim k,s
k=((x and &h7fff) or (&H8000 * ((x and &h8000) <>0 )))
s=chrw(k)
k=((x and &h7fff0000)\&h10000 or(&H8000 * (x<0)))
s=s & chrw(k)
long2wstr=s
end function
'test code
for i=0 to &hffffff
x=long2wstr(i)
y=ascw(mid(x,1,1))+&h10000*ascw(mid(x,2,1))
if i<>y then wscript.echo hex(i),hex(y)
next
wscript.echo "ok" 'if the conversion is correct the program should print only ok
Can you help me?
Today I can answer my own question. To write binary data to a file two bytes at a time is possible. The bad news is the increase of speed is just marginal. Here is a demo code, the solution was about adding some & sufixes to the hex values in my original code.
fn=CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2)& "\testwchr.bmp"
Function long2wstr( x) 'falta muy poco!!!
Dim k1,k2,x1
k1=((x And &h7fff) Or (&H8000& And ((X And &h8000&)<>0)))
k2=((X And &h7fffffff&) \ &h10000&) Or (&H8000& And ((X And &h80000000&) <>0 ))
long2wstr=chrw(k1) & chrw(k2)
End Function
Function wstr2long(s)
x1=AscW(mid(s,1,1))
xx1=x1-(65536 *(x1<0))
x2=AscW(mid(s,2,1))
wstr2long=x2*65536+xx1
End Function
Function rndlong() rndlong=CLng(4294967296* rnd()-2147483648+256*rnd) :End Function
Dim a(1000)
With CreateObject("ADODB.Stream")
.Charset = "UTF-16LE" 'o "UTF16-BE"
.Type = 2' adTypeText
.open
Randomize timer
For I=0 To 1000
a(i)=rndlong
.writetext long2wstr(a(i))
Next
.savetofile fn,2
.close
'now read the file to see if ADODB has changed anything
.open
.loadfromfile fn
.position=2 'skip bom
cnt=0
For I=0 To 1000
j= wstr2long(.readtext (2))
If j<>a(i) Then WScript.Echo a(i),j:cnt=cnt+1
Next
WScript.Echo cnt 'should print 0
.close
End With
Related
I ran the below code looped for 6.5 thousand cells of criteria which are looked up against the range contained on the "LISTS" tab refered to. This range is some 20 thousand rows.
I ran the code numerous times yesterday in a test file and it ran very quickly. Maybe 2 minutes: if that.
Today, after deciding I was happy with the code, I've PASTED it (caps there because I'm wondering if that has something to do with it) into my main project.
Now when I run the code, it takes 2 hours plus!
I didn't change any of the code except for sheet names.
Does anyone know of any reason for this that I'm missing?
I'm new to VBA so I'm suspecting it's some rookie error somewhere!
Dim x As Long
x = WorksheetFunction.CountA(Columns(1))
'define string length for CELL loop
Dim char As Integer
char = Len(ActiveCell)
'define cell loop name
Dim counter As Integer
'Begin RANGE loop
For Each cell In Range("b1:b" & x)
cell.Activate
'Incorporate CELL loop
For counter = 1 To char
'Determine if numeric value present in cell = TRUE or FALSE
If IsNumeric(Right(Mid(ActiveCell, 1, counter), 1)) = True Then
ActiveCell.Offset(0, 1).Value = Right(ActiveCell.Offset(0, 0), Len(ActiveCell.Offset(0, 0)) - counter + 1)
Exit For
Else
ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(0, 0)
End If
Next
Next
Try the code below, explanations inside the code's comments:
Dim x As Long
Dim char As Long 'define string length for CELL loop
Dim counter As Long 'define cell loop name
x = WorksheetFunction.CountA(Columns(1))
Application.ScreenUpdating = False ' will make your code run faster
Application.EnableEvents = False
'Begin RANGE loop
For Each cell In Range("b1:b" & x)
'cell.Activate ' <--- no need to Activate, realy slows down your code
'Incorporate CELL loop
For counter = 1 To char
'Determine if numeric value present in cell = TRUE or FALSE
If IsNumeric(Right(Mid(cell.Value, 1, counter), 1)) = True Then
cell.Offset(0, 1).Value = Right(cell.Value, Len(cell.Value) - counter + 1)
Exit For
Else
cell.Offset(0, 1).Value = cell.Value
End If
Next counter
Next cell
Application.ScreenUpdating = True
Application.EnableEvents = True
You need to avoid the ActiveCell, as far as it slows your code. You are looping with for-each thus you can use the variable in the loop like this:
For Each cell In Range("b1:b" & x)
For counter = 1 To char
If IsNumeric(Right(Mid(cell, 1, counter), 1)) = True Then
cell.Offset(0, 1).Value = Right(cell, Len(cell) - counter + 1)
Exit For
Else
cell.Offset(0, 1) = cell.Offset(0, 0)
End If
Next
Next
Furthermore, things like cell.Offset(0, 0) are a bit useless. If you do not need Offset, do not write it. And in general:
How to avoid using Select in Excel VBA
How To Speed Up VBA Code
Thanks to everyone who took the time to post on this one.
Turns out I'm an IDIOT!!!
The first time I ran the code, I dsiabled autocalculation, and all this time when I was re-running it, I'd commented it out.
I'm new to VBA but there's no excuse for that! Agh!
So, the fix (as suggested by others on the thread):
enter before main body of the macro:
Application.Calculation = xlCalculationManual
then after the macro, enter:
Application.Calculation = xlCalculationAutomatic
I am working on VB Script and I am trying to read the txt file and sore it in a array.
I check for the number of lines and use that variable for the For loop.
I am getting an error Input past end of the file.
I am not sure how to solve this problem.
looking forward for your help.
Thank you!!
Dim num As Integer
'Skip lines one by one
Do While objTextFile.AtEndOfStream <> True
objTextFile.SkipLine ' or strTemp = txsInput.ReadLine
Loop
num = objTextFile.Line - 1
Dim para()
ReDim para(num)
For i = 1 To num
para(i) = objTextFile.ReadLine
Next
For two reasons (the second coming intp play if you fix the first):
You have already read the file to the end. You would need to reset or reopen it.
You are always reading 125 lines, regardless of how many lines you found.
You can read the lines and put them in the array in one go:
Dim para()
Dim num As Integer = 0
Do While Not objTextFile.AtEndOfStream
ReDim Preserve para(num)
para(num) = txsInput.ReadLine
num = num + 1
Loop
Note: Arrays are zero based, and the code above places the first line at index 0. If you place the data from index 1 and up (as in the original code) you leave the first item unused, and you have to keep skipping the first item when you use the array.
Edit:
I see that you changed 125 to num in the code, that would fix the second problem.
I've used the following style code which is fast for small files:
Const ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(strList, ForReading)
strText = objTextFile.ReadAll
objTextFile.Close
arrList = Split(strText, vbCrLf)
I have 250.000 rows and I wanted to erase all rows that have a 0 in col AR. This takes too much time using a filter and deleting only visible cells, so I wrote a code. But still takes 1 minute for 1000 lines. So I will have to take 250 minutes!!! Besides after the first 6 minutes (6k lines) the number showed in AS3 (see code below) freezes, so I don't know if it's still running.
Is there a way to do this more efficiently (using less time)?
My code is:
Sub delrow()
Application.Calculation=xlCalculationManual
With Sheets("bners")
LR3 = Range("A" & Rows.Count).End(xlUp).Row
For i3 = 3 To LR3
range("AS2")=i3
a = Sheets("bners").Range("AR" & i3).Value
If a = 0 Then
Rows(i3).Delete
Else
End If
Next i3
End With
Application.calculate
End Sub
thanks!
Yes, definitely Step -1. But does that alone make it fast?
This batches the deletes 10 at a time (if needed now).
Option Explicit
Dim ws as Range
Sub delrow1()
Dim LR3&, i3&, a&
Set ws = Sheets("bners")
LR3 = ws.Range("A" & Rows.Count).End(xlUp).Row
For i3 = LR3 To 3 Step -1
a = ws.Cells(i3, "AR").Value
If a = 0 Then
Call delrow2(i3)
End If
Next i3
Call delrow2(0) ' flush
End Sub
Sub delrow2(delRow&) ' deletes 10 rows at a time
Static a1&(10), na1&
Dim i1&, zRange As Range
If delRow = 0 Then ' finish;end;flush
For i1 = 1 To na1
ws.Rows(a1(i1)).Delete
Next i1
na1 = 0
Else ' store row in array a1
na1 = na1 + 1
a1(na1) = delRow
If na1 = 10 Then ' del 10 rows
Set zRange = Union( _
Rows(a1(1)), Rows(a1(2)), Rows(a1(3)), Rows(a1(4)), Rows(a1(5)), _
Rows(a1(6)), Rows(a1(7)), Rows(a1(8)), Rows(a1(9)), Rows(a1(10)))
ws.Range(zRange).Rows.Delete
na1 = 0
End If
End If
I liked this method I found a couple weeks ago but didn't remember until last night http://goo.gl/NYtY9R that could easily be adapted for yours
Sub RowKiller()
Dim F As Range, rKill As Range
Set F = Range("A2:A250000")
Set rKill = Nothing
For Each r In F
v = r.Text
If InStr(1, v, "0") = 1 Then
If rKill Is Nothing Then
Set rKill = r
Else
Set rKill = Union(r, rKill)
End If
End If
Next r
If Not rKill Is Nothing Then
rKill.EntireRow.Delete
End If
End Sub
To me very efficient in that it builds up into the Union and then deletes all at once instead of deleting one at a time.
in the example , you with sheets() is totally useless, as you forgot every dot "." before the words cells or range or rows.
I'll try an other approach, by using two VBA arrays (not tested, and might memory overflow).
first array is original data before the macro.
second array is data after the macro
I won't delete rows, i just write my second array from the good lines of the 1rst array,
and then paste it over the sheet
Sub RowKill()
'Declaring Variables :
Dim MaxRows as long 'number of lines in the First Array
Dim NewRows as Long 'number of lines in the Second Array
Dim q as long 'simple loop counter
Dim i as long 'simple loop counter , for the purpose of copying line
Dim Rg As Range 'Range of the original Data (number of lines = MaxRows-2, because the Original example code starts at 3, not 1)
Dim Sh as Worksheet
Dim Array1() as variant 'First VBA Array
Dim Array2() as variant 'Second VBA Array
with Application
.enableevents=false
.screnupdating=false
.Calculation=xlCalculationManual
end with
set Sh=thisworkbook.Sheets("bners")
with Sh
MaxRows = .Range( .Rows.Count , 44).End(xlUp).Row ' note the .rows, and i read on cloumn 44 and not 1
Set Rg = .Range( .cells(3,44) , .cells ( MaxRows,44) ) '44 is the column of .range("AR")
'The Range Rg is important , later we delete the whole thing ^^
Redim Array1 ( 1 to MaxRows, 1 to 44) 'Only if "AR" is your last column
Array1 = Rg.value2 'if you work with dates or time format in your cells, please replace by : Array1 = Rg.value
for q= 3 to MaxRows
if Array1 (q , 44) <> 0 Then 'wasn't sure, because empty cells will trigger too, in wich case: <>"" would be better, or: If not IsEmpty( Array1 (q,44)) .....
call CopyRowToSecondArray ( q , NewRows , Array2)
End If
next q
End With 'Sh
'Rg.delete 'old version
With Sh
.range ( .cells(1,1) , .cells (44 , NewRows).Value2 = Array2 ' again use .value, if you have date or time formating inside the data cells
if NewRows<MaxRows then .range ( .cells(1,NewRows+1) , .cells (44 , MaxRows).Value2 = ""
End with
with Application
.enableevents= True
.screnupdating= True
.Calculation=xlCalculationAutomatic
end with
Set Rg = Nothing
Ser Sh = Nothing
Erase Array1, Array 2
End Sub
Sub CopyRowToSecondArray ( byval q as long , byref NewRows as long , byref Array2 as variant)
Dim i as long
NewRows=NewRows+1
Redim Preserve Array2 (1 to NewRows, 1 to 44)
for i = 1 to 44 'this entire for i loop, might be faster with unknown vba array function (i'm new), please share with me
Array2 ( NewRows , i) = Array1 ( q , i )
next i
end sub
Maybe there is a better way to simply copy a whole line from one array to an other, i don't know...
The code is untested, and , I assumed 44 is the last column (change only in loops and Rg if needed), so copy your work before testing my code.
Hope this helps, and is faster.
I want to load the ascii code of all letters and digits in first n bytes (100000 for example) of a binary file into an array. I wrote this code:
Option Explicit
Dim i, lCharCount, lFileByte, lFileArray(99999)
Dim oFSO, oStream, sInFileName
'Validate input command line
If WScript.Arguments.Count < 1 Then
MsgBox "No input file has been specified!", vbExclamation, "My Script"
WScript.Quit
End If
sInFileName = WScript.Arguments(0)
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oStream = oFSO.OpenTextFile(sInFileName, 1)
Do While Not oStream.AtEndOfStream
lFileByte = Asc(oStream.Read(1))
If (lFileByte > 47 And lFileByte < 58) Or (lFileByte > 64 And lFileByte < 91) Or (lFileByte > 96 And lFileByte < 123) Then
lFileArray(lCharCount) = lFileByte
lCharCount = lCharCount + 1
If lCharCount = 100000 Then Exit Do
End If
Loop
oStream.Close: Set oStream = Nothing
But I need it to run faster. I'd rather not use ADODB but, I'm open to all suggestions if it can't be sped up using FSO. Any ideas?
Try something like this:
cnt = 100000
data = oFSO.OpenTextFile(sInFileName).Read(cnt)
ReDim lFileArray(Len(data)-1)
For i = 1 To Len(data)
lFileArray(i-1) = Asc(Mid(data, i, 1))
Next
Try calling ReadAll on your file instead char by char. This will read the entire file and return it as a string. Then use the same loop, but this time on the returned string, using string scan methods.
So I have a number of text files that I'm trying to read with Visual Basic. They all have the same formatting:
[number of items in the file]
item 1
item 2
item 3
...etc.
What I'm trying to do is declare an array of the size of the integer in the first line, and then read each line into corresponding parts of the array (so item 1 would be array[0], item 2 would be array[1], etc. However, I'm not sure where to start on this. Any help would be appreciated.
Pretty basic stuff (no pun intended):
Dim F As Integer
Dim Count As Integer
Dim Items() As String
Dim I As Integer
F = FreeFile(0)
Open "data.txt" For Input As #F
Input #F, Count
ReDim Items(Count - 1)
For I = 0 To Count - 1
Line Input #F, Items(I)
Next
Close #F
try this for VB6
Dim file_id As Integer
Dim strline as string
Dim array_item() as string
'Open file
file_id = FreeFile
Open "C:\list.txt" For Input AS #file_id
Dim irow As Integer
irow = 0
'Loop through the file
Do Until EOF(file_id)
'read a line from a file
Line Input #file_id, strline
'Resize the array according to the line read from file
Redim Preserve array_item(irow)
'put the line into the array
array_item(irow) = strline
'move to the next row
irow = irow + 1
Loop
Close #file_id
The VB function you're looking for is "split":
http://www.vb-helper.com/howto_csv_to_array.html
Try this:
Dim FullText As String, l() As String
'''Open file for reading using Scripting Runtime. But you can use your methods
Dim FSO As Object, TS As Object
Set FSO = createbject("Scripting.FileSystemObject")
Set TS = createbject("Scripting.TextStream")
Set TS = FSO.OpenTextFile(FilePath)
TS.ReadLine 'Skip your first line. It isn't needed now.
'''Reading the contents to FullText and splitting to the array.
FullText = TS.ReadAll
l = Split(FullText, vbNewLine) '''the main trick
Splitting automatically resizes l() and stores all data.
Now the l() array has everything you want.