Excel VBA Append to TextBox is Slow - performance

I've got a user-form that generates a large amount of text and puts it into a Textbox.
I have the following function to append the next line of text to the textbox:
Sub AddLineToSQL(sLine As String)
frmSQL.txtSQL.Value = frmSQL.txtSQL.Value & sLine & vbCr
End Sub
When adding several hundred lines of text it takes a while to process (up to 20 seconds).
The problem with this is that there is the possibility of adding more than a thousand lines of text.
We have an old form that does basically the same thing, but I'm trying to create a cleaner user experience. the old form wrote the text to a worksheet, and it seems to work much quicker than appending to the textbox.
Is there a More efficient way to append text to a textbox than what I have above?
should I just do what the old form did and write lines to a worksheet?
Thanks,
Mark

Do not appending line by line to the TextBox. Instead do concatenating a String with all lines and then set that String as the TextBox value.
Sub test()
Dim sTxtSQL As String
For i = 1 To 5000
sTxtSQL = sTxtSQL & "This is row " & i & vbCrLf
Next
frmSQL.txtSQL.Value = sTxtSQL
frmSQL.Show
End Sub

should your amount of text be veeery large then you could use this class:
' Class: StringBuilder
' from http://stackoverflow.com/questions/1070863/hidden-features-of-vba
Option Explicit
Private Const initialLength As Long = 32
Private totalLength As Long ' Length of the buffer
Private curLength As Long ' Length of the string value within the buffer
Private buffer As String ' The buffer
Private Sub Class_Initialize()
' We set the buffer up to it's initial size and the string value ""
totalLength = initialLength
buffer = Space(totalLength)
curLength = 0
End Sub
Public Sub Append(Text As String)
Dim incLen As Long ' The length that the value will be increased by
Dim newLen As Long ' The length of the value after being appended
incLen = Len(Text)
newLen = curLength + incLen
' Will the new value fit in the remaining free space within the current buffer
If newLen <= totalLength Then
' Buffer has room so just insert the new value
Mid(buffer, curLength + 1, incLen) = Text
Else
' Buffer does not have enough room so
' first calculate the new buffer size by doubling until its big enough
' then build the new buffer
While totalLength < newLen
totalLength = totalLength + totalLength
Wend
buffer = Left(buffer, curLength) & Text & Space(totalLength - newLen)
End If
curLength = newLen
End Sub
Public Property Get Length() As Integer
Length = curLength
End Property
Public Property Get Text() As String
Text = Left(buffer, curLength)
End Property
Public Sub Clear()
totalLength = initialLength
buffer = Space(totalLength)
curLength = 0
End Sub
just place it in any Class Module and name it after "StringBuilder"
then you can test it similarly as per Axel answer:
Sub test()
Dim i As Long
Dim sb As StringBuilder
Dim sTxtSQL As String
Dim timeCount As Long
timeCount = Timer
Set sb = New StringBuilder
For i = 1 To 50000
sb.Append "This is row " & CStr(i) & vbCrLf
Next i
sTxtSQL = sb.Text
MsgBox Timer - timeCount
frmSQL.txtSQL.Value = sTxtSQL
frmSQL.Show
End Sub
My test showed significant time reduction for "i" loops over 50k

Related

How to speed up this code to find and delete rows if a substring is found

