http://72.9.234.170/~purebasi/english/v ... hp?t=11772
Code : Tout sélectionner
;Jan 2004.
;********************************************
;-Enumerations
Enumeration
#MainWindow
EndEnumeration
;Menu enumeration.
Enumeration
#MenuNew
#MenuOpen
#MenuSave
#MenuSaveAs
#MenuClose
#MenuQuit
EndEnumeration
;Gadget enumeration.
Enumeration
#RichEdit
#TBNew
#TBOpen
#TBSave
#PanelBase
EndEnumeration
;The following sequence identifies any errors occurring; e.g. 'Unable to open file' etc.
Enumeration
#NoError
#FileNotFound
EndEnumeration
;Font enumeration
Enumeration
#FontEdit
EndEnumeration
;-Structures
Structure _tag; Used in an array to store all supported HTML tags.
Description.s
Open.s
Close.s
Attributes.s
EndStructure
Structure File; Used to record information on each open file.
FileName$
RichEdit.l
RichEdit_OldHandler.l
CursorPosition.l
EndStructure
;-Constants and globals.
;Declare constants.
Enumeration
#False
#True
EndEnumeration
#COLOR_Text = $000000 : #EFFECTS_Text = 0
#COLOR_Tag = $0000ff : #EFFECTS_Tag = #CFE_Bold
#COLOR_Attribute = $00ff00 : #EFFECTS_Attribute = 0
#COLOR_Quote = $cc00ff : #EFFECTS_Quote = #CFE_Italic
#COLOR_Symbol = $ff0000 : #EFFECTS_Symbol = 0
#NumberOfTags = 2 : #NumberOfSymbols = 2
;Declare global variables
Global gErrorCode.b, gOldWinProc
Dim Symbol.s(#NumberOfSymbols)
Dim Tag._tag(#NumberOfTags)
;Load fonts.
LoadFont(#FontEdit, "Times New Roman", 12)
;Declare procedures.
Declare HighlightLine(Line)
Declare.l HighlightTag(LineText.s, StartPos, EndPos, Left, Right, i)
Declare WindowCallback(hWnd, uMsg, wParam, lParam)
;- Startup
;Read the list of available tags.
Restore TagList
For i = 1 To #NumberOfTags
Read Tag(i)\Description : Read Tag(i)\Open : Read Tag(i)\Close : Read Tag(i)\Attributes
Next i
Restore SymbolList
For i = 1 To #NumberOfSymbols
Read Symbol(i)
Next i
;- Open main window and display gadgets.
OpenWindow(#MainWindow,0,0,400,400, #PB_Window_Invisible | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget,"")
ShowWindow_(WindowID(#MainWindow), #SW_maximize)
CreateGadgetList(WindowID(#MainWindow))
CreateTB(0,WindowID(),16,16,#TBpro_FLAT)
SetTBimage(0,0,#TBpro_NORMAL)
SetTBimage(0,0,#TBpro_Hot)
SetTBimage(0,0,#TBpro_Disabled)
AddTBsysIcons()
AddTBbutton(#TBNew, #TBpro_FILENEW, #TBpro_Button) : SetTBbuttonTooltip(#TBNew,"Create a new HTML document")
AddTBbutton(#TBOpen, #TBpro_FILEOPEN, #TBpro_Button) : SetTBbuttonTooltip(#TBOpen,"Open an existing HTML document")
AddTBbutton(#TBSave, #TBpro_FILESAVE, #TBpro_Button) : SetTBbuttonTooltip(#TBSave,"Save HTML document")
CreateMenu(0, WindowID(#MainWindow))
MenuTitle("File")
MenuItem(#MenuNew, "&New")
MenuItem(#MenuOpen, "&Open")
MenuItem(#MenuSave, "&Save")
MenuItem(#MenuSaveAs, "Save &As ...")
MenuItem(#MenuClose, "&Close")
MenuItem(#MenuQuit, "&Quit")
EditorGadget (#RichEdit,0,50,3*WindowWidth()/4,WindowHeight()-50)
SetGadgetFont(#RichEdit, UseFont(#FontEdit))
SendMessage_(GadgetID(#RichEdit), #EM_SETBKGNDCOLOR, 0, $b6fcf8); Set background colour.
;Allow the trapping of the EN_CHANGE message which occurs after the contents of the editor gadget
;has changed.
SendMessage_(GadgetID(#RichEdit), #EM_SETEVENTMASK, 0, #ENM_CHANGE)
ActivateGadget(#RichEdit)
gOldWinProc = GetWindowLong_(WindowID(), #GWL_WNDPROC); This is used to bypass our Window callback procedure when required.
SetWindowCallback(@WindowCallback())
;Main message loop..
Repeat
EventID=WaitWindowEvent()
Select EventId
Case #WM_KeyDown
Case #PB_EventMenu
Select EventMenuID()
EndSelect
Case #PB_EventGadget
Select EventGadgetID()
Case #RichEdit
EndSelect
EndSelect
Until EventID=#PB_EventCloseWindow
;The following procedure scans the given line of text in the richedit control looking for HTML tags etc.
;Such tags / symbols etc. are coloured appropriately.
Procedure HighlightLine(Line)
Protected LineText.s, Format.CHARFORMAT, StartPos, Endpos, Left, Right, Flag.b
LineText = LCase(GetGadgetItemText(#RichEdit, Line,0))
;Get the character index's of both ends of the line.
StartPos = SendMessage_(GadgetID(#RichEdit),#EM_LINEINDEX, Line,0)
EndPos = StartPos + Len(LineText)
Format\cbSize = SizeOf(CHARFORMAT)
Format\dwMask = #CFM_COLOR | #CFM_BOLD | #CFM_ITALIC
Left = StartPos : Right = StartPos
Repeat
;Identify possible tags.
i = FindString(LineText, "&", Left-StartPos+1) + StartPos
j = FindString(LineText, "<", Left-StartPos+1) + StartPos
If i = StartPos And j = StartPos;No special characters found.
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, EndPos)
Format\crTextColor = #COLOR_Text : Format\dwEffects = #EFFECTS_Text
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
Left = EndPos
Else; A character of significance has been found; i.e. '&' or '<'.
;Interested in the first occurring special character.
If i = StartPos
Right = j
ElseIf j = StartPos
Right = i
ElseIf i < j
Right = i
Else
Right = j
EndIf
;The variable Right now points to the next occurring character of importance.
If Right > left; The text up to this character needs to be coloured accordingly.
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, Right-1)
Format\crTextColor = #COLOR_Text : Format\dwEffects = #EFFECTS_Text
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
Left = Right-1
EndIf
Select Mid(LineText,Right-StartPos,1)
Case "&"
;We need to search for a valid HTML symbol.
Flag = #False
For i = 1 To #NumberOfSymbols
If FindString(LineText,Symbol(i),Right-StartPos) + StartPos = Right;Symbol found.
Flag = #True
Break; Break from loop, leaving i as the pointer to the relevant symbol.
EndIf
Next i
If Flag = #True
Right = Left + Len(Symbol(i))
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, Right)
Left = Right
Format\crTextColor = #COLOR_Symbol : Format\dwEffects = #EFFECTS_Symbol
Else
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, Right)
Left = Right
Format\crTextColor = #COLOR_Text : Format\dwEffects = #EFFECTS_Text
EndIf
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
Case "<"
;First search for a valid closing tag.
Flag = #False
For i = 1 To #NumberOfTags
If FindString(LineText,Tag(i)\Close,Right-StartPos) + StartPos = Right;Tag found.
Flag = #True
Break; Break from loop, leaving i as the pointer to the relevant tag.
EndIf
Next i
If Flag=#True
Right = Left + Len(Tag(i)\Close)
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, Right)
Left = Right
Format\crTextColor = #COLOR_Tag : Format\dwEffects = #EFFECTS_Tag
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
Else
;Now search for a valid opening tag.
Flag = #False
For i = 1 To #NumberOfTags
If FindString(LineText,Tag(i)\Open,Right-StartPos) + StartPos = Right; Tag found.
Flag = #True
Break; Break from loop, leaving i as the pointer to the relevant tag.
EndIf
Next i
If Flag=#True ; A valid open tag has been found.
;First colour the open tag accordingly.
Left = HighlightTag(LineText, StartPos, EndPos, Left, Right, i)
Right = Left
Else
;No open Or close tag found.
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, Right)
Left = Right
Format\crTextColor = #COLOR_Text : Format\dwEffects = #EFFECTS_Text
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
EndIf
EndIf
EndSelect
EndIf
Until Left = EndPos
EndProcedure
;The following procedure is part of the highlightline routine and highlights the statements within
;< and > tags. The left parameter points to the left of the '<' tag and right = left + 1.
Procedure.l HighlightTag(LineText.s, StartPos, EndPos, Left, Right, i)
Protected Text.s, Format.CHARFORMAT, Flag.b, Limit
Format\cbSize = SizeOf(CHARFORMAT)
Format\dwMask = #CFM_COLOR | #CFM_BOLD | #CFM_ITALIC
Right = Left + Len(Tag(i)\Open)
If Right = Endpos
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, Right)
Format\crTextColor = #COLOR_Tag : Format\dwEffects = #EFFECTS_Tag
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
ProcedureReturn Right
EndIf
If Mid(LineText,Right-StartPos +1,1) = ">" Or Mid(LineText,Right-StartPos +1,1) = " "
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, Right+1)
Format\crTextColor = #COLOR_Tag : Format\dwEffects = #EFFECTS_Tag
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
If Mid(LineText,Right-StartPos +1,1) = ">" : ProcedureReturn Right+1 : EndIf
Right + 1
Left = Right
If Right = Endpos : ProcedureReturn Right : EndIf
;We now search for valid attributes and/or values within quotes etc.
;The variable Limit will either point to the next occuring '>' or the end of the string as appropriate.
Limit = FindString(LineText, ">", Left-StartPos+1) + StartPos
If Limit = StartPos : Limit = EndPos : EndIf
Repeat
;Mark the boundaries of the next alphabetic string within the HTML tags.
While (Right < Limit) And Asc(Mid(LineText,Right-StartPos+1,1)) >='a' And Asc(Mid(LineText,Right-StartPos+1,1)) <= 'z'
Right + 1
Wend
If Right > Left; Indicates an alphabetic string was located.
;Check to see if this string is a valid attribute.
If FindString(Tag(i)\Attributes, "*" + Mid(LineText, Left-StartPos+1, Right-Left) + "*",1) > 0
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, Right)
Format\crTextColor = #COLOR_Attribute : Format\dwEffects = #EFFECTS_Attribute
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
Left = Right
Else
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, Right)
Format\crTextColor = #COLOR_Text : Format\dwEffects = #EFFECTS_Text
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
Left = Right
EndIf
Else; Some other character such as whitespace or a quotation mark.
If Asc(Mid(LineText,Right-StartPos+1,1)) = 34; Quotation mark.
;Search for a closing quotation.
Right = FindString(LineText, Chr(34), Right-StartPos+2) + StartPos
If (Right > Limit) Or (Right = StartPos) : Right = Limit : EndIf
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, Right)
Format\crTextColor = #COLOR_Quote : Format\dwEffects = #EFFECTS_Quote
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
Left = Right
Else
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, Right+1)
Format\crTextColor = #COLOR_Text : Format\dwEffects = #EFFECTS_Text
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
Right+1
Left = Right
EndIf
EndIf
Until Right = Limit
;Finally, check if there is a closing tag.
If Mid(LineText, Limit - StartPos,1) = ">"
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Limit-1, Limit)
Format\crTextColor = #COLOR_Tag : Format\dwEffects = #EFFECTS_Tag
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
EndIf
ProcedureReturn Right
Else; Open tag ends with an invalid character; e.g. <pk> instead of <p> etc.
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, Left, Right)
Format\crTextColor = #COLOR_Text : Format\dwEffects = #EFFECTS_Text
SendMessage_(GadgetID(#RichEdit), #EM_SETCHARFORMAT, #SCF_SELECTION, @Format)
ProcedureReturn Right
EndIf
ProcedureReturn Left+1
EndProcedure
;The following call back procedure is responsible for highlighting HTML tags etc.
;It does this by intercepting the #EN_CHANGE command message which fires whenever
;text in the rich edit control has changed. We then examine the entire line containing the text.
Procedure WindowCallback(hWnd, uMsg, wParam, lParam)
Protected ReturnValue, Chr.CHARRANGE, Line, CurrentStartPos
ReturnValue = #PB_ProcessPureBasicEvents
Select uMsg
Case #WM_COMMAND
If wParam >>16 = #EN_CHANGE And lparam = GadgetID(#RichEdit)
;The following returns the index (0-based) of the line containing the current character.
SendMessage_(GadgetID(#RichEdit),#EM_GETSEL,@CurrentStartPos, @Line)
Line = SendMessage_(GadgetID(#RichEdit),#EM_LINEFROMCHAR, CurrentStartPos,0)
SendMessage_(GadgetID(#RichEdit), #EM_HIDESELECTION, 1,0)
HighlightLine(Line)
If GetAsyncKeyState_(#VK_return) & 1 = 1; Bit 0 is set if the enter key was pressed since the last check.
;Investigate the previous line.
HighlightLine(Line-1)
EndIf
SendMessage_(GadgetID(#RichEdit), #EM_SETSEL, CurrentStartPos,CurrentStartPos); Return cursor to its correct position.
SendMessage_(GadgetID(#RichEdit),#EM_SETMODIFY,0,0)
SendMessage_(GadgetID(#RichEdit), #EM_HIDESELECTION, 0,0)
;ActivateGadget(#RichEdit)
EndIf
EndSelect
ProcedureReturn ReturnValue
EndProcedure
;- DataSection
DataSection
TagList:
Data.s "BODY section", "<body", "</body>"
Data.s "*bgcolor*background*text*link*alink*vlink*bgproperties*"
Data.s "Paragraph", "<p", "</p>"
Data.s "*align*"
SymbolList:
Data.s "<"
Data.s " "
EndDataSection