Announcement

**Chris Holbrook** · 14 Sep 2009, 06:59 AM

added keyword colors etc

This code works on XP professional SP3.
Discussion http://www.powerbasic.com/support/pb...379#post323379

Code:

'
' Experimenting with a function/sub list for a code module
' starting off with a basic function list like the F2 list in the PB compilers
' Each function or sub can be viewed in a seperate window
' Synchronises with the last saved version of the subject file by checking the directory entry
' of the target file and reloading the function index and any changed windows
'
' Chris Holbrook 12-Sep-2009
'
' Changes
' 13-SEP-2009 includes comments preceding sub/function header in the function viewer windows
' 13-SEP-2009 uses keyword, comment and literal coloring
'
' Issues
' 13-SEP-2009 PB keyword list is for PBWin V7 only
' 14-SEP-2009 refreshes all viewer windows when any change occurs, not just the changed ones.
'
#compile exe
#debug display
#dim all

#if not %def(%WINAPI)
    #include "WIN32API.INC"
#endif
#if not %def(%COMMCTRL_INC)
    #include "COMMCTRL.INC"
#endif
#if not %def(%COMDLG32_INC)
    #include "COMDLG32.INC"
#endif
#include "richedit.inc"
#include "CCE_BASRO.INC"   
$version = "0.1.2"
%IDD_DIALOG1         =  101
%IDC_LV = 1001
%IDD_DIALOG2         =  102
%IDC_TEXTBOX1        = 1003
%IDC_SOUFILE_BN      = 1004

type tfindex
    sfname as asciz * 256
    start as long
    finish as long
    hwnd as dword
end type
global findex() as tfindex      ' global table of functions and subs
global sourcecode() as string   ' global table of source code
global ghfont as dword          ' font
'---------------------------------------------------------------------------
function build ( hD as dword, LVid as long, sfile as string) as long
    local i, j, n, hfile, nrow, linenum as long
    local s, sline, s1, s2, s3, slist, swork as string
'
    hfile = freefile
    try
        open sfile for input as hfile
        linenum = 1
        while isfalse eof(hfile)
            line input #hfile, sline
            n = ubound(sourcecode()) + 1
            redim preserve sourcecode(0 to n)
            sourcecode(n) = sline
            incr linenum
        wend
        close hfile
    catch
        dialog set text hd, "FILE ERROR": beep: sleep 2000
        exit function
    end try
    ' pick out functions & subs from the array
    for i = lbound(sourcecode()) to ubound(sourcecode())
        SWORK = Sourcecode(i) + " @@@@@@@@"
        s1 = ucase$(parse$(ltrim$(swork), " ", 1))
        s2 = parse$(ltrim$(swork), any " (", 2)
        s3 = parse$(ltrim$(swork), any " (", 3)
        select case s1
            case "SUB"
                gosub addtolist
            case "FUNCTION"
                if left$(s2,1) <> "=" then gosub addtolist
            case "CALLBACK"
                gosub addtolist
            case "END"
                if ucase$(left$(s2,8)) = "FUNCTION" then
                    gosub nudgelist
                    exit select
                end if
                if ucase$(left$(s2,3)) = "SUB" then
                    gosub nudgelist
                end if
        end select
    next

    s = ""
    for i = 50 to ubound(findex())
        s = s + str$(i) + str$(findex(i).start) + str$(findex(i).finish) + " " + findex(i).sfname + $crlf
    next

    exit function
'''''''''''''''
addtolist:
    incr nrow
    j = 1
    do while (i-j) > 0
        s = ltrim$(sourcecode(i - j))
        if left$(ltrim$(s),1) = $sq then
            incr j
        else
            exit loop
        end if
    loop
    if s1 = "CALLBACK" then
        s = s3
    else
        s = s2
    end if
    listview insert item hD, %IDC_LV, nrow, 0, s
    redim preserve findex(1 to nrow)
    findex(nrow).start = i - j + 1
    findex(nrow).sfname = s'sourcecode(i)
    if nrow > 1 then
        if findex(nrow -1).finish = 0 then
            findex(nrow-1).finish = i -1
        end if
    end if
    listview set text hD, %IDC_LV, nrow, 2, sourcecode(i)
return
'''''''''''''''
nudgelist:
    findex(nrow).finish = i
return
end function
'--------------------------------------------------------
callback function MainDlgProc()
    local i, j, l, n, nfrom, nto, nsel, x, y as long
    local s, soldcode, spath as string
    ' temporary array into which the old findex array is copied
    ' when a dirent change is detected
    local prevfindex() as tfindex
    ' rect used to define CCE window
    local r as rect

    ' used in checking the dirent for updates
    static htimer as dword
    ' filename and dialog title
    static sourcecodefile, stitle as string
    ' used in checking the dirent for updates
    static dird, dird1 as dirdata
    ' index in the Findex array of the subject of a call to CCE_BASRO
    ' used by the wm_user + 500 handler - message passed back from BBE_BASRO
    ' to identify the CCE dialog and control
    static editx as long
    ' Control id of the Edit control passed back in wm_user + 500 msg
    static lEditCtlId as long
    '
    select case as long cbmsg
        case %wm_initdialog
'            dialog set text cb.hndl, "wm_init"
            listview set stylexx cb.hndl, %IDC_LV, _
                %LVS_ex_infotip or %LVS_EX_FULLROWSELECT or  %LVS_EX_ONECLICKACTIVATE or %LVS_EX_GRIDLINES
            listview reset cb.hndl, %IDC_LV
            listview  insert column cb.hndl, %IDC_LV, 1, "Name", 100, 0
            listview  insert column cb.hndl, %IDC_LV, 2, "header", 500, 0
            stitle = "F2+ Source Code File Selection"
            gosub setsourcecodefile
            if trim$(sourcecodefile) = "" then
                dialog end cb.hndl, 0
            end if
            if isfile(sourcecodefile) = 0 then
                ? "file " + sourcecodefile + " not found!"
                dialog end cb.hndl, 0
            end if
            s = dir$ (sourcecodefile to dird)
            build(cb.hndl, %IDC_LV, sourcecodefile)
            htimer = settimer ( cb.hndl,%null, 2000, %null)
        '
        case %wm_destroy
            killtimer cb.hndl, htimer
            if ubound(findex()) < 0 then exit select
            for i = lbound(findex()) to ubound(findex())
                if findex(i).hWnd <> 0 then
                    dialog end findex(i).hWnd, 0
                end if
            next
        '
        case %wm_timer
            'dialog set text cb.hndl, "wm_timer"
            s = dir$ (sourcecodefile to dird1)
            if dird1.LastWriteTime <> dird.lastwritetime then
                erase sourcecode() ' get rid of the previous sourcecode array
                dird = dird1
                listview reset cb.hndl, %IDC_LV
                l = lbound(findex())
                dim prevfindex(l to ubound(findex()))
                poke$ varptr(prevfindex(l)), peek$(varptr(findex(l)),sizeof(findex(l)) * arrayattr(findex(),4))
                erase findex()
                build(cb.hndl, %IDC_LV, sourcecodefile)
                for i = lbound(findex()) to ubound(findex())
                     if prevfindex(i).hWnd then
                         ' get the text in the "new" file for the named Function
                         ' kill off viewer window
                         dialog end prevfindex(i).hWnd, 0
                         s = trim$(prevfindex(i).sfname)
                         listview find exact cb.hndl, %IDC_LV, 1, s to n
                         ' if the function no longer exists, no further action required
                         if n = 0 then exit select
                         ' fn is present, create a new window
                         s = ""
                         for j = findex(i).start to findex(i).finish
                             s = s + $crlf + sourcecode(j)
                         next
                         s = mid$(s, 3) ' lose leading $crlf
                         stitle = findex(i).sfname + " in " + sourcecodefile + " " + time$
                         setrect r, 0, 0, 400, 300
                         editx = i
                         CCE_basro( cb.hndl, r, byval strptr(s), stitle)
                     end if
                next
            end if
        '
        case %wm_user + 500 ' CCE_BASRO is passing hWnds
            findex(editx).hWnd = cb.wparam ' store the CCE dialog hWnd
            lEditCtlId = cb.lparam
        '
        case %wm_user + 501 ' child dialog has ended - clear hWnd in findex table
            for i = lbound(findex()) to ubound(findex())
                if findex(i).hWnd = cb.wparam then
                    findex(i).hWnd = 0
                    exit for
                end if
            next
        '
        case %wm_move, %wm_size
            local xx, yy as long
            if cb.wparam = %SIZE_MINIMIZED then
                for i = lbound(findex()) to ubound(findex())
                    if findex(i).hWnd <> 0 then
                        dialog send findex(i).hWnd, %wm_syscommand, %sc_minimize, 0
                    end if
                next
            end if
            dialog get client cb.hndl to x, y
            control set size cb.hndl, %IDC_LV, x, y
            control get size cb.hndl, %IDC_SOUFILE_BN to xx, yy
            control set size cb.hndl, %IDC_SOUFILE_BN, x, yy
        '
        case %wm_notify
            select case cb.ctl
                case %IDC_LV
                    select case cb.nmcode
                        case %nm_click
                            listview get select cb.hndl, %IDC_LV to nsel
                            'l = ubound(findex)
                            nfrom = findex(nsel).start
                            nto   = findex(nsel).finish
                            for i = findex(nsel).start to findex(nsel).finish
                                s = s + $crlf + sourcecode(i)
                            next
                            s = mid$(s,3)
                            stitle = findex(nsel).sfname + " in " + sourcecodefile + " " + time$
                            setrect r, 0, 0, 400, 300
                            editx = nsel
                            CCE_basro( cb.hndl, r, byval strptr(s), stitle)
                    end select
            end select
        '
        case %wm_command
            select case cb.ctl
                case %IDC_SOUFILE_BN
                    gosub setsourcecodefile
            end select
        '
        case %wm_ncrbuttondown
            for i = lbound(findex()) to ubound(findex())
                 s = s + str$(findex(i).start) + str$(findex(i).finish) + " " + findex(i).sfname + $crlf
            next
            ?s
        '
        case %wm_ncactivate
            static hWndSaveFocus as dword
            if isfalse cbwparam then
                hWndSaveFocus = GetFocus()
            elseif hWndSaveFocus then
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            end if
    end select
    exit function