Below code works great as expected the only downside is its slow because I am using this to search for all the instances of the substring and delete the Entire row if found in any cell of the whole workbook.
Aim is simple just delete the entirerow if the entered string is found in any cell string
Dim wo As Worksheet, ws As Worksheet
Dim I As Long, j As Long, m As Long
Dim toFind As String, testStr As String
Dim pos As Long
Dim lstRow As Long, cutRow As Long
Dim WS_Count As Integer
Dim Cell As Range
Option Compare Text
Option Explicit
Sub SearchDelete()
toFind = InputBox("Enter the substring you want to search for.", "Welcome", "AAAA")
toFind = Trim(toFind)
j = 0
If toFind = "" Then
MsgBox "Empty String Entered.Exiting Sub Now."
Exit Sub
Else
WS_Count = ActiveWorkbook.Worksheets.Count
'Begin the loop.
For I = 1 To WS_Count
Label1:
For Each Cell In Worksheets(I).UsedRange.Cells
If Trim(Cell.Text) <> "" Then
pos = 0
pos = InStr(1, Trim(Cell.Text), toFind, vbTextCompare)
If pos > 0 Then 'match Found'
cutRow = Cell.Row
Worksheets(I).Rows(cutRow).EntireRow.Delete
j = j + 1
GoTo Label1
Else: End If
Else: End If
Next Cell
Next I
End If
MsgBox "Total " & j & " Rows were deleted!"
End Sub
Individual operations are pretty much always slower than bulk operations and the Range.Delete method is no exception. Collecting the matching rows with a Union method and then performing the removal en masse will significantly speed up the operation.
Temporarily suspending certain application environment handlers will also help things along. You do not need Application.ScreenUpdating active while you are removing rows; only after you have completed the operation.
Option Explicit
Option Compare Text
Sub searchDelete()
Dim n As Long, w As Long
Dim toFind As String, addr As String
Dim fnd As Range, rng As Range
toFind = InputBox("Enter the substring you want to search for.", "Welcome", "AAAA")
toFind = Trim(toFind)
If Not CBool(Len(toFind)) Then
MsgBox "Empty String Entered.Exiting Sub Now."
GoTo bm_Safe_Exit
End If
'appTGGL bTGGL:=False 'uncomment this line when you have finsihed debugging
With ActiveWorkbook
For w = 1 To .Worksheets.Count
With .Worksheets(w)
Set fnd = .Cells.Find(what:=toFind, lookat:=xlPart, _
after:=.Cells.SpecialCells(xlCellTypeLastCell))
If Not fnd Is Nothing Then
Set rng = .Rows(fnd.Row)
n = n + 1
addr = fnd.Address
Do
If Intersect(fnd, rng) Is Nothing Then
n = n + 1
Set rng = Union(rng, .Rows(fnd.Row))
End If
Set fnd = .Cells.FindNext(after:=fnd)
Loop Until addr = fnd.Address
Debug.Print rng.Address(0, 0)
rng.Rows.EntireRow.Delete
End If
End With
Next w
End With
Debug.Print "Total " & n & " rows were deleted!"
bm_Safe_Exit:
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
Application.ScreenUpdating = bTGGL
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
Debug.Print Timer
End Sub
The answer to your question: "How to speed up this code to find and delete rows if a substring is found" is - DON'T repeat the search from the top of the sheet after you found and removed the row!

Sending data to device via MS Comm VB6

