shannon_cogan
asked on
Make it go Faster !!!
To answer this question,
all you have to do is modify my function to make it faster.
In the following, I have pasted one of my functions
with a small timer attached. (dStart & dFinish)
Once the function has done its work, it will print the time
it took in your debug window.
Beat it and I give you the points.
Have fun.
Ok.
First start a new project and add a RichTextBox to your
form.
Save it somewhere.
Select a HTML file on your Hard Drive and place it in the
same folder with your project.
Now paste the following...
' Our Timer Feature...
Dim dStart As Double, dFinish As Double
Dim fnum As Integer
Dim txt As String
' Load the file.
fnum = FreeFile
Open App.Path & "\books.htm" For Input As fnum
txt = Input$(LOF(fnum), fnum)
richtextbox1.Text = txt
Close fnum
' Color the HTML tags.
dStart = Timer
ColorTags RichTextBox1
dFinish = Timer
debug.print Format$(dFinish - dStart, "00.00") & " secs."
'-------------------------
'The Function , Well its a Sub After All
'but you can change it...
'-------------------------
Private Sub ColorTags(rch As RichTextBox)
Dim txt As String
Dim tag_open As Integer
Dim tag_close As Integer
txt = rch.Text
tag_close = 1
Do
' See where the next tag starts.
tag_open = InStr(tag_close, txt, "<")
If tag_open = 0 Then Exit Do
' See where the tag ends.
tag_close = InStr(tag_open, txt, ">")
If tag_open = 0 Then tag_close = Len(txt)
' Color the tag.
rch.SelStart = tag_open - 1
rch.SelLength = tag_close - tag_open + 1
rch.SelColor = &H4000&
Loop
tag_close = 1
Do
' See where the next tag starts.
tag_open = InStr(tag_close, txt, "<img")
If tag_open = 0 Then Exit Do
' See where the tag ends.
tag_close = InStr(tag_open, txt, ">")
If tag_open = 0 Then tag_close = Len(txt)
' Color the tag.
rch.SelStart = tag_open - 1
rch.SelLength = tag_close - tag_open ' + 1
rch.SelColor = &H400040
Loop
tag_close = 1
Do
' See where the next tag starts.
tag_open = InStr(tag_close, txt, "<A")
If tag_open = 0 Then Exit Do
' See where the tag ends.
tag_close = InStr(tag_open, txt, ">")
If tag_open = 0 Then tag_close = Len(txt)
' Color the tag.
rch.SelStart = tag_open - 1
rch.SelLength = tag_close - tag_open + 1
rch.SelColor = &H8080&
Loop
tag_close = 1
Do
' See where the next tag starts.
tag_open = InStr(tag_close, txt, "<b")
If tag_open = 0 Then Exit Do
' See where the tag ends.
tag_close = InStr(tag_open, txt, ">")
If tag_open = 0 Then tag_close = Len(txt)
' Color the tag.
rch.SelStart = tag_open - 1
rch.SelLength = tag_close - tag_open + 1
rch.SelColor = &H8000000F
Loop
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Waty,
do you mind if I keep this question open?
I would like to see if someone can come up with a bigger difference.
Ok, no problem, I am curious for the best code.
The tests of performance should be done on the same computer, with the same HTML file.
Instead of testing for '<b', '<a'... you should test for the maximum of tags.
I have also code to highlight VB Code.
NB : I will release soon the VBIDEUtils, a useful big addins with the best Code Repository ever found on Internet (all my VB librairies, link to the best HTML files, ... on Internet) come often on the VBDiamond site (see in my profile).
The tests of performance should be done on the same computer, with the same HTML file.
Instead of testing for '<b', '<a'... you should test for the maximum of tags.
I have also code to highlight VB Code.
NB : I will release soon the VBIDEUtils, a useful big addins with the best Code Repository ever found on Internet (all my VB librairies, link to the best HTML files, ... on Internet) come often on the VBDiamond site (see in my profile).
Here is another solution, but is a little bit slower :
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, Source As Any, ByVal bytes As Long)
Private isSeparator(0 To 255) As Boolean
Private Sub ColorTags(RTF As RichTextBox)
Dim sHTML As String
Dim nTagOpen As Long
Dim nTagClose As Long
Dim nI As Long
Dim nColor As Long
Dim byteArrayString() As Byte
Dim nSize As Long
Dim sTmp2 As String * 2
Dim sTmp4 As String * 4
sHTML = RTF.Text
nTagClose = 1
nSize = Len(sHTML)
If nSize = 0 Then Exit Sub
ReDim byteArrayString(1 To nSize)
' *** Copy string to byte array
CopyMemory byteArrayString(1), ByVal sHTML, nSize
With RTF
For nI = 1 To nSize
If isSeparator(byteArrayStrin
' *** See where the next tag starts.
If byteArrayString(nI) = 60 Then ' *** <
nTagOpen = nI
CopyMemory ByVal sTmp4, byteArrayString(nI), 4
CopyMemory ByVal sTmp2, byteArrayString(nI), 2
If LCase(sTmp4) = "<img" Then
nColor = &H400040
ElseIf LCase(sTmp2) = "<a" Then
nColor = &H8080&
ElseIf LCase(sTmp2) = "<b" Then
nColor = &H8000000F
Else
nColor = &H4000&
End If
Else
' *** Color the tag.
.SelStart = nTagOpen - 1
.SelLength = nI - nTagOpen + 1
.SelColor = nColor
End If
End If
Next
End With
End Sub
Private Sub Form_Load()
' Our Timer Feature...
Dim dStart As Double, dFinish As Double
Dim fnum As Integer
Dim sHTML As String
Call Init
' Load the file.
fnum = FreeFile
Open "d:\kiki.html" For Input As fnum
sHTML = Input$(LOF(fnum), fnum)
RichTextBox1.Text = sHTML
Close fnum
' Color the HTML tags.
dStart = Timer
ColorTags RichTextBox1
dFinish = Timer
Debug.Print Format$(dFinish - dStart, "00.00") & " secs."
End Sub
Private Sub Init()
'Const sSeparators = vbTab & " ,.:;!?""()=-><+&#" & vbCrLf
Const sSeparators = "<>"
Dim nI As Integer
For nI = 1 To Len(sSeparators)
isSeparator(Asc(Mid$(sSepa
Next
End Sub
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, Source As Any, ByVal bytes As Long)
Private isSeparator(0 To 255) As Boolean
Private Sub ColorTags(RTF As RichTextBox)
Dim sHTML As String
Dim nTagOpen As Long
Dim nTagClose As Long
Dim nI As Long
Dim nColor As Long
Dim byteArrayString() As Byte
Dim nSize As Long
Dim sTmp2 As String * 2
Dim sTmp4 As String * 4
sHTML = RTF.Text
nTagClose = 1
nSize = Len(sHTML)
If nSize = 0 Then Exit Sub
ReDim byteArrayString(1 To nSize)
' *** Copy string to byte array
CopyMemory byteArrayString(1), ByVal sHTML, nSize
With RTF
For nI = 1 To nSize
If isSeparator(byteArrayStrin
' *** See where the next tag starts.
If byteArrayString(nI) = 60 Then ' *** <
nTagOpen = nI
CopyMemory ByVal sTmp4, byteArrayString(nI), 4
CopyMemory ByVal sTmp2, byteArrayString(nI), 2
If LCase(sTmp4) = "<img" Then
nColor = &H400040
ElseIf LCase(sTmp2) = "<a" Then
nColor = &H8080&
ElseIf LCase(sTmp2) = "<b" Then
nColor = &H8000000F
Else
nColor = &H4000&
End If
Else
' *** Color the tag.
.SelStart = nTagOpen - 1
.SelLength = nI - nTagOpen + 1
.SelColor = nColor
End If
End If
Next
End With
End Sub
Private Sub Form_Load()
' Our Timer Feature...
Dim dStart As Double, dFinish As Double
Dim fnum As Integer
Dim sHTML As String
Call Init
' Load the file.
fnum = FreeFile
Open "d:\kiki.html" For Input As fnum
sHTML = Input$(LOF(fnum), fnum)
RichTextBox1.Text = sHTML
Close fnum
' Color the HTML tags.
dStart = Timer
ColorTags RichTextBox1
dFinish = Timer
Debug.Print Format$(dFinish - dStart, "00.00") & " secs."
End Sub
Private Sub Init()
'Const sSeparators = vbTab & " ,.:;!?""()=-><+&#" & vbCrLf
Const sSeparators = "<>"
Dim nI As Integer
For nI = 1 To Len(sSeparators)
isSeparator(Asc(Mid$(sSepa
Next
End Sub
ASKER
Waty,
do you mind if I keep this question open?
I would like to see if someone can come up with a bigger difference.
now : 00,71 secs.
Private Sub ColorTags(RTF As RichTextBox)
Dim sHTML As String
Dim nTagOpen As Long
Dim nTagClose As Long
Dim nI As Long
Dim nColor As Long
sHTML = LCase(RTF.Text)
nTagClose = 1
With RTF
For nI = 1 To Len(sHTML)
' *** See where the next tag starts.
nTagOpen = InStr(nTagClose, sHTML, "<")
If nTagOpen = 0 Then Exit For
If Mid(sHTML, nTagOpen, 4) = "<img" Then
nColor = &H400040
Else
Select Case Mid(sHTML, nTagOpen, 2)
Case "<a":
nColor = &H8080&
Case "<b":
nColor = &H8000000F
Case Else:
nColor = &H4000&
End Select
End If
' *** See where the tag ends.
nTagClose = InStr(nTagOpen, sHTML, ">")
If nTagOpen = 0 Then nTagClose = Len(sHTML)
' *** Color the tag.
.SelStart = nTagOpen - 1
.SelLength = nTagClose - nTagOpen + 1
.SelColor = nColor
Next
End With
End Sub
Private Sub ColorTags(RTF As RichTextBox)
Dim sHTML As String
Dim nTagOpen As Long
Dim nTagClose As Long
Dim nI As Long
Dim nColor As Long
sHTML = LCase(RTF.Text)
nTagClose = 1
With RTF
For nI = 1 To Len(sHTML)
' *** See where the next tag starts.
nTagOpen = InStr(nTagClose, sHTML, "<")
If nTagOpen = 0 Then Exit For
If Mid(sHTML, nTagOpen, 4) = "<img" Then
nColor = &H400040
Else
Select Case Mid(sHTML, nTagOpen, 2)
Case "<a":
nColor = &H8080&
Case "<b":
nColor = &H8000000F
Case Else:
nColor = &H4000&
End Select
End If
' *** See where the tag ends.
nTagClose = InStr(nTagOpen, sHTML, ">")
If nTagOpen = 0 Then nTagClose = Len(sHTML)
' *** Color the tag.
.SelStart = nTagOpen - 1
.SelLength = nTagClose - nTagOpen + 1
.SelColor = nColor
Next
End With
End Sub
shannon_cogan, reject my answer, and wait until tomorrow for possible better solution. If none is found, you should accept my answer.
ASKER
Oups... I just accepted your answer. :)
Bought This Question.
Before : 00,74 secs.
Now : 00,72 secs.