Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

PB/DDT Richedit Syntax color demo

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

  • PB/DDT Richedit Syntax color demo

    Code:
    ' NOTE: corrected for latest RichEdit.inc Feb 17, 2004
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' RichEdit example for PB/DLL 6.0, showing how to create a Richedit
    ' control and mark all occurrences of search-text with a specific color.
    ' It also shows you how to use subclassing to get %WM_.. -events and how
    ' to detect caret position and change-flag. I hope it can be of some use,
    ' even though it's not at all optimized for any specific purpose..  :-)
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' I actually don't think it can become much faster than this. The part
    ' that slows it down, is when you select text in order to set the color.
    ' Maybe it would be possible to stream out the text and use RTF code to
    ' set colors before you stream it in again, but that's another story..
    '
    ' I compared it to a C++ sample I found, and my code is both faster and
    ' manages coloring while editing. Edit a word and see what happens.
    ' It's slow on big texts though, but I've added a timer to enable you
    ' to experiment and see if you can make it faster.
    '
    ' Oh yes - I've included code to set a red color to text between quotes,
    ' and it works fine when its used on the whole text, but it does not
    ' handle editing 100% correct - it fails double quotes..
    '
    ' There's also some flickering that occurs when the Richedit window
    ' is redrawn after an action. Couldn't find any good solutions to this,
    ' but maybe someone else knows how to fix it in the Richedit control?
    ' ----------------------------------------------------------------------
    ' TIPS: By not using ES_NOHIDESEL when you create the control, all
    ' actions that involves selecting text becomes faster. Also set the
    ' event mask to zero before you do repeated stuff and reset it after
    ' you are done, plus use WM_SETREDRAW on/off for faster action. This
    ' sample shows all these trix and then some more..
    ' ----------------------------------------------------------------------
    ' IMPORTANT NOTICE: Richedit only handles text up to 65,535 bytes in
    ' Win95/98, but since some of the used EM_ -messages only works up to
    ' 32,766 bytes, the actual limit here is 32,766 bytes, in Win95/98..
    ' ----------------------------------------------------------------------
    ' DISCLAIMER: This is just one example of how it can be done. I normally
    ' don't use Richedit that much myself, but I know a lot people have been
    ' asking for this, so here's my solution to it - compile and run..  :-)
    '
    ' By Borje Hagsten, released as Public Domain - May 7, 2000
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
     
    #COMPILE EXE
    #DIM ALL
     
    #INCLUDE "WIN32API.INC"   'Some include files
    #INCLUDE "RICHEDIT.INC"
     
    'TYPE CHARFORMAT2          'Special Type for correct format setting
    '  cbSize AS LONG
    '  dwMask AS DWORD
    '  dwEffects AS DWORD
    '  yHeight AS LONG
    '  yOffset AS LONG         '0 for superscript, 0 for subscript
    '  crTextColor AS DWORD
    '  bCharSet AS BYTE
    '  bPitchAndFamily AS BYTE
    '  szFaceName AS ASCIIZ * %LF_FACESIZE
    '  szDummy AS INTEGER      'added as a 2 Byte correction
    'END TYPE
     
    %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
     
                              'Declare subs and functions
    DECLARE CALLBACK FUNCTION DlgCallback()
    DECLARE SUB      GetPosText(BYVAL hDlg AS LONG)
    DECLARE FUNCTION LoadPBdata(MyArray() AS STRING) AS LONG
    DECLARE FUNCTION MakeFont(BYVAL FontName AS STRING, BYVAL PointSize AS LONG) AS LONG
    DECLARE SUB      ScanLine(BYVAL Line1 AS LONG, BYVAL Line2 AS LONG)
    DECLARE FUNCTION setRichTextColor( BYVAL NewColor AS LONG) AS LONG
    DECLARE SUB      TurnOffCol(BYVAL hDlg AS LONG)
     
     
    '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
    ' Start point - build dialog, controls and set some initial data
    ' ----------------------------------------------------------------------------
    FUNCTION PBMAIN
      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      'Load the Richedit dll.
      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      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
     
      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      '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
     
      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
     
      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 STRING, Buf AS STRING
      LOCAL Aspect AS LONG, Events AS LONG, I AS LONG , J AS LONG, stopPos AS LONG
      LOCAL lnLen AS LONG, Result AS LONG, wFlag AS BYTE, Letter AS BYTE PTR
     
      CALL SendMessage(hEdit, %EM_EXGETSEL, 0, VARPTR(Oldpd)) 'Original position
                                                              '(so we can reset it later)
      'Disable the event mask, for better speed
      Events = 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 Events THEN CALL SendMessage(hEdit, %EM_SETEVENTMASK, 0, Events)
     
    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, Event AS LONG
      LOCAL tTime AS SINGLE : tTime = TIMER                      'get time
     
      Event = 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, -1, VARPTR(cf)) '%SCF_ALL = -1
     
      IF Event THEN
         CALL SendMessage(hEdit, %EM_SETEVENTMASK, 0, Event)     '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


    [This message has been edited by Borje Hagsten (edited February 17, 2004).]

  • #2
    Code:
    Borje, this is an excellent example of color syntax highlighting.
    As you are aware, if you search the net, anyone using the RichEdit
    control has the same problem, and yet no one has yet fixed it
    or at least wants to share the fix with us.
     
    I have experimented a little using tips from various programming
    sites.  The best solution so far is to reduce the overhead while
    repainting the client area. I have narrowed it down to just the
    line that we are editing on the fly. Eventually I hope to get it
    down to just the word.
     
     
    Here are the changes:
     
    1.
    'Added WS_CLIPCHILDREN to the parent window
    DIALOG NEW 0, "PB/DDT RichEdit syntax color demo",,, 400, 300, %WS_CLIPCHILDREN OR %WS_SYSMENU TO hDlg
     
    2.
    'Changed WS_CLIPCHILDREN to WS_CLIPSIBLINGS to the RichEdit window
      CONTROL ADD "RichEdit", hDlg, %ID_RICHEDIT, "", 6, 6, 384, 252, _
                  %WS_CHILD  OR %WS_CLIPSIBLINGS OR %WS_VISIBLE OR %ES_MULTILINE OR %WS_VSCROLL OR _
                  %WS_HSCROLL OR %ES_AUTOVSCROLL OR %ES_AUTOHSCROLL OR %ES_WANTRETURN, %WS_EX_CLIENTEDGE
                                 
     
    3.
    'Moved the ScanLine call to this select case block. (from TextWndProc->WM_KEYUP)
    'This way we eliminate scanning if any of the navigation keys are used.
     
                     CASE %EN_CHANGE 'is trigged after..
     
                     LOCAL CurLine AS LONG
                     CurLine = SendMessage(hEdit, %EM_EXLINEFROMCHAR, 0, -1)
                     CALL ScanLine(CurLine, CurLine)'check current line only
     
     
    4.
    'Changed line...
      SendMessage hEdit, %WM_SETREDRAW, 0, 0
    'To
      SendMessage hEdit, %EM_HIDESELECTION,1,0
     
    5.
    'and Changed line
      SendMessage hEdit, %WM_SETREDRAW, 1, 0
    'To...
      SendMessage hEdit, %EM_HIDESELECTION,0,0
       
    6.
    'Comment out repainting in the ScanLine routine.
      'InvalidateRect hEdit, BYVAL %NULL, 0 : UpdateWindow hEdit
    Regards, Jules




    [This message has been edited by Jules Marchildon (edited May 10, 2000).]
    Best regards
    Jules
    www.rpmarchildon.com

    Comment


    • #3
      Your changes works fine, Jules. Nice. I did a test and loaded it
      with RICHED20.DLL instead, and noticed that using WM_SETREDRAW +
      InvalidateRect didn't cause any flicker at all in the new version.
      It was *much* slower on whole texts though. I'll see if I can come
      up with some StreamIn/StreamOut code to use later on. That should
      do it. A bit busy right now, but one of these days..

      BTW, I've looked up the following keywords to use - I think this
      covers them all: (in case someone is working on a "better" PB editor..

      Code:
        'PB syntax color data - at least most of it..  :-)
      DATA #COMPILE, #DEBUG, #DIM, #ELSE, #ELSEIF, #ENDIF, #IF, #INCLUDE, #OPTION, #REGISTER
      DATA #RESOURCE, #SEGMENT, #STACK, $COMPILE, $DEBUG, $DIM, $ELSE, $ELSEIF, $ENDIF, $IF
      DATA $INCLUDE, $OPTION, $REGISTER, $RESOURCE, $SEGMENT, $STACK, %DEF, %PB_EXE
      DATA ABS, ACCESS, ADD, ADDR, ALIAS, ALL, AND, ANY, APPEND, ARRAY, AS, ASC, ASCEND, ASCIIZ
      DATA AT, ATN, ATTACH, BAR, BASE, BAUD, BDECL, BEEP
      DATA BIN$, BINARY, BIT, BITS%, BITS&, BITS?, BITS??, BITS???, BREAK, BUTTON, BYCMD, BYCOPY, BYREF
      DATA BYTE, BYVAL, CALL, CALLBACK, CASE, CBCTL, CBCTLMSG, CBHNDL, CBLPARAM, CBMSG, CBWPARAM, CBYT
      DATA CCUR, CCUX, CD, CDBL, CDECL, CDWD, CEIL, CEXT, CHDIR, CHDRIVE, CHECK, CHECK3STATE, CHECKBOX
      DATA CHR$, CINT, CLIENT, CLNG, CLOSE, CLS, CODEPTR, COLLATE, COLOR, COMBOBOX, COMM, COMMAND$
      DATA CONTROL, COS, CQUD, CREATE, CSNG, CTSFLOW, CUR, CURDIR$, CUX, CVBYT, CVCUR, CVCUX, CVD, CVDWD
      DATA CVE, CVI, CVL, CVQ, CVS, CVWRD, CWRD, DATA, DATACOUNT, DATE$, DECLARE, DECR, DEFAULT, DEFBYT
      DATA DEFCUR, DEFCUX, DEFDBL, DEFDWD, DEFEXT, DEFINT, DEFLNG, DEFQUD, DEFSNG, DEFSTR, DEFWRD
      DATA DELETE, DESCEND, DIALOG, DIM, DIR$, DISABLE, DISKFREE, DISKSIZE, DLL, DO, DOEVENTS, DOUBLE
      DATA DOWN, DRAW, DSRFLOW, DSRSENS, DTRFLOW, DTRLINE, DWORD, ELSE, ELSEIF, ENABLE, END, ENVIRON$
      DATA EOF, EQV, ERASE, ERR, ERRAPI, ERRCLEAR, ERROR, EXE, EXIT, EXP, EXP10, EXP2, EXPLICIT, EXPORT
      DATA EXT, EXTRACT$, FILEATTR, FILECOPY, FILENAME, FIX, FLOW, FLUSH, FOCUS, FOR, FORMAT$
      DATA FORMFEED, FRAC, FRAME, FREEFILE, FROM, FUNCTION, GET, GET$, GETATTR, GLOBAL, GOSUB, GOTO
      DATA HANDLE, HEX$, HIBYT, HIWRD, HOST, IDN, IF, IMAGE, IMAGEX, IMGBUTTON, IMGBUTTONX, IMP, IN
      DATA INCR, INPUT, INPUT#, INPUTBOX$, INSERT, INSTR, INT, INTEGER, INV, ISFALSE, ISTRUE, ITERATE
      DATA KILL, LABEL, LBOUND, LCASE$, LEFT, LEFT$, LEN, LET, LIB, LINE, LISTBOX, LOBYT, LOC, LOCAL
      DATA LOCK, LOF, LOG, LOG10, LOG2, LONG, LOOP, LOWRD, LPRINT, LSET, LTRIM$, MAKDWD, MAKLNG, MAKPTR
      DATA MAT, MAX, MAX$, MAX%, MAX&, MENU, MID$, MIN, MIN$, MIN%, MIN&, MKBYT$, MKCUR$, MKCUX$, MKD$
      DATA MKDIR, MKDWD$, MKE$, MKI$, MKL$, MKQ$, MKS$, MKWRD$, MOD, MODAL, MODELESS, MOUSEPTR, MSGBOX
      DATA NAME, NEW, NEXT, NONE, NOT, NOTIFY, NULL, OCT$, OFF, ON, OPEN, OPTION, OR, OUTPUT, PAGE, PARITY
      DATA PARITYCHAR, PARITYREPL, PARITYTYPE, PARSE$, PARSECOUNT, PBD, PBMAIN, PEEK, PEEK$, PIXELS
      DATA POKE, POKE$, POPUP, PORT, PRESERVE, PRINT, PRINT#, PTR, PUT, PUT$, QUAD, RANDOM, RANDOMIZE
      DATA READ, READ$, RECV, REDIM, REGEXPR, REGISTER, REGREPL, REMAIN$, REMOVE$, REPEAT$
      DATA REPLACE, RESET, RESUME, RET16, RET32, RET87, RETP16, RETP32, RETPRM, RETURN, RGB, RIGHT
      DATA RIGHT$, RING, RLSD, RMDIR, RND, ROTATE, ROUND, RSET, RTRIM$, RTSFLOW, RXBUFFER, RXQUE, SCAN
      DATA SCROLLBAR, SDECL, SEEK, SELECT, SEND, SERVER, SET, SETATTR, SETEOF, SGN, SHARED, SHELL
      DATA SHIFT, SHOW, SIN, SINGLE, SIZE, SIZEOF, SLEEP, SORT, SPACE$, SPC, SQR, STATE, STATIC, STATUS
      DATA STDCALL, STEP, STOP, STR$, STRDELETE, STRING, STRING$, STRINSERT, STRPTR, STRREVERSE, SUB
      DATA SUSPEND, SWAP, TAB, TAGARRAY, TALLY, TAN, TCP, TEXT, TEXTBOX, THEN, THREAD, TIME$, TIMER
      DATA TIMEOUT, TO, TOGGLE, TRIM$, TRN, TXBUFFER, TXQUE, TYPE, UBOUND, UCASE, UCASE$, UDP, UNION
      DATA UNITS, UNLOCK, UNTIL, UP, USING, VAL, VARPTR, VERIFY, VERSION3, VERSION4, VERSION5, WEND
      DATA WHILE, WIDTH#, WINMAIN, WITH, WORD, WRITE, WRITE#, XOR, XINPFLOW, XOUTFLOW, ZER
      ------------------

      Comment


      • #4
        Thanks Borje,
        I'm just putting the final touches on a 'toolbox' for PowerBASIC users that will incorporate some of your colored text features. If anyone would like a compiled copy, email me.

        -Bob
        [email protected]

        ------------------
        "It was too lonely at the top".

        Comment

        Working...
        X