Solved

Make it go Faster !!!

Posted on 1998-11-26
10
188 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 6
  • 3
10 Comments
 
LVL 14

Accepted Solution

by:
waty earned 100 total points
ID: 1446921
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
ID: 1446922
Stats on my computer :
Before : 00,74 secs.
Now    : 00,72 secs.

0
 

Author Comment

by:shannon_cogan
ID: 1446923

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
Salesforce Has Never Been Easier

Improve and reinforce salesforce training & adoption using WalkMe's digital adoption platform. Start saving on costly employee training by creating fast intuitive Walk-Thrus for Salesforce. Claim your Free Account Now

 
LVL 14

Expert Comment

by:waty
ID: 1446924
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
ID: 1446925
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
 

Author Comment

by:shannon_cogan
ID: 1446926

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
ID: 1446927
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
ID: 1446928
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
ID: 1446929

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

0
 
LVL 13

Expert Comment

by:Mirkwood
ID: 1446930
Bought This Question.
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction While answering a recent question about filtering a custom class collection, I realized that this could be accomplished with very little code by using the ScriptControl (SC) library.  This article will introduce you to the SC library a…
When trying to find the cause of a problem in VBA or VB6 it's often valuable to know what procedures were executed prior to the error. You can use the Call Stack for that but it is often inadequate because it may show procedures you aren't intereste…
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 utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
Suggested Courses
Course of the Month4 days, 21 hours left to enroll

636 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