|
-
May 22nd, 2000, 01:35 AM
#1
Ok, someone gave me some source code to an HTML editor that changes the color of HTML tags to blue but im not good enough to figure it out. Could someone just explain to me how to detect the tags and then turn them blue and capitalize them, and in detail please...
-
May 22nd, 2000, 02:17 AM
#2
is your html source code in a text box or what? let me know that and i can help you.
-
May 22nd, 2000, 02:19 AM
#3
if you dont want to copy all the code... download the project here
http://denniswrenn.virtualave.net/HTMLColorChanger.zip
paste this into the form code module
Code:
Private Sub Form_Load()
m_TagCol = vbBlue
End Sub
Private Sub rtfText_Change()
If Not trapUndo Then Exit Sub 'because trapping is disabled
Dim newElement As New UndoElement 'create new undo element
Dim c%, l&
'remove all redo items because of the change
For c% = 1 To RedoStack.Count
RedoStack.Remove 1
Next c%
'set the values of the new element
newElement.SelStart = rtfText.SelStart
newElement.TextLen = Len(rtfText.Text)
newElement.Text = rtfText.Text
'add it to the undo stack
UndoStack.Add Item:=newElement
' EnableControls
End Sub
Private Sub rtfText_KeyDown(KeyCode As Integer, Shift As Integer)
'GetEditStatus
Dim TypedIn As String
If Shift And vbCtrlMask Then
If KeyCode > vbKey0 And KeyCode < vbKey7 Then
Dim HeadingTag As String
HeadingTag = "<H" & CStr(KeyCode - vbKey0) & "></H" & CStr(KeyCode - vbKey0) & ">"
InsertTag HeadingTag, True
PlaceCursor HeadingTag, 5
rtfText.SelColor = vbBlack
Else
Select Case KeyCode
Case vbKeyV
' User pressed Ctrl+V - Paste
Dim a$, S As Long
S = rtfText.SelStart ' save this since selstart moves up after the paste
a = Clipboard.GetText(vbCFText)
rtfText.SelText = ""
rtfText.SelText = a ' This removes any unwanted formatting (font, &c)
HtmlColorCode S, rtfText.SelStart
KeyCode = 0
Case vbKeyReturn
InsertTag "<P>", True
rtfText.SelColor = vbBlack
KeyCode = 0
Case vbKeySpace
rtfText.SelColor = vbBlack
rtfText.SelText = " "
KeyCode = 0
End Select
End If
ElseIf Shift And vbShiftMask Then
If KeyCode = vbKeyReturn Then
InsertTag "<BR>", True
rtfText.SelColor = vbBlack
KeyCode = 0
End If
End If
IsOutsideTag
End Sub
Private Sub rtfText_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyControl Then
CtlKey = False
End If
IsOutsideTag
rtfText.SetFocus
End Sub
Public Sub GetEditStatus()
Dim lLine As Long, lCol As Long
Dim cCol As Long, lChar As Long, i As Long
lChar = rtfText.SelStart + 1
' Get the line number
lLine = 1 + SendMessageLong(rtfText.hwnd, EM_LINEFROMCHAR, _
rtfText.SelStart, 0&)
' Get the Character Position
cCol = SendMessageLong(rtfText.hwnd, EM_LINELENGTH, lChar - 1, 0&)
i = SendMessageLong(rtfText.hwnd, EM_LINEINDEX, lLine - 1, 0&)
lCol = lChar - i
lbl_Lines.Caption = lbl_Lines.Caption & lLine & vbCrLf
'sbStatusBar.Panels(1).Text = "Line: " & lLine & ", Col: " & lCol
End Sub
Public Sub PlaceCursor(Text$, Cursor As Long)
Dim T As Long
T = rtfText.SelStart
rtfText.SelStart = (T + Len(Tag)) - Cursor
End Sub
Private Sub rtfText_KeyPress(KeyAscii As Integer)
'pOKUS
Dim Button As Integer
Dim Shift As Integer
Dim x As Single
Dim y As Single
'Pokus
Dim Key As String
Key = Chr(KeyAscii)
If Key = "<" Then
'################################
' Gives the Combo to select from
'################################
'MsgBox "Syntax AutoCoplete will be included in next version."
'If lblAutoSyntax.Caption = "1" Then
'PopupMenu fMainForm.syntax
'End If
End If
On Error Resume Next
KeyAscii = KeyPressEvent(KeyAscii)
End Sub
paste this into and class module called "UndoElement"
Code:
Public SelStart As Long 'start position in text box
Public TextLen As Long
Public Text As String
paste this into a regular module called "ColorCode"
Code:
Option Explicit
Public m_TextCol As String
Public m_AttribCol As String
Public m_TagCol As String
Public m_CommentCol As String
Public m_AspCol As String
Public Sub HtmlHighlight()
On Error Resume Next
'frmMain.trapUndo = False
' Color Html and asp
HtmlColorCode
' Move back to the start of the thing
frmDocument.rtfText.SelStart = 0
'frmMain.trapUndo = True
End Sub
Public Function KeyPressEvent(KeyAscii As Integer) As Integer
Static cInAttrib As Boolean, cInTag As Boolean
Static cInAttribQuote As Boolean, cTypedIn As Boolean
Static cInComment As Boolean
Static cInASP As Boolean
Static cInFunction As Boolean
'frmMain.trapUndo = False
Dim cChar As String
'frmDocument.rtfText
With frmDocument.rtfText
cChar = Chr$(KeyAscii)
If cInTag = False And cInAttrib = False And cInComment = False And cInASP = False Then
.SelColor = m_TextCol
End If
If cInTag = True And (cInAttrib = True Or cInAttribQuote = True) Then
.SelColor = m_AttribCol
End If
If cChar = "<" Then
.SelColor = m_TagCol
cInTag = True
cTypedIn = True
End If
If cChar = "=" And cInTag = True Then
cInAttrib = True
End If
If cChar = Chr$(34) And cInAttrib = True And cInAttribQuote = True Then
cInAttrib = False
cInAttribQuote = False
ElseIf cChar = Chr$(34) And cInAttrib = True And cInAttribQuote = False Then
cInAttribQuote = True
End If
If cChar = " " And (cInAttribQuote = False And cInTag = True) Then
.SelColor = m_TagCol
cInAttrib = False
End If
If cChar = "!" And Mid$(.Text, .SelStart, 1) = "<" Then
.SelStart = .SelStart - 1
.SelLength = 1
.SelColor = m_CommentCol
.SelText = "<!--"
cInTag = False
cInAttrib = False
cInASP = False
cInComment = True
KeyAscii = 0
End If
If cChar = "%" And Mid$(.Text, .SelStart, 1) = "<" Then
.SelStart = .SelStart - 1
.SelLength = 1
.SelColor = m_AspCol
.SelText = "<%"
cInTag = False
cInAttrib = False
cInASP = True
cInComment = False
KeyAscii = 0
End If
If cChar = ">" Then
If cInComment = False And cInASP = True Then
.SelColor = m_AspCol
ElseIf cInComment = True And cInASP = False Then
.SelColor = m_CommentCol
ElseIf cInComment = False And cInASP = False Then
.SelColor = m_TagCol
End If
cInTag = False
cInASP = False
cInComment = False
cTypedIn = False
End If
End With
KeyPressEvent = KeyAscii
'frmMain.trapUndo = True
ErrExit:
Exit Function
End Function
' Insert text w/tag coloring if necessary
Public Sub InsertTag(Tag$, StopAsp As Boolean)
Dim S As Long
'frmMain.trapUndo = False
S = frmDocument.rtfText.SelStart
If Len(frmDocument.rtfText.SelText) > 0 Then frmDocument.rtfText.SelText = ""
frmDocument.rtfText.SelText = Tag$
If StopAsp = True Then
HtmlColorCode S, S + Len(Tag), True
Else
HtmlColorCode S, S + Len(Tag), False
End If
'frmMain.trapUndo = True
End Sub
' Insert Asp code with asp coloring
Public Sub InsertAspTag(Tag$)
Dim U As Long
U = frmMain.rtfText.SelStart
If Len(frmMain.rtfText.SelText) > 0 Then frmMain.rtfText.SelText = ""
frmMain.rtfText.SelText = Tag$
frmMain.trapUndo = False
ASPColorCode U, U + Len(Tag)
frmMain.trapUndo = True
End Sub
' This function determines whether the caret is currently outside a tag. This was a royal pain in the ass.
Public Function IsOutsideTag()
On Error Resume Next
Dim LastGT As Long, LastLT As Long, NextGT As Long, NextLT As Long
Dim EndTag As Long, StartTag As Long
Dim txt$, Start As Long, Start2 As Long
Dim InMainTag As Boolean, InEndTag As Boolean
txt = frmDocument.rtfText.Text
Start = frmDocument.rtfText.SelStart
If Start = 0 Then
m_TextCol = vbBlack
Exit Function
Else
EndTag = InStr(Start + 1, txt, ">")
StartTag = InStr(Start + 1, txt, "<")
If StartTag > EndTag Then
InMainTag = True
Else
InMainTag = False
End If
LastLT = RevInStr(txt, "<", Start + 1)
LastGT = RevInStr(txt, ">", Start + 1)
If LastLT < LastGT Then
InEndTag = True
Else
InEndTag = False
End If
If InMainTag = True Or InEndTag = True Then
m_TextCol = frmDocument.rtfText.SelColor
Else
m_TextCol = vbBlack
End If
End If
End Function
' ##########################################################################################
' These are the main color coding functions. These are not called ever by the user.
' ##########################################################################################
' This is the main color coding function. This does everything html, comments, and attributes. It also calls
' the ASP color coding function if nessasary
Public Function HtmlColorCode(Optional startchar As Long = 1, Optional endchar As Long = -1, Optional StopAsp As Boolean = False)
On Error GoTo ErrHandler
' These are the variables for the tags for ColorCoding
Dim CommentOpenTag As String
Dim CommentCloseTag As String
Dim oldselstart As Long, oldsellen As Long
' These are place holders for the color coding
Dim tag_open As Long
Dim tag_close As Long
Dim bef As String
Dim Curr As String
Dim CI As Integer
'frmMain.trapUndo = False
' Find out where the cursor is
oldselstart = frmDocument.rtfText.SelStart
oldsellen = frmDocument.rtfText.SelLength
If endchar = -1 Then endchar = Len(frmDocument.rtfText.Text)
If startchar = 0 Then startchar = 1
' These are the close tags for colorcoding
tag_close = startchar
' Lets try to hide the color coding from the user:
frmDocument.rtfText.HideSelection = True
CI = 0
frmDocument.rtfText.Visible = False
frmDocument.PrgBar.Visible = True
' Now lets loop through the tags and color code it
Do
CI = CI + 1
If CI = 100 Then
CI = 0
End If
frmDocument.PrgBar.Value = CI
' See where the next tag starts. if any
tag_open = InStr(tag_close, frmDocument.rtfText.Text, "<")
'If so, then color it...
If tag_open <> 0 Then 'Found a tag
'Get everything before the tag we're on...
bef = Mid$(frmDocument.rtfText.Text, 1, tag_open - 1)
'Find the end of the next tag...
tag_close = InStr(tag_open, frmDocument.rtfText.Text, ">")
'Get the current HTML tag...
Curr = Mid$(frmDocument.rtfText.Text, tag_open, tag_close - tag_open + 1)
If tag_close <> 0 Then
Select Case Left$(Curr, 3)
Case "<!-"
' It's a comment...
tag_close = InStr(tag_open, frmDocument.rtfText.Text, "->") + 1
frmDocument.rtfText.SelStart = tag_open - 1
frmDocument.rtfText.SelLength = tag_close - tag_open + 1
frmDocument.rtfText.SelColor = m_CommentCol
Case Else
' This colors basic Html tags and then colors the attributes
cycleAttrib Curr, tag_open, tag_close
End Select
End If
If tag_close = 0 Or tag_close >= endchar Then
' If we are coloring tags and it's over the end tag then
' get me out of this loop and don't color anymore
Exit Do
End If
Else
Exit Do
End If
Loop
frmDocument.PrgBar.Visible = False
frmDocument.rtfText.Visible = True
' Color ASP Stuff only if we need to. We have a special function for coloring ASP tags so we won't
' worry if this deals with it or not.
If StopAsp = False Then
ASPColorCode startchar, endchar
End If
frmDocument.rtfText.SelStart = oldselstart
frmDocument.rtfText.SelLength = oldsellen
frmDocument.rtfText.HideSelection = False
frmDocument.rtfText.SetFocus
'frmMain.trapUndo = True
Exit Function
ErrHandler:
Exit Function
End Function
' This function colorizes ASP code
Private Function ASPColorCode(Optional startchar As Long = 1, Optional endchar As Long = -1)
On Error GoTo ErrHandler
Dim oldselstart As Long, oldsellen As Long
' These are place holders for the color coding
Dim tag_open As Long
Dim tag_close As Long
Dim bef As String
Dim Curr As String
'frmMain.trapUndo = False
' Find out where the cursor is
oldselstart = frmDocument.rtfText.SelStart
oldsellen = frmDocument.rtfText.SelLength
If endchar = -1 Then endchar = Len(frmDocument.rtfText.Text)
If startchar = 0 Then startchar = 1
' These are the close tags for colorcoding
tag_close = startchar
' Lets try to hide the color coding from the user:
frmDocument.rtfText.HideSelection = True
' Now lets loop through the tags and color code it
Do
' See where the next tag starts. if any
tag_open = InStr(tag_close, frmDocument.rtfText.Text, "<%")
'If so, then color it...
If tag_open <> 0 Then 'Found a tag
'Get everything before the tag we're on...
bef = Mid$(frmDocument.rtfText.Text, 1, tag_open - 1)
'Find the end of the next tag...
tag_close = InStr(tag_open, frmDocument.rtfText.Text, "%>")
'Get the current HTML tag...
Curr = Mid$(frmDocument.rtfText.Text, tag_open, tag_close - tag_open + 1)
If tag_close <> 0 Then
Select Case Left$(Curr, 2)
Case "<%"
' It's asp
tag_close = InStr(tag_open, frmDocument.rtfText.Text, "%>") + 1
frmDocument.rtfText.SelStart = tag_open - 1
frmDocument.rtfText.SelLength = tag_close - tag_open + 1
frmDocument.rtfText.SelColor = m_AspCol
Case Else
' it's not an asp tag so do nothing
End Select
End If
If tag_close = 0 Or tag_close >= endchar Then
' If we are coloring tags and it's over the end tag then
' get me out of this loop and don't color anymore
Exit Do
End If
Else
Exit Do
End If
Loop
frmDocument.rtfText.SelStart = oldselstart
frmDocument.rtfText.SelLength = oldsellen
frmDocument.rtfText.HideSelection = False
frmDocument.rtfText.SetFocus
'frmMain.trapUndo = True
Exit Function
ErrHandler:
Exit Function
End Function
' This cycles through the html and comes back with the right tag colors for the tag and all of it's
' attributes
Private Function cycleAttrib(CurrTag As String, opentag As Long, closetag As Long)
Dim fPos As Long, sPos As Long, qPos As Long, qnPos As Long, aPos As Long, tBeg As Long, tEnd As Long
Dim isFirstCycle As Boolean
Dim eTag As String
Dim sPosTxt As String
Dim LeftOver As Long
Dim EndTag As Long, QuotePos As Long, QuoteEndPos As Long
'frmDocument.trapUndo = False
eTag = CurrTag
isFirstCycle = True
Do While Len(eTag) > 0
fPos = InStr(1, eTag, "=")
If (fPos = 0 And isFirstCycle = True) Then
' This just checks to see if it's a basic html tag w/ no attributes and if so colors that
' without going through the rest of the junk.
frmDocument.rtfText.SelStart = opentag - 1
frmDocument.rtfText.SelLength = closetag - opentag + 1
frmDocument.rtfText.SelColor = m_TagCol
Exit Function
' It looks like we have an attribute. Here comes the hard part...
ElseIf fPos <> 0 Then 'Put in the color info...
If Left$(eTag, 1) = "<" Then
' This brings back the entire tag. something like:
' <img src="blah.jpg" onclick="blah">
' and then color codes the entire thing
tBeg = opentag
tEnd = opentag + fPos
' Color Code the entire tag first
frmDocument.rtfText.SelStart = tBeg - 1
frmDocument.rtfText.SelLength = closetag - tBeg + 1
frmDocument.rtfText.SelColor = m_TagCol
' This brings back the text that is past the attribute. in the previous example:
' "blah.jpg" onclick="blah">
eTag = Mid$(eTag, fPos + 1)
LeftOver = closetag - Len(eTag)
End If
End If
'Find the first instance of a space in the
'part of the tag that we have left...
sPos = InStr(1, eTag, Chr$(32))
'Gets the text up to the next space...
sPosTxt = Mid$(eTag, 1, sPos)
'Checks to see if there's a quote in the text...
qPos = InStr(1, sPosTxt, Chr$(34))
'If there's a quote found, then we need to find
'its end...
If qPos <> 0 Then
'Look for the next quote...
qnPos = InStr(2, eTag, Chr$(34))
If qnPos <> 0 Then
sPosTxt = Mid$(eTag, 1, qnPos)
End If
End If
LeftOver = closetag - Len(eTag)
frmDocument.rtfText.SelStart = LeftOver
frmDocument.rtfText.SelLength = Len(sPosTxt)
frmDocument.rtfText.SelColor = m_AttribCol
'Truncates the tag so there's no attrib value left...
eTag = Mid$(eTag, Len(sPosTxt) + 1)
'Find the next position of an equal sign...
sPos = InStr(1, eTag, "=")
'If there's no =, then we know we're on the last
'attrib value, so we need to put in some final
'info...all that's left is something like:
'"#ffffff">
If sPos = 0 Then
'Put in the attrib color before the ">"
'if it's the last attribute...
eTag = Mid$(eTag, 1, Len(eTag) - 1)
'Insert the RTF info...
'bef = bef & infoRTF & AttribInfo & eTag
frmDocument.rtfText.SelStart = LeftOver
frmDocument.rtfText.SelLength = Len(eTag)
frmDocument.rtfText.SelColor = m_AttribCol
'Truncate the end...
sPos = Len(eTag)
Exit Do
End If
'Truncates the tag appropriately...
eTag = Mid$(eTag, sPos + 1)
isFirstCycle = False
'If there's nothing left, then we need to exit
'the loop so it doesn't loop infinitely...
If sPos = 0 And qPos = 0 Then Exit Do
Loop
'frmMain.trapUndo = True
Exit Function
End Function
paste this into a module called "Declares"
Code:
Public Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Long) As Long
Public Const WM_USER = &H400
Public Const EM_HIDESELECTION = WM_USER + 63
paste this into a module called "VB6Function"
Code:
Option Explicit
' These are vb6 functions not in vb5. If using vb 6 comment out these functions or
' remove this module from the project... note that i have edited some of these functions
' for my use and the vb 6 functions may not work the same. You could always change the
' name of these functions and replace the call in the code. These functions were taken from
' support.microsoft.com
Public Function RevInStr(ByVal sIn As String, sFind As String, Optional nStart As Long = 1, Optional bCompare As VbCompareMethod = vbBinaryCompare) As Long
Dim nPos As Long
nPos = InStr(nStart, sIn, sFind, bCompare)
If nPos = 0 Then
RevInStr = 0
Else
RevInStr = Len(sIn) - nPos - Len(sFind) + 2
End If
End Function
' End VB6 functions
[Edited by denniswrenn on 05-22-2000 at 03:24 PM]
-
May 22nd, 2000, 05:27 AM
#4
Thank you so much for posting all that but theres a problem with it, it colors non HTML tags too. I need it to color and capitalize only html tags.
-
May 22nd, 2000, 05:50 AM
#5
so are you using a rich text box for the the html code? im sure there is an easier way than what was posted. you want to get all of the tags?
-
May 22nd, 2000, 07:16 AM
#6
download the file, I may have made a copy and paste error.
it works fine for me, but it doesnt uppercase... I am sure I could modify it a bit to make it upper case...
it would be easy, if I can find the temp. string that holds the text to make blue... I can just ucase or whatever the command is...
BTW I copied this code from an html editor on http://www.planetsourcecode.com
-
May 22nd, 2000, 09:36 AM
#7
Yes i am using a rich text box and since i am not that advanced the easiest way would be the best for me. And i did download the file, it still turns non-html tags blue.
-
May 22nd, 2000, 03:48 PM
#8
Will someone please tell me how to do it, please...
-
May 22nd, 2000, 05:02 PM
#9
Conquistador
you can change the case by using UCASE
-
May 23rd, 2000, 02:29 AM
#10
oh, I see what your talking about...
you would have to have a list of all the tags.... which would be hard...
-
May 23rd, 2000, 02:45 AM
#11
Yup thats exactly how i want to do it. You got any idea on the code for it?
-
May 23rd, 2000, 03:08 AM
#12
Actually I believe it was me who gave you the code. Here
it is again. Make a Form with a RichTextBox on it.
Put the following code in the Declarations section of your Form.
Code:
Option Explicit
Private Sub HighlightText(sKeyword As String)
Dim nStart As Integer, sPrevChar As String, sNextChar As String
nStart = InStr(1, LCase(RichTextBox1.Text), sKeyword)
Do While nStart <> 0
If nStart > 1 Then
sPrevChar = Mid$(RichTextBox1.Text, nStart - 1, 1)
Else
sPrevChar = " "
End If
If Len(RichTextBox1.Text) >= nStart + Len(sKeyword) Then
sNextChar = Mid$(RichTextBox1.Text, nStart + Len(sKeyword), 1)
Else
sNextChar = " "
End If
If (sPrevChar = Chr(32) Or sPrevChar = Chr(13) Or _
sPrevChar = Chr(10) Or sPrevChar = Chr(9)) And _
(sNextChar = Chr(32) Or sNextChar = Chr(13) Or _
sNextChar = Chr(10) Or sNextChar = Chr(9)) Then
With RichTextBox1
.SelStart = nStart - 1
.SelLength = Len(sKeyword)
.SelColor = vbBlue
.SelText = UCase(sKeyword)
.SelStart = Len(RichTextBox1.Text)
.SelColor = vbBlack
End With
End If
nStart = InStr(nStart + Len(sKeyword), LCase(RichTextBox1.Text), sKeyword)
Loop
End Sub
Private Sub Form_Resize()
RichTextBox1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Private Sub RichTextBox1_Change()
With RichTextBox1
.SelStart = 0
.SelLength = Len(.Text)
.SelColor = vbBlack
.SelStart = Len(.Text)
End With
HighlightText "<html>"
HighlightText "<title>"
HighlightText "<body>"
HighlightText "</html>"
HighlightText "</title>"
HighlightText "</body>"
End Sub
I hope this helps.
-
May 23rd, 2000, 03:48 AM
#13
Hey Megatron,
Yup thats what i was looking for, but it screws up sometimes. If you have a line of text and you go to the beggining of it and press delete it moves the cursor to the front. But i found a site that said it used api to do this but i couldnt make beans or farts of it, heres the url maybe you can. http://members.xoom.com/_XMCM/yellow...es/tboxex1.htm
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|
Reply With Quote