PureBasic

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 "&lt"
    Data.s "&nbsp"
EndDataSection

Code : Tout sélectionner

  ; 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")