''''''''''''''''''''''
setsourcecodefile:
    spath = curdir$
    OpenFileDialog(cb.hndl, stitle, sourcecodefile, sPATH, _
        "Basic Source Code Files|*.bas|Include Files|*.inc|All Files|*.*", "txt", 0)
    control set text cb.hndl, %IDC_SOUFILE_BN, sourcecodefile
return
end function
'------------------------------------------------------------------------
function MainDlg(byval hParent as dword) as long
    local lRslt, w, h as long
    local hDlg  as dword

    dialog font default "Courier New", 10, 0, 0
    dialog new hParent, "F2+", 0, 0, 201, 121, _
        %ws_popup or %ws_border or %ws_dlgframe or %ws_sysmenu or %ws_minimizebox or _
        %ws_clipsiblings or %ws_visible or %ds_modalframe or %ds_3dlook or _
        %ds_nofailcreate or %ds_setfont or %ds_center or %ws_thickframe, _
        %ws_ex_controlparent or %ws_ex_left or %ws_ex_ltrreading or %ws_ex_rightscrollbar, _
        to hDlg
    dialog get client hDlg to w, h
    control add button, hDlg, %IDC_SOUFILE_BN, "source code file", 0, 0, w, 14
    control add "SysListView32", hDlg, %IDC_LV, "SysListView32_1", 0, 15, 192, 100, _
        %ws_child or %ws_visible or %ws_tabstop or %lvs_report or %lvs_showselalways, _
        %ws_ex_left or %ws_ex_clientedge or %ws_ex_rightscrollbar
    dialog show modal hDlg, call MainDlgProc to lRslt
    function = lRslt
end function
'---------------------------------------------------------------------
function pbmain()
    initcommoncontrols
    MainDlg %hwnd_desktop
end function

this is the CCE_BASRO.INC file:

Code:

'------------------------------------------------------------------------------------------------------
' COMPACT CODE EDITOR CCE.INC
' Chris Holbrook July 2008
' including some code by Charles Dietz, Eric Christensen and Borje Hagsten
' modified to use with F2plus application
'

' CHANGES
' 13-SEP-2009 subset for RO PB Code viewing
'============================================


%CCE_MAXTEXTSIZE = 32768
global gKeywords as string
global ghlib as dword
'--------------------------------------------------------------------------------------
'PBWin 7.0 syntax color data - think at least most of it..  :-)
'----------------------------------------------------------------------------
'
sub CreatePBKeyWordString
    local hfile as long
    local s as string
    static slangwords, skeywords as string

    sLangWords = " ,=-+*/\(;" + $crlf + _
                 "'"         + $crlf + _
                 $dq          + $crlf
    sKeyWords = _
"#BLOAT,#COMPILE,#DEBUG,#DIM,#ELSE,#ELSEIF,#ENDIF,#IF,#INCLUDE,#OPTION,#REGISTER,#RESOURCE," + _
"#SEGMENT,#STACK,#TOOLS,$BEL,$BS,$COMPILE,$CR,$CRLF,$DEBUG,$DIM,$DQ,$ELSE,$ELSEIF,$ENDIF," + _
"$EOF,$ESC,$FF,$IF,$INCLUDE,$LF,$NUL,$OPTION,$REGISTER,$RESOURCE,$SEGMENT,$SPC,$STACK," + _
"$TAB,$VT,%DEF,%FALSE,%NULL,%PB_EXE,%TRUE," + _
"ABS,ACCEL,ACCEPT,ACCESS,ACODE$,ADD,ADDR,ALIAS,ALL,AND,ANY,APPEND,ARRAY,ARRAYATTR," + _
"AS,ASC,ASCEND,ASCIZ,ASCIIZ,AT,ATN,ATTACH,ATTRIB,BAR,BASE,BAUD,BDECL,BEEP," + _
"BIN$,BINARY,BIT,BITS%,BITS&,BITS?,BITS??,BITS???,BREAK,BUTTON,BYCMD,BYCOPY,BYREF," + _
"BYTE,BYVAL,CALC,CALL,CALLBACK,CALLSTK,CALLSTK$,CALLSTKCOUNT,CASE,CATCH,CBCTL,CBCTLMSG," + _
"CBHNDL,CBLPARAM,CBMSG,CBWPARAM,CBYT,CCUR,CCUX,CD,CDBL,CDECL,CDWD,CEIL,CEXT,CHDIR," + _
"CHDRIVE,CHECK,CHECK3STATE,CHECKBOX,CHOOSE,CHOOSE&,CHOOSE%,CHOOSE$,CHR$,CINT,CLIENT,CLNG," + _
"CLOSE,CLS,CLSID$,CODEPTR,COLLATE,COLOR,COLUMN,COMBOBOX,COMM,COMMAND$,CON,CONNECT,CONST,CONTROL," + _
"COS,CQUD,CREATE,CSET,CSET$,CSNG,CTSFLOW,CUR,CURDIR$,CURRENCY,CURRENCYX,CUX,CVBYT,CVCUR," + _
"CVCUX,CVD,CVDWD,CVE,CVI,CVL,CVQ,CVS,CVWRD,CWRD,DATA,DATACOUNT,DATE$,DECLARE,DECR,DEFAULT," + _
"DEFBYT,DEFCUR,DEFCUX,DEFDBL,DEFDWD,DEFEXT,DEFINT,DEFLNG,DEFQUD,DEFSNG,DEFSTR,DEFWRD,DELETE," + _
"DESCEND,DIALOG,DIM,DIR$,DISABLE,DISKFREE,DISKSIZE,DISPATCH,DLL,DLLMAIN,DO,DOEVENTS,DOUBLE," + _
"DOWN,DRAW,DSRFLOW,DSRSENS,DTRFLOW,DTRLINE,DWORD,ELSE,ELSEIF,EMPTY,ENABLE,END,ENVIRON$," + _
"EOF,EQV,ERASE,ERR,ERRAPI,ERRCLEAR,ERROR,ERROR$,EXE,EXIT,EXP,EXP10,EXP2,EXPLICIT,EXPORT," + _
"EXT,EXTENDED,EXTRACT$,FILEATTR,FILECOPY,FILENAME$,FILESCAN,FILL,FINALLY,FIX,FLOW,FLUSH,FOCUS," + _
"FONT,FOR,FORMAT$,FORMFEED,FRAC,FRAME,FREEFILE,FROM,FUNCTION,FUNCNAME$,GET,GET#,GET$," + _
"GETATTR,GLOBAL,GOSUB,GOTO,GUID$,GUIDTXT$,HANDLE,HEX$,HIBYT,HIINT,HIWRD,HOST,ICASE,ICON," + _
"IDN,IF,IFACE,IIF,IIF&,IIF%,IIF$,IMAGE,IMAGEX,IMGBUTTON,IMGBUTTONX,IMP,IN,INCR,INP,INOUT," + _
"INPUT,INPUT#,INPUTBOX$,INSERT,INSTR,INT,INTERFACE,INTEGER,INV,ISFALSE,ISNOTHING," + _
"ISOBJECT,ISTRUE,ITERATE,JOIN$,KILL,LABEL,LBOUND,LCASE$,LEFT,LEFT$,LEN,LET,LIB,LIBMAIN," + _
"LINE,LISTBOX,LISTVIEW,LOBYT,LOC,LOCAL,LOCK,LOF,LOG,LOG10,LOG2,LOINT,LONG,LOOP,LOWRD,LPRINT," + _
"LSET,LSET$,LTRIM$,MACRO,MACROTEMP,MAIN,MAKDWD,MAKINT,MAKLNG,MAKPTR,MAKWRD,MAT,MAX,MAX$," + _
"MAX%,MAX&,MCASE$,MEMBER,MENU,MID$,MIN,MIN$,MIN%,MIN&,MKBYT$,MKCUR$,MKCUX$,MKD$," + _
"MKDIR,MKDWD$,MKE$,MKI$,MKL$,MKQ$,MKS$,MKWRD$,MOD,MODAL,MODELESS,MOUSEPTR,MSGBOX," + _
"NAME,NEW,NEXT,NONE,NOT,NOTHING,NOTIFY,NULL,OBJACTIVE,OBJECT,OBJPTR,OBJRESULT,OCT$,OF," + _
"OFF,ON,OPEN,OPT,OPTION,OPTIONAL,OR,OUT,OUTPUT,PAGE,PARITY,PARITYCHAR,PARITYREPL,PARITYTYPE," + _
"PARSE,PARSE$,PARSECOUNT,PBD,PBMAIN,PEEK,PEEK$,PIXELS,POINTER,POKE,POKE$,POPUP,PORT,POST," + _
"PRESERVE,PRINT,PRINT#,PRIVATE,PROFILE,PROGID$,PTR,PUT,PUT$,QUAD,QWORD,RANDOM,RANDOMIZE,READ," + _
"READ$,RECEIVE,RECORDS,RECV,REDIM,REDRAW,REGEXPR,REGISTER,REGREPL,REMAIN$,REMOVE$,REPEAT$," + _
"REPLACE,RESET,RESUME,RET16,RET32,RET87,RETAIN$,RETP16,RETP32,RETPRM,RETURN,RGB,RIGHT," + _
"RIGHT$,RING,RLSD,RMDIR,RND,ROTATE,ROUND,RSET,RSET$,RTRIM$,RTSFLOW,RXBUFFER,RXQUE,SCAN," + _
"SCROLLBAR,SDECL,SEEK,SELECT,SEND,SERVER,SET,SETATTR,SETEOF,SGN,SHARED,SHELL," + _
"SHIFT,SHOW,SIGNED,SIN,SINGLE,SIZE,SIZEOF,SLEEP,SORT,SPACE$,SPC,SQR,STATE,STATIC,STATUS," + _
"STDCALL,STEP,STOP,STR$,STRDELETE$,STRING,STRING$,STRINSERT$,STRPTR,STRREVERSE$,SUB,SUSPEND," + _
"SWAP,SWITCH,SWITCH&,SWITCH%,SWITCH$,TAB,TAB$,TAGARRAY,TALLY,TAN,TCP,TEXT,TEXTBOX,THEN," + _
"THREAD,THREADCOUNT,THREADID,TIME$,TIMEOUT,TIMER,TO,TOGGLE,TRACE,TRIM$,TRN,TRY,TXBUFFER," + _
"TXQUE,TYPE,UBOUND,UCASE,UCASE$,UCODE$,UDP,UNION,UNITS,UNLOCK,UNTIL,UP,USER,USING,USING$," + _
"VAL,VARIANT,VARIANT#,VARIANT$,VARIANTVT,VARPTR,VERIFY,VERSION3,VERSION4,VERSION5," + _
"WEND,WHILE,WIDTH,WIDTH#,WINMAIN,WITH,WORD,WRITE,WRITE#,XOR,XINPFLOW,XOUTFLOW,ZER"
    gKeywords = sLangwords + sKeywords
end sub



$Ver = "Ver 0.50"

%IDC_New                  = 102
%IDC_Show                 = 103
%IDC_Hlp                  = 108
%IDC_Statusbar            = 110
%IDC_Note                 = 201
%IDC_DEBUG_LB             = 202
%HASHTABLESIZE            = &H1000

' the following are used in DIALOG GET/SET USER statements
' user dialog user values for communicating with TACE
%Ptr2UserText       = 1
%Ptr2Keywords       = 2
%CCERetval          = 3
' dialog user values used internally
%Hashtab            = 4
%FREPMSG            = 5
'----------------------------------------------------------------------------

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' setRichTextColor sets the textcolor for selected text in a RichNote control.
' Example: CALL setRichTextColor(&HFF) sets the color to red.
' &HFF0000 is blue, &H008000 is dark green, &H0 is black, etc..
' ----------------------------------------------------------------------------
function setRichTextColor( hNote as dword, 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(hNote, %EM_SETCHARFORMAT, %SCF_SELECTION, varptr(cf))

end function
'-------------------------------------------------------------------------------
' a hashing algo
function Elf32(sKey as string) as long
  local key as byte ptr
  local h as long
  local g as long
  local i as long
  key = strptr(sKey)
  h = 0
  while @key
    shift left h, 4
    h = h + @key
    key = key + 1
    g = h and &HF0000000???
    if g then
      i = g
      shift right i, 24
      h = h xor i
    end if
    h = h and (not g)
  wend
  function = h
end function
'-------------------------------------------------------------------------------
sub getRichEditText(byval hEd as dword, byval psz as dword)
   local sBuffer as string, ES as EDITSTREAM

   es.dwCookie = psz
   es.pfnCallback = codeptr(getRichEditTextCB)
   SendMessage(hEd, %EM_STREAMOUT, %SF_TEXT, byval varptr(es))
end sub
'-------------------------------------------------------------------------------
function getRichEditTextCB(byval dwCookie as dword, byval pRichEd as byte ptr, _
                         byval cb as long, byref pcb as long) as long
   local psBuffer as asciz ptr
   psBuffer = dwCookie
   if cb < 1 then exit function
   @psBuffer = @psBuffer & peek$(pRichEd, cb)
   pcb = cb
end function
'-------------------------------------------------------------------------------
function putRichEditTextCB(byval dwCookie as dword, byval pRichEd as byte ptr, _
                      byval cb as long, byref pcb as long) as long
    'dwCookie used to pass ptr to asciz buffer holding the data to load
    'pRichEd is the ptr to the rich edit control buffer to receive the data
    'cb = bytes to read in chunks (4K) defined by the OS
    'pcb = bytes actually needed to be read (last chunk less than 4K)
    '-------------------------------------------------------------------------
    local psBuffer as asciz ptr

    psBuffer = dwCookie
    pcb = min(len(@psBuffer), cb)
    if pcb > 0 then
        poke$ pRichEd, left$(@psBuffer, pcb)
        @psBuffer = mid$(@psBuffer, pcb + 1)
    end if
end function
'-------------------------------------------------------------------------------
function putRichEditText(byval hEd as dword, byval ps as string ptr) as long
'   '-------------------------------------------------------------------------------
'   'let rich edit call the callback function repeatedly, reading in 4K chunks
'   'of data at a time until there is no more to read.
'   '-------------------------------------------------------------------------------
   local ES as EDITSTREAM
   es.dwCookie    = ps
   es.pfnCallback = codeptr(putRichEditTextCB)
   function = SendMessage(hEd, %EM_STREAMIN, %SF_TEXT, byval varptr(es))  ' %SFF_TEXT
end function
'-------------------------------------------------------------------------------

sub saveText( hNote as dword)
    SendMessage hNote, %EM_SETMODIFY, 0, 0
end sub

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Syntax color parser for received line numbers
' borrowed from Borje Hagsten, much rewritten
%our_quote = 1
%our_comment = 2
%our_word = 3
%our_other = 4
' ----------------------------------------------------------------------------
sub ScanLine(hNote as dword, byval Line1 as long, byval Line2 as long)

    local hUser as dword ' to hold the dialog handle of the user dialog which calls TACE
    local pd as CHARRANGE, Oldpd as CHARRANGE, tBuff as TEXTRANGE
    local szword as asciz * 256 ' to contain a word extracted from line
    local szBuf, sprotobuf as string ' line length propably won't exceed this!
    local openbrkt, Offset, levents, I, J, l, startpos, w as long
    local lnLen, Result, foundmatch, foundword as long
    local Letter as byte ptr
    local prevletter as byte
    local s, sword as string
    local phashtab              as long   ptr
    local pLangWords            as byte ptr
    local pKeyWords             as string ptr
    local sStringQuote, sSingleLineComment, SKeyWords                as string
    local n, ldebug, ldebugsave, lenszbuf    as long
    local tstart as double
    local CharVals()            as long
    dim charvals(0 to 255)

    tstart = timer ' debug
    '
    ' charvals : an array in which the index is the ASC value of a character,
    ' and the cell value is the sub index to execute when the char is encountered
    ' in the text being parsed for keywords.
    for n = 0 to 255: charvals(n) = %our_other:next
    '
'    DIALOG GET USER hNote, %Ptr2Keywords TO pKeyWords
    ' first line is the word delimiters string
    s = parse$(gKeyWords, $crlf,1)
    ' these characters can terminate a "word" in the text being parsed:
    for n = 1 to len( s)
        charvals(asc(mid$(s,n,1))) = %our_word
    next
    ' next single line comment string, NB can be more than 1 char in length.
    ' if it is a single char, just enter it in the char table. If a string, make no
    ' entry in the char table... it is tested inline as a word.
    '
    sSingleLineComment = parse$(gKeyWords, $crlf,2)
    if len( sSingleLineComment) = 1 then charvals(asc(sSingleLineComment)) = %our_comment
    '
    ' next is the string quote char, always a single char
    sStringQuote = parse$(gKeyWords, $crlf,3)
    charvals(asc(sStringQuote)) = %our_quote
    ' rest is the keywords string as a single line
    sKeyWords = ucase$(parse$(gKeyWords, $crlf,4))
    pkeywords = varptr(sKeyWords)
    '
    dialog get user getparent(hNote), %HashTab to phashtab
    '
    call SendMessage(hNote, %EM_EXGETSEL, 0, varptr(Oldpd)) 'Original position
                                                            '(so we can reset it later)
    'Disable the event mask, for better speed
    levents = SendMessage(hNote, %EM_GETEVENTMASK, 0, 0)
    call SendMessage(hNote, %EM_SETEVENTMASK, 0, 0)

    SendMessage hNote, %EM_HIDESELECTION,1,0

    if Line1 <> Line2 then                                  'if multiple lines
        mouseptr 11
    else                                                                     'editing a line
        pd.cpMin = SendMessage(hNote, %EM_LINEINDEX, Line1, 0)                'line start
        pd.cpMax = pd.cpMin + SendMessage(hNote, %EM_LINELENGTH, pd.cpMin, 0) 'line end
        call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(pd))                  'select line
        setRichTextColor ( hNote, &H0)                                        'set black
    end if
    sprotobuf = string$(500," ")

    for J = Line1 to Line2
        szbuf = sprotobuf '+ " "
        Offset = SendMessage(hNote, %EM_LINEINDEX, J, 0)       'line start
        lnLen  = SendMessage(hNote, %EM_LINELENGTH, Offset, 0) 'line length

        if lnLen = 0 then iterate
        tBuff.chrg.cpMin = Offset
        ' the extra char is for CR or 1st char of next line if wrapped
        tBuff.chrg.cpMax = Offset + lnLen
        tBuff.lpstrText = strptr(szBuf)
        lnLen = SendMessage(hNote, %EM_GETTEXTRANGE, 0, byval varptr(tBuff)) 'Get line
        szbuf = left$(acode$(szbuf), lnLen)
        call CharUpperBuff(byval strptr(szBuf), lnLen)        'Make UCASE, handles all chars 0-255
        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        ' Loop through the line, using a pointer for better speed
        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        foundword = 0
        szbuf = szbuf + " " : incr lnLen ' force the last word in the line to be handled inside the loop
        Letter = strptr(szBuf)
        '

        for I = 1 to lnLen ' about 5% improvement
            on Charvals(@letter) goto LQUOTE, LCOMMENT, LWORD, LOTHER
LQUOTE:
            startpos = instr(I + 1, szBuf, sStringQuote)
            if startpos then
                pd.cpMin = Offset + I
                pd.cpMax = Offset + startpos - 1
                call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(pd))  ' was sendmessage
                setRichTextColor hNote, &HFF
                startpos = (startpos - I + 1)
                I = I + startpos
                Letter = Letter + startpos
                foundword = 0
            end if
            incr letter
            iterate
LCOMMENT:
            pd.cpMin = Offset + I - 1
            pd.cpMax = Offset + lnLen
            call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(pd))
            setRichTextColor hnote, &H00008000&
            foundword = 0
            exit for      ' done with line
LWORD:
            if foundword = 1 then
                w = i - startpos
                szword = mid$(szbuf, startpos, w + 1)
                poke varptr(szword) + w , 0 ' null terminate!
                if szword = sSingleLineComment then
                    pd.cpMin = Offset + I - w - 2
                    pd.cpMax = Offset + lnLen
                    call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(pd))
                    setRichTextColor hnote, &H00008000&
                    foundword = 0
                    exit for
                end if

                n = elf32(trim$(szword)) mod %HASHTABLESIZE

                foundmatch = %false
                ldebug = 0
                do while @phashtab[n] <> 0
                    incr ldebug
                    s = parse$(@pKeyWords, @phashtab[n])
                    if SZWORD <> parse$(@pKeyWords, @phashtab[n]) then
                        if n >= %HASHTABLESIZE then
                            foundmatch = %false
                            exit loop
                        else
                            incr n
                        end if
                    else
                        foundmatch = %TRUE
                        exit loop
                    end if
                loop
                if ldebug > ldebugsave then ldebugsave = ldebug
                if foundmatch = %FALSE then
                    incr letter
                    foundword = 0
                    iterate
                end if
                pd.cpMin = Offset + startpos - 1
                pd.cpMax = Offset + I - 1
                call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(pd))       ' was sendmessage
                call setRichTextColor( hnote, &HFF0000)                    'set blue color
                foundword = 0
            else
                ' just in case the single line comment is two delimiters like // or --
                if (@letter = prevletter ) and ((chr$(@letter) + chr$(@letter)) = sSingleLineComment) then
                    pd.cpMin = Offset + I - w - 2
                    pd.cpMax = Offset + lnLen
                    call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(pd))
                    setRichTextColor hnote, &H00008000&
                    foundword = 0
                    exit for
                end if
                prevLetter = @letter
            end if
            incr letter
            iterate

LOTHER:      ' we're inside a word
            if foundword = 0 then
                startpos = I
            end if
            foundword = 1
            incr Letter
        next I
    next J

    'Reset original caret position
    call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(Oldpd))
    SendMessage hNote, %EM_HIDESELECTION,0,0

    'Reset the event mask
    if levents then call SendMessage(hNote, %EM_SETEVENTMASK, 0, levents)
end sub
'------------------------------------------------------------------------------------
function MakeFont(byval fName as string, byval ptSize as long, _
                  opt byval attr as string) as dword
   '--------------------------------------------------------------------
   ' Create a desired font and return its handle.
   ' attr = "biu" for bold, italic, and underlined (any order)
   '--------------------------------------------------------------------
   local hDC as dword, CharSet as long, CyPixels as long
   local bold, italic, uLine as long
   if len(attr) then
      if instr(lcase$(attr), "b") then bold = %FW_BOLD
      if instr(lcase$(attr), "i") then italic = 1
      if instr(lcase$(attr), "u") then uLine = 1
   end if
   hDC = GetDC(%hwnd_desktop)
   CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
   ReleaseDC %hwnd_desktop, hDC
   PtSize = 0 - (ptSize * CyPixels) \ 72
   function = CreateFont(ptSize, 0, 0, 0, bold, italic, uLine, _
             %FALSE, CharSet, %OUT_TT_PRECIS, _
             %CLIP_DEFAULT_PRECIS, %DEFAULT_QUALITY, _
             %FF_DONTCARE , bycopy fName)
end function
'-------------------------------------------------------------------------------
function quitNote( hD as dword, hNote as dword) as long
   local n as long
   function = -1
   if SendMessage(hNote, %EM_GETMODIFY, 0, 0) then ' file has changed
      n = msgbox("Text has changed..." & $crlf _
      & "do you want to save it?", %mb_taskmodal or %mb_yesnocancel or %mb_iconquestion, "Save Text")
      if n = %idcancel then
         function = 0
      else
         if n = %idyes then
             ' export text
             function = 1
         end if
      end if
   end if
end function
'------------------------------------------------------------------------
function fileExists(fileName as string) as long
  local n as long
  n = getattr(fileName)
  function = (errclear = 0)
end function
'------------------------------------------------------------------------
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<< find & replace code borrowed from Eric Christensen
function openfindorreplacetextdialog (byval hwnd as long, byval ind as long, byval flgs as long) as long
    static fr as findreplace, ztxt as asciiz * 256, ztxt2 as asciiz * 256
    '
    ' the dialog remembers the find-string and replace-string between calls.
    ' there is no need to set them here.
    '
    fr.lstructsize      = sizeof(fr)
    fr.hwndowner        = hwnd
    fr.hinstance        = %null
    ' first time set flags to downward search direction - else to previous values.
    if istrue flgs then fr.flags = flgs else fr.flags = %fr_down or %fr_hideupdown ' this method only allows downward search
    fr.lpstrfindwhat    = varptr(ztxt)
    fr.wfindwhatlen     = sizeof(ztxt)
    fr.lpstrreplacewith = varptr(ztxt2)
    fr.wreplacewithlen  = sizeof(ztxt2)
    fr.lcustdata        = 0
    fr.lpfnhook         = %null
    fr.lptemplatename   = %null
    '
    if ind = 1 then function = findtext(fr)
    if ind = 2 then function = replacetext(fr)
    '
end function
'-------------------------------------
type FINDTEXTEXW
   chrg      as CHARRANGE    ' CHARRANGE chrg
   lpstrText as word ptr     ' LPCWSTR   lpstrText
   chrgText  as CHARRANGE    ' CHARRANGE chrgText
end type
'------------------------------------------------------------------
type FINDTEXTEXW
   chrg      as CHARRANGE    ' CHARRANGE chrg
   lpstrText as word ptr     ' LPCWSTR   lpstrText
   chrgText  as CHARRANGE    ' CHARRANGE chrgText
end type
'------------------------------------------------------------------------------------------
function dofindreplaceaction(byval llparam as long, byval hwnd as long, byref flgs as long) as long
    static txt as string
    static ipos as long
    static match as long
    static przt as string
    static lppfr as findreplace ptr
    static zt as asciiz ptr, zt2 as asciiz ptr
    local cr as charrange
    local tf as textrange
    local ptf as textrange ptr
    local buf as string
    local searchflag&, res&
    local n as long
    static s, stemp as string
    local tFT as FINDTEXTEXW
    local ps as asciz ptr

    lppfr = llparam
    if (@lppfr.flags and %fr_dialogterm) then     ' find or replace dialog is closed
        'hdlgmodeless = %null :
        function = 0 : exit function
    end if
    '
    flgs = @lppfr.flags                           ' save flags for next call
    zt   = @lppfr.lpstrfindwhat                   ' text to search for
    zt2  = @lppfr.lpstrreplacewith                ' replacing text if any
    '
    ' determine flags for specification of search
    searchflag& = 0
    if (@lppfr.flags and %fr_matchcase) then searchflag& = searchflag& or %fr_matchcase
    if (@lppfr.flags and %fr_wholeword) then searchflag& = searchflag& or %fr_wholeword
    '
    ' find caret or selection, if any
    sendmessage hwnd, %em_exgetsel, 0, varptr(cr)
    '
    if (@lppfr.flags and %fr_findnext) then ' find next
        gosub positioncheck
        gosub search
        if isfalse match then ? "no match found",%mb_iconinformation or %mb_taskmodal, "find"
    elseif (@lppfr.flags and %fr_replace) then ' replace
        gosub search
        if istrue match then
            sendmessage hwnd, %em_replacesel, %true, zt2
            cr.cpmax = cr.cpmin + len(@zt2)
            sendmessage hwnd, %em_exsetsel,0, varptr(cr)
            gosub search
            if isfalse match then msgbox "no further match found",%mb_taskmodal or %mb_iconinformation, "find"
        else
            msgbox "no match found",%mb_taskmodal or %mb_iconinformation, "find"
        end if
    elseif (@lppfr.flags and %fr_replaceall) then ' replace all
        gosub search
        if istrue match then
            do
                sendmessage hwnd, %em_replacesel, %true, zt2
                cr.cpmax = cr.cpmin + len(@zt2)
                sendmessage hwnd, %em_exsetsel, 0,  varptr(cr)
                gosub search
            loop until isfalse match    ' loop until no more matches
        else
            msgbox "no match found",%mb_taskmodal or %mb_iconinformation, "find"
        end if
    end if
    function = 1 : exit function
    '
    positioncheck:
        ' get selected text for checking purposes
        tf.chrg.cpmin = cr.cpmin
        tf.chrg.cpmax = cr.cpmax
        buf = space$(cr.cpmax - cr.cpmin + 1)
        tf.lpstrtext = strptr(buf)
        n = 999
        n = sendmessage (hwnd, %em_gettextrange, 0, varptr(tf))
        ' adjust start position of search if necessary - to avoid being stuck in the same place.
        if (left$(ucase$(buf),len(buf)-1) = przt) and (cr.cpmin < cr.cpmax) then incr cr.cpmin
    return
    '
    search:
        ' get upper limit of searching range
        tft.chrg.cpmin = cr.cpmin
        tft.chrg.cpmax = sendmessage ( hwnd, %em_getlimittext, 0, 0)
        s = ucode$(@zt)
        ps = strptr(s) 'movememory BYVAL ps, BYVAL STRPTR(s), BYVAL LEN(s) 'UCODE$(@zt),
        tft.lpstrtext  = ps
        '
        ' do specified search for specified text
        ipos = sendmessage (hwnd, %em_findtextexW, %FR_DOWN, varptr(tft)) ' searchflag&

        if ipos <> -1 then ' search is successful
            cr.cpmin = ipos
            cr.cpmax = cr.cpmin + len(@zt)
            '
            ' select found text
            sendmessage hwnd, %em_exsetsel, 0,  varptr(cr )
            ' save search string for checking purposes.
            przt = ucase$(trim$(@zt))
            ' match found
            match = %true
        else
            match = %false
        end if
    return
    '

end function
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> /find & replace code borrowed from Eric Christensen
'------------------------------------------------------------------------------
callback function Floatmsg_dialogProc()

    select case as long cbmsg
        case %wm_initdialog
        case %wm_command
            dialog end cbhndl, 0
        case %wm_destroy 'delete what we created on exit, to avoid mem leaks
    end select
end function

'------------------------------------------------------------------------------
function FloatMsg_dialog(byval hParent as dword, s as string) as long
    local lRslt as long
    local hDlg  as dword
    local p as pointapi
    local x, y, w, h as long

    dialog get loc hparent to x, y
    dialog new pixels, hParent, "", x , y , 65, 14, %ws_popup or  _
        %ws_clipsiblings or %ws_visible  or _         ' OR  %DS_NOFAILCREATE OR %DS_3DLOOK OR %WS_THICKFRAME OR
        %ds_setfont, %ws_ex_controlparent or %ws_ex_toolwindow or _
        %ws_ex_topmost or %ws_ex_left or %ws_ex_ltrreading to hdlg
    dialog  set color   hDlg, -1, rgb(255, 255, 155)
    control add label, hDlg, 1001, s, 0, 0, 58, 12, %ss_notify
    control set color hdlg, 1001, -1, -2
    dialog show modeless hDlg, call FloatMsg_dialogProc to lRslt
    function = hdlg
end function

'----------------------------------------------------------------------------
function subClassEditProc(byval hWnd as long, byval wMsg&, byval wParm&, byval lparam as long) as long
    local lRet                      as long
    local sztabchar                 as asciz * 2
    local szbuffer                  as asciz * %CCE_MAXTEXTSIZE
    local p                         as PointAPI
    local pdwretval                 as dword ptr
    static psUserTextBuffer         as string ptr
    local curline, l, MenuChoice    as long
    local s, smsg                   as string
    static flgs                     as long ' saving find or replace flags between calls.
    static lPrevSCLN, lSelChangeLineNum as long
    static hMsgFindReplace          as long
    static dwOrigEditProc, hw       as dword
    static InfoDlg                  as dword' handle of Ctrl-G info dialog
    static hpopup                   as dword ' menu handle
    '
    if hWnd& = 0 then           ' initial message from parent
        dwOrigEditProc = wparm&
        hMsgFindReplace = lparam
        function = 1
        exit function
    end if

    select case wMsg&

        case hMsgFindReplace ' this is the message registered
            smsg = "FINDREPLACE"
            ' do actions in response to your input in the dialog box
            function = dofindreplaceaction(lparam, hWnd, flgs)
            gosub tell

        case %wm_vscroll

        case %wm_user + 100             ' parent has recieved selchange notification
            if InfoDlg <> 0 then
                dialog end InfoDlg, 0
                InfoDlg = 0
            end if

            gosub refreshKeyWords

        case %wm_keyup
            l = wparm&
            select case wParm&
               case %VK_TAB
                  sztabchar = chr$(9): SendMessage hWnd, %EM_REPLACESEL, 1, byval varptr(sztabchar)
            end select

        case %wm_rbuttonup
            call GetCursorPos(byref p)
            hPopup = CreatePopupMenu ' creating the menu inline to save having to pass the handle back
                                     ' to the main dlg which is where it would logically be destroyed.
            call InsertMenu(hPopup, 0, %MF_BYCOMMAND              , 1, "&Find")
            call InsertMenu(hPopup, 0, %MF_BYCOMMAND              , 2, "&Done")
            MenuChoice = TrackPopupMenuEx(hPopup, %mf_enabled or %MF_BYCOMMAND or %TPM_RETURNCMD, p.x, p.y, _
                         getparent(hWnd), byval %NULL)

            destroymenu ( hpopup)
            control get user getparent(hwnd), %IDC_NOTE, %CCERetVal to pdwretval
            select case menuchoice
                case 1 ' find
                    call openfindorreplacetextdialog(hWnd, 1, flgs)
                case 2 ' replace
                    call openfindorreplacetextdialog(hWnd, 2, flgs)
                case 3 ' done
                    hw = getparent(hwnd)
                    getRichEditText( hWnd, byval varptr(szbuffer))
                    @pdwretval = 1
                    dialog end getparent(hWnd), 0
                case 4 ' Cancel
                    @pdwretval = 0
                    dialog end getparent(hWnd), 0
            end select

        case %wm_char
             if InfoDlg <> 0 then
                 dialog end InfoDlg, 0
                 InfoDlg = 0
             end if
             select case wParm&
                 case &H16 ' have we been pasted with CTL-V ?
                     smsg = "CTRL-V"
                     scanline  hWnd, lPrevSCLN, lSelChangeLineNum
            end select

        case %WM_GETDLGCODE
            if isfalse lparam then 'not a message being sent to the control
                ' Ensure that the edit control does not select its contents on receiving the focus
                lRet = CallWindowProc(dwOrigEditProc, hWnd, wMsg&, wParm&, lparam)
                function = lRet xor %dlgc_hassetsel 'Clear the DLGC_HASSETSEL bit from lRet
                exit function
            end if

    end select
    ' Pass the message on to the original window procedure
    function = CallWindowProc(dwOrigEditProc, hWnd, wMsg&, wParm&, lparam)
    exit function
'
refreshKeyWords:
    lPrevSCLN = lSelChangeLineNum
    lSelChangeLineNum = SendMessage(hWnd, %EM_EXLINEFROMCHAR, 0, -1)
return
'
tell:
    return
end function
'----------------------------------------------------------------------------
callback function showNoteProc()
    local fontSize, hpopup, i, l, linecount, menuchoice, wi, ht, tabunits as long
    local fontName, fn, s           as string
    static sbuffer                  as string
    static szbuffer                 as asciz * %CCE_MAXTEXTSIZE ' define the max buffer size for CCE
    local pmmi                      as MINMAXINFO ptr
    local p                         as PointAPI
    local pnmh                      as nmhdr ptr
    static flgs                     as long ' saving find or replace flags between calls.
    local CurLine                   as long  ' ephemeral current line position
    static hNote                    as dword
    local  pKeyWords                as string ptr     ' slangwords
    static lhashtab()               as long
    static lUboundCData             as long
    static szReqdchars              as asciz * 256
    static hMsgFindReplace          as long
    static dwOrigEditProc           as dword
    static  psUserTextBuffer        as asciz ptr
    local  dwInitProc               as long
    local pdw                       as dword ptr
    local huser                     as dword ' handle of user dialog which called TACE
    static hfont                    as dword ' font for editor window
    local h                         as dword

    select case cbmsg
      case %wm_initdialog

          redim lhashtab(0 to %HASHTABLESIZE -1) as static long ' %HASHTABLESIZE -1
          ' register a message for the find or replace dialog.
          hMsgFindReplace = registerwindowmessage ("commdlg_findreplace")
          dialog set user cbhndl, %Frepmsg, hMsgFindReplace
          gosub loaddata
          ' set pointer to KeyWords array as a property of this window
          dialog set user cbhndl, %Hashtab, varptr(lhashtab(0))
          '------------------------------------------------------------------
          ' resize dialog to show vertical scrollbar
          '------------------------------------------------------------------
          control handle cbhndl, %IDC_Note to hNote
          dialog get client cbhndl to wi, ht
          dialog set size cbhndl, wi, ht

          '------------------------------------------------------------------
          ' create and set an initial fixed-width font as default
          '------------------------------------------------------------------
          fontName = "Courier New": fontSize = 10
          hFont = MakeFont(fontName, fontSize)
          SendMessage hNote, %WM_SETFONT, hFont, 0

          tabUnits = 16 'interval of 8 spaces
          SendMessage hNote, %EM_SETTABSTOPS, 1, byval varptr(tabUnits)
          SendMessage hNote, %EM_LIMITTEXT, %CCE_MAXTEXTSIZE, 0
          SendMessage hNote, %EM_SETOPTIONS, %ECOOP_OR, %ECO_SELECTIONBAR 'left margin selection
          SendMessage hNote, %EM_FMTLINES, %TRUE, 0
          '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          'Must set the event mask, so we can pick up a few events from RichNote
          '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          call SendMessage(hNote, %EM_SETEVENTMASK, 0, %ENM_SELCHANGE or %ENM_CHANGE or %ENM_UPDATE)
          dwOrigEditProc = SetWindowLong(hNote, %GWL_WNDPROC, codeptr(subClassEditProc)) 'subclass
          ' call the subclassed control directly
          ' to tell it what it's original WndProc is
          ' and what the find/replace message number is
          subClassEditProc ( 0, 0, dwOrigEditProc, hMsgFindReplace)
          SendMessage hNote, %EM_SETMODIFY, 0, 0
          h = cbhndl ' debug
          control get user cb.hndl, %IDC_Note, %Ptr2UserText to psUserTextBuffer
          szbuffer = space$(%CCE_MAXTEXTSIZE)
          szbuffer = @psUserTextBuffer
          putRichEditText( hNote, byval varptr(szbuffer)) 'hWnd, string ptr
          CurLine = SendMessage(hNote, %EM_getlinecount, 0, 0)
          call ScanLine(hnote, 0, CurLine)

        case %wm_size
          RedrawWindow cbhndl, byval 0, byval 0, %RDW_VALIDATE
          dialog get client cbhndl to wi, ht
          control set size cbhndl, %IDC_Note, wi, ht
          RedrawWindow cbhndl, byval 0, byval 0, %RDW_INVALIDATE

       case %WM_GETMINMAXINFO
           pmmi = cblparam
           @pmmi.ptMinTrackSize.x = 200  'minimum size of window
           @pmmi.ptMinTrackSize.y = 200

       case %wm_command
           select case cbctl
               case %IDC_NOTE
                   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..
                           CurLine = SendMessage(hNote, %EM_EXLINEFROMCHAR, 0, -1)
                           call ScanLine(hnote, CurLine, CurLine)
                   end select
          end select

       case %wm_notify
           select case cbctl
               case %IDC_NOTE
                   pnmh = cblparam
                   select case @pnmh.code
                       case %EN_SELCHANGE
                           sendmessage hNote, %wm_user + 100, 0, 0
                   end select
           end select

        case %WM_SETTEXT  ' assume that this is the initial data load of the edit control
            control send cbhndl, %IDC_note, %WM_SETTEXT, cbwparam, cblparam
        '
        case %wm_user + 201  ' user shut down - drop everything & close
            control kill cbhndl, %IDC_NOTE
            dialog end cbhndl, 0
        '
        case %wm_user + 202  ' maximize window
            dialog show state cbhndl,  %sw_show
        '
        case %wm_destroy
            ' remove subclassing
            SetWindowLong hNote, %GWL_WNDPROC, dwOrigEditProc
            DeleteObject hFont
            FreeLibrary ghLib

    end select
    exit function
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
loaddata:
    local hfile as long
    local n as long

    ' keywords string has 3 lines of non-keywords at start, strip these
    n = parsecount(gKeywords, $crlf)
    s = ucase$(parse$(gKeyWords,$crlf,4))
    '
    n = parsecount(s)
    for i = 0 to n -1
        h = elf32(parse$(s, i)) mod %HASHTABLESIZE
        while lhashtab(h)<> 0: incr h: wend
        lhashtab(h) = i
    next
return
end function
'-------------------------------------------------------------------------------------------
' params are parent window coordinates for edit window, text ptr, title
function CCE_BASRO ( hParent as dword, r as rect, byval pstext as dword, Title as string) as long

    local nStyle, bStyle as long
    local dwresult as dword ' to contain the result from the CB function
    local dwretval              as dword
    local hDlg as dword
    static s as string

    local debug1, debug2 as string ptr

    CreatePBKeyWordString ' create global keywords string
    ghLib = LoadLibrary("Msftedit.dll") 'Riched32.dll")
'    hLib = LoadLibrary("Riched20.dll")
    if ghLib = 0 then
       s = "File 'Msftedit.dll' required"
       msgbox s, %mb_taskmodal or %mb_iconwarning, "File not Found": exit function
    end if
    ghLib = 0
    nStyle = %ws_child or %ws_popup or %ws_sysmenu or %ws_minimizebox or %ws_maximizebox or _
             %ds_center or %ds_modalframe or %ws_thickframe or %ws_caption

    dialog new pixels, 0, Title, r.nleft, r.ntop, r.nright, r.nbottom, nStyle to hDlg
    '
    nStyle = %ws_child  or %ws_clipchildren or %ws_visible or %es_multiline _
           or %ws_vscroll or %es_autovscroll  or %ws_hscroll  or %es_autohscroll or %es_wantreturn _
           or %ws_tabstop  or %es_nohidesel    ' or %ES_NOIME

    control add "RichEdit50W", hDlg, %IDC_Note, "", 0, 0, r.nright, r.nbottom, nStyle
    control set user hdlg, %IDC_NOTE, %Ptr2UserText, pstext

    ' send our dialog & editor control hwnd to parent
    dialog send hparent, %wm_user + 500, hdlg, %IDC_NOTE
    ' set edit window to Read Only
    control send hDlg, %IDC_Note, %EM_SETREADONLY, 1, 0
    dialog show modeless hDlg, call ShowNoteProc to dwresult
end function

**Chris Holbrook** · 15 Sep 2009, 12:17 AM

new version - see top of code for changes

discussion here: http://www.powerbasic.com/support/pb...379#post323379

main application file F2Plus.bas

Code:

'
' Experimenting with a function/sub list for a code module
' starting off with a basic function list like the F2 list in the PB compilers
' Each function or sub can be viewed in a seperate window
' Synchronises with the last saved version of the subject file by checking the directory entry
' of the target file and reloading the function index and any changed windows
'
' Chris Holbrook 12-Sep-2009
'
' Changes
' 13-SEP-2009 includes comments preceding sub/function header in the function viewer windows
' 13-SEP-2009 uses keyword, comment and literal coloring
' 14-SEP-2009 added tooltips to controls on main screen
' 14-SEP-2009 added source file name to main dialog title
' 15-SEP-2009 fixed GPF problem
' 15-SEP-2009 only a single source code file can be examined by a single instance of the application
'
' Issues list (* = incorporated in change)
' 13-SEP-2009 PB keyword list is for PBWin V7 only
' 14-SEP-2009 refreshes all viewer windows when any change occurs, not just the changed ones.
' 14-SEP-2009 * Charles Dietz & Artur Gomide report GPFs - cannot recreate
'
' to do list (* = incorporated in change)
' 15-SEP-2009 Gösta H. Lovgren-2 suggests making the function list sortable
' 15-SEP-2009 Gösta H. Lovgren-2 suggests including macros
' 15-SEP-2009 * Gösta H. Lovgren-2 suggests making the initial screen larger
' 15-SEP-2005 Add a viewer window containing all globals
' 15-SEP-2005 Add a viewer window containing all variable declarations
' 15-SEP-2005 Add a viewer window containing all TYPE declarations
' 15-SEP-2005 Add a viewer window containing the code before the first function/macro declaration
'
#compile exe
'#debug display
#dim all

#if not %def(%WINAPI)
    #include "WIN32API.INC"
#endif
#if not %def(%COMMCTRL_INC)
    #include "COMMCTRL.INC"
#endif
#if not %def(%COMDLG32_INC)
    #include "COMDLG32.INC"
#endif
#include "richedit.inc"
#include "c:\chris\edit\CCE_BASRO.INC"
$version = "0.1.2"
%IDD_DIALOG1         =  101
%IDC_LV = 1001
%IDD_DIALOG2         =  102
%IDC_TEXTBOX1        = 1003
%IDC_SOUFILE_BN      = 1004

type tfindex
    sfname as asciz * 256
    start as long
    finish as long
    hwnd as dword
end type
global findex() as tfindex      ' global table of functions and subs
global sourcecode() as string   ' global table of source code
global ghfont as dword          ' font
global gOutputHandle as dword
'-----------------------------------------------------------------------------
sub StopConsole
    if gOutputHandle = 0 then exit sub
    Freeconsole
end sub
'-----------------------------------------------------------------------------
sub startconsole
    Allocconsole
    gOutputHandle = getstdhandle ( %STD_OUTPUT_HANDLE)
end sub
'-----------------------------------------------------------------------------
sub Conout ( s as string)
    local lpreserved as dword
    local n as long

    if gOutputHandle = 0 then exit sub
    WriteConsole( gOutputHandle, byval strptr(s), len(s), byval varptr(n), lpReserved)
end sub
'-----------------------------------------------------------------------------
global hWndToolTip  as dword
'-----------------------------------------------------------------
sub CreateTip( hDlg as dword, tl as dword, Tip as string )
static Crt          as CREATESTRUCT
static TlInfo       as TOOLINFO
static hInst        as long

    if hWndToolTip then 'it's been initialized

        if tl = 0 then exit if
        'Tip = Left$(Tip, 79)
        control handle hDlg, tl to tl
        TlInfo.hwnd = tl
        TlInfo.uId = tl
        TlInfo.lpszText = strptr(Tip)
        SendMessage( hWndToolTip, %TTM_ADDTOOL, 0, varptr( TlInfo ) )
        SendMessage( hWndToolTip, %TTM_ACTIVATE, 1, 0 )

    else 'just initializing this time through
        local ice as INIT_COMMON_CONTROLSEX
        ice.dwSize = sizeof(ice)
        ice.dwICC = %ICC_WIN95_CLASSES
        InitCommonControlsEx(ice)

        hInst = GetModuleHandle("")
        Tip = "ToolTip"
        Crt.lpCreateParams = 0
        Crt.hInstance    = hInst
        Crt.hMenu        = 0
        Crt.hwndParent   = hDlg
        Crt.style        = %ws_popup or %TTS_NOPREFIX or %TTS_ALWAYSTIP
        Crt.lpszName     = strptr(Tip)
        Tip = $TOOLTIPS_CLASS
        Crt.lpszClass    = strptr(Tip)
        Crt.dwExStyle    = %ws_ex_topmost

        hWndToolTip = CreateWindowEx( %ws_ex_topmost, $TOOLTIPS_CLASS, "", _
        %ws_popup or %TTS_NOPREFIX or %TTS_ALWAYSTIP or %TTS_BALLOON, _
            %CW_USEDEFAULT, %CW_USEDEFAULT, %CW_USEDEFAULT, _
            %CW_USEDEFAULT, hDlg, 0, hInst, Crt )


        dialog send hWndToolTip, %TTM_SETMAXTIPWIDTH, 0, 200

        SetWindowPos( hWndToolTip, %HWND_TOPMOST, 100, 100, 300, 300, _
            %SWP_NOMOVE or %SWP_NOSIZE or %SWP_NOACTIVATE )

        SendMessage( hWndToolTip, %TTM_SETDELAYTIME, %TTDT_INITIAL, 100 ) 'time a pointer must remain stationary before the tooltip appears
        SendMessage( hWndToolTip, %TTM_SETDELAYTIME, %TTDT_AUTOPOP, 7000 ) 'time a tooltip window remains visible If the Pointer is stationary
        SendMessage( hWndToolTip, %TTM_SETDELAYTIME, %TTDT_RESHOW, 400 ) 'time before subsequent tooltips to appear

        '------------------------------
        TlInfo.cbSize = sizeof( TOOLINFO )
        'this doesn't make sense, but it works
        TlInfo.uFlags = %TTF_SUBCLASS or %TTS_ALWAYSTIP or %TTS_BALLOON or %TTF_CENTERTIP
        'if hToolParWnd <> 0 then tl is a control ID instead of a window handle
        TlInfo.hinst = hInst

    end if 'hWndToolTip

end sub 'CreateTip

'-------------------------------------------------------------------------------------------------------------
sub SetToolTips(hDlg as dword)
static  f   as long

    if f then exit sub else incr f 'make sure it only runs once
        CreateTip hDlg, 0, ""     'initialize tooltips
        CreateTip hDlg, %IDC_LV, "Click a function in the listview to see the source code in a new window"
        CreateTip hDlg, %IDC_SOUFILE_BN, "Click here to chose a new source file"
end sub 'SetToolTips

'---------------------------------------------------------------------------
function build ( hD as dword, LVid as long, sfile as string) as long
    local i, j, n, hfile, nrow, linenum as long
    local s, sline, s1, s2, s3, slist, swork as string
'
    hfile = freefile
    try
        open sfile for input as hfile
        linenum = 1
        while isfalse eof(hfile)
            line input #hfile, sline
            n = ubound(sourcecode()) + 1
            redim preserve sourcecode(0 to n)
            sourcecode(n) = sline
            incr linenum
        wend
        close hfile
    catch
        dialog set text hd, "FILE ERROR": beep: sleep 2000
        exit function
    end try
    ' pick out functions & subs from the array
    for i = lbound(sourcecode()) to ubound(sourcecode())
        SWORK = Sourcecode(i) + " @@@@@@@@"
        s1 = ucase$(parse$(ltrim$(swork), " ", 1))
        s2 = parse$(ltrim$(swork), any " (", 2)
        s3 = parse$(ltrim$(swork), any " (", 3)
        select case s1
            case "SUB"
                gosub addtolist
            case "FUNCTION"
                if left$(s2,1) <> "=" then gosub addtolist
            case "CALLBACK"
                gosub addtolist
            case "END"
                if ucase$(left$(s2,8)) = "FUNCTION" then
                    gosub nudgelist
                    exit select
                end if
                if ucase$(left$(s2,3)) = "SUB" then
                    gosub nudgelist
                end if
        end select
    next

    s = ""
    exit function
'''''''''''''''
addtolist:
    incr nrow
    j = 1
    do while (i-j) > 0
        s = ltrim$(sourcecode(i - j))
        if left$(ltrim$(s),1) = $sq then
            incr j
        else
            exit loop
        end if
    loop
    if s1 = "CALLBACK" then
        s = s3
    else
        s = s2
    end if
    listview insert item hD, %IDC_LV, nrow, 0, s
    redim preserve findex(1 to nrow)
    findex(nrow).start = i - j + 1
    findex(nrow).sfname = s'sourcecode(i)
    if nrow > 1 then
        if findex(nrow -1).finish = 0 then
            findex(nrow-1).finish = i -1
        end if
    end if
    listview set text hD, %IDC_LV, nrow, 2, sourcecode(i)
