• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 193
  • Last Modified:

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
0
shannon_cogan
Asked:
shannon_cogan
  • 6
  • 3
1 Solution
 
watyCommented:
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
 
watyCommented:
Stats on my computer :
Before : 00,74 secs.
Now    : 00,72 secs.

0
 
shannon_coganAuthor Commented:

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
Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
watyCommented:
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
 
watyCommented:
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
 
shannon_coganAuthor Commented:

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
 
watyCommented:
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
 
watyCommented:
shannon_cogan, reject my answer, and wait until tomorrow for possible better solution. If none is found, you should accept my answer.
0
 
shannon_coganAuthor Commented:

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

0
 
MirkwoodCommented:
Bought This Question.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Cloud Class® Course: Microsoft Exchange Server

The MCTS: Microsoft Exchange Server 2010 certification validates your skills in supporting the maintenance and administration of the Exchange servers in an enterprise environment. Learn everything you need to know with this course.

  • 6
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now