I need to send a file to some electronic device and execute it.
I couldn't find any information online regarding MS Comms and I didn't find Documentation on the Microsoft (https://msdn.microsoft.com/en-us/library/aa231237(v=vs.60).aspx) any useful :
' Send Byte array data
MSComm1.Output = Out
Would be great if you guys could give me some pointers and help me to solve my problem. The problem that I am experiencing is an infinite loop at Loop Until MSComm1.OutBufferCount = 0, when I return "MSComm1.OutBufferCount" between Do and Loop "MSComm1.OutBufferCount" is 0 and files dont seem to be sent over to the device.
Closest function I got to at the present moment is below:
Function SendFile(tmp$)
Dim temp$
Dim hsend, bsize, LF&
' Open file
Open tmp$ For Binary Access Read As #2
' Check size on Mscomm1 OutBuffer
bsize = MSComm1.OutBufferSize
' Check file length
LF& = LOF(2)
' This code makes tiny pieces of data (Buffer sized)
' And send's it
Do Until EOF(2)
If LF& - Loc(2) <= bsize Then
bsize = LF& - Loc(2) + 1
End If
' Make room for some data
temp$ = Space$(bsize)
' Put the data piece in the Temp$ string
Get #2, , temp$
MSComm1.Output = temp$
Do
' Wait until the buffer is empty
Loop Until MSComm1.OutBufferCount = 0
Loop
' close file
Close #2
End Function
Have a look at the RThreshold and SThreshold properties
Below is a simple example project :
'1 form with :
' 1 label control : name=Label1
' 1 textbox control : name=Text1
' 1 command button : name=Command1
Option Explicit
Private Sub Command1_Click()
'send command
MSComm1.Output = Text1.Text & vbCr
End Sub
Private Sub Form_Load()
'config mscomm control and open connection
With MSComm1
.Settings = "9600,N,8,1"
.RThreshold = 1
.SThreshold = 0
.CommPort = 1
.PortOpen = True
End With 'MSComm1
End Sub
Private Sub Form_Resize()
'position controls
Dim sngWidth As Single, sngHeight As Single
Dim sngCmdWidth As Single, sngCmdHeight As Single
Dim sngTxtWidth As Single
Dim sngLblHeight As Single
sngWidth = ScaleWidth
sngHeight = ScaleHeight
sngCmdWidth = 1215
sngCmdHeight = 495
sngLblHeight = sngHeight - sngCmdHeight
sngTxtWidth = sngWidth - sngCmdWidth
Label1.Move 0, 0, sngWidth, sngLblHeight
Text1.Move 0, sngLblHeight, sngTxtWidth, sngCmdHeight
Command1.Move sngTxtWidth, sngLblHeight, sngCmdWidth, sngCmdHeight
End Sub
Private Sub MSComm1_OnComm()
'process received data
Dim strInput As String
Select Case MSComm1.CommEvent
Case comEvReceive
strInput = MSComm1.Input
Label1.Caption = Label1.Caption & strInput
End Select
End Sub
In Command1_Click I add a carriage return to the command from Text1 as most devices require the command to be finished by that
In MSComm1_OnComm I just print the received data to the label, but you might want to add the received data to a global variable, and then process the contents of that variable, as all data might not be received at once

Visual Basic split function

Ok so now I'm not getting an error but instead of everything being posted in the listbox it only contains the first line of text from the .txt file. This is the code I changed it too:
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Dim inFile As IO.StreamReader
If IO.File.Exists("StudentList.txt") = True Then
inFile = IO.File.OpenText("StudentList.txt")
For index As Integer = 0 To inFile.Peek = -1
Dim splits = inFile.ReadLine.Split(","c)
Member(index).ID = splits(0)
Member(index).lastName = splits(1)
Member(index).firstName = splits(2)
Member(index).middleName = splits(3)
Member(index).grade = splits(4)
Member(index).period = splits(5)
ListBox1.Items.Add(Member(index).ID.PadLeft(10) & " " & Member(index).lastName & " " & Member(index).firstName)
Next
inFile.Close()
Else
MessageBox.Show("error", "error", MessageBoxButtons.OK)
End If
End Sub
The problem is that you're trying to assign a string array to a Member. That is, you have:
Member(index) = infile.ReadLine.Split(",", c);
You need to assign each field:
Dim splits = infile.ReadLine.Split(",", c);
Member(index).ID = splits(0);
Member(index).lastName = splits(1);
... etc.
Update after OP edit
I suspect the problem now is that your For loop is executing only once, or index isn't being incremented. I don't know where you came up with that wonky infile.Peek = -1 thing, but I suspect it doesn't work the way you think it does. Use something more conventional, like this.
Dim index As Integer = 0
For Each line As String In File.ReadLines("StudentList.txt")
Dim splits = line.Split(",", c)
Member(index).ID = splits(0)
' etc.
ListBox1.Add(...)
Index = Index + 1
Next

"integer out of range" error in a for next statement

I've gone nuts on this, and I'm sure the error is right in front of me, I just cant see it. appreciate all the help in debugging the statements below.
I have multiple slides in a ppt presentation. in some of the slides, there is a star shape, and a textbox with text "Hold" or "Yearly". I want to change the color of the star only if there is no textbox with "Hold" or "Yearly".
Sub Set_Star_Shape_Color_Green_Test()
Dim PPApp As Object ' As PowerPoint.Application
Dim PPPres As Object ' As PowerPoint.Presentation
Dim PPSlide As Object ' As PowerPoint.Slide
Dim iShpCnt1 As Integer
Dim iShpCnt2 As Integer
Dim iShpCnt3 As Integer
Dim iSlideCnt As Integer
Dim iBoxTopPos As Integer
Dim sHold As String
Dim sStar As String
Dim sTbox As String
Dim sTColor As String
Dim oShp As Shape
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
iShpCnt0 = PPSlide.Shapes.Count
For iShpCnt1 = 1 To iShpCnt0 'PPSlide.Shapes.Count
iBoxTopPos = 260
' iSlideCnt = 2 removed
sHold = ""
sStar = ""
iShpCnt1 = 1
For iShpCnt1 = 1 To PPSlide.Shapes.Count
If iShpCnt1 <= PPSlide.Shapes.Count Then
**Set oSh = PPApp.ActivePresentation.Slides(iSlideCnt).Shapes(iShpCnt1) ' this is where i am getting the integer out of range error**
If oSh.Name.Text Like "*Hold*" Or oSh.Name.Text Like "*Yearly*" Then
sHold = oSh.Name
End If
If oSh.Name Like "*Star*" Then
sStar = oSh.Name
End If
End If
Next
For iShpCnt2 = 1 To iShpCnt0 ' this fixed the error
Set oSh = PPApp.ActivePresentation.Slides(iSlideCnt).Shapes(iShpCnt2)
If oSh.Name Like "*Star*" And sHold = "" Then
oSh.Fill.ForeColor.RGB = RGB(50, 205, 50) ' change the color to green
End If
Next
' go to next slide
If PPSlide.SlideIndex + 1 < PPPres.Slides.Count Then
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex + 1
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex + 1)
End If
Next
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
You are setting the iterator to two.
For iSlideCnt = 1 To PPPres.Slides.Count
iBoxTopPos = 260
iSlideCnt = 2 <--- right here
It will go out of bounds if you have just one slide.