return
'''''''''''''''
nudgelist:
    findex(nrow).finish = i
return
end function
'--------------------------------------------------------
callback function MainDlgProc()
    local i, j, l, n, nfrom, nto, nsel, x, y as long
    local s, soldcode, spath as string
    ' temporary array into which the old findex array is copied
    ' when a dirent change is detected
    local prevfindex() as tfindex
    ' rect used to define CCE window
    local r as rect

    ' used in checking the dirent for updates
    static htimer as dword
    ' filename and dialog title
    static sourcecodefile, stitle as string
    ' used in checking the dirent for updates
    static dird, dird1 as dirdata
    '
    select case as long cbmsg
        case %wm_initdialog
            'startconsole
            conout ("init")
            settooltips ( cb.hndl)
            listview set stylexx cb.hndl, %IDC_LV, _
                %LVS_ex_infotip or %LVS_EX_FULLROWSELECT or  %LVS_EX_ONECLICKACTIVATE or %LVS_EX_GRIDLINES
            listview reset cb.hndl, %IDC_LV
            listview  insert column cb.hndl, %IDC_LV, 1, "Name", 100, 0
            listview  insert column cb.hndl, %IDC_LV, 2, "header", 500, 0
            stitle = "F2+ Source Code File Selection"
            gosub setsourcecodefile
        '
        case %wm_destroy
            conout ("destroy")
            killtimer cb.hndl, htimer
            if ubound(findex()) < 0 then exit select
            for i = lbound(findex()) to ubound(findex())
                if findex(i).hWnd <> 0 then
                    dialog end findex(i).hWnd, 0
                end if
            next
            stopconsole
        '
        case %wm_timer
            conout ("timer")
            s = dir$ (sourcecodefile to dird1)
            if dird1.LastWriteTime <> dird.lastwritetime then
                erase sourcecode() ' get rid of the previous sourcecode array
                dird = dird1
                listview reset cb.hndl, %IDC_LV
                l = lbound(findex())
                dim prevfindex(l to ubound(findex()))
                poke$ varptr(prevfindex(l)), peek$(varptr(findex(l)),sizeof(findex(l)) * arrayattr(findex(),4))
                erase findex()
                build(cb.hndl, %IDC_LV, sourcecodefile)
                for i = lbound(findex()) to ubound(findex())
                     if prevfindex(i).hWnd then
                         ' get the text in the "new" file for the named Function
                         ' kill off viewer window
                         dialog end prevfindex(i).hWnd, 0
                         s = trim$(prevfindex(i).sfname)
                         listview find exact cb.hndl, %IDC_LV, 1, s to n
                         ' if the function no longer exists, no further action required
                         if n = 0 then exit select
                         ' fn is present, create a new window
                         s = ""
                         for j = findex(i).start to findex(i).finish
                             s = s + $crlf + sourcecode(j)
                         next
                         s = mid$(s, 3) ' lose leading $crlf
                         stitle = findex(i).sfname + " in " + sourcecodefile + " " + time$
                         setrect r, 0, 0, 400, 300
                         findex(i).hWnd = CCE_basro( cb.hndl, r, byval strptr(s), stitle)
                     end if
                next
            end if
        '
        case %wm_user + 501 ' child dialog has ended - clear hWnd in findex table
            conout ("501")
            for i = lbound(findex()) to ubound(findex())
                if findex(i).hWnd = cb.wparam then
                    findex(i).hWnd = 0
                    exit for
                end if
            next
        '
        case %wm_move, %wm_size
            conout ("movesize")

            local xx, yy as long
            if cb.wparam = %SIZE_MINIMIZED then
                for i = lbound(findex()) to ubound(findex())
                    if findex(i).hWnd <> 0 then
                        dialog send findex(i).hWnd, %wm_syscommand, %sc_minimize, 0
                    end if
                next
            end if
            dialog get client cb.hndl to x, y
            control set size cb.hndl, %IDC_LV, x, y -25
            control get size cb.hndl, %IDC_SOUFILE_BN to xx, yy
            control set size cb.hndl, %IDC_SOUFILE_BN, x, yy
        '
        case %wm_notify
            conout ("notify")

            select case cb.ctl
                case %IDC_LV
                    select case cb.nmcode
                        case %nm_click
                            listview get select cb.hndl, %IDC_LV to nsel
                            if nsel > ubound(findex()) then
                                ? "selected item above expected range"
                                exit select
                            end if
                            if nsel < lbound(findex()) then
                                ? "selected item below expected range"
                                exit select
                            end if

                            nfrom = findex(nsel).start
                            nto   = findex(nsel).finish
                            for i = findex(nsel).start to findex(nsel).finish
                                s = s + $crlf + sourcecode(i)
                            next
                            s = mid$(s,3)
                            stitle = findex(nsel).sfname + " in " + sourcecodefile + " " + time$
                            setrect r, 0, 0, 400, 300
                            findex(nsel).hWnd = CCE_basro( cb.hndl, r, byval strptr(s), stitle)
                    end select
            end select
        '
        case %wm_command
            conout ("command")

            select case cb.ctl
                case %IDC_SOUFILE_BN
                    gosub setsourcecodefile
            end select
        '
'        case %wm_ncrbuttondown
'            for i = lbound(findex()) to ubound(findex())
'                 s = s + str$(findex(i).start) + str$(findex(i).finish) + " " + findex(i).sfname + $crlf
'            next
'            ?s
        '
        case %wm_ncactivate
            static hWndSaveFocus as dword
            if isfalse cbwparam then
                hWndSaveFocus = GetFocus()
            elseif hWndSaveFocus then
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            end if
    end select
    exit function
''''''''''''''''''''''
setsourcecodefile:
    local sfname as string
    spath = curdir$
    OpenFileDialog(cb.hndl, stitle, sourcecodefile, sPATH, _
        "Basic Source Code Files|*.bas|Include Files|*.inc|All Files|*.*", "txt", 0)
    control set text cb.hndl, %IDC_SOUFILE_BN, sourcecodefile
    sfname = parse$(sourcecodefile,"\",-1)
    dialog set text cb.hndl, "F2+ " + sfname
    if ubound(findex) > -1 then
        for i = lbound(findex()) to ubound(findex())
            if findex(i).hWnd then dialog end findex(i).hWnd, 0
        next
    end if
    erase findex()
    erase sourcecode()
    s = dir$ (sourcecodefile to dird)
    listview reset cb.hndl, %IDC_LV
    build(cb.hndl, %IDC_LV, sourcecodefile)
    htimer = settimer ( cb.hndl,%null, 2000, %null)
return
end function
'------------------------------------------------------------------------
function MainDlg(byval hParent as dword) as long
    local lRslt, w, h as long
    local hDlg  as dword

    dialog font default "Courier New", 10, 0, 0
    dialog new hParent, "F2+", 0, 0, 201, 321, _
        %ws_popup or %ws_border or %ws_dlgframe or %ws_sysmenu or %ws_minimizebox or _
        %ws_clipsiblings or %ws_visible or %ds_modalframe or %ds_3dlook or _
        %ds_nofailcreate or %ds_setfont or %ds_center or %ws_thickframe, _
        %ws_ex_controlparent or %ws_ex_left or %ws_ex_ltrreading or %ws_ex_rightscrollbar, _
        to hDlg
    dialog get client hDlg to w, h
    control add button, hDlg, %IDC_SOUFILE_BN, "source code file", 0, 0, w, 14
    control add "SysListView32", hDlg, %IDC_LV, "SysListView32_1", 0, 15, 192, 100, _
        %ws_child or %ws_visible or %ws_tabstop or %lvs_report or %lvs_showselalways, _
        %ws_ex_left or %ws_ex_clientedge or %ws_ex_rightscrollbar
    dialog show modal hDlg, call MainDlgProc to lRslt
    function = lRslt
end function
'---------------------------------------------------------------------
function pbmain()
    initcommoncontrols
    MainDlg %hwnd_desktop
end function

Viewer Include file CCE_BASRO.inc

Code:

'------------------------------------------------------------------------------------------------------
' COMPACT CODE EDITOR CCE.INC
' Chris Holbrook July 2008
' including some code by Charles Dietz, Eric Christensen and Borje Hagsten
' modified to use with F2plus application
'

' CHANGES
' 13-SEP-2009 subset for RO PB Code viewing
' 15-SEP-2009 CCE_BASRO now returns viewer dialog handle to caller
'============================================


%CCE_MAXTEXTSIZE = 32768
global gKeywords as string
global ghlib as dword
'--------------------------------------------------------------------------------------
'PBWin 7.0 syntax color data - think at least most of it..  :-)
'----------------------------------------------------------------------------
'
sub CreatePBKeyWordString
    local hfile as long
    local s as string
    static slangwords, skeywords as string

    sLangWords = " ,=-+*/\(;" + $crlf + _
                 "'"         + $crlf + _
                 $dq          + $crlf
    sKeyWords = _
"#BLOAT,#COMPILE,#DEBUG,#DIM,#ELSE,#ELSEIF,#ENDIF,#IF,#INCLUDE,#OPTION,#REGISTER,#RESOURCE," + _
"#SEGMENT,#STACK,#TOOLS,$BEL,$BS,$COMPILE,$CR,$CRLF,$DEBUG,$DIM,$DQ,$ELSE,$ELSEIF,$ENDIF," + _
"$EOF,$ESC,$FF,$IF,$INCLUDE,$LF,$NUL,$OPTION,$REGISTER,$RESOURCE,$SEGMENT,$SPC,$STACK," + _
"$TAB,$VT,%DEF,%FALSE,%NULL,%PB_EXE,%TRUE," + _
"ABS,ACCEL,ACCEPT,ACCESS,ACODE$,ADD,ADDR,ALIAS,ALL,AND,ANY,APPEND,ARRAY,ARRAYATTR," + _
"AS,ASC,ASCEND,ASCIZ,ASCIIZ,AT,ATN,ATTACH,ATTRIB,BAR,BASE,BAUD,BDECL,BEEP," + _
"BIN$,BINARY,BIT,BITS%,BITS&,BITS?,BITS??,BITS???,BREAK,BUTTON,BYCMD,BYCOPY,BYREF," + _
"BYTE,BYVAL,CALC,CALL,CALLBACK,CALLSTK,CALLSTK$,CALLSTKCOUNT,CASE,CATCH,CBCTL,CBCTLMSG," + _
"CBHNDL,CBLPARAM,CBMSG,CBWPARAM,CBYT,CCUR,CCUX,CD,CDBL,CDECL,CDWD,CEIL,CEXT,CHDIR," + _
"CHDRIVE,CHECK,CHECK3STATE,CHECKBOX,CHOOSE,CHOOSE&,CHOOSE%,CHOOSE$,CHR$,CINT,CLIENT,CLNG," + _
"CLOSE,CLS,CLSID$,CODEPTR,COLLATE,COLOR,COLUMN,COMBOBOX,COMM,COMMAND$,CON,CONNECT,CONST,CONTROL," + _
"COS,CQUD,CREATE,CSET,CSET$,CSNG,CTSFLOW,CUR,CURDIR$,CURRENCY,CURRENCYX,CUX,CVBYT,CVCUR," + _
"CVCUX,CVD,CVDWD,CVE,CVI,CVL,CVQ,CVS,CVWRD,CWRD,DATA,DATACOUNT,DATE$,DECLARE,DECR,DEFAULT," + _
"DEFBYT,DEFCUR,DEFCUX,DEFDBL,DEFDWD,DEFEXT,DEFINT,DEFLNG,DEFQUD,DEFSNG,DEFSTR,DEFWRD,DELETE," + _
"DESCEND,DIALOG,DIM,DIR$,DISABLE,DISKFREE,DISKSIZE,DISPATCH,DLL,DLLMAIN,DO,DOEVENTS,DOUBLE," + _
"DOWN,DRAW,DSRFLOW,DSRSENS,DTRFLOW,DTRLINE,DWORD,ELSE,ELSEIF,EMPTY,ENABLE,END,ENVIRON$," + _
"EOF,EQV,ERASE,ERR,ERRAPI,ERRCLEAR,ERROR,ERROR$,EXE,EXIT,EXP,EXP10,EXP2,EXPLICIT,EXPORT," + _
"EXT,EXTENDED,EXTRACT$,FILEATTR,FILECOPY,FILENAME$,FILESCAN,FILL,FINALLY,FIX,FLOW,FLUSH,FOCUS," + _
"FONT,FOR,FORMAT$,FORMFEED,FRAC,FRAME,FREEFILE,FROM,FUNCTION,FUNCNAME$,GET,GET#,GET$," + _
"GETATTR,GLOBAL,GOSUB,GOTO,GUID$,GUIDTXT$,HANDLE,HEX$,HIBYT,HIINT,HIWRD,HOST,ICASE,ICON," + _
"IDN,IF,IFACE,IIF,IIF&,IIF%,IIF$,IMAGE,IMAGEX,IMGBUTTON,IMGBUTTONX,IMP,IN,INCR,INP,INOUT," + _
"INPUT,INPUT#,INPUTBOX$,INSERT,INSTR,INT,INTERFACE,INTEGER,INV,ISFALSE,ISNOTHING," + _
"ISOBJECT,ISTRUE,ITERATE,JOIN$,KILL,LABEL,LBOUND,LCASE$,LEFT,LEFT$,LEN,LET,LIB,LIBMAIN," + _
"LINE,LISTBOX,LISTVIEW,LOBYT,LOC,LOCAL,LOCK,LOF,LOG,LOG10,LOG2,LOINT,LONG,LOOP,LOWRD,LPRINT," + _
"LSET,LSET$,LTRIM$,MACRO,MACROTEMP,MAIN,MAKDWD,MAKINT,MAKLNG,MAKPTR,MAKWRD,MAT,MAX,MAX$," + _
"MAX%,MAX&,MCASE$,MEMBER,MENU,MID$,MIN,MIN$,MIN%,MIN&,MKBYT$,MKCUR$,MKCUX$,MKD$," + _
"MKDIR,MKDWD$,MKE$,MKI$,MKL$,MKQ$,MKS$,MKWRD$,MOD,MODAL,MODELESS,MOUSEPTR,MSGBOX," + _
"NAME,NEW,NEXT,NONE,NOT,NOTHING,NOTIFY,NULL,OBJACTIVE,OBJECT,OBJPTR,OBJRESULT,OCT$,OF," + _
"OFF,ON,OPEN,OPT,OPTION,OPTIONAL,OR,OUT,OUTPUT,PAGE,PARITY,PARITYCHAR,PARITYREPL,PARITYTYPE," + _
"PARSE,PARSE$,PARSECOUNT,PBD,PBMAIN,PEEK,PEEK$,PIXELS,POINTER,POKE,POKE$,POPUP,PORT,POST," + _
"PRESERVE,PRINT,PRINT#,PRIVATE,PROFILE,PROGID$,PTR,PUT,PUT$,QUAD,QWORD,RANDOM,RANDOMIZE,READ," + _
"READ$,RECEIVE,RECORDS,RECV,REDIM,REDRAW,REGEXPR,REGISTER,REGREPL,REMAIN$,REMOVE$,REPEAT$," + _
"REPLACE,RESET,RESUME,RET16,RET32,RET87,RETAIN$,RETP16,RETP32,RETPRM,RETURN,RGB,RIGHT," + _
"RIGHT$,RING,RLSD,RMDIR,RND,ROTATE,ROUND,RSET,RSET$,RTRIM$,RTSFLOW,RXBUFFER,RXQUE,SCAN," + _
"SCROLLBAR,SDECL,SEEK,SELECT,SEND,SERVER,SET,SETATTR,SETEOF,SGN,SHARED,SHELL," + _
"SHIFT,SHOW,SIGNED,SIN,SINGLE,SIZE,SIZEOF,SLEEP,SORT,SPACE$,SPC,SQR,STATE,STATIC,STATUS," + _
"STDCALL,STEP,STOP,STR$,STRDELETE$,STRING,STRING$,STRINSERT$,STRPTR,STRREVERSE$,SUB,SUSPEND," + _
"SWAP,SWITCH,SWITCH&,SWITCH%,SWITCH$,TAB,TAB$,TAGARRAY,TALLY,TAN,TCP,TEXT,TEXTBOX,THEN," + _
"THREAD,THREADCOUNT,THREADID,TIME$,TIMEOUT,TIMER,TO,TOGGLE,TRACE,TRIM$,TRN,TRY,TXBUFFER," + _
"TXQUE,TYPE,UBOUND,UCASE,UCASE$,UCODE$,UDP,UNION,UNITS,UNLOCK,UNTIL,UP,USER,USING,USING$," + _
"VAL,VARIANT,VARIANT#,VARIANT$,VARIANTVT,VARPTR,VERIFY,VERSION3,VERSION4,VERSION5," + _
"WEND,WHILE,WIDTH,WIDTH#,WINMAIN,WITH,WORD,WRITE,WRITE#,XOR,XINPFLOW,XOUTFLOW,ZER"
    gKeywords = sLangwords + sKeywords
end sub



$Ver = "Ver 0.50"

%IDC_New                  = 102
%IDC_Show                 = 103
%IDC_Hlp                  = 108
%IDC_Statusbar            = 110
%IDC_Note                 = 201
%IDC_DEBUG_LB             = 202
%HASHTABLESIZE            = &H1000

' the following are used in DIALOG GET/SET USER statements
' user dialog user values for communicating with TACE
%Ptr2UserText       = 1
%Ptr2Keywords       = 2
%CCERetval          = 3
' dialog user values used internally
%Hashtab            = 4
%FREPMSG            = 5
'----------------------------------------------------------------------------

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' setRichTextColor sets the textcolor for selected text in a RichNote control.
' Example: CALL setRichTextColor(&HFF) sets the color to red.
' &HFF0000 is blue, &H008000 is dark green, &H0 is black, etc..
' ----------------------------------------------------------------------------
function setRichTextColor( hNote as dword, 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(hNote, %EM_SETCHARFORMAT, %SCF_SELECTION, varptr(cf))

end function
'-------------------------------------------------------------------------------
' a hashing algo
function Elf32(sKey as string) as long
  local key as byte ptr
  local h as long
  local g as long
  local i as long
  key = strptr(sKey)
  h = 0
  while @key
    shift left h, 4
    h = h + @key
    key = key + 1
    g = h and &HF0000000???
    if g then
      i = g
      shift right i, 24
      h = h xor i
    end if
    h = h and (not g)
  wend
  function = h
end function
'-------------------------------------------------------------------------------
sub getRichEditText(byval hEd as dword, byval psz as dword)
   local sBuffer as string, ES as EDITSTREAM

   es.dwCookie = psz
   es.pfnCallback = codeptr(getRichEditTextCB)
   SendMessage(hEd, %EM_STREAMOUT, %SF_TEXT, byval varptr(es))
end sub
'-------------------------------------------------------------------------------
function getRichEditTextCB(byval dwCookie as dword, byval pRichEd as byte ptr, _
                         byval cb as long, byref pcb as long) as long
   local psBuffer as asciz ptr
   psBuffer = dwCookie
   if cb < 1 then exit function
   @psBuffer = @psBuffer & peek$(pRichEd, cb)
   pcb = cb
end function
'-------------------------------------------------------------------------------
function putRichEditTextCB(byval dwCookie as dword, byval pRichEd as byte ptr, _
                      byval cb as long, byref pcb as long) as long
    'dwCookie used to pass ptr to asciz buffer holding the data to load
    'pRichEd is the ptr to the rich edit control buffer to receive the data
    'cb = bytes to read in chunks (4K) defined by the OS
    'pcb = bytes actually needed to be read (last chunk less than 4K)
    '-------------------------------------------------------------------------
    local psBuffer as asciz ptr

    psBuffer = dwCookie
    pcb = min(len(@psBuffer), cb)
    if pcb > 0 then
        poke$ pRichEd, left$(@psBuffer, pcb)
        @psBuffer = mid$(@psBuffer, pcb + 1)
    end if
end function
'-------------------------------------------------------------------------------
function putRichEditText(byval hEd as dword, byval ps as string ptr) as long
'   '-------------------------------------------------------------------------------
'   'let rich edit call the callback function repeatedly, reading in 4K chunks
'   'of data at a time until there is no more to read.
'   '-------------------------------------------------------------------------------
   local ES as EDITSTREAM
   es.dwCookie    = ps
   es.pfnCallback = codeptr(putRichEditTextCB)
   function = SendMessage(hEd, %EM_STREAMIN, %SF_TEXT, byval varptr(es))  ' %SFF_TEXT
end function
'-------------------------------------------------------------------------------

sub saveText( hNote as dword)
    SendMessage hNote, %EM_SETMODIFY, 0, 0
end sub

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Syntax color parser for received line numbers
' borrowed from Borje Hagsten, much rewritten
%our_quote = 1
%our_comment = 2
%our_word = 3
%our_other = 4
' ----------------------------------------------------------------------------
sub ScanLine(hNote as dword, byval Line1 as long, byval Line2 as long)

    local hUser as dword ' to hold the dialog handle of the user dialog which calls TACE
    local pd as CHARRANGE, Oldpd as CHARRANGE, tBuff as TEXTRANGE
    local szword as asciz * 256 ' to contain a word extracted from line
    local szBuf, sprotobuf as string ' line length propably won't exceed this!
    local openbrkt, Offset, levents, I, J, l, startpos, w as long
    local lnLen, Result, foundmatch, foundword as long
    local Letter as byte ptr
    local prevletter as byte
    local s, sword as string
    local phashtab              as long   ptr
    local pLangWords            as byte ptr
    local pKeyWords             as string ptr
    local sStringQuote, sSingleLineComment, SKeyWords                as string
    local n, ldebug, ldebugsave, lenszbuf    as long
    local tstart as double
    local CharVals()            as long
    dim charvals(0 to 255)

    tstart = timer ' debug
    '
    ' charvals : an array in which the index is the ASC value of a character,
    ' and the cell value is the sub index to execute when the char is encountered
    ' in the text being parsed for keywords.
    for n = 0 to 255: charvals(n) = %our_other:next
    '
'    DIALOG GET USER hNote, %Ptr2Keywords TO pKeyWords
    ' first line is the word delimiters string
    s = parse$(gKeyWords, $crlf,1)
    ' these characters can terminate a "word" in the text being parsed:
    for n = 1 to len( s)
        charvals(asc(mid$(s,n,1))) = %our_word
    next
    ' next single line comment string, NB can be more than 1 char in length.
    ' if it is a single char, just enter it in the char table. If a string, make no
    ' entry in the char table... it is tested inline as a word.
    '
    sSingleLineComment = parse$(gKeyWords, $crlf,2)
    if len( sSingleLineComment) = 1 then charvals(asc(sSingleLineComment)) = %our_comment
    '
    ' next is the string quote char, always a single char
    sStringQuote = parse$(gKeyWords, $crlf,3)
    charvals(asc(sStringQuote)) = %our_quote
    ' rest is the keywords string as a single line
    sKeyWords = ucase$(parse$(gKeyWords, $crlf,4))
    pkeywords = varptr(sKeyWords)
    '
    dialog get user getparent(hNote), %HashTab to phashtab
    '
    call SendMessage(hNote, %EM_EXGETSEL, 0, varptr(Oldpd)) 'Original position
                                                            '(so we can reset it later)
    'Disable the event mask, for better speed
    levents = SendMessage(hNote, %EM_GETEVENTMASK, 0, 0)
    call SendMessage(hNote, %EM_SETEVENTMASK, 0, 0)

    SendMessage hNote, %EM_HIDESELECTION,1,0

    if Line1 <> Line2 then                                  'if multiple lines
        mouseptr 11
    else                                                                     'editing a line
        pd.cpMin = SendMessage(hNote, %EM_LINEINDEX, Line1, 0)                'line start
        pd.cpMax = pd.cpMin + SendMessage(hNote, %EM_LINELENGTH, pd.cpMin, 0) 'line end
        call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(pd))                  'select line
        setRichTextColor ( hNote, &H0)                                        'set black
    end if
    sprotobuf = string$(500," ")

    for J = Line1 to Line2
        szbuf = sprotobuf '+ " "
        Offset = SendMessage(hNote, %EM_LINEINDEX, J, 0)       'line start
        lnLen  = SendMessage(hNote, %EM_LINELENGTH, Offset, 0) 'line length

        if lnLen = 0 then iterate
        tBuff.chrg.cpMin = Offset
        ' the extra char is for CR or 1st char of next line if wrapped
        tBuff.chrg.cpMax = Offset + lnLen
        tBuff.lpstrText = strptr(szBuf)
        lnLen = SendMessage(hNote, %EM_GETTEXTRANGE, 0, byval varptr(tBuff)) 'Get line
        szbuf = left$(acode$(szbuf), lnLen)
        call CharUpperBuff(byval strptr(szBuf), lnLen)        'Make UCASE, handles all chars 0-255
        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        ' Loop through the line, using a pointer for better speed
        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        foundword = 0
        szbuf = szbuf + " " : incr lnLen ' force the last word in the line to be handled inside the loop
        Letter = strptr(szBuf)
        '

        for I = 1 to lnLen ' about 5% improvement
            on Charvals(@letter) goto LQUOTE, LCOMMENT, LWORD, LOTHER
LQUOTE:
            startpos = instr(I + 1, szBuf, sStringQuote)
            if startpos then
                pd.cpMin = Offset + I
                pd.cpMax = Offset + startpos - 1
                call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(pd))  ' was sendmessage
                setRichTextColor hNote, &HFF
                startpos = (startpos - I + 1)
                I = I + startpos
                Letter = Letter + startpos
                foundword = 0
            end if
            incr letter
            iterate
