Date: 02-16-2022
Return to Index
created by gbSnippets
'Credit: Borje Hagsten
http://www.powerbasic.com/support/pbforums/showthread.php?t=23591&highlight=text+rich+edit+control
'Compiler Comments:
'To compile with PBWin9, pass rc rather than VarPTR(rc) in MapWIndowPoints API
'Compilable Example: (Jose Includes)
'������������������������������������������������������������������������������
' Fast RichEdit syntax color code viewer for PB code (BAS, INC, RC, etc)
' Public Domain by Borje Hagsten, November 2002
' Written for PB/WIN 7.0, but should compile fine in version 6.x too
'
' Completely free to use and enhance - at own responsibility, of course.
' Save file as something like "PBtoRTF.bas" (whatever), compile and run.
''
' This code + compiled exe also available for download from:
' http://www.tolkenxp.com/pb/codeview.zip (~36 KB)
'
' Update Nov 19: fixed a mistake with ASM keyword. Also added special endblock
' for PB keywords to enable size trim if two keywords follows each other.
' RichEdit's speed depends on size of text, so must try to keep it down.
'
' Update Nov 18: Changed NewEvents macro to SUB, since it contains a
' local declare. Since macros become inline code, that would mean error
' if it is used more than one time in same routine. Also changed from
' using WM_SETTEXT to proper RichEdit stream in procedure. For best speed,
' I added global text buffer and some global variables for streaming proc,
' and changed SyntaxColorBAS and SyntaxColorRC to SUB's instead.
'
' Note: RichEditViewCode parser is very fast - RichEdit is not.
' Even +100 KB files are parsed in less than a second, but RichEdit
' can need many seconds to load them. MB files means long vacation..
' Hopefully, some day MS will buy a copy of PB and learn how to write
' tighter, faster code for RichEdit..
'
' Tip: For color printouts, press Ctrl+A to select all, Ctrl+C to copy,
' paste into WordPad (whatever) and print.
'------------------------------------------------------------------------------
#COMPILE EXE
#INCLUDE "WIN32API.INC"
#INCLUDE "COMDLG32.INC"
#INCLUDE "RICHEDIT.INC"
'------------------------------------------------------------------------------
%IDC_LABEL = 10
%IDC_OPEN = 20
%ID_RICHEDIT = 50
'------------------------------------------------------------------------------
GLOBAL aStart() AS LONG, aCount() AS LONG
GLOBAL gPos AS LONG, gPtr AS LONG, gTxt AS STRING
'------------------------------------------------------------------------------
DECLARE CALLBACK FUNCTION DlgProc() AS LONG
DECLARE FUNCTION LoadPBdata(dArray() AS STRING) AS LONG
DECLARE FUNCTION LoadHTMLdata(dArray() AS STRING) AS LONG
DECLARE FUNCTION LoadRCdata(dArray() AS STRING) AS LONG
DECLARE FUNCTION RichEditViewCode (BYVAL hRichEdit AS LONG, BYVAL fName AS STRING) AS LONG
DECLARE FUNCTION RichEditStreamInString (BYVAL dwCookie AS DWORD, BYVAL pbBuff AS BYTE PTR, _
BYVAL cb AS LONG, pcb AS LONG) AS DWORD
DECLARE SUB NewEvents
DECLARE SUB SyntaxColorBAS
DECLARE SUB SyntaxColorHTML
DECLARE SUB SyntaxColorRC
'������������������������������������������������������������������������������
' Main entrance - create dialog and controls, etc
'------------------------------------------------------------------------------
FUNCTION PBMAIN () AS LONG
LOCAL hDlg AS LONG
DIALOG NEW 0, "PBtoRTF code viewer",,, 380, 240, %WS_OVERLAPPEDWINDOW, 0 TO hDlg
CONTROL ADD BUTTON, hDlg, %IDC_OPEN, "&Open", 2, 2, 50, 14
CONTROL ADD BUTTON, hDlg, %IDCANCEL, "E&xit", 56, 2, 50, 14
CONTROL ADD LABEL, hDlg, %IDC_LABEL, "", 120, 0, 150, 18
IF LoadLibrary("RICHED32.DLL") THEN
CONTROL ADD "RichEdit", hDlg, %ID_RICHEDIT, "", 0, 18, 380, 190, _
%WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %WS_HSCROLL OR %WS_VSCROLL OR _
%ES_AUTOHSCROLL OR %ES_AUTOVSCROLL OR %ES_MULTILINE OR _
%ES_NOHIDESEL OR %ES_SAVESEL OR %ES_WANTRETURN, %WS_EX_CLIENTEDGE '%ES_READONLY ?
ELSE
EXIT FUNCTION
END IF
CONTROL SEND hDlg, %ID_RICHEDIT, %EM_SETOPTIONS, %ECOOP_OR, %ECO_SELECTIONBAR 'for left margin select..
CONTROL SEND hDlg, %ID_RICHEDIT, %EM_EXLIMITTEXT, 0, 1024 * 1024 - 1 '1 MB limit?
DIALOG SHOW MODAL hDlg CALL DlgProc
END FUNCTION
'������������������������������������������������������������������������������
' Main dialog's callback procedure
'------------------------------------------------------------------------------
CALLBACK FUNCTION DlgProc() AS LONG
SELECT CASE CBMSG
CASE %WM_INITDIALOG 'first message - initiate
LOCAL dwStyle AS DWORD, fName AS STRING, sBuf AS STRING, rc AS RECT
STATIC hEdit AS LONG, Path AS STRING
hEdit = GetDlgItem(CBHNDL, %ID_RICHEDIT)
Path = CURDIR$
CASE %WM_COMMAND 'command message
SELECT CASE CBCTL
CASE %IDC_OPEN 'Open
IF CBCTLMSG <> %BN_CLICKED THEN EXIT SELECT
fName = "*.BAS;*.INC"
sBuf = "PB code files (*.BAS, *.INC)|*.bas;*.inc|" + _
"HTML files (*.HTM, *.HTML)|*.htm;*.html|" + _
"Resource files (*.RC)|*.rc|" + _
"All Files (*.*)|*.*"
dwStyle = %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY OR %OFN_LONGNAMES
IF OpenFileDialog(CBHNDL, "", fName, Path, sBuf, "BAS", dwStyle) THEN
NewEvents 'take a breath for proper redraw between actions
RichEditViewCode hEdit, fName 'start action
Path = LEFT$(fName, INSTR(-1, fName, ANY "\/"))
sBuf = "PBtoRTF Code viewer - " + fName
SetWindowText CBHNDL, BYVAL STRPTR(sBuf)
END IF
CASE %IDCANCEL 'Exit
IF CBCTLMSG = %BN_CLICKED THEN DIALOG END CBHNDL
END SELECT
CASE %WM_SIZE 'resize message
IF CBWPARAM <> %SIZE_MINIMIZED THEN
GetWindowRect hEdit, rc ' get Richedit's position on screen
MapWindowPoints 0, CBHNDL, varptr(rc), 2 ' map rect to dialog - we need top pos
SetWindowPos hEdit, 0, 0, 0, _
LOWRD(CBLPARAM), HIWRD(CBLPARAM) - rc.nTop, _
%SWP_NOMOVE OR %SWP_NOZORDER
END IF
END SELECT
END FUNCTION
'������������������������������������������������������������������������������
' Custom DOEVENTS to make sure all pending messages are processed.
'------------------------------------------------------------------------------
SUB NewEvents
LOCAL Msg AS tagMsg
DO WHILE PeekMessage(Msg, 0, 0, 0, %PM_NOREMOVE) 'peek only, do not remove
DIALOG DOEVENTS 'let DDT handle all pending messages
LOOP
END SUB
'������������������������������������������������������������������������������
' Open given file, convert text to RTF and insert into Rich Edit
'------------------------------------------------------------------------------
FUNCTION RichEditViewCode (BYVAL hRichEdit AS LONG, BYVAL fName AS STRING) AS LONG
LOCAL ff AS LONG, t AS SINGLE, txt AS STRING, eStream AS EDITSTREAM
ff = FREEFILE
OPEN fName FOR BINARY AS ff LEN = 8192
IF ERR THEN 'if file couldn't be opened
MessageBeep &HFFFFFFFF 'I prefer speaker beep on errors..
RESET : ERRCLEAR 'Should of course flash a message here, but I'm too lazy today..
EXIT FUNCTION
END IF
GET$ ff, LOF(ff), gTxt 'all is ok, read entire contents into global text buffer
CLOSE ff 'close file
IF LEN(gTxt) = 0 THEN 'if length is zero, exit
MessageBeep &HFFFFFFFF
EXIT FUNCTION
END IF
CONTROL SET TEXT GetParent(hRichEdit), %IDC_LABEL, "Please wait.."
MOUSEPTR 11 'show Hourglass mouse pointer during process
t = TIMER 'for timing Syntax color parser
IF UCASE$(RIGHT$(fName, 3)) = ".RC" THEN
CALL SyntaxColorRC 'convert resource file code to RTF - this is fast
ELSEIF UCASE$(RIGHT$(fName, 4)) = ".BAS" OR UCASE$(RIGHT$(fName, 4)) = ".INC" THEN
CALL SyntaxColorBAS 'convert PB code to RTF - this is also fast
ELSEIF UCASE$(RIGHT$(fName, 4)) = ".HTM" OR UCASE$(RIGHT$(fName, 5)) = ".HTML" THEN
CALL SyntaxColorHTML 'convert PB code to RTF - this is also fast
ELSE
SendMessage hRichEdit, %WM_SETTEXT, 0, STRPTR(gTxt) 'else simply insert text and exit
CONTROL SET TEXT GetParent(hRichEdit), %IDC_LABEL, "Not a code file!"
EXIT FUNCTION
END IF
t = TIMER - t
txt = "Parsing took " + FORMAT$(t, "0.000") + " sec."
CONTROL SET TEXT GetParent(hRichEdit), %IDC_LABEL, txt + $CRLF + "Please wait.."
t = TIMER 'for timing RichEdit
gPos = 1 'position in text to start from
gPtr = STRPTR(gTxt) 'pointer to global text buffer
eStream.pfnCallback = CODEPTR(RichEditStreamInString) 'pointer to RichEdit callback procedure
SendMessage hRichEdit, %EM_STREAMIN, %SF_RTF, VARPTR(eStream) 'stream in text
t = TIMER - t
txt = txt + $CRLF + "RichEdit took " + FORMAT$(t, "0.000") + " sec." + STR$(LEN(gTxt))
CONTROL SET TEXT GetParent(hRichEdit), %IDC_LABEL, txt
MOUSEPTR 1 'done, so time to reset mouse pointer
gTxt = "" 'and we can clear global string buffer
FUNCTION = %TRUE 'if we get to this point, it should be succes - return true
END FUNCTION
'������������������������������������������������������������������������������
' Rich Edit stream in callback - for streaming in string contents
'������������������������������������������������������������������������������
FUNCTION RichEditStreamInString (BYVAL dwCookie AS DWORD, BYVAL pbBuff AS BYTE PTR, _
BYVAL cb AS LONG, pcb AS LONG) AS DWORD
pcb = MIN&(cb, LEN(gTxt) - (gPos - 1)) 'number of bytes to copy
IF pcb > 0 THEN 'copy block from global string directly into Richedit's buffer.
CopyMemory pbBuff, (gPtr + gPos - 1), pcb 'could use POKE$ too, but this is a bit faster
gPos = gPos + pcb 'incr pos for next callback position.
ELSE
FUNCTION = 1 'else break action
END IF
END FUNCTION
'������������������������������������������������������������������������������
' Redim and load given array with PB keyword data
'------------------------------------------------------------------------------
FUNCTION LoadPBdata(dArray() AS STRING) AS LONG
LOCAL ii AS LONG, jj AS LONG, kk AS LONG, rc AS LONG
rc = DATACOUNT
REDIM dArray(rc - 1) AS STRING 'zero based, so -1
REDIM aStart(26), aCount(26) 'for index
FOR ii = 1 TO rc 'read the data into the array
dArray(ii - 1) = UCASE$(READ$(ii))
NEXT
ARRAY SORT dArray()
jj = 64 'Index on first character, $%&# = 0, A = 1, etc..
FOR ii = 0 TO UBOUND(dArray)
kk = ASC(dArray(ii))
IF kk > jj THEN 'A - Z
aCount(jj - 64) = MAX&(0, ii - 1) 'indexed end
jj = kk
aStart(kk - 64) = ii
END IF
NEXT
aCount(jj - 64) = MAX&(0, ii - 1)
FOR ii = 0 TO 26 're-calculate count
IF aCount(ii) THEN aCount(ii) = MAX&(0, aCount(ii) - aStart(ii) + 1)
NEXT
FUNCTION = rc 'Return the count, in case we ever should need it..
'PB/WIN (DLL) keywords - think at least most of them.. :-)
DATA #BLOAT, #COMPILE, #DEBUG, #DIM, #ELSE, #ELSEIF, #ENDIF, #IF, #INCLUDE, #OPTION, #REGISTER, #RESOURCE
DATA #SEGMENT, #STACK, #TOOLS, $BEL, $BS, $COMPILE, $CR, $CRLF, $DEBUG, $DIM, $DQ, $ELSE, $ELSEIF, $ENDIF
DATA $EOF, $ESC, $FF, $IF, $INCLUDE, $LF, $NUL, $OPTION, $REGISTER, $RESOURCE, $SEGMENT, $SPC, $STACK
DATA $TAB, $VT, %DEF, %FALSE, %NULL, %PB_EXE, %TRUE
DATA ABS, ACCEL, ACCEPT, ACCESS, ACODE$, ADD, ADDR, ALIAS, ALL, AND, ANY, APPEND, ARRAY, ARRAYATTR
DATA AS, ASC, ASCEND, ASCIZ, ASCIIZ, AT, ATN, ATTACH, ATTRIB, BAR, BASE, BAUD, BDECL, BEEP
DATA BIN$, BINARY, BIT, BITS%, BITS&, BITS?, BITS??, BITS???, BREAK, BUTTON, BYCMD, BYCOPY, BYREF
DATA BYTE, BYVAL, CALC, CALL, CALLBACK, CALLSTK, CALLSTK$, CALLSTKCOUNT, CASE, CATCH, CBCTL, CBCTLMSG
DATA CBHNDL, CBLPARAM, CBMSG, CBWPARAM, CBYT, CCUR, CCUX, CD, CDBL, CDECL, CDWD, CEIL, CEXT, CHDIR
DATA CHDRIVE, CHECK, CHECK3STATE, CHECKBOX, CHOOSE, CHOOSE&, CHOOSE%, CHOOSE$, CHR$, CINT, CLIENT, CLNG
DATA CLOSE, CLS, CLSID$, CODEPTR, COLLATE, COLOR, COMBOBOX, COMM, COMMAND$, CON, CONNECT, CONST, CONTROL
DATA COS, CQUD, CREATE, CSET, CSET$, CSNG, CTSFLOW, CUR, CURDIR$, CURRENCY, CURRENCYX, CUX, CVBYT, CVCUR
DATA CVCUX, CVD, CVDWD, CVE, CVI, CVL, CVQ, CVS, CVWRD, CWRD, DATA, DATACOUNT, DATE$, DECLARE, DECR, DEFAULT
DATA DEFBYT, DEFCUR, DEFCUX, DEFDBL, DEFDWD, DEFEXT, DEFINT, DEFLNG, DEFQUD, DEFSNG, DEFSTR, DEFWRD, DELETE
DATA DESCEND, DIALOG, DIM, DIR$, DISABLE, DISKFREE, DISKSIZE, DISPATCH, DLL, DLLMAIN, DO, DOEVENTS, DOUBLE
DATA DOWN, DRAW, DSRFLOW, DSRSENS, DTRFLOW, DTRLINE, DWORD, ELSE, ELSEIF, EMPTY, ENABLE, END, ENVIRON$
DATA EOF, EQV, ERASE, ERR, ERRAPI, ERRCLEAR, ERROR, ERROR$, EXE, EXIT, EXP, EXP10, EXP2, EXPLICIT, EXPORT
DATA EXT, EXTENDED, EXTRACT$, FILEATTR, FILECOPY, FILENAME$, FILESCAN, FILL, FINALLY, FIX, FLOW, FLUSH, FOCUS
DATA FONT, FOR, FORMAT$, FORMFEED, FRAC, FRAME, FREEFILE, FROM, FUNCTION, FUNCNAME$, GET, GET#, GET$
DATA GETATTR, GLOBAL, GOSUB, GOTO, GUID$, GUIDTXT$, HANDLE, HEX$, HIBYT, HIINT, HIWRD, HOST, ICASE, ICON
DATA IDN, IF, IFACE, IIF, IIF&, IIF%, IIF$, IMAGE, IMAGEX, IMGBUTTON, IMGBUTTONX, IMP, IN, INCR, INP, INOUT
DATA INPUT, INPUT#, INPUTBOX$, INSERT, INSTR, INT, INTERFACE, INTEGER, INV, ISFALSE, ISNOTHING
DATA ISOBJECT, ISTRUE, ITERATE, JOIN$, KILL, LABEL, LBOUND, LCASE$, LEFT, LEFT$, LEN, LET, LIB, LIBMAIN
DATA LINE, LISTBOX, LOBYT, LOC, LOCAL, LOCK, LOF, LOG, LOG10, LOG2, LOINT, LONG, LOOP, LOWRD, LPRINT
DATA LSET, LSET$, LTRIM$, MACRO, MACROTEMP, MAIN, MAKDWD, MAKINT, MAKLNG, MAKPTR, MAKWRD, MAT, MAX, MAX$
DATA MAX%, MAX&, MCASE$, MEMBER, MENU, MID$, MIN, MIN$, MIN%, MIN&, MKBYT$, MKCUR$, MKCUX$, MKD$
DATA MKDIR, MKDWD$, MKE$, MKI$, MKL$, MKQ$, MKS$, MKWRD$, MOD, MODAL, MODELESS, MOUSEPTR, MSGBOX
DATA NAME, NEW, NEXT, NONE, NOT, NOTHING, NOTIFY, NULL, OBJACTIVE, OBJECT, OBJPTR, OBJRESULT, OCT$, OF
DATA OFF, ON, OPEN, OPT, OPTION, OPTIONAL, OR, OUT, OUTPUT, PAGE, PARITY, PARITYCHAR, PARITYREPL, PARITYTYPE
DATA PARSE, PARSE$, PARSECOUNT, PBD, PBMAIN, PEEK, PEEK$, PIXELS, POINTER, POKE, POKE$, POPUP, PORT, POST
DATA PRESERVE, PRINT, PRINT#, PRIVATE, PROFILE, PROGID$, PTR, PUT, PUT$, QUAD, QWORD, RANDOM, RANDOMIZE, READ
DATA READ$, RECEIVE, RECORDS, RECV, REDIM, REDRAW, REGEXPR, REGISTER, REGREPL, REMAIN$, REMOVE$, REPEAT$
DATA REPLACE, RESET, RESUME, RET16, RET32, RET87, RETAIN$, RETP16, RETP32, RETPRM, RETURN, RGB, RIGHT
DATA RIGHT$, RING, RLSD, RMDIR, RND, ROTATE, ROUND, RSET, RSET$, RTRIM$, RTSFLOW, RXBUFFER, RXQUE, SCAN
DATA SCROLLBAR, SDECL, SEEK, SELECT, SEND, SERVER, SET, SETATTR, SETEOF, SGN, SHARED, SHELL
DATA SHIFT, SHOW, SIGNED, SIN, SINGLE, SIZE, SIZEOF, SLEEP, SORT, SPACE$, SPC, SQR, STATE, STATIC, STATUS
DATA STDCALL, STEP, STOP, STR$, STRDELETE$, STRING, STRING$, STRINSERT$, STRPTR, STRREVERSE$, SUB, SUSPEND
DATA SWAP, SWITCH, SWITCH&, SWITCH%, SWITCH$, TAB, TAB$, TAGARRAY, TALLY, TAN, TCP, TEXT, TEXTBOX, THEN
DATA THREAD, THREADCOUNT, THREADID, TIME$, TIMEOUT, TIMER, TO, TOGGLE, TRACE, TRIM$, TRN, TRY, TXBUFFER
DATA TXQUE, TYPE, UBOUND, UCASE, UCASE$, UCODE$, UDP, UNION, UNITS, UNLOCK, UNTIL, UP, USER, USING, USING$
DATA VAL, VARIANT, VARIANT#, VARIANT$, VARIANTVT, VARPTR, VERIFY, VERSION3, VERSION4, VERSION5
DATA WEND, WHILE, WIDTH, WIDTH#, WINMAIN, WITH, WORD, WRITE, WRITE#, XOR, XINPFLOW, XOUTFLOW, ZER
END FUNCTION
'�����������������������������������������������������������������������������
' Load HTML keywords into memory block
'�����������������������������������������������������������������������������
FUNCTION LoadHTMLdata(dArray() AS STRING) AS LONG
LOCAL ii AS LONG, jj AS LONG, kk AS LONG, rc AS LONG
rc = DATACOUNT
REDIM dArray(rc - 1) AS STRING 'zero based, so -1
REDIM aStart(26), aCount(26) 'for index
FOR ii = 1 TO rc 'read the data into the array
dArray(ii - 1) = UCASE$(READ$(ii))
NEXT
ARRAY SORT dArray()
jj = 64 'Index on first character, $%&# = 0, A = 1, etc..
FOR ii = 0 TO UBOUND(dArray)
kk = ASC(dArray(ii))
IF kk > jj THEN 'A - Z
aCount(jj - 64) = MAX&(0, ii - 1) 'indexed end
jj = kk
aStart(kk - 64) = ii
END IF
NEXT
aCount(jj - 64) = MAX&(0, ii - 1)
FOR ii = 0 TO 26 're-calculate count
IF aCount(ii) THEN aCount(ii) = MAX&(0, aCount(ii) - aStart(ii) + 1)
NEXT
FUNCTION = rc 'Return the count, in case we ever should need it..
'HTML syntax color data
DATA A, ABBR, ACCESSKEY, ACRONYM, ACTION, ADDRESS, ALIGN, ALINK, ALT, APPLET, ARCHIVE, AREA, AU, AXIS
DATA B, BACKGROUND, BANNER, BASE, BASEFONT, BGCOLOR, BGSOUND, BIG, BLINK, BLOCKQUOTE
DATA BODY, BORDER, BORDERCOLORLIGHT, BOTTOM, BQ, BR, BUTTON
DATA CAPTION, CDATA, CELLPADDING, CELLSPACING, CENTER, CHAR, CHAROFF, CHARSET, CHECKED, CITE, CLASS, CLASSID
DATA CLEAR, CODE, CODEBASE, CODETYPE, COL, COLGROUP, COLOR, COLS, COLSPAN, COMMENT, CONTENT, COORDS
DATA DAT, DATA, DATETIME, DECLARE, DD, DEFER, DFN, DEL, DIR, DISABLED, DISABLES, DIV, DL, DOCTYPE, DT
DATA EM, EMBED, FACE, FIG, FIELDSET, FN, FONT, FORM, FRAME, FRAMEBORDER, FRAMESET
DATA H1, H2, H3, H4, H5, H6, HEAD, HEADERS, HEIGHT, HIGH, HR, HREF, HREFLANG, HSPACE, HTML, HTTP-EQUIV
DATA I, ID, IFRAME, IMG, INPUT, INS, ISMAP, JUSTIFY, KBD
DATA LABEL, LANG, LANGUAGE, LEGEND, LEFT, LEFTMARGIN, LI, LINK, LISTING, LONGDESC, LOOP, LOW
DATA MAP, MARGINHEIGHT, MARGINLEFT, MARGINRIGHT, MARGINWIDTH, MARQUEE, MAXLENGTH, MEDIA, MENU, META
DATA METHOD, MIDDLE, MULTICOL
DATA NAME, NEXTID, NOBR, NOFRAMES, NORESIZE, NOSAVE, NOSCRIPT, NOSHADE, NOTE, NOWRAP
DATA OBJECT, OL, ONBLUR, ONCHANGE, ONFOCUS, ONLOAD, ONMOUSEOUT, ONMOUSEOVER, ONMOUSEUP, ONSELECT
DATA ONUNLOAD, OPTGROUP, OPTION, OVERLAY
DATA P, PARAM, PERSON, PLAINTEXT, PLUGINSPAGE, PRE, PROFILE, PUBLIC
DATA Q, QUALITY, RANGE, READONLY, RECT, REF, REL, RESET, REV, RIGHT, RIGHTMARGIN, ROW, ROWS, ROWSPAN
DATA S, SAMP, SCHEME, SCOPE, SCRIPT, SCRIPTA, SCROLLING, SELECT, SELECTED, SHAPE, SIZE, SMALL, SOUND
DATA SPACER, SPAN, SRC, STANDBY, STRIKE, STRONG, STYLE, SUB, SUBMIT, SUMMARY, SUP
DATA TAB, TABINDEX, TABLE, TARGET, TBODY, TD, TEXT, TEXTAREA, TFOOT, TH, THEAD, TITLE, TOP, TOPMARGIN
DATA TR, TT, TYPE, U, UL, URL, USEMAP, VALIGN, VALUE, VALUETYPE, VAR, VLINK, VSPACE, WBR, WIDTH, WRAP, XMP
END FUNCTION
'������������������������������������������������������������������������������
' Redim and load given array with Resource file keywords
'------------------------------------------------------------------------------
FUNCTION LoadRCdata(dArray() AS STRING) AS LONG
LOCAL ii AS LONG, jj AS LONG, kk AS LONG, rc AS LONG
rc = DATACOUNT
REDIM dArray(rc - 1) AS STRING 'zero based, so -1
REDIM aStart(26), aCount(26) 'for index
FOR ii = 1 TO rc 'read the data into the array
dArray(ii - 1) = UCASE$(READ$(ii))
NEXT
ARRAY SORT dArray()
jj = 64 'Index on first character, $%&# = 0, A = 1, etc..
FOR ii = 0 TO UBOUND(dArray)
kk = ASC(dArray(ii))
IF kk > jj THEN 'A - Z
aCount(jj - 64) = MAX&(0, ii - 1) 'indexed end
jj = kk
aStart(kk - 64) = ii
END IF
NEXT
aCount(jj - 64) = MAX&(0, ii - 1)
FOR ii = 0 TO 26 're-calculate count
IF aCount(ii) THEN aCount(ii) = MAX&(0, aCount(ii) - aStart(ii) + 1)
NEXT
FUNCTION = rc 'Return the count, in case we ever should need it..
'RC syntax color data, extracted from RCDLL.DLL, the RC help file and other sources.. :-)
'Note, first line, definition words, must be lower case in RC file. Is upper case
'here for search resons, but will *not* be automatically changed in text, since RC.EXE
'is case sensitive.
DATA #INCLUDE, #DEFINE, #ELIF, #ELSE, #ENDIF, #IF, #IFDEF, #IFNDEF, #INCLUDE, #PRAGMA, #UNDEF
DATA ACCELERATOR, ACCELERATORS, ALT, ANICURSOR, ANIICON, ASCII, AUTO3STATE
DATA AUTOCHECKBOX, AUTORADIOBUTTON, AVI, BEDIT, BEGIN, BITMAP, BLOCK, BUTTON
DATA CAPTION, CHARACTERISTICS, CHECKBOX, CHECKED, CLASS, COMBOBOX, CONTROL, CTEXT, CURSOR
DATA DEFPUSHBUTTON, DIALOG, DIALOGEX, DISCARDABLE, DLGINCLUDE, DLGINIT, EDIT, EDITTEXT, END, EXSTYLE
DATA FILEFLAGS, FILEFLAGSMASK, FILEOS, FILESUBTYPE, FILETYPE, FILEVERSION, FIXED, FONT, FONTDIR
DATA GRAYED, GROUP_CURSOR, GROUP_ICON, GROUPBOX, HELP, ICON, IEDIT, IMPURE, INACTIVE
DATA LANGUAGE, LISTBOX, LOADONCALL, LTEXT, MAINMENU, MENU, MENUBARBREAK, MENUBREAK, MENUEX
DATA MENUITEM, MESSAGETABLE, MOVEABLE, NOINVERT, NONSHARED, NOT, OBJECTS, OWNERDRAW
DATA PLUGPLAY, POPUP, PRELOAD, PRODUCTVERSION, PURE, PUSHBOX, PUSHBUTTON, RADIOBUTTON, RCDATA, RTEXT
DATA SCROLLBAR, SEPARATOR, SHARED, SHIFT, STATE3, STATIC, STRING, STRINGTABLE, STYLE, SOUND
DATA USERBUTTON, VALUE, VERSION, VERSIONINFO, VIRTKEY, VS_VERSION_INFO, WAVE, VXD
END FUNCTION
'������������������������������������������������������������������������������
' Parser builds syntax colored RTF from PB code files. Here we use pointers and
' pre-allocated output string for good speed. Should be fast enough for most needs.
'------------------------------------------------------------------------------
SUB SyntaxColorBAS
LOCAL ii AS LONG, Ac AS LONG, stopPos AS LONG, Result AS LONG
LOCAL wFlag AS LONG, remFlag AS LONG, dqFlag AS LONG
LOCAL pLet AS BYTE PTR, pLet2 AS BYTE PTR
LOCAL tmpWord AS STRING, outBuf AS STRING, uCaseBuf AS STRING
LOCAL rtfPrefix AS STRING, rtfPostfix AS STRING, endBlock AS STRING, endBlue AS STRING
LOCAL greenStr AS STRING, blueStr AS STRING, redStr AS STRING, PBFstr AS STRING
DIM cData() AS STRING
LoadPBdata cData() 'load PB keywords into array
rtfPrefix = "{\rtf1\ansi \deff0{\fonttbl{\f0\fmodern Courier New;}}" + _ 'RTF header
"{\colortbl;\red0\green128\blue0;" + _ 'cf1, green
"\red255\green255\blue255;" + _ 'cf2, white
"\red0\green0\blue255;" + _ 'cf3, blue
"\red0\green0\blue0;" + _ 'cf4, black
"\red255\green0\blue0;" + _ 'cf5, red
"\red192\green100\blue0;}" + _ 'cf6, brown (#PBForms)
"\deftab1134\margl0\margt0\margr0\margb0\plain\f0\fs18 "
rtfPostfix = "\n\par }" 'RTF end
endBlock = "\plain\f0\fs18 " 'block end
endBlue = "\plain\f0\fs18b" 'use temporary block end for blue color, to enable size trim
greenStr = "\cf1 " 'green block start (uncommented)
blueStr = "\cf3 " 'blue block start (PB keywords)
redStr = "\cf5 " 'red block start (string literals and asm)
PBFstr = "\cf6 " 'PBForms block start
gTxt = gTxt + " " 'add a space to ensure last word will be checked if nothing follows it
REPLACE "\" WITH "\\" IN gTxt 'RTF needs this to understand backslash
REPLACE "{" WITH "\{" IN gTxt 'RTF needs this to understand {
REPLACE "}" WITH "\}" IN gTxt 'RTF needs this to understand }
OutBuf = STRING$(MAX&(1000, 3 * LEN(gTxt)), 0) 'create enough big output buffer
uCaseBuf = UCASE$(gTxt) 'use uppercase string for compare
pLet = STRPTR(gTxt) 'pointer to global string (input)
pLet2 = STRPTR(OutBuf) 'pointer to output buffer
FOR ii = 1 TO LEN(gTxt)
SELECT CASE @pLet 'the characters we need to inlude in a word
CASE 65 TO 90, 97 TO 122, 35 TO 38, 48 TO 57, 63, 95
IF wFlag = 0 AND remFlag = 0 AND dqFlag = 0 THEN
wFlag = 1 : stopPos = ii
END IF
CASE 34 ' double quote -> "
IF dqFlag = 0 AND remFlag = 0 THEN 'if start of string literal
POKE$ pLet2, redStr 'poke RTF code into output string
pLet2 = pLet2 + 5 'and move pointer forward
dqFlag = 1 : wFlag = 0 'set flags - since now inside DQ, wordflag is off
ELSEIF dqFlag = 1 THEN 'should be end of DQ block
@pLet2 = @pLet 'set value in output string
INCR pLet2 'move one character ahead
POKE$ pLet2, endBlock 'poke RTF end block string into output
pLet2 = pLet2 + 15 'and move pointer forward
dqFlag = 3 'end of DQ - set DQ flag
END IF
CASE 59 ' asm uncomment character -> ;
IF remFlag = 0 AND dqFlag = 2 THEN
POKE$ pLet2, endBlock
pLet2 = pLet2 + 15
POKE$ pLet2, greenStr
pLet2 = pLet2 + 5
remFlag = 1 : wFlag = 0
END IF
CASE 39 ' uncomment character -> '
IF remFlag = 0 AND dqFlag <> 1 THEN
IF dqFlag = 2 THEN
POKE$ pLet2, endBlock
pLet2 = pLet2 + 15
END IF
POKE$ pLet2, greenStr
pLet2 = pLet2 + 5
remFlag = 1 : wFlag = 0
END IF
CASE 33 ' asm character -> !
IF remFlag = 0 AND dqFlag = 0 THEN
POKE$ pLet2, redStr
pLet2 = pLet2 + 5
dqFlag = 2 : wFlag = 0
END IF
CASE ELSE 'word is ready
IF @pLet = 13 THEN 'if CRLF - end of line
IF remFlag OR dqFlag THEN 'if in rem, asm or unfinished string literal (DQ)
POKE$ pLet2, endBlock
pLet2 = pLet2 + 15
remFlag = 0 : wFlag = 0 : dqFlag = 0 'reset all flags
END IF
END IF
IF wFlag = 1 THEN 'if we have a word
tmpWord = MID$(uCaseBuf, stopPos, ii - stopPos) 'Get word
Ac = ASC(tmpWord) 'look at first letter
IF Ac < 91 THEN 'if within English alphabet
Ac = MAX&(0, Ac - 64) 'convert for index array
ARRAY SCAN cData(aStart(Ac)) FOR aCount(Ac), = tmpWord, TO Result 'is it in the array?
END IF
IF Result THEN 'if match was found, it's a PB keyword
pLet2 = pLet2 - LEN(tmpWord) 'set position to start of word
POKE$ pLet2, blueStr 'and poke RTF string for blue color into output string
pLet2 = pLet2 + 5 'move pointer ahead
POKE$ pLet2, tmpWord 'poke the word into output string
pLet2 = pLet2 + LEN(tmpWord) 'move pointer ahead
POKE$ pLet2, endBlue 'and finally poke RTF end block string into output-
pLet2 = pLet2 + 15 'move pointer ahead
Result = 0 'and reset result
ELSE
IF tmpWord = "REM" THEN 'extra for REM keyword
pLet2 = pLet2 - 3 'set position to start of word
POKE$ pLet2, greenStr
pLet2 = pLet2 + 5
POKE$ pLet2, tmpWord
pLet2 = pLet2 + 3
remFlag = 1
ELSEIF tmpWord = "#PBFORMS" THEN 'extra for #PBFORMS statement
pLet2 = pLet2 - 8 'set position to start of word
POKE$ pLet2, PBFstr
pLet2 = pLet2 + 5
POKE$ pLet2, tmpWord
pLet2 = pLet2 + 8
remFlag = 1
ELSEIF tmpWord = "ASM" THEN 'extra for ASM keyword
pLet2 = pLet2 - 3 'set position to start of word
POKE$ pLet2, RedStr
pLet2 = pLet2 + 5
POKE$ pLet2, tmpWord
pLet2 = pLet2 + 3
dqFlag = 2
END IF
END IF
wFlag = 0
END IF
END SELECT
IF dqFlag <> 3 THEN 'if not handled matching double-quote
@pLet2 = @pLet 'copy original character to output
INCR pLet2 'and increase pos in output
ELSE
dqFlag = 0 'else reset DQ flag
END IF
INCR pLet 'move ahead to next character
NEXT ii
gTxt = EXTRACT$(OutBuf, CHR$(32, 0)) 'extract result (and remove the added space)
REPLACE endBlue + " " + blueStr WITH " " IN gTxt 'Trim size: If keywords follows each other,
REPLACE endBlue WITH endBlock IN gTxt 'replace remaining blue endblocks with proper RTF
REPLACE $CRLF WITH "\par " IN gTxt 'RTF likes this kind of line feed better
gTxt = rtfPrefix + gTxt + rtfPostfix 'combine RTF header + result + end string
END SUB
'������������������������������������������������������������������������������
' Parser builds syntax colored RTF from HTML files.
'------------------------------------------------------------------------------
SUB SyntaxColorHTML
LOCAL ii AS LONG, Ac AS LONG, stopPos AS LONG, Result AS LONG
LOCAL wFlag AS LONG, dqFlag AS LONG, IsHtml AS LONG
LOCAL pLet AS BYTE PTR, pLet2 AS BYTE PTR
LOCAL tmpWord AS STRING, outBuf AS STRING, uCaseBuf AS STRING
LOCAL rtfPrefix AS STRING, rtfPostfix AS STRING, endBlock AS STRING, endBlue AS STRING
LOCAL greenStr AS STRING, blueStr AS STRING, redStr AS STRING, PBFstr AS STRING
DIM cData() AS STRING
LoadHTMLdata cData() 'load RC keywords into array
rtfPrefix = "{\rtf1\ansi \deff0{\fonttbl{\f0\fmodern Courier New;}}" + _ 'RTF header
"{\colortbl;\red0\green128\blue0;" + _ 'cf1, green
"\red255\green255\blue255;" + _ 'cf2, white
"\red0\green0\blue255;" + _ 'cf3, blue
"\red0\green0\blue0;" + _ 'cf4, black
"\red255\green0\blue0;" + _ 'cf5, red
"\red192\green100\blue0;}" + _ 'cf6, brown (#PBForms)
"\deftab1134\margl0\margt0\margr0\margb0\plain\f0\fs18 "
rtfPostfix = "\n\par }" 'RTF end
endBlock = "\plain\f0\fs18 " 'block end
endBlue = "\plain\f0\fs18b" 'use temporary block end for blue color, to enable size trim
greenStr = "\cf1 " 'green block start
blueStr = "\cf3 " 'blue block start
redStr = "\cf5 " 'red block start
PBFstr = "\cf6 " 'PBForms block start
REPLACE "<" WITH "<" IN gTxt
gTxt = gTxt + " " 'add a space to ensure last word will be checked if nothing follows it
REPLACE "\" WITH "\\" IN gTxt 'RTF needs this to understand backslash
REPLACE "{" WITH "\{" IN gTxt 'RTF needs this to understand {
REPLACE "}" WITH "\}" IN gTxt 'RTF needs this to understand }
OutBuf = STRING$(MAX&(1000, 3 * LEN(gTxt)), 0) 'create enough big output buffer
uCaseBuf = UCASE$(gTxt) 'use uppercase string for compare
pLet = STRPTR(gTxt) 'pointer to global string (input)
pLet2 = STRPTR(OutBuf) 'pointer to output buffer
FOR ii = 1 TO LEN(gTxt)
SELECT CASE @pLet 'the characters we need to inlude in a word
CASE 60 : IsHtml = 1 '<
CASE 65 TO 90, 97 TO 122, 35 TO 38, 48 TO 57, 63, 95, 45
IF IsHtml AND wFlag = 0 AND dqFlag = 0 THEN
wFlag = 1 : stopPos = ii
END IF
CASE 34 ' double quote -> "
IF dqFlag = 0 THEN 'if start of string literal
POKE$ pLet2, redStr 'poke RTF code into output string
pLet2 = pLet2 + 5 'and move pointer forward
dqFlag = 1 : wFlag = 0 'set flags - since now inside DQ, wordflag is off
ELSEIF dqFlag = 1 THEN 'should be end of DQ block
@pLet2 = @pLet 'set value in output string
INCR pLet2 'move one character ahead
POKE$ pLet2, endBlock 'poke RTF end block string into output
pLet2 = pLet2 + 15 'and move pointer forward
dqFlag = 3 'end of DQ - set DQ flag
END IF
CASE ELSE 'word is ready
IF @pLet = 13 THEN 'if CRLF - end of line
IF dqFlag THEN 'if unfinished string literal (DQ)
POKE$ pLet2, endBlock
pLet2 = pLet2 + 15
wFlag = 0 : dqFlag = 0 'reset all flags
END IF
END IF
IF wFlag = 1 THEN 'if we have a word
tmpWord = MID$(uCaseBuf, stopPos, ii - stopPos) 'Get word
Ac = ASC(tmpWord) 'look at first letter
IF Ac < 91 THEN 'if within English alphabet
Ac = MAX&(0, Ac - 64) 'convert for index array
ARRAY SCAN cData(aStart(Ac)) FOR aCount(Ac), = tmpWord, TO Result 'is it in the array?
END IF
IF Result THEN 'if match was found, it's an RC keyword
'tmpWord = MID$(gTxt, stopPos, ii - stopPos) 'use original word - RC compiler is case sensitive..
pLet2 = pLet2 - LEN(tmpWord) 'set position to start of word
POKE$ pLet2, blueStr 'and poke RTF string for blue color into output string
pLet2 = pLet2 + 5 'move pointer ahead
POKE$ pLet2, tmpWord 'poke the word into output string
pLet2 = pLet2 + LEN(tmpWord) 'move pointer ahead
POKE$ pLet2, endBlue 'and finally poke end block for blue into output
pLet2 = pLet2 + 15 'move pointer ahead
Result = 0 'and reset result
END IF
wFlag = 0
END IF
IF @pLet = 62 THEN IsHtml = 0
END SELECT
IF dqFlag <> 3 THEN 'if not handled matching double-quote
@pLet2 = @pLet 'copy original character to output
INCR pLet2 'and increase pos in output
ELSE
dqFlag = 0 'else reset DQ flag
END IF
INCR pLet 'move ahead to next character
NEXT ii
gTxt = EXTRACT$(OutBuf, CHR$(32, 0)) 'extract result (and remove the added space)
REPLACE endBlue + " " + blueStr WITH " " IN gTxt 'If two PB keywords follows each other,
REPLACE endBlue WITH endBlock IN gTxt 'replace remaining blue endblocks with proper RTF
REPLACE $CRLF WITH "\par " IN gTxt 'RTF likes this kind of line feed better
gTxt = rtfPrefix + gTxt + rtfPostfix 'combine RTF header + result + end string
END SUB
'������������������������������������������������������������������������������
' Parser builds syntax colored RTF from resource files (RC).
'------------------------------------------------------------------------------
SUB SyntaxColorRC
LOCAL ii AS LONG, Ac AS LONG, stopPos AS LONG, Result AS LONG
LOCAL wFlag AS LONG, remFlag AS LONG, dqFlag AS LONG
LOCAL pLet AS BYTE PTR, pLet2 AS BYTE PTR
LOCAL tmpWord AS STRING, outBuf AS STRING, uCaseBuf AS STRING
LOCAL rtfPrefix AS STRING, rtfPostfix AS STRING, endBlock AS STRING, endBlue AS STRING
LOCAL greenStr AS STRING, blueStr AS STRING, redStr AS STRING, PBFstr AS STRING
DIM cData() AS STRING
LoadRCdata cData() 'load RC keywords into array
rtfPrefix = "{\rtf1\ansi \deff0{\fonttbl{\f0\fmodern Courier New;}}" + _ 'RTF header
"{\colortbl;\red0\green128\blue0;" + _ 'cf1, green
"\red255\green255\blue255;" + _ 'cf2, white
"\red0\green0\blue255;" + _ 'cf3, blue
"\red0\green0\blue0;" + _ 'cf4, black
"\red255\green0\blue0;" + _ 'cf5, red
"\red192\green100\blue0;}" + _ 'cf6, brown (#PBForms)
"\deftab1134\margl0\margt0\margr0\margb0\plain\f0\fs18 "
rtfPostfix = "\n\par }" 'RTF end
endBlock = "\plain\f0\fs18 " 'block end
endBlue = "\plain\f0\fs18b" 'use temporary block end for blue color, to enable size trim
greenStr = "\cf1 " 'green block start
blueStr = "\cf3 " 'blue block start
redStr = "\cf5 " 'red block start
PBFstr = "\cf6 " 'PBForms block start
gTxt = gTxt + " " 'add a space to ensure last word will be checked if nothing follows it
REPLACE "\" WITH "\\" IN gTxt 'RTF needs this to understand backslash
REPLACE "{" WITH "\{" IN gTxt 'RTF needs this to understand {
REPLACE "}" WITH "\}" IN gTxt 'RTF needs this to understand }
OutBuf = STRING$(MAX&(1000, 3 * LEN(gTxt)), 0) 'create enough big output buffer
uCaseBuf = UCASE$(gTxt) 'use uppercase string for compare
pLet = STRPTR(gTxt) 'pointer to global string (input)
pLet2 = STRPTR(OutBuf) 'pointer to output buffer
FOR ii = 1 TO LEN(gTxt)
SELECT CASE @pLet 'the characters we need to inlude in a word
CASE 65 TO 90, 97 TO 122, 35 TO 38, 48 TO 57, 63, 95
IF wFlag = 0 AND remFlag = 0 AND dqFlag = 0 THEN
wFlag = 1 : stopPos = ii
END IF
CASE 34 ' double quote -> "
IF dqFlag = 0 AND remFlag = 0 THEN 'if start of string literal
POKE$ pLet2, redStr 'poke RTF code into output string
pLet2 = pLet2 + 5 'and move pointer forward
dqFlag = 1 : wFlag = 0 'set flags - since now inside DQ, wordflag is off
ELSEIF dqFlag = 1 THEN 'should be end of DQ block
@pLet2 = @pLet 'set value in output string
INCR pLet2 'move one character ahead
POKE$ pLet2, endBlock 'poke RTF end block string into output
pLet2 = pLet2 + 15 'and move pointer forward
dqFlag = 3 'end of DQ - set DQ flag
END IF
CASE 47 ' uncomment character -> /
IF remFlag = 0 AND dqFlag <> 1 THEN
IF ii < LEN(gTxt) AND PEEK(pLet + 1) = 47 THEN 'if //
POKE$ pLet2, greenStr
pLet2 = pLet2 + 5
remFlag = 1 : wFlag = 0
END IF
END IF
CASE ELSE 'word is ready
IF @pLet = 13 THEN 'if CRLF - end of line
IF remFlag OR dqFlag THEN 'if in rem or unfinished string literal (DQ)
POKE$ pLet2, endBlock
pLet2 = pLet2 + 15
remFlag = 0 : wFlag = 0 : dqFlag = 0 'reset all flags
END IF
END IF
IF wFlag = 1 THEN 'if we have a word
tmpWord = MID$(uCaseBuf, stopPos, ii - stopPos) 'Get word
Ac = ASC(tmpWord) 'look at first letter
IF Ac < 91 THEN 'if within English alphabet
Ac = MAX&(0, Ac - 64) 'convert for index array
ARRAY SCAN cData(aStart(Ac)) FOR aCount(Ac), = tmpWord, TO Result 'is it in the array?
END IF
IF Result THEN 'if match was found, it's an RC keyword
tmpWord = MID$(gTxt, stopPos, ii - stopPos) 'use original word - RC compiler is case sensitive..
pLet2 = pLet2 - LEN(tmpWord) 'set position to start of word
POKE$ pLet2, blueStr 'and poke RTF string for blue color into output string
pLet2 = pLet2 + 5 'move pointer ahead
POKE$ pLet2, tmpWord 'poke the word into output string
pLet2 = pLet2 + LEN(tmpWord) 'move pointer ahead
POKE$ pLet2, endBlue 'and finally poke end block for blue into output
pLet2 = pLet2 + 15 'move pointer ahead
Result = 0 'and reset result
END IF
wFlag = 0
END IF
END SELECT
IF dqFlag <> 3 THEN 'if not handled matching double-quote
@pLet2 = @pLet 'copy original character to output
INCR pLet2 'and increase pos in output
ELSE
dqFlag = 0 'else reset DQ flag
END IF
INCR pLet 'move ahead to next character
NEXT ii
gTxt = EXTRACT$(OutBuf, CHR$(32, 0)) 'extract result (and remove the added space)
REPLACE endBlue + " " + blueStr WITH " " IN gTxt 'If two PB keywords follows each other,
REPLACE endBlue WITH endBlock IN gTxt 'replace remaining blue endblocks with proper RTF
REPLACE $CRLF WITH "\par " IN gTxt 'RTF likes this kind of line feed better
gTxt = rtfPrefix + gTxt + rtfPostfix 'combine RTF header + result + end string
END SUB
'gbs_01062
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm