Announcement

Collapse
No announcement yet.

RichEdit With Syntax Highlighting - Fail

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • RichEdit With Syntax Highlighting - Fail

    Some years back I used the RichEdit control for presenting syntax highlighted code, using code from Borje. I've since moved to the Scintilla control.

    But, I was playing tonight with the RichEdit syntax highlighting code and found that all my older code uses this, i.e., it uses the older version of the RichEdit control instead of the latest version ...

    Code:
        LoadLibrary("riched32.dll")
        Control Add "RichEdit", hDlg, %IDC_RichEdit, "", 5, 60, 150, 100, _
    
    in lieu of this ...
    
        LoadLibrary("msftedit.dll")
        Control Add "RichEdit50W", hDlg, %IDC_RichEdit, "", 5, 60, 150, 100, _
    I can't find a single example in the various apps where I used the more recent version of the RichEdit control.

    When I tried it, the syntax highlighting code fails. It's not obvious to me why it fails. No error messages, just failed syntax highlighting

    Example code:
    Code:
    'Compilable Example:
    #Compiler PBWin 10
    #Compile Exe "syntax_template.exe"
    #Dim All
    
    #Debug Error On
    #Debug Display On
    
    %Unicode = 1
    #Include "Win32API.inc"
    
    '#Resource Manifest, 1, "xptheme.xml"
    
    %IDC_RichEdit = 500
    
    Global hDlg, hRichEdit, hCodeFont, OldREProc As Dword, CodeCase As Long
    Global UWords(), MWords() As String
    
    Function PBMain() As Long
       Dialog Default Font "Tahoma", 12,1
       Dialog New Pixels, 0, "Syntax Highlighting Test", , , 300,200, %WS_OverlappedWindow,, To hDlg
       Dialog Show Modal hDlg, Call DlgProc
    End Function
    
    CallBack Function DlgProc
       Local w,h As Long
       Select Case Cb.Msg
          Case %WM_InitDialog
             CodeCase = 3
             CreateRichEdit
             Control Set Text hDlg, %IDC_RichEdit, "Function PBMain" + $CrLf + "  'test" + $CrLf + "  x = ""2""" + $CrLf + "End Function"
             synInitializeWords
             PostMessage hDlg, %WM_User+500, 0, 0
    
          Case %WM_User+500
             synApplySyntax
    
          Case %WM_Size
             Dialog Get Client hDlg To w,h
             Control Set Loc hDlg, %IDC_RichEdit, 0,0
             Control Set Size hDlg, %IDC_RichEdit, w,h
    
       End Select
    End Function
    
    Sub CreateRichEdit
    '    LoadLibrary("msftedit.dll")... fail
    '    Control Add "RichEdit50W", ... fail
    
        LoadLibrary("riched32.dll")
        Control Add "RichEdit", hDlg, %IDC_RichEdit, "", 5, 60, 150, 100, _
              %WS_Child Or %WS_Visible Or %ES_MultiLine Or %WS_VScroll Or %ES_AutoHScroll _
           Or %WS_TabStop Or %WS_HScroll Or %ES_AutoVScroll Or %ES_WantReturn Or %ES_NoHideSel, %WS_Ex_ClientEdge
        Control Handle hDlg, %IDC_RichEdit To hRichEdit
        Font New "Courier New",12,1 To hCodeFont
        Control Set Font hDlg, %IDC_RichEdit, hCodeFont
        OldREProc = SetWindowLong(hRichEdit, %GWL_WndProc, CodePtr(NewREProc))
    End Sub
    
    Function NewREProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
      Select Case wMsg
        Case %WM_KeyUp        'trap key up, for syntax color check while editing
            Local CurLine As Long
            CurLine = SendMessage(hRichEdit, %EM_EXLINEFROMCHAR, 0, -1)
            ScanLine(CurLine, CurLine)              'check current line only
            Function = 0 : Exit Function                  'return zero
      End Select
      NewREProc = CallWindowProc(OldREProc, hWnd, wMsg, wParam, lParam)
    End Function
    
    Sub synApplySyntax()
      MousePtr 11                  'Scan all lines
      TurnOffCol
      ScanLine(0, SendMessage(hRichEdit, %EM_GETLINECOUNT, 0, 0) - 1)
      MousePtr 0
      SetFocus hRichEdit
    End Sub
    
    Sub synInitializeWords
      Local temp$, i As Long
      ReDim UWords(1000), MWords(1000)
      Open Exe.Path$ + "keywords.txt" For Input As #1  'has humpback words in it, used for display
      While IsFalse Eof(1)
        Line Input #1, temp$
        If Len(Trim$(temp$)) Then
            MWords(i) = temp$
            UWords(i) = UCase$(MWords(i))    'UCase is used to compare code against keywords
            Incr i
        End If
      Wend
      Close #1
      ReDim Preserve UWords(i-1), MWords(i-1)
    End Sub
    
    Function setRichTextColor( ByVal NewColor As Long) As Long
    ' setRichTextColor sets the textcolor for selected text in a Richedit control.
    ' &HFF - read, &HFF0000 - blue, &H008000 - dark green, &H0 is black, etc.
      Local cf As CHARFORMAT
      cf.cbSize      = Len(cf)      'Length of structure
      cf.dwMask      = %CFM_COLOR    'Set mask to colors only
      cf.crTextColor = NewColor      'Set the new color value
      SendMessage(hRichEdit, %EM_SETCHARFORMAT, %SCF_SELECTION, VarPtr(cf))
    End Function
    
    Sub TurnOffCol
    ' Set all text to black - faster this way
      Local cf As CHARFORMAT, xEvent As Long
      Local tTime As Single : tTime = Timer                      'get time
      xEvent = SendMessage(hRichEdit, %EM_GETEVENTMASK, 0, 0)        'Get eventmask
      SendMessage(hRichEdit, %EM_SETEVENTMASK, 0, 0)            'Disable eventmask
      MousePtr 11                                                'Hourglass
      cf.cbSize      = Len(cf)                                  'Length of structure
      cf.dwMask      = %CFM_COLOR                                'Set mask to colors only
      cf.crTextColor = &H0                                      'Set black color value
      SendMessage(hRichEdit, %EM_SETCHARFORMAT, -1, VarPtr(cf)) '%SCF_ALL = -1
      If xEvent Then
        SendMessage(hRichEdit, %EM_SETEVENTMASK, 0, xEvent)    'Enable eventmask
      End If                                                    'Arrow
      MousePtr 0
      SendMessage(hRichEdit, %EM_SETMODIFY, %FALSE, 0)          'reset modify flag
    End Sub
    
    Sub ScanLine(ByVal Line1 As Long, ByVal Line2 As Long)
    ' Syntax color parser for received line numbers
      Local pd As CHARRANGE, Oldpd As CHARRANGE, tBuff As TEXTRANGE
      Local xWord, Buf As String
      Local Aspect, xEvents, i, j, stopPos, lnLen, Result As Long
      Local wFlag As Byte, Letter As Byte Ptr
    
      SendMessage(hRichEdit, %EM_EXGETSEL, 0, VarPtr(Oldpd)) 'Original position
                                                              '(so we can reset it later)
      'Disable the event mask, for better speed
      xEvents = SendMessage(hRichEdit, %EM_GETEVENTMASK, 0, 0)
      SendMessage(hRichEdit, %EM_SETEVENTMASK, 0, 0)
    
      'Turn off redraw for faster and smoother action
      SendMessage(hRichEdit, %WM_SETREDRAW, 0, 0)
    
      If Line1 <> Line2 Then                                  'if multiple lines
        MousePtr 11
      Else                                                                    'editing a line
        pd.cpMin = SendMessage(hRichEdit, %EM_LINEINDEX, Line1, 0)                'line start
        pd.cpMax = pd.cpMin + SendMessage(hRichEdit, %EM_LINELENGTH, pd.cpMin, 0) 'line end
        SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPtr(pd))                  'select line
        setRichTextColor &H0                                            'set black
      End If
    
      For J = Line1 To Line2
        Aspect = SendMessage(hRichEdit, %EM_LINEINDEX, J, 0)      'line start
        lnLen  = SendMessage(hRichEdit, %EM_LINELENGTH, Aspect, 0) 'line length
    
        If lnLen Then
            Buf = Space$(lnLen + 1)
            tBuff.chrg.cpMin = Aspect
            tBuff.chrg.cpMax = Aspect + lnLen
            tBuff.lpstrText = StrPtr(Buf)
            lnLen = SendMessage(hRichEdit, %EM_GETTEXTRANGE, 0, ByVal VarPtr(tBuff)) 'Get line
    
            'CharUpperBuff(ByVal StrPtr(Buf), lnLen)        'Make UCASE
            Buf = UCase$(Buf)
            'I always use this one, since it handles characters > ASC(127) as well.. ;-)
    
            '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
            ' Loop through the line, using a pointer for better speed
            '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
            Letter = StrPtr(Buf) : wFlag = 0
            For I = 1 To Len(Buf)
              Select Case @Letter 'The characters we need to inlude in a word
                  Case 97 To 122, 65 To 90, 192 To 214, 216 To 246, 248 To 255, _
                                                    35 To 38, 48 To 57, 63, 95
                    If wFlag = 0 Then
                        wFlag = 1 : stopPos = I
                    End If
    
                  Case 34 ' string quotes -> "
                    stopPos = InStr(I + 1, Buf, Chr$(34)) 'Find match
                    If stopPos Then
                      pd.cpMin = Aspect + I
                      pd.cpMax = Aspect + stopPos - 1
                      SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPtr(pd))
                      setRichTextColor &HFF
                      StopPos = (StopPos - I + 1)
                      I = I + StopPos
                      Letter = Letter + StopPos
                      wFlag = 0
                    End If
    
                  Case 39 ' uncomment character -> '
                    pd.cpMin = Aspect + I - 1
                    pd.cpMax = Aspect + lnLen
                    SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPtr(pd))
                    setRichTextColor &H00008000&
                    wFlag = 0
                    Exit For
    
                  Case Else  'word is ready
                    If wFlag = 1 Then
                        xWord = Mid$(Buf, stopPos, I - stopPos)  'Get word
    
                        If xWord = "REM" Then  'extra for the uncomment word, REM
                          pd.cpMin = Aspect + I - Len(xWord) - 1
                          pd.cpMax = Aspect + lnLen
                          SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPtr(pd))
                          setRichTextColor &H00008000&
                          wFlag = 0
                          Exit For
                        End If
                        Array Scan UWords(0), = xWord, To Result  'Is it in the array?
                        If Result Then
                          pd.cpMin = Aspect + stopPos - 1
                          pd.cpMax = Aspect + I - 1
                          SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPtr(pd))
                          Control Send hDlg, %IDC_RichEdit, %EM_ReplaceSel, %True, StrPtr(MWords(Result-1))
                          SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPtr(pd))
                          setRichTextColor(&HFF0000)      'set blue color
                        End If
                        wFlag = 0
                    End If
              End Select
    
              Incr Letter
            Next I
        End If
      Next J
    
      'Reset original caret position
      SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPtr(Oldpd))
    
      'Turn on Redraw again and refresh - this one causes some flicker in Richedit..
      SendMessage hRichEdit, %WM_SETREDRAW, 1, 0
      InvalidateRect hRichEdit, ByVal %NULL, 0 : UpdateWindow hRichEdit
    
      'Reset the event mask
      If xEvents Then SendMessage(hRichEdit, %EM_SETEVENTMASK, 0, xEvents)
    End Sub

  • #2
    Through experimentation, if I change MWords() to StringZ and apply VarPtr to MWords, then the syntax highlighting seems to work.

    Something to do with %EM_ReplaceSel it seems, but not sure what the difference is between old and new RichEdit that accounts for the need to change.

    Will look for some documentation that clarifies the result.

    On BOTH versions of the code, I noticed that pasted text does not get syntax highlighted. I'll to look at the code to fix that.

    Comment


    • #3
      ...
      Forum: http://www.jose.it-berater.org/smfforum/index.php

      Comment


      • #4
        Howdy, Jose!

        I see that you almost spoke up.

        Did my experimental fix appear correct?

        Comment


        • #5
          And, adding this to NewREProc detects the paste and applies syntax highlighting.

          Code:
              Case %WM_Char
                 If wParam = &H16 Then synApplySyntax
          It does it for the entire RichEdit control, not just the pasted content. For short code that's ok but for much larger code listings I ought to apply the syntax to just the changed lines.

          ,,, added .. I had that somewhere in my notes but I'm not sure which equate &H16 applies to. I'll have to look more to know for sure. I went through Jose's includes but couldn't narrow down which equate description applied here.

          Comment


          • #6
            Never tried syntax highlighting code with latest RichEdit, but quick test shows it works with LoadLibrary("RICHED20.DLL") and CONTROL ADD "RichEdit20A", in case "new" features in later version (2 or 3) is wanted. Can guess it's some sort of unicode (wide) character problem - will have a look at it later on.

            Comment


            • #7
              Ok, in own code - in Sub ScanLine, it was enough to change Letter AS BYTE PTR to Letter AS WORD PTR and Local xWord, Buf As wString. Old example, updated to work with RichEdit50W:
              Code:
              #COMPILE EXE
              #DIM ALL
              #INCLUDE "WIN32API.INC"   'Some include files
              #INCLUDE "RICHEDIT.INC"
              
              %IDLABEL      = 100        'Some Id's for the controls
              %IDLABELPOS   = 101
              %IDLABELTIME  = 102
              %IDLABELSIZE  = 103
              %IDNOCOL      = 200
              %ID_RICHEDIT  = 500
              
              GLOBAL hEdit   AS LONG    'A bit easier with this handle as Global
              GLOBAL OldProc AS LONG    'For the subclassed edit control
              GLOBAL cData() AS STRING  'an array to hold all keywords
              
              %NewRichEdit = 1          ' 1 = RichEdit50W / 0 = RichEdit v1       <<<<<<<<<<<<<<<<<<<
              
              '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
              ' Start point - build dialog, controls and set some initial data
              ' ----------------------------------------------------------------------------
              FUNCTION PBMAIN
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                'Load the Richedit dll.
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
              '  LoadLibrary("MSFTEDIT.DLL")  v4.1
              '  LoadLibrary("RICHED20.DLL")  v2 or v3
              '  LoadLibrary("RICHED32.DLL")  v1
                #IF %NewRichEdit
                    IF LoadLibrary("MSFTEDIT.DLL") = 0 THEN
                       MSGBOX "Unable to load MSFTEDIT.DLL - sorry, no point in continuing",,"File missing!"
                       EXIT FUNCTION  'is this correct? At least it seems to terminate properly..
                    END IF
                #ELSE
                    IF LoadLibrary("RICHED32.DLL") = 0 THEN
                       MSGBOX "Unable to load RICHED32.DLL - sorry, no point in continuing",,"File missing!"
                       EXIT FUNCTION  'is this correct? At least it seems to terminate properly..
                    END IF
                #ENDIF
              
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                'Declare some variables, plus build dialog and controls
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                LOCAL txt AS STRING, fDir AS STRING, fFile AS STRING, rText AS STRING
                LOCAL hDlg AS LONG, hFont AS LONG, hFile AS LONG
              
                DIALOG NEW 0, "PB/DDT RichEdit syntax color demo",,, 400, 300, %WS_SYSMENU TO hDlg
                CONTROL ADD BUTTON, hDlg, %IDOK,     "&Set color",  230, 266,  50, 14
                CONTROL ADD BUTTON, hDlg, %IDNOCOL, "&Reset",    285, 266,  50, 14
                CONTROL ADD BUTTON, hDlg, %IDCANCEL, "E&xit",       340, 266,  50, 14
                CONTROL ADD LABEL,  hDlg, %IDLABEL,  "Changed:",     10, 272, 100, 12
                CONTROL ADD LABEL,  hDlg, %IDLABELPOS,  "Position",  10, 260, 100, 12
                CONTROL ADD LABEL,  hDlg, %IDLABELTIME,  "Time elapsed:", 115, 260, 115, 12
                CONTROL ADD LABEL,  hDlg, %IDLABELSIZE,  "Size:",         115, 272, 115, 12
                ' RichEdit     v1
                ' RichEdit20A  v2 or v3
                ' RichEdit50W  v 4.1
                #IF %NewRichEdit
                  CONTROL ADD "RichEdit50W", hDlg, %ID_RICHEDIT, "", 6, 6, 384, 252, _
                              %WS_CHILD  OR %WS_CLIPCHILDREN OR %WS_VISIBLE OR %ES_MULTILINE OR %WS_VSCROLL OR _
                              %WS_HSCROLL OR %ES_AUTOVSCROLL OR %ES_AUTOHSCROLL OR %ES_WANTRETURN, %WS_EX_CLIENTEDGE
                #ELSE
                  CONTROL ADD "RichEdit", hDlg, %ID_RICHEDIT, "", 6, 6, 384, 252, _
                              %WS_CHILD  OR %WS_CLIPCHILDREN OR %WS_VISIBLE OR %ES_MULTILINE OR %WS_VSCROLL OR _
                              %WS_HSCROLL OR %ES_AUTOVSCROLL OR %ES_AUTOHSCROLL OR %ES_WANTRETURN, %WS_EX_CLIENTEDGE
                #ENDIF
              
                CONTROL HANDLE hDlg, %ID_RICHEDIT TO hEdit
              
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                'Subclass the Richedit control and set it to use "Courier New", 9 p.
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                OldProc = SetWindowLong(hEdit, %GWL_WNDPROC, CODEPTR(TextWndProc))
                hFont   = MakeFont("Courier New", 9)
                SendMessage hEdit, %WM_SETFONT, hFont, 0
              
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                'Must set the event mask, so we can pick up a few events from Richedit
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                CALL SendMessage(hEdit, %EM_SETEVENTMASK, 0, %ENM_SELCHANGE OR %ENM_CHANGE OR %ENM_UPDATE)
                CALL SendMessage(hEdit, %EM_SETLIMITTEXT, &H100000&, 0) 'make it accept text > 32767 bytes &H100000&
              
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                'Try to open some .BAS file. If it fails, create and set some other text
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                fDir = CURDIR$ : IF RIGHT$(fDir, 1) <> "\" THEN fDir = fDir & "\"
                fFile = DIR$(fDir & "*.bas")
              
                IF LEN(fFile) THEN
                   hFile = FREEFILE                         'simple file-to-richedit -routine
                   OPEN fFile FOR BINARY AS hFile
                      GET$ hFile, LOF(hFile), txt
                   CLOSE hFile
                   SetWindowText hEdit, BYVAL STRPTR(txt)
              
                ELSE                                        'failed, so create a dummy text..
                   txt =       "FUNCTION PBMAIN  ' Test for color syntax" & CHR$(10)
                   txt = txt & "    DIALOG NEW 0, ""Syntax color"",,, 400, 300, %WS_SYSMENU TO hDlg" & CHR$(10)
                   txt = txt & "    CONTROL ADD LABEL, hDlg, id, ""demo"", x, y, xx, yy" & CHR$(10)
                   txt = txt & "    DIALOG SHOW MODAL hDlg CALL DlgCallback" & CHR$(10) 'LF - line feed
                   txt = txt & "END FUNCTION" & CHR$(13, 10) & CHR$(13, 10)             'CRLF - new paragraph
              
                   rText = REPEAT$(10, txt)
                   CALL SendMessage(hEdit, %WM_SETTEXT, 0, STRPTR(rText))
                END IF
              
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                'Pass the array on to another function that will redim and load it with data.
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                LoadPBdata cData()
              
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                'Enable the following if you want it to start with syntax colored text..
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
              '  MOUSEPTR 11                  'Scan all lines
              '  CALL  ScanLine(0, SendMessage(hEdit, %EM_GETLINECOUNT, 0, 0) - 1)
              '  MOUSEPTR 0
              
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                'Set the modify flag to zero = text not changed
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                CALL SendMessage(hEdit, %EM_SETMODIFY, %FALSE, 0)
              
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                'Get the initial position data into the labels
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                CALL GetPosText(hDlg)
                SetFocus hEdit
              
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                ' Show the dialog
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                DIALOG SHOW MODAL hDlg CALL DlgCallback
              
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                'This point is reached when the program terminates - delete what we have created
                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                IF hFont THEN DeleteObject hFont
                IF OldProc THEN SetWindowLong hDlg, %GWL_WNDPROC, OldProc
              
              END FUNCTION
              
              
              '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
              ' Main callback procedure for all controls
              ' ----------------------------------------------------------------------------
              CALLBACK FUNCTION DlgCallback()
                SELECT CASE CBMSG
                   CASE %WM_COMMAND
                      SELECT CASE CBCTL
                         CASE %IDOK                       '<- Set color -button
                            LOCAL tTime AS SINGLE : tTime = TIMER 'To see how long it takes
                            DIALOG DOEVENTS
                            MOUSEPTR 11                   'Scan all lines
                            CALL  ScanLine(0, SendMessage(hEdit, %EM_GETLINECOUNT, 0, 0) - 1)
                            MOUSEPTR 0
                            SetFocus hEdit
              
                            CALL GetPosText(CBHNDL)
                            CONTROL SET TEXT CBHNDL, %IDLABELTIME, "Time elapsed: " & _
                                             FORMAT$(TIMER - tTime, "0.0000") & " seconds."
              
                         CASE %IDNOCOL                    '<- Reset -button
                            CALL TurnOffCol(CBHNDL)
                            SetFocus hEdit
              
                         CASE %IDCANCEL                   '<- Exit -button
                            DIALOG END CBHNDL             'Exit program
              
                         CASE %ID_RICHEDIT                'Some Richedit events, just to
                            SELECT CASE HIWRD(CBWPARAM)   'show you where to find them
                               CASE %EN_UPDATE 'is trigged before displaying altered text
              
                               CASE %EN_CHANGE 'is trigged after..
                                  'BEEP         'uncomment, to see that it works on changes
                            END SELECT
              
                      END SELECT
              
                 CASE %WM_NOTIFY
                    LOCAL nh AS NMHDR PTR
                    nh =  CBLPARAM                                'More Richedit events
                    IF CBCTL = %ID_RICHEDIT THEN                  'Get caret movement
                       IF @nh.code = %EN_SELCHANGE THEN
                          CALL GetPosText(CBHNDL)
                       END IF
                    END IF
                 END SELECT
              END FUNCTION
              
              
              '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
              ' Routine to get text and changed-flag status
              ' ----------------------------------------------------------------------------
              SUB GetPosText(BYVAL hDlg AS LONG)
                 LOCAL txt AS STRING, l AS LONG, pd AS CHARRANGE
              
                 l = SendMessage(hEdit, %WM_GETTEXTLENGTH, 0, 0)
                 CALL SendMessage(hEdit, %EM_EXGETSEL, 0, VARPTR(pd))
                 txt = "Size:" & STR$(l) & " bytes.  (pos: "  & STR$(pd.cpMin) & " )"
                 CONTROL SET TEXT hDlg, %IDLABELSIZE, txt
              
                 IF pd.cpMin = pd.cpMax THEN  ' nothing selected
                    pd.cpMin = SendMessage(hEdit, %EM_EXLINEFROMCHAR, 0, (pd.cpMin)) + 1 'line number
                    pd.cpMax = pd.cpMax - SendMessage(hEdit, %EM_LINEINDEX, -1, 0) + 1   'pos. in line
              
                    txt = "Line:" + STR$(pd.cpMin) & "   Pos:" & STR$(pd.cpMax)
                 ELSE
                    txt = "Selected: " & STR$(pd.cpMax - pd.cpMin) & " bytes"
                END IF
              
                CONTROL SET TEXT hDlg, %IDLABELPOS, txt
              
                'Get status - returns %FALSE (0) for not modified, or %TRUE (-1) for modified
                IF SendMessage(hEdit, %EM_GETMODIFY, 0, 0) THEN
                   CONTROL SET TEXT hDlg, %IDLABEL, "Modified"
                ELSE
                   CONTROL SET TEXT hDlg, %IDLABEL, "Not modified"
                END IF
              
              END SUB
              
              
              '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
              ' Redim and load a received array with data
              ' ----------------------------------------------------------------------------
              FUNCTION LoadPBdata(dArray() AS STRING) AS LONG
                LOCAL I AS LONG, rc AS LONG
              
                rc = DATACOUNT
                REDIM dArray(rc - 1) AS STRING 'zero based, so -1
              
                FOR I = 1 TO rc                  'read the data into the array
                   dArray(I-1) = UCASE$(READ$(I))
                NEXT
              
                FUNCTION = rc  'Return the count, in case we ever should need it..
              
                'PB/DLL 6.0 syntax color data - at least most of it..  :-)
                DATA %DEF, #COMPILE, #DEBUG, #DIM, #IF, #INCLUDE, #RESOURCE, #OPTION
                DATA #REGISTER, #RESOURCE, #STACK
                DATA ABS, ADD, ADDR, ALL, AND, ARRAY, AS, ASC, ASCIIZ, ATN, ATTACH
                DATA BAR, BEEP, BIN$, BIT, BITS?, BITS??, BITS???, BITS%, BITS&, BYTE, BUTTON, BYCOPY, BYREF, BYVAL
                DATA CALL, CALLBACK, CASE, CBCTL, CBCTLMSG, CBHNDL, CBLPARAM, CBMSG, CBWPARAM, CBYT, CCUR
                DATA CCUX, CDBL, CDWD, CEIL, CEXT, CHDIR, CHDRIVE, CHECK, CHECKBOX, CHR$, CINT
                DATA CLIENT, CLNG, CLOSE, CODEPTR, COMBOBOX, COMM, COMMAND$, CONTROL, COS, CQUD,
                DATA CSNG, CUR, CUX, CURDIR$, CVBYT, CVCUR, CVCUX, CVD, CVDWD, CVE, CVI, CVL
                DATA CVQ, CVS, CVWRD, CWRD
                DATA DATA, DATACOUNT, DATE$, DECLARE, DECR, DEFBYT, DEFCUR, DEFCUX, DEFDBL
                DATA DEFDWD, DEFEXT, DEFINT, DEFLNG, DEFQUD, DEFSNG, DEFSTR, DEFWRD, DELETE
                DATA DIALOG, DIM, DIR$, DISABLE, DISKFREE, DISKSIZE, DLL, DO, DOEVENTS, DOUBLE, DRAW, DWORD
                DATA ELSE, ENABLE, END, ENVIRON$, EOF, EQV, ERASE, ERR, ERRAPI, ERRCLEAR, ERROR, EXE, EXIT
                DATA EXP, EXP2, EXP10, EXPLICIT, EXT, EXTRACT$
                DATA FILEATTR, FILECOPY, FILENAME, FIX, FLUSH, FOCUS, FOR, FORMAT$, FRAC
                DATA FRAME, FREEFILE, FUNCTION
                DATA GET, GET$, GETATTR, GLOBAL, GOSUB, GOTO, HANDLE, HEX$, HIBYT, HIWRD, HOST
                DATA IF, IMAGE, IMAGEX, IMGBUTTON, IMGBUTTONX, IMP, INCR, INPUT#
                DATA INSERT, INSTR, INT, INTEGER, ISFALSE, ISTRUE, ITERATE, KILL
                DATA LABEL, LBOUND, LCASE$, LEFT, LEN, LET, LINE, LISTBOX, LOBYT
                DATA LOC, LOCAL, LOCK, LOF, LOG, LOG2, LOG10, LONG, LOOP, LOWRD, LSET, LTRIM$
                DATA MAKDWD, MAKLNG, MAKPTR, MAT, MAX, MENU, MID$, MIN, MKBYT$, MKCUR$, MKCUX$
                DATA MKD$, MKDIR, MKDWD$, MKE$, MKI$, MKL$, MKQ$, MKS$, MKWRD$, MOD, MODAL, MODELESS
                DATA MOUSEPTR, MSGBOX, NAME, NEW, NEXT, NONE, NOT, NOTIFY, OCT$, ON, OPEN,
                DATA OPTION, OR, PARSE$, PARSECOUNT, PBMAIN, PEEK, PEEK$, PIXELS, POKE, POKE$, POPUP
                DATA PRINT, PRINT#, PTR, PUT, PUT$, QUAD, RANDOMIZE, READ, READ$, RECV, REDIM, REGEXPR
                DATA REGISTER, REGREPL, REMAIN$, REMOVE$, REPEAT$, REPLACE, RESET, RESUME, RETURN
                DATA  RGB, RIGHT , RMDIR, RND, ROTATE, ROUND, RSET, RTRIM$
                DATA SCAN, SEEK, SELECT, SEND, SET, SETATTR, SETEOF, SGN, SHELL, SHIFT
                DATA SHOW, SIN, SINGLE, SIZE, SIZEOF, SLEEP, SORT, SPACE$, SQR, STATE, STATIC, STEP
                DATA STR$, STRDELETE, STRING, STRING$, STRINSERT, STRPTR, STRREVERSE, SUB, SWAP
                DATA TALLY, TAN, TCP, TEXT, TEXTBOX, THEN, THREAD, TIME$, TIMER, TO, TRIM$, TYPE
                DATA UBOUND, UCASE, UDP, UNION, UNITS, UNLOCK, VAL
                DATA VARPTR, VERIFY, WEND, WHILE, WIDTH#, WINMAIN, WORD, WRITE, WRITE#, XOR
              
              END FUNCTION
              
              
              '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
              ' Create a desirable font and return its handle
              ' ----------------------------------------------------------------------------
              FUNCTION MakeFont(BYVAL FontName AS STRING, BYVAL PointSize AS LONG) AS LONG
                LOCAL hDC AS LONG, CyPixels AS LONG
              
                hDC = GetDC(%HWND_DESKTOP)
                CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
                ReleaseDC %HWND_DESKTOP, hDC
                PointSize = (PointSize * CyPixels) \ 72
              
                FUNCTION = CreateFont(0 - PointSize, 0, 0, 0, %FW_NORMAL, 0, 0, 0, _
                           %ANSI_CHARSET, %OUT_TT_PRECIS, %CLIP_DEFAULT_PRECIS, _
                           %DEFAULT_QUALITY, %FF_DONTCARE, BYCOPY FontName)
              
              END FUNCTION
              
              
              '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
              ' Syntax color parser for received line numbers
              ' ----------------------------------------------------------------------------
              SUB ScanLine(BYVAL Line1 AS LONG, BYVAL Line2 AS LONG)
                LOCAL pd AS CHARRANGE, Oldpd AS CHARRANGE, tBuff AS TEXTRANGE
              '  LOCAL xWord AS WSTRING, Buf AS WSTRING
                LOCAL Aspect AS LONG, iEvents AS LONG, I AS LONG , J AS LONG, stopPos AS LONG
                LOCAL lnLen AS LONG, Result AS LONG, wFlag AS BYTE
              
                #IF %NewRichEdit
                    LOCAL xWord, Buf AS WSTRING, Letter AS WORD PTR
                #ELSE
                    LOCAL xWord, Buf AS STRING, Letter AS BYTE PTR
                #ENDIF
              
                CALL SendMessage(hEdit, %EM_EXGETSEL, 0, VARPTR(Oldpd)) 'Original position
                                                                        '(so we can reset it later)
                'Disable the event mask, for better speed
                iEvents = SendMessage(hEdit, %EM_GETEVENTMASK, 0, 0)
                CALL SendMessage(hEdit, %EM_SETEVENTMASK, 0, 0)
              
                'Turn off redraw for faster and smoother action
                CALL SendMessage(hEdit, %WM_SETREDRAW, 0, 0)
              
                IF Line1 <> Line2 THEN                                  'if multiple lines
                   MOUSEPTR 11
                ELSE                                                                     'editing a line
                   pd.cpMin = SendMessage(hEdit, %EM_LINEINDEX, Line1, 0)                'line start
                   pd.cpMax = pd.cpMin + SendMessage(hEdit, %EM_LINELENGTH, pd.cpMin, 0) 'line end
                   CALL SendMessage(hEdit, %EM_EXSETSEL, 0, VARPTR(pd))                  'select line
                   setRichTextColor &H0                                                  'set black
                END IF
              
                FOR J = Line1 TO Line2
                   Aspect = SendMessage(hEdit, %EM_LINEINDEX, J, 0)       'line start
                   lnLen  = SendMessage(hEdit, %EM_LINELENGTH, Aspect, 0) 'line length
              
                   IF lnLen THEN
                      Buf = SPACE$(lnLen + 1)
                      tBuff.chrg.cpMin = Aspect
                      tBuff.chrg.cpMax = Aspect + lnLen
                      tBuff.lpstrText = STRPTR(Buf)
                      lnLen = SendMessage(hEdit, %EM_GETTEXTRANGE, 0, BYVAL VARPTR(tBuff)) 'Get line
              
                      CALL CharUpperBuff(BYVAL STRPTR(Buf), lnLen)        'Make UCASE
                      'I always use this one, since it handles characters > ASC(127) as well.. ;-)
              
                      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                      ' Loop through the line, using a pointer for better speed
                      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                      Letter = STRPTR(Buf) : wFlag = 0
                      FOR I = 1 TO LEN(Buf)
                         SELECT CASE @Letter 'The characters we need to inlude in a word
                            CASE 97 TO 122, 65 TO 90, 192 TO 214, 216 TO 246, 248 TO 255, _
                                                               35 TO 38, 48 TO 57, 63, 95
                               IF wFlag = 0 THEN
                                  wFlag = 1 : stopPos = I
                               END IF
              
                            CASE 34 ' string quotes -> "
                              stopPos = INSTR(I + 1, Buf, CHR$(34)) 'Find match
                              IF stopPos THEN
                                 pd.cpMin = Aspect + I
                                 pd.cpMax = Aspect + stopPos - 1
                                 CALL SendMessage(hEdit, %EM_EXSETSEL, 0, VARPTR(pd))
                                 setRichTextColor &HFF
                                 StopPos = (StopPos - I + 1)
                                 I = I + StopPos
                                 Letter = Letter + StopPos
                                 wFlag = 0
                              END IF
              
                            CASE 39 ' uncomment character -> '
                               pd.cpMin = Aspect + I - 1
                               pd.cpMax = Aspect + lnLen
                               CALL SendMessage(hEdit, %EM_EXSETSEL, 0, VARPTR(pd))
                               setRichTextColor &H00008000&
                               wFlag = 0
                               EXIT FOR
              
                            CASE ELSE  'word is ready
                               IF wFlag = 1 THEN
                                  xWord = MID$(Buf, stopPos, I - stopPos)  'Get word
              
                                  IF xWord = "REM" THEN  'extra for the uncomment word, REM
                                     pd.cpMin = Aspect + I - LEN(xWord) - 1
                                     pd.cpMax = Aspect + lnLen
                                     CALL SendMessage(hEdit, %EM_EXSETSEL, 0, VARPTR(pd))
                                     setRichTextColor &H00008000&
                                     wFlag = 0
                                     EXIT FOR
                                  END IF
              
                                  ARRAY SCAN cData(0), = xWord, TO Result  'Is it in the array?
                                  IF Result THEN
                                     pd.cpMin = Aspect + stopPos - 1
                                     pd.cpMax = Aspect + I - 1
                                     CALL SendMessage(hEdit, %EM_EXSETSEL, 0, VARPTR(pd))
                                     CALL setRichTextColor(&HFF0000)       'set blue color
                                  END IF
                                  wFlag = 0
                               END IF
                         END SELECT
              
                         INCR Letter
                      NEXT I
                   END IF
                NEXT J
              
                'Reset original caret position
                CALL SendMessage(hEdit, %EM_EXSETSEL, 0, VARPTR(Oldpd))
              
                'Turn on Redraw again and refresh - this one causes some flicker in Richedit..
                SendMessage hEdit, %WM_SETREDRAW, 1, 0
                InvalidateRect hEdit, BYVAL %NULL, 0 : UpdateWindow hEdit
              
                'Reset the event mask
                IF iEvents THEN CALL SendMessage(hEdit, %EM_SETEVENTMASK, 0, iEvents)
              
              END SUB
              
              
              '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
              ' setRichTextColor sets the textcolor for selected text in a Richedit control.
              ' Example: CALL setRichTextColor(&HFF) sets the color to red.
              ' &HFF0000 is blue, &H008000 is dark green, &H0 is black, etc..
              ' ----------------------------------------------------------------------------
              FUNCTION setRichTextColor( BYVAL NewColor AS LONG) AS LONG
                LOCAL cf AS CHARFORMAT
              
                cf.cbSize      = LEN(cf)       'Length of structure
                cf.dwMask      = %CFM_COLOR    'Set mask to colors only
                cf.crTextColor = NewColor      'Set the new color value
              
                CALL SendMessage(hEdit, %EM_SETCHARFORMAT, %SCF_SELECTION, VARPTR(cf))
              
              END FUNCTION
              
              
              '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
              ' TextWndProc - traps %WM_.. -actions in the richtext window
              ' ----------------------------------------------------------------------------
              FUNCTION TextWndProc(BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
                                   BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
                SELECT CASE wMsg
                   CASE %WM_KEYUP         'trap key up, for syntax color check while editing
                      LOCAL CurLine AS LONG
                      CurLine = SendMessage(hEdit, %EM_EXLINEFROMCHAR, 0, -1)
                      CALL ScanLine(CurLine, CurLine)               'check current line only
                      FUNCTION = 0 : EXIT FUNCTION                  'return zero
                END SELECT
              
                TextWndProc = CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)
              END FUNCTION
              
              
              '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
              ' Set all text to black - faster this way
              ' ----------------------------------------------------------------------------
              SUB TurnOffCol(BYVAL hDlg AS LONG)
                LOCAL cf AS CHARFORMAT, pd AS CHARRANGE, Oldpd AS CHARRANGE, iEvent AS LONG
                LOCAL tTime AS SINGLE : tTime = TIMER                      'get time
              
                iEvent = SendMessage(hEdit, %EM_GETEVENTMASK, 0, 0)        'Get eventmask
                CALL SendMessage(hEdit, %EM_SETEVENTMASK, 0, 0)            'Disable eventmask
                MOUSEPTR 11                                                'Hourglass
              
                cf.cbSize      = LEN(cf)                                   'Length of structure
                cf.dwMask      = %CFM_COLOR                                'Set mask to colors only
                cf.crTextColor = &H0                                       'Set black color value
                CALL SendMessage(hEdit, %EM_SETCHARFORMAT, %SCF_ALL, VARPTR(cf)) '%SCF_ALL = &H0004
              
                IF iEvent THEN
                   CALL SendMessage(hEdit, %EM_SETEVENTMASK, 0, iEvent)     'Enable eventmask
                END IF                                                     'Arrow
                MOUSEPTR 0
              
                CALL SendMessage(hEdit, %EM_SETMODIFY, %FALSE, 0)          'reset modify flag
                CALL GetPosText(hDlg)                                      'show position
              
                CONTROL SET TEXT hDlg, %IDLABELTIME, "Time elapsed: " & _  'Show elapsed time
                            FORMAT$(TIMER - tTime, "0.0000") & " seconds."
              
              END SUB
              Last edited by Borje Hagsten; 11 Sep 2019, 04:32 PM.

              Comment


              • #8
                Hi All
                Is that RichEdit50W the latest component?

                Comment


                • #9
                  Yep. 50W is the latest.

                  Comment


                  • #10
                    Borje, thank you for this ...

                    it was enough to change Letter AS BYTE PTR to Letter AS WORD PTR and Local xWord, Buf As wString.
                    ... it works for me too, when made to the OP code.

                    I had played briefly with using Word PTR but didn't get far enough in my thinking to know that xWord/Buf needed to be wString.

                    I was also looking at some code for doing a RichEdit search, forwards and backwards. The code (from Pierre) did not work with the old RichEdit, whereas the syntax highlighting did. So it was good to get both to work with the most recent RichEdit control. Your information was the missing piece for me.

                    Thanks again!

                    Comment

                    Working...
                    X