LCOMMENT:
            pd.cpMin = Offset + I - 1
            pd.cpMax = Offset + lnLen
            call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(pd))
            setRichTextColor hnote, &H00008000&
            foundword = 0
            exit for      ' done with line
LWORD:
            if foundword = 1 then
                w = i - startpos
                szword = mid$(szbuf, startpos, w + 1)
                poke varptr(szword) + w , 0 ' null terminate!
                if szword = sSingleLineComment then
                    pd.cpMin = Offset + I - w - 2
                    pd.cpMax = Offset + lnLen
                    call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(pd))
                    setRichTextColor hnote, &H00008000&
                    foundword = 0
                    exit for
                end if

                n = elf32(trim$(szword)) mod %HASHTABLESIZE

                foundmatch = %false
                ldebug = 0
                do while @phashtab[n] <> 0
                    incr ldebug
                    s = parse$(@pKeyWords, @phashtab[n])
                    if SZWORD <> parse$(@pKeyWords, @phashtab[n]) then
                        if n >= %HASHTABLESIZE then
                            foundmatch = %false
                            exit loop
                        else
                            incr n
                        end if
                    else
                        foundmatch = %TRUE
                        exit loop
                    end if
                loop
                if ldebug > ldebugsave then ldebugsave = ldebug
                if foundmatch = %FALSE then
                    incr letter
                    foundword = 0
                    iterate
                end if
                pd.cpMin = Offset + startpos - 1
                pd.cpMax = Offset + I - 1
                call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(pd))       ' was sendmessage
                call setRichTextColor( hnote, &HFF0000)                    'set blue color
                foundword = 0
            else
                ' just in case the single line comment is two delimiters like // or --
                if (@letter = prevletter ) and ((chr$(@letter) + chr$(@letter)) = sSingleLineComment) then
                    pd.cpMin = Offset + I - w - 2
                    pd.cpMax = Offset + lnLen
                    call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(pd))
                    setRichTextColor hnote, &H00008000&
                    foundword = 0
                    exit for
                end if
                prevLetter = @letter
            end if
            incr letter
            iterate

LOTHER:      ' we're inside a word
            if foundword = 0 then
                startpos = I
            end if
            foundword = 1
            incr Letter
        next I
    next J

    'Reset original caret position
    call SendMessage(hNote, %EM_EXSETSEL, 0, byval varptr(Oldpd))
    SendMessage hNote, %EM_HIDESELECTION,0,0

    'Reset the event mask
    if levents then call SendMessage(hNote, %EM_SETEVENTMASK, 0, levents)
end sub
'------------------------------------------------------------------------------------
function MakeFont(byval fName as string, byval ptSize as long, _
                  opt byval attr as string) as dword
   '--------------------------------------------------------------------
   ' Create a desired font and return its handle.
   ' attr = "biu" for bold, italic, and underlined (any order)
   '--------------------------------------------------------------------
   local hDC as dword, CharSet as long, CyPixels as long
   local bold, italic, uLine as long
   if len(attr) then
      if instr(lcase$(attr), "b") then bold = %FW_BOLD
      if instr(lcase$(attr), "i") then italic = 1
      if instr(lcase$(attr), "u") then uLine = 1
   end if
   hDC = GetDC(%hwnd_desktop)
   CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
   ReleaseDC %hwnd_desktop, hDC
   PtSize = 0 - (ptSize * CyPixels) \ 72
   function = CreateFont(ptSize, 0, 0, 0, bold, italic, uLine, _
             %FALSE, CharSet, %OUT_TT_PRECIS, _
             %CLIP_DEFAULT_PRECIS, %DEFAULT_QUALITY, _
             %FF_DONTCARE , bycopy fName)
end function
'-------------------------------------------------------------------------------
function quitNote( hD as dword, hNote as dword) as long
   local n as long
   function = -1
   if SendMessage(hNote, %EM_GETMODIFY, 0, 0) then ' file has changed
      n = msgbox("Text has changed..." & $crlf _
      & "do you want to save it?", %mb_taskmodal or %mb_yesnocancel or %mb_iconquestion, "Save Text")
      if n = %idcancel then
         function = 0
      else
         if n = %idyes then
             ' export text
             function = 1
         end if
      end if
   end if
end function
'------------------------------------------------------------------------
function fileExists(fileName as string) as long
  local n as long
  n = getattr(fileName)
  function = (errclear = 0)
end function
'------------------------------------------------------------------------
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<< find & replace code borrowed from Eric Christensen
function openfindorreplacetextdialog (byval hwnd as long, byval ind as long, byval flgs as long) as long
    static fr as findreplace, ztxt as asciiz * 256, ztxt2 as asciiz * 256
    '
    ' the dialog remembers the find-string and replace-string between calls.
    ' there is no need to set them here.
    '
    fr.lstructsize      = sizeof(fr)
    fr.hwndowner        = hwnd
    fr.hinstance        = %null
    ' first time set flags to downward search direction - else to previous values.
    if istrue flgs then fr.flags = flgs else fr.flags = %fr_down or %fr_hideupdown ' this method only allows downward search
    fr.lpstrfindwhat    = varptr(ztxt)
    fr.wfindwhatlen     = sizeof(ztxt)
    fr.lpstrreplacewith = varptr(ztxt2)
    fr.wreplacewithlen  = sizeof(ztxt2)
    fr.lcustdata        = 0
    fr.lpfnhook         = %null
    fr.lptemplatename   = %null
    '
    if ind = 1 then function = findtext(fr)
    if ind = 2 then function = replacetext(fr)
    '
end function
'-------------------------------------
type FINDTEXTEXW
   chrg      as CHARRANGE    ' CHARRANGE chrg
   lpstrText as word ptr     ' LPCWSTR   lpstrText
   chrgText  as CHARRANGE    ' CHARRANGE chrgText
end type
'------------------------------------------------------------------
type FINDTEXTEXW
   chrg      as CHARRANGE    ' CHARRANGE chrg
   lpstrText as word ptr     ' LPCWSTR   lpstrText
   chrgText  as CHARRANGE    ' CHARRANGE chrgText
end type
'------------------------------------------------------------------------------------------
function dofindreplaceaction(byval llparam as long, byval hwnd as long, byref flgs as long) as long
    static txt as string
    static ipos as long
    static match as long
    static przt as string
    static lppfr as findreplace ptr
    static zt as asciiz ptr, zt2 as asciiz ptr
    local cr as charrange
    local tf as textrange
    local ptf as textrange ptr
    local buf as string
    local searchflag&, res&
    local n as long
    static s, stemp as string
    local tFT as FINDTEXTEXW
    local ps as asciz ptr

    lppfr = llparam
    if (@lppfr.flags and %fr_dialogterm) then     ' find or replace dialog is closed
        'hdlgmodeless = %null :
        function = 0 : exit function
    end if
    '
    flgs = @lppfr.flags                           ' save flags for next call
    zt   = @lppfr.lpstrfindwhat                   ' text to search for
    zt2  = @lppfr.lpstrreplacewith                ' replacing text if any
    '
    ' determine flags for specification of search
    searchflag& = 0
    if (@lppfr.flags and %fr_matchcase) then searchflag& = searchflag& or %fr_matchcase
    if (@lppfr.flags and %fr_wholeword) then searchflag& = searchflag& or %fr_wholeword
    '
    ' find caret or selection, if any
    sendmessage hwnd, %em_exgetsel, 0, varptr(cr)
    '
    if (@lppfr.flags and %fr_findnext) then ' find next
        gosub positioncheck
        gosub search
        if isfalse match then ? "no match found",%mb_iconinformation or %mb_taskmodal, "find"
    elseif (@lppfr.flags and %fr_replace) then ' replace
        gosub search
        if istrue match then
            sendmessage hwnd, %em_replacesel, %true, zt2
            cr.cpmax = cr.cpmin + len(@zt2)
            sendmessage hwnd, %em_exsetsel,0, varptr(cr)
            gosub search
            if isfalse match then msgbox "no further match found",%mb_taskmodal or %mb_iconinformation, "find"
        else
            msgbox "no match found",%mb_taskmodal or %mb_iconinformation, "find"
        end if
    elseif (@lppfr.flags and %fr_replaceall) then ' replace all
        gosub search
        if istrue match then
            do
                sendmessage hwnd, %em_replacesel, %true, zt2
                cr.cpmax = cr.cpmin + len(@zt2)
                sendmessage hwnd, %em_exsetsel, 0,  varptr(cr)
                gosub search
            loop until isfalse match    ' loop until no more matches
        else
            msgbox "no match found",%mb_taskmodal or %mb_iconinformation, "find"
        end if
    end if
    function = 1 : exit function
    '
    positioncheck:
        ' get selected text for checking purposes
        tf.chrg.cpmin = cr.cpmin
        tf.chrg.cpmax = cr.cpmax
        buf = space$(cr.cpmax - cr.cpmin + 1)
        tf.lpstrtext = strptr(buf)
        n = 999
        n = sendmessage (hwnd, %em_gettextrange, 0, varptr(tf))
        ' adjust start position of search if necessary - to avoid being stuck in the same place.
        if (left$(ucase$(buf),len(buf)-1) = przt) and (cr.cpmin < cr.cpmax) then incr cr.cpmin
    return
    '
    search:
        ' get upper limit of searching range
        tft.chrg.cpmin = cr.cpmin
        tft.chrg.cpmax = sendmessage ( hwnd, %em_getlimittext, 0, 0)
        s = ucode$(@zt)
        ps = strptr(s) 'movememory BYVAL ps, BYVAL STRPTR(s), BYVAL LEN(s) 'UCODE$(@zt),
        tft.lpstrtext  = ps
        '
        ' do specified search for specified text
        ipos = sendmessage (hwnd, %em_findtextexW, %FR_DOWN, varptr(tft)) ' searchflag&

        if ipos <> -1 then ' search is successful
            cr.cpmin = ipos
            cr.cpmax = cr.cpmin + len(@zt)
            '
            ' select found text
            sendmessage hwnd, %em_exsetsel, 0,  varptr(cr )
            ' save search string for checking purposes.
            przt = ucase$(trim$(@zt))
            ' match found
            match = %true
        else
            match = %false
        end if
    return
    '

end function
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> /find & replace code borrowed from Eric Christensen
'------------------------------------------------------------------------------
callback function Floatmsg_dialogProc()

    select case as long cbmsg
        case %wm_initdialog
        case %wm_command
            dialog end cbhndl, 0
        case %wm_destroy 'delete what we created on exit, to avoid mem leaks
    end select
end function

'------------------------------------------------------------------------------
function FloatMsg_dialog(byval hParent as dword, s as string) as long
    local lRslt as long
    local hDlg  as dword
    local p as pointapi
    local x, y, w, h as long

    dialog get loc hparent to x, y
    dialog new pixels, hParent, "", x , y , 65, 14, %ws_popup or  _
        %ws_clipsiblings or %ws_visible  or _         ' OR  %DS_NOFAILCREATE OR %DS_3DLOOK OR %WS_THICKFRAME OR
        %ds_setfont, %ws_ex_controlparent or %ws_ex_toolwindow or _
        %ws_ex_topmost or %ws_ex_left or %ws_ex_ltrreading to hdlg
    dialog  set color   hDlg, -1, rgb(255, 255, 155)
    control add label, hDlg, 1001, s, 0, 0, 58, 12, %ss_notify
    control set color hdlg, 1001, -1, -2
    dialog show modeless hDlg, call FloatMsg_dialogProc to lRslt
    function = hdlg
end function

'----------------------------------------------------------------------------
function subClassEditProc(byval hWnd as long, byval wMsg&, byval wParm&, byval lparam as long) as long
    local lRet                      as long
    local sztabchar                 as asciz * 2
    local szbuffer                  as asciz * %CCE_MAXTEXTSIZE
    local p                         as PointAPI
    local pdwretval                 as dword ptr
    static psUserTextBuffer         as string ptr
    local curline, l, MenuChoice    as long
    local s, smsg                   as string
    static flgs                     as long ' saving find or replace flags between calls.
    static lPrevSCLN, lSelChangeLineNum as long
    static hMsgFindReplace          as long
    static dwOrigEditProc, hw       as dword
    static InfoDlg                  as dword' handle of Ctrl-G info dialog
    static hpopup                   as dword ' menu handle
    '
    if hWnd& = 0 then           ' initial message from parent
        dwOrigEditProc = wparm&
        hMsgFindReplace = lparam
        function = 1
        exit function
    end if

    select case wMsg&

        case hMsgFindReplace ' this is the message registered
            smsg = "FINDREPLACE"
            ' do actions in response to your input in the dialog box
            function = dofindreplaceaction(lparam, hWnd, flgs)
            gosub tell

        case %wm_vscroll

        case %wm_user + 100             ' parent has recieved selchange notification
            if InfoDlg <> 0 then
                dialog end InfoDlg, 0
                InfoDlg = 0
            end if

            gosub refreshKeyWords

        case %wm_keyup
            l = wparm&
            select case wParm&
               case %VK_TAB
                  sztabchar = chr$(9): SendMessage hWnd, %EM_REPLACESEL, 1, byval varptr(sztabchar)
            end select

        case %wm_rbuttonup
            call GetCursorPos(byref p)
            hPopup = CreatePopupMenu ' creating the menu inline to save having to pass the handle back
                                     ' to the main dlg which is where it would logically be destroyed.
            call InsertMenu(hPopup, 0, %MF_BYCOMMAND              , 1, "&Find")
            call InsertMenu(hPopup, 0, %MF_BYCOMMAND              , 2, "&Done")
            MenuChoice = TrackPopupMenuEx(hPopup, %mf_enabled or %MF_BYCOMMAND or %TPM_RETURNCMD, p.x, p.y, _
                         getparent(hWnd), byval %NULL)

            destroymenu ( hpopup)
            control get user getparent(hwnd), %IDC_NOTE, %CCERetVal to pdwretval
            select case menuchoice
                case 1 ' find
                    call openfindorreplacetextdialog(hWnd, 1, flgs)
                case 2 ' replace
                    call openfindorreplacetextdialog(hWnd, 2, flgs)
                case 3 ' done
                    hw = getparent(hwnd)
                    getRichEditText( hWnd, byval varptr(szbuffer))
                    @pdwretval = 1
                    dialog end getparent(hWnd), 0
                case 4 ' Cancel
                    @pdwretval = 0
                    dialog end getparent(hWnd), 0
            end select

        case %wm_char
             if InfoDlg <> 0 then
                 dialog end InfoDlg, 0
                 InfoDlg = 0
             end if
             select case wParm&
                 case &H16 ' have we been pasted with CTL-V ?
                     smsg = "CTRL-V"
                     scanline  hWnd, lPrevSCLN, lSelChangeLineNum
            end select

        case %WM_GETDLGCODE
            if isfalse lparam then 'not a message being sent to the control
                ' Ensure that the edit control does not select its contents on receiving the focus
                lRet = CallWindowProc(dwOrigEditProc, hWnd, wMsg&, wParm&, lparam)
                function = lRet xor %dlgc_hassetsel 'Clear the DLGC_HASSETSEL bit from lRet
                exit function
            end if

    end select
    ' Pass the message on to the original window procedure
    function = CallWindowProc(dwOrigEditProc, hWnd, wMsg&, wParm&, lparam)
    exit function
'
refreshKeyWords:
    lPrevSCLN = lSelChangeLineNum
    lSelChangeLineNum = SendMessage(hWnd, %EM_EXLINEFROMCHAR, 0, -1)
return
'
tell:
    return
end function
'----------------------------------------------------------------------------
callback function showNoteProc()
    local fontSize, hpopup, i, l, linecount, menuchoice, wi, ht, tabunits as long
    local fontName, fn, s           as string
    static sbuffer                  as string
    static szbuffer                 as asciz * %CCE_MAXTEXTSIZE ' define the max buffer size for CCE
    local pmmi                      as MINMAXINFO ptr
    local p                         as PointAPI
    local pnmh                      as nmhdr ptr
    static flgs                     as long ' saving find or replace flags between calls.
    local CurLine                   as long  ' ephemeral current line position
    static hNote                    as dword
    local  pKeyWords                as string ptr     ' slangwords
    static lhashtab()               as long
    static lUboundCData             as long
    static szReqdchars              as asciz * 256
    static hMsgFindReplace          as long
    static dwOrigEditProc           as dword
    static  psUserTextBuffer        as asciz ptr
    local  dwInitProc               as long
    local pdw                       as dword ptr
    local huser                     as dword ' handle of user dialog which called TACE
    static hfont                    as dword ' font for editor window
    local h                         as dword

    select case cbmsg
      case %wm_initdialog

          redim lhashtab(0 to %HASHTABLESIZE -1) as static long ' %HASHTABLESIZE -1
          ' register a message for the find or replace dialog.
          hMsgFindReplace = registerwindowmessage ("commdlg_findreplace")
          dialog set user cbhndl, %Frepmsg, hMsgFindReplace
          gosub loaddata
          ' set pointer to KeyWords array as a property of this window
          dialog set user cbhndl, %Hashtab, varptr(lhashtab(0))
          '------------------------------------------------------------------
          ' resize dialog to show vertical scrollbar
          '------------------------------------------------------------------
          control handle cbhndl, %IDC_Note to hNote
          dialog get client cbhndl to wi, ht
          dialog set size cbhndl, wi, ht

          '------------------------------------------------------------------
          ' create and set an initial fixed-width font as default
          '------------------------------------------------------------------
          fontName = "Courier New": fontSize = 10
          hFont = MakeFont(fontName, fontSize)
          SendMessage hNote, %WM_SETFONT, hFont, 0

          tabUnits = 16 'interval of 8 spaces
          SendMessage hNote, %EM_SETTABSTOPS, 1, byval varptr(tabUnits)
          SendMessage hNote, %EM_LIMITTEXT, %CCE_MAXTEXTSIZE, 0
          SendMessage hNote, %EM_SETOPTIONS, %ECOOP_OR, %ECO_SELECTIONBAR 'left margin selection
          SendMessage hNote, %EM_FMTLINES, %TRUE, 0
          '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          'Must set the event mask, so we can pick up a few events from RichNote
          '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          call SendMessage(hNote, %EM_SETEVENTMASK, 0, %ENM_SELCHANGE or %ENM_CHANGE or %ENM_UPDATE)
          dwOrigEditProc = SetWindowLong(hNote, %GWL_WNDPROC, codeptr(subClassEditProc)) 'subclass
          ' call the subclassed control directly
          ' to tell it what it's original WndProc is
          ' and what the find/replace message number is
          subClassEditProc ( 0, 0, dwOrigEditProc, hMsgFindReplace)
          SendMessage hNote, %EM_SETMODIFY, 0, 0
          h = cbhndl ' debug
          control get user cb.hndl, %IDC_Note, %Ptr2UserText to psUserTextBuffer
          szbuffer = space$(%CCE_MAXTEXTSIZE)
          szbuffer = @psUserTextBuffer
          putRichEditText( hNote, byval varptr(szbuffer)) 'hWnd, string ptr
          CurLine = SendMessage(hNote, %EM_getlinecount, 0, 0)
          call ScanLine(hnote, 0, CurLine)

        case %wm_size
          RedrawWindow cbhndl, byval 0, byval 0, %RDW_VALIDATE
          dialog get client cbhndl to wi, ht
          control set size cbhndl, %IDC_Note, wi, ht
          RedrawWindow cbhndl, byval 0, byval 0, %RDW_INVALIDATE

       case %WM_GETMINMAXINFO
           pmmi = cblparam
           @pmmi.ptMinTrackSize.x = 200  'minimum size of window
           @pmmi.ptMinTrackSize.y = 200

       case %wm_command
           select case cbctl
               case %IDC_NOTE
                   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..
                           CurLine = SendMessage(hNote, %EM_EXLINEFROMCHAR, 0, -1)
                           call ScanLine(hnote, CurLine, CurLine)
                   end select
          end select

       case %wm_notify
           select case cbctl
               case %IDC_NOTE
                   pnmh = cblparam
                   select case @pnmh.code
                       case %EN_SELCHANGE
                           sendmessage hNote, %wm_user + 100, 0, 0
                   end select
           end select

        case %WM_SETTEXT  ' assume that this is the initial data load of the edit control
            control send cbhndl, %IDC_note, %WM_SETTEXT, cbwparam, cblparam
        '
        case %wm_user + 201  ' user shut down - drop everything & close
            control kill cbhndl, %IDC_NOTE
            dialog end cbhndl, 0
        '
        case %wm_user + 202  ' maximize window
            dialog show state cbhndl,  %sw_show
        '
        case %wm_destroy
            ' remove subclassing
            SetWindowLong hNote, %GWL_WNDPROC, dwOrigEditProc
            DeleteObject hFont
            FreeLibrary ghLib

    end select
    exit function
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
loaddata:
    local hfile as long
    local n as long

    ' keywords string has 3 lines of non-keywords at start, strip these
    n = parsecount(gKeywords, $crlf)
    s = ucase$(parse$(gKeyWords,$crlf,4))
    '
    n = parsecount(s)
    for i = 0 to n -1
        h = elf32(parse$(s, i)) mod %HASHTABLESIZE
        while lhashtab(h)<> 0: incr h: wend
        lhashtab(h) = i
    next
return
end function
'-------------------------------------------------------------------------------------------
' params are parent window coordinates for edit window, text ptr, title
function CCE_BASRO ( hParent as dword, r as rect, byval pstext as dword, Title as string) as long

    local nStyle, bStyle as long
    local dwresult as dword ' to contain the result from the CB function
    local dwretval              as dword
    local hDlg as dword
    static s as string

    local debug1, debug2 as string ptr

    CreatePBKeyWordString ' create global keywords string
    ghLib = LoadLibrary("Msftedit.dll") 'Riched32.dll")
'    hLib = LoadLibrary("Riched20.dll")
    if ghLib = 0 then
       s = "File 'Msftedit.dll' required"
       msgbox s, %mb_taskmodal or %mb_iconwarning, "File not Found": exit function
    end if
    ghLib = 0
    nStyle = %ws_child or %ws_popup or %ws_sysmenu or %ws_minimizebox or %ws_maximizebox or _
             %ds_center or %ds_modalframe or %ws_thickframe or %ws_caption

    dialog new pixels, 0, Title, r.nleft, r.ntop, r.nright, r.nbottom, nStyle to hDlg
    '
    nStyle = %ws_child  or %ws_clipchildren or %ws_visible or %es_multiline _
           or %ws_vscroll or %es_autovscroll  or %ws_hscroll  or %es_autohscroll or %es_wantreturn _
           or %ws_tabstop  or %es_nohidesel    ' or %ES_NOIME

    control add "RichEdit50W", hDlg, %IDC_Note, "", 0, 0, r.nright, r.nbottom, nStyle
    control set user hdlg, %IDC_NOTE, %Ptr2UserText, pstext

    ' send our dialog & editor control hwnd to parent
    dialog send hparent, %wm_user + 500, hdlg, %IDC_NOTE
    ' set edit window to Read Only
    control send hDlg, %IDC_Note, %EM_SETREADONLY, 1, 0
    dialog show modeless hDlg, call ShowNoteProc to dwresult
    function = hDlg
end function

**Stephane Fonteyne** · 4 Feb 2011, 04:22 AM

Cannot compile the applications

Hi Chris

1. Include files : Jose Roca
2. Compiler : PBWin 9.05 for Windows

When I try to compile the application it give me this error report for all your examples.

PowerBASIC for Windows
PB/Win Version 9.05.
Copyright (c) 1996-2010 PowerBasic Inc.
Englewood, Florida USA
All Rights Reserved

Error 481 in C:\PROGRAM FILES\POWERBASIC\FORUMS\POWERBASIC\SOURCE CODE\2009\PBWIN\SOURCE\CCE_BASRO_NEW.INC(452:006): Mismatch with prior definition
Line 452: type FINDTEXTEXW

What wrong here it's in de type struct
Can you please help me

Thanks
Stephane

**Chris Holbrook** · 4 Feb 2011, 05:08 AM

Stephane, please don't post questions or responses in the Source Code forum. You will notice that almost all threads here have a "comments" or "discussion" link - post your question or response there instead. Also, look at the notice at the top of the forum. What does it say?

Thanks for telling me about the problem. I will look into it.

**** added - there wasn't a problem, see discussion thread.

**Chris Holbrook** · 7 Feb 2011, 12:17 PM

Faster

The main code only has changed - the viewer source code can be taken from the post above.

The time to load a source file is now greatly reduced.

Comments here

Code:

''
' A Blocklist (Function/sub/method/class/type) utility inspired by PowerBASIC's F2 function
' Presents a list of blocks from which a selection can be made to view source code
' Synchronises with the last saved version of the subject file by checking the directory entry
' every 2000 milliseconds or so and reloading the function index and any changed windows
'
' Chris Holbrook 12-Sep-2009
'
' Changes
' 13-SEP-2009 includes comments preceding sub/function header in the function viewer windows
' 13-SEP-2009 uses keyword, comment and literal coloring
' 14-SEP-2009 added tooltips to controls on main screen
' 14-SEP-2009 added source file name to main dialog title
' 15-SEP-2009 fixed GPF problem
' 15-SEP-2009 only a single source code file can be examined by a single instance of the application
'
' Issues list (* = incorporated in change)
' 13-SEP-2009 PB keyword list is for PBWin V7 only
' 14-SEP-2009 refreshes all viewer windows when any change occurs, not just the changed ones.
' 14-SEP-2009 * Charles Dietz & Artur Gomide report GPFs - cannot recreate
'
' to do list (* = incorporated in change)
' 15-SEP-2009 Gösta H. Lovgren-2 suggests making the function list sortable
' 15-SEP-2009 Gösta H. Lovgren-2 suggests including macros
' 15-SEP-2009 * Gösta H. Lovgren-2 suggests making the initial screen larger
' 15-SEP-2009 Add a viewer window containing all globals
' 15-SEP-2009 Add a viewer window containing all variable declarations
' 15-SEP-2009 Add a viewer window containing all TYPE declarations
' 15-SEP-2009 Add a viewer window containing the code before the first function/macro declaration
'
' 7-FEB-2011 improved the performance of the source file load
'19-FEB-2011 fixed bug where CLASS and CLASS METHOD were handled wrongly
'19-FEB-2011 Added multi-line MACRO sensing
'19-FEB-2011 Added TYPE declaration sensing
'19-FEB-2011 fixed bug where leading comments were not properly handled
'19-FEB-2011 fixed bug where trailing lines were included after END...
'19-FEB-2011 Path of target source code file can be supplied on command line as first parameter
#compile exe
#debug display
#dim all

#include "WIN32API.INC"
#include "COMMCTRL.INC"
#include "COMDLG32.INC"
#include "richedit.inc"
#include "c:\chris\edit\CCE_BASRO.INC"  '<==========you will need to change this!
$version = "0.1.4"
%TIMERINTERVAL   = 2000
%IDD_DIALOG1         =  101
%IDC_LV = 1001
%IDD_DIALOG2         =  102
%IDC_TEXTBOX1        = 1003
%IDC_SOUFILE_BN      = 1004

type tfindex
    sfname as asciz * 256
    start as long
    finish as long
    hwnd as dword
    ptr2source as asciz ptr
end type
global findex() as tfindex      ' global table of functions and subs
global sourcecode as string   ' global table of source code
global ghfont as dword          ' font
'global gOutputHandle as dword
'-----------------------------------------------------------------------------
global hWndToolTip  as dword
'-----------------------------------------------------------------
sub CreateTip( hDlg as dword, tl as dword, Tip as string )
static Crt          as CREATESTRUCT
static TlInfo       as TOOLINFO
static hInst        as long

    if hWndToolTip then 'it's been initialized

        if tl = 0 then exit if
        'Tip = Left$(Tip, 79)
        control handle hDlg, tl to tl
        TlInfo.hwnd = tl
        TlInfo.uId = tl
        TlInfo.lpszText = strptr(Tip)
        SendMessage( hWndToolTip, %TTM_ADDTOOL, 0, varptr( TlInfo ) )
        SendMessage( hWndToolTip, %TTM_ACTIVATE, 1, 0 )

    else 'just initializing this time through
        local ice as INIT_COMMON_CONTROLSEX
        ice.dwSize = sizeof(ice)
        ice.dwICC = %ICC_WIN95_CLASSES
        InitCommonControlsEx(ice)

        hInst = GetModuleHandle("")
        Tip = "ToolTip"
        Crt.lpCreateParams = 0
        Crt.hInstance    = hInst
        Crt.hMenu        = 0
        Crt.hwndParent   = hDlg
        Crt.style        = %ws_popup or %TTS_NOPREFIX or %TTS_ALWAYSTIP
        Crt.lpszName     = strptr(Tip)
        Tip = $TOOLTIPS_CLASS
        Crt.lpszClass    = strptr(Tip)
        Crt.dwExStyle    = %ws_ex_topmost

        hWndToolTip = CreateWindowEx( %ws_ex_topmost, $TOOLTIPS_CLASS, "", _
        %ws_popup or %TTS_NOPREFIX or %TTS_ALWAYSTIP or %TTS_BALLOON, _
            %CW_USEDEFAULT, %CW_USEDEFAULT, %CW_USEDEFAULT, _
            %CW_USEDEFAULT, hDlg, 0, hInst, Crt )


        dialog send hWndToolTip, %TTM_SETMAXTIPWIDTH, 0, 200

        SetWindowPos( hWndToolTip, %HWND_TOPMOST, 100, 100, 300, 300, _
            %SWP_NOMOVE or %SWP_NOSIZE or %SWP_NOACTIVATE )

        SendMessage( hWndToolTip, %TTM_SETDELAYTIME, %TTDT_INITIAL, 100 ) 'time a pointer must remain stationary before the tooltip appears
        SendMessage( hWndToolTip, %TTM_SETDELAYTIME, %TTDT_AUTOPOP, 7000 ) 'time a tooltip window remains visible If the Pointer is stationary
        SendMessage( hWndToolTip, %TTM_SETDELAYTIME, %TTDT_RESHOW, 400 ) 'time before subsequent tooltips to appear

        '------------------------------
        TlInfo.cbSize = sizeof( TOOLINFO )
        'this doesn't make sense, but it works
        TlInfo.uFlags = %TTF_SUBCLASS or %TTS_ALWAYSTIP or %TTS_BALLOON or %TTF_CENTERTIP
        'if hToolParWnd <> 0 then tl is a control ID instead of a window handle
        TlInfo.hinst = hInst

    end if 'hWndToolTip

end sub 'CreateTip

'-------------------------------------------------------------------------------------------------------------
sub SetToolTips(hDlg as dword)
static  f   as long

    if f then exit sub else incr f 'make sure it only runs once
        CreateTip hDlg, 0, ""     'initialize tooltips
        CreateTip hDlg, %IDC_LV, "Click a function in the listview to see the source code in a new window"
        CreateTip hDlg, %IDC_SOUFILE_BN, "Click here to chose a new source file"
end sub 'SetToolTips

'---------------------------------------------------------------------------
function build ( hD as dword, LVid as long, sfile as string) as long
    local i, j, n, hfile, nrow, linenum as long
    local s, sline, s1, s2, s3, slist, swork as string
    local nsource as long
    local p as asciz ptr
    local t as quad
    local lline, lcomments as long
    local lpline, pcomments as asciz ptr

    hfile = freefile
    try
        open sfile for binary as hfile
        nsource = lof(hfile)
        get$ #hfile, nsource, sourcecode
        close hfile
    catch
        dialog set text hd, "FILE ERROR": beep: sleep 2000
        exit function
    end try
    ' pick out functions & subs from the array
    ' i is the offset of the start of line character in sourcecode
    ' lline is the line number
    ' row is the listview row number
    ' lcomments is the line # of the start of comments block prior to the proc
    ' pcomments is a ptr to the start of the comments block
    i = 1 ' character position
    while i =< nsource
        j = i
        sline = mid$(sourcecode, i, 255)
        replace $crlf with $nul in sline
        p = strptr(sline)
        SWORK = @p + " @@@@@@@@"
        s1 = ucase$(parse$(ltrim$(swork), " ", 1))
        s2 = parse$(ltrim$(swork), any " (", 2)
        s3 = parse$(ltrim$(swork), any " (", 3)
        if left$(s1,1) = "'" then s1 = "REM"
        select case s1
            case "REM" ' start comment block
                if lcomments = 0 then
                    lcomments = lline
                    pcomments = strptr(sourcecode) + i - 1
                end if
            '
            case "SUB"
                gosub addtolist
            '
            case "TYPE"
                gosub addtolist
            '
            case "FUNCTION"
                if left$(s2,1) <> "=" then gosub addtolist
            '
            case "METHOD"
                if left$(s2,1) <> "=" then gosub addtolist
            '
            case "MACRO"
                if left$(s2,1) <> "=" then gosub addtolist
            '
            case "CLASS" ' either a CLASS declaration or a CLASS METHOD declaration
                gosub addtolist
            '
            case "CALLBACK"
                gosub addtolist
            '
            case "END"
                if ucase$(left$(s2,8)) = "FUNCTION" then
                    gosub nudgelist
                    exit select
                end if
                if ucase$(left$(s2,5)) = "CLASS" then
                    gosub nudgelist
                    exit select
                end if
                if ucase$(left$(s2,6)) = "METHOD" then
                    gosub nudgelist
                    exit select
                end if
                if ucase$(left$(s2,5)) = "MACRO" then
                    gosub nudgelist
                    exit select
                end if
                '
                if ucase$(left$(s2,3)) = "SUB" then
                    gosub nudgelist
                end if
                '
                if ucase$(left$(s2,4)) = "TYPE" then
                    gosub nudgelist
                end if
            '
            case else ' unstart comment block
                lcomments = 0

        end select
        i += len(@p) + 2 ' advance i to next line start
        incr lline          ' increment line count
    wend
    s = ""
    findex(nrow).finish  = lline
    exit function
'''''''''''''''
addtolist:
    incr nrow
    select case as const$ S1
        case "CALLBACK"
            s = s3
        '
        case "CLASS"
            s = s2
            if ucase$(S2) = "METHOD" then
                s = s3
            end if
        '
        case else
            s = s2
    end select
    listview insert item hD, %IDC_LV, nrow, 0, s
    redim preserve findex(1 to nrow)
    if lcomments then
        findex(nrow).ptr2source = pcomments
        findex(nrow).start  = lcomments
        if nrow > 1 then
            findex(nrow-1).finish = lcomments - 1
        end if
    else
        findex(nrow).ptr2source = strptr(sourcecode) + i - 1
        findex(nrow).start  = lline
    end if
    lcomments = 0 ' unstart comment block
    findex(nrow).sfname = s'sourcecode(i)
    listview set text hD, %IDC_LV, nrow, 2, ltrim$(sline) 'sourcecode(i)
return
'''''''''''''''
nudgelist:
    findex(nrow).finish = lline 'i
    lcomments = 0 ' unstart comment block
return
end function
'--------------------------------------------------------
callback function MainDlgProc()
    local sfname as string ' filename of source code file
    local i, j, l, n, nfrom, nto, nsel, x, y as long
    local s, ss, st, soldcode, spath as string
    ' temporary array into which the old findex array is copied
    ' when a dirent change is detected
    local prevfindex() as tfindex
    ' rect used to define CCE window
    local r as rect
    local p as asciz ptr

    ' used in checking the dirent for updates
    static htimer as dword
    ' filename and dialog title
    static sourcecodefile, stitle as string
    ' used in checking the dirent for updates
    static dird, dird1 as dirdata
    '
    select case as long cbmsg
        case %wm_initdialog
            'startconsole
            settooltips ( cb.hndl)
            listview set stylexx cb.hndl, %IDC_LV, _
                %lvs_ex_infotip or %lvs_ex_fullrowselect or  %lvs_ex_oneclickactivate or %lvs_ex_gridlines
            listview  insert column cb.hndl, %IDC_LV, 1, "Name", 100, 0
            listview  insert column cb.hndl, %IDC_LV, 2, "header", 500, 0
            stitle = "F2+ Source Code File Selection"
            if trim$(command$) <> "" then
                sourcecodefile = command$(1)
                gosub gotsourcecodefile
            end if
        '
        case %wm_destroy
            killtimer cb.hndl, htimer
            if ubound(findex()) < 0 then exit select
            for i = lbound(findex()) to ubound(findex())
                if findex(i).hWnd <> 0 then
                    dialog end findex(i).hWnd, 0
                end if
            next
        '
        case %wm_ncactivate
            static hWndSaveFocus as dword
            if isfalse cbwparam then
                hWndSaveFocus = GetFocus()
            elseif hWndSaveFocus then
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            end if
        '
        case %wm_timer
            if trim$(sourcecodefile) = "" then
                exit select
            end if
            s = dir$ (sourcecodefile to dird1)
            if dird1.LastWriteTime <> dird.lastwritetime then
                dird = dird1
                listview reset cb.hndl, %IDC_LV
                l = lbound(findex())
                dim prevfindex(l to ubound(findex()))
                poke$ varptr(prevfindex(l)), peek$(varptr(findex(l)),sizeof(findex(l)) * arrayattr(findex(),4))
                erase findex()
                
                build(cb.hndl, %IDC_LV, sourcecodefile)
                for i = lbound(findex()) to ubound(findex())
                     if prevfindex(i).hWnd then
                         ' get the text in the "new" file for the named Function
                         ' kill off viewer window
                         dialog end prevfindex(i).hWnd, 0
                         s = trim$(prevfindex(i).sfname)
                         listview find exact cb.hndl, %IDC_LV, 1, s to n
                         ' if the function no longer exists, no further action required
                         if n = 0 then exit select
                         ' fn is present, create a new window
                         s = ""
                         p = findex(i).ptr2source
                         for j = findex(i).start to findex(i).finish
                             ss = left$(@p,255)
                             replace $crlf with $nul in ss
                             p += len(@p) + 1' jump over null
                             s = s + $crlf + ss
                         next
                         s = mid$(s, 3) ' lose leading $crlf
                         stitle = findex(i).sfname + " in " + sourcecodefile + " " + time$
                         setrect r, 0, 0, 400, 300
                         findex(i).hWnd = CCE_basro( cb.hndl, r, byval strptr(s), stitle)
                     end if
                next
            end if
        '
        case %wm_user + 501 ' child dialog has ended - clear hWnd in findex table
            for i = lbound(findex()) to ubound(findex())
                if findex(i).hWnd = cb.wparam then
                    findex(i).hWnd = 0
                    exit for
                end if
            next
        '
        case %wm_move, %wm_size
            local xx, yy as long
            if cb.wparam = %SIZE_MINIMIZED then
                for i = lbound(findex()) to ubound(findex())
                    if findex(i).hWnd <> 0 then
                        dialog send findex(i).hWnd, %wm_syscommand, %sc_minimize, 0
                    end if
                next
            end if
            dialog get client cb.hndl to x, y
            control set size cb.hndl, %IDC_LV, x, y -25
            control get size cb.hndl, %IDC_SOUFILE_BN to xx, yy
            control set size cb.hndl, %IDC_SOUFILE_BN, x, yy
        '
        case %wm_notify
            select case cb.ctl
                case %IDC_LV
                    select case cb.nmcode
                        case %nm_click
                            listview get select cb.hndl, %IDC_LV to nsel
                            if nsel > ubound(findex()) then
                                ? "selected item above expected range"
                                exit select
                            end if
                            if nsel < lbound(findex()) then
                                ? "selected item below expected range"
                                exit select
                            end if

                            nfrom = findex(nsel).start
                            nto   = findex(nsel).finish
                            p = findex(nsel).ptr2source
                            for j = findex(nsel).start to findex(nsel).finish
                                 ss = left$(@p, instr(@p,$crlf))
                                 p += len(ss)
                                 incr p' jump over LF
                                 s += ss
                            next
                            stitle = findex(nsel).sfname + " in " + sourcecodefile + " " + time$
                            setrect r, 0, 0, 400, 300
                            findex(nsel).hWnd = CCE_basro( cb.hndl, r, byval strptr(s), stitle)
                    end select
            end select
        '
        case %wm_command

            select case cb.ctl
                case %IDC_SOUFILE_BN
                    gosub setsourcecodefile
            end select
        '
'        case %wm_ncactivate
'            static hWndSaveFocus as dword
'            if isfalse cbwparam then
'                hWndSaveFocus = GetFocus()
'            elseif hWndSaveFocus then
'                SetFocus(hWndSaveFocus)
'                hWndSaveFocus = 0
'            end if
    end select
    exit function
''''''''''''''''''''''
setsourcecodefile:
    spath = curdir$
    OpenFileDialog(cb.hndl, stitle, sourcecodefile, sPATH, _
        "Basic Source Code Files|*.bas|Include Files|*.inc|All Files|*.*", "txt", 0)
gotsourcecodefile:
    if trim$(sourcecodefile) = "" then return
    control set text cb.hndl, %IDC_SOUFILE_BN, sourcecodefile
    sfname = parse$(sourcecodefile,"\",-1)
    dialog set text cb.hndl, "F2+ " + $version + " " + sfname
    if ubound(findex) > -1 then
        for i = lbound(findex()) to ubound(findex())
            if findex(i).hWnd then dialog end findex(i).hWnd, 0
        next
    end if
    erase findex()
    s = dir$ (sourcecodefile to dird)
    listview reset cb.hndl, %IDC_LV
    build(cb.hndl, %IDC_LV, sourcecodefile)
    htimer = settimer ( cb.hndl,%null, %TIMERINTERVAL, %null)
return
end function
'------------------------------------------------------------------------
function MainDlg(byval hParent as dword) as long
    local lRslt, w, h as long
    local hDlg  as dword

    dialog font default "Courier New", 10, 0, 0
    dialog new hParent, "F2+", 0, 0, 201, 321, _
        %ws_popup or %ws_border or %ws_dlgframe or %ws_sysmenu or %ws_minimizebox or _
        %ws_clipchildren or %ws_visible or %ds_modalframe or %ds_3dlook or _
        %ds_nofailcreate or %ds_setfont or %ds_center or %ws_thickframe, _
        %ws_ex_controlparent or %ws_ex_left or %ws_ex_ltrreading or %ws_ex_rightscrollbar, _
        to hDlg
    dialog get client hDlg to w, h
    control add button, hDlg, %IDC_SOUFILE_BN, "source code file", 0, 0, w, 14
    control add listview, hDlg, %IDC_LV, "", 0, 15, 192, 100, _
        %ws_child or %ws_visible or %ws_tabstop or %lvs_report or %lvs_showselalways, _
        %ws_ex_left or %ws_ex_clientedge or %ws_ex_rightscrollbar
    dialog show modal hDlg, call MainDlgProc to lRslt
    function = lRslt
end function
'---------------------------------------------------------------------
' testing comment block prior to a proc
function pbmain()
    initcommoncontrols
    MainDlg %hwnd_desktop
end function

Announcement

Forum Guidelines

Function list utility - F2 plus? exploration

PBWin Function list utility - F2 plus? exploration

Comment

Comment

Comment

Comment

Comment