I want to read the last 400 lines from a txt file

I know how to do it in VB.Net but not an idea in vb6.
What I what to achieve is to avoid reading the whole file.
Is that possible?
You could open the file using Random access. Work your way backward a byte at a time, counting the number of carriage return line feed character pairs. Store each line in an array, or something similar, and when you've read your 400 lines, stop.
Cometbill has a good answer.
To open file for Random access:
Open filename For Random Access Read As #filenumber Len = reclength
To get the length of the file in Bytes:
FileLen(ByVal PathName As String) As Long
To read from Random access file:
Get [#]filenumber,<[recnumber]>,<varname>
IMPORTANT: the <varname> from the Get function must be a fixed length string Dim varname as String * 1, otherwise it will error out with Bad record length (Error 59) if the variable is declared as a variable length string like this Dim varname as String
EDIT:
Just wanted to point out that in Dim varname as String * 1 you are defining a fixed length string and the length is 1. This is if you wish to use the read-1-byte-backwards approach. If your file has fixed length records, there is no need to go 1 byte at a time, you can read a record at a time (don't forget to add 2 bytes for carriage return and new line feed). In the latter case, you would define Dim varname as String * X where X is the record length + 2. Then a simple loop going backwards 400 times or untill reaching the beginning of the file.
The following is my take on this. This is more efficient than the previous two answers if you have a very large file, since we don't have to store the entire file in memory.
Option Explicit
Private Sub Command_Click()
Dim asLines() As String
asLines() = LoadLastLinesInFile("C:\Program Files (x86)\VMware\VMware Workstation\open_source_licenses.txt", 400)
End Sub
Private Function LoadLastLinesInFile(ByRef the_sFileName As String, ByVal the_nLineCount As Long) As String()
Dim nFileNo As Integer
Dim asLines() As String
Dim asLinesCopy() As String
Dim bBufferWrapped As Boolean
Dim nLineNo As Long
Dim nLastLineNo As Long
Dim nNewLineNo As Long
Dim nErrNumber As Long
Dim sErrSource As String
Dim sErrDescription As String
On Error GoTo ErrorHandler
nFileNo = FreeFile
Open the_sFileName For Input As #nFileNo
On Error GoTo ErrorHandler_FileOpened
' Size our buffer to the number of specified lines.
ReDim asLines(0 To the_nLineCount - 1)
nLineNo = 0
' Read all lines until the end of the file.
Do Until EOF(nFileNo)
Line Input #nFileNo, asLines(nLineNo)
nLineNo = nLineNo + 1
' Check to see whether we have got to the end of the string array.
If nLineNo = the_nLineCount Then
' In which case, flag that we did so, and wrap back to the beginning.
bBufferWrapped = True
nLineNo = 0
End If
Loop
Close nFileNo
On Error GoTo ErrorHandler
' Were there more lines than we had array space?
If bBufferWrapped Then
' Create a new string array, and copy the bottom section of the previous array into it, followed
' by the top of the previous array.
ReDim asLinesCopy(0 To the_nLineCount - 1)
nLastLineNo = nLineNo
nNewLineNo = 0
For nLineNo = nLastLineNo + 1 To the_nLineCount - 1
asLinesCopy(nNewLineNo) = asLines(nLineNo)
nNewLineNo = nNewLineNo + 1
Next nLineNo
For nLineNo = 0 To nLastLineNo
asLinesCopy(nNewLineNo) = asLines(nLineNo)
nNewLineNo = nNewLineNo + 1
Next nLineNo
' Return the new array.
LoadLastLinesInFile = asLinesCopy()
Else
' Simply resize down the array, and return it.
ReDim Preserve asLines(0 To nLineNo)
LoadLastLinesInFile = asLines()
End If
Exit Function
ErrorHandler_FileOpened:
' If an error occurred whilst reading the file, we must ensure that the file is closed
' before reraising the error. We have to backup and restore the error object.
nErrNumber = Err.Number
sErrSource = Err.Source
sErrDescription = Err.Description
Close #nFileNo
Err.Raise nErrNumber, sErrSource, sErrDescription
ErrorHandler:
Err.Raise Err.Number, Err.Source, Err.Description
End Function

Resources