Solved

Make it go Faster !!!

Posted on 1998-11-26
10
180 Views
Last Modified: 2010-05-03

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
0
Comment
Question by:shannon_cogan
  • 6
  • 3
10 Comments
 
LVL 14

Accepted Solution

by:
waty earned 100 total points
Comment Utility
Here is the fastest way I have found. I will check to add some other tags...

Option Explicit

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 = 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 LCase(Mid(sHTML, nTagOpen, 4)) = "<img" Then
            nColor = &H400040
         ElseIf LCase(Mid(sHTML, nTagOpen, 2)) = "<a" Then
            nColor = &H8080&
         ElseIf LCase(Mid(sHTML, nTagOpen, 2)) = "<b" Then
            nColor = &H8000000F
         Else
            nColor = &H4000&
         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 Form_Load()
   
   ' Our Timer Feature...
   Dim dStart As Double, dFinish As Double
   
   Dim fnum As Integer
   Dim sHTML As String
   ' 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

0
 
LVL 14

Expert Comment

by:waty
Comment Utility
Stats on my computer :
Before : 00,74 secs.
Now    : 00,72 secs.

0
 

Author Comment

by:shannon_cogan
Comment Utility

Waty,
do you mind if I keep this question open?
I would like to see if someone can come up with a bigger difference.


0
 
LVL 14

Expert Comment

by:waty
Comment Utility
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).
0
 
LVL 14

Expert Comment

by:waty
Comment Utility
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(byteArrayString(nI)) Then
            ' *** 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$(sSeparators, nI, 1))) = True
   Next

End Sub

0
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 

Author Comment

by:shannon_cogan
Comment Utility

Waty,
do you mind if I keep this question open?
I would like to see if someone can come up with a bigger difference.


0
 
LVL 14

Expert Comment

by:waty
Comment Utility
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

0
 
LVL 14

Expert Comment

by:waty
Comment Utility
shannon_cogan, reject my answer, and wait until tomorrow for possible better solution. If none is found, you should accept my answer.
0
 

Author Comment

by:shannon_cogan
Comment Utility

Oups... I just accepted your answer. :)

0
 
LVL 13

Expert Comment

by:Mirkwood
Comment Utility
Bought This Question.
0

Featured Post

Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

Join & Write a Comment

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…

763 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now