RichEdit syntax coloring
RichEdit syntax coloring
Is there any code written in FB which can show us simple syntax coloring with richedit control ??
thanks..
thanks..
Re: RichEdit syntax coloring
Extracted from fbdebugger this function is used to color sourcecode. Not sure it's enough simple...
h : handle of the richedit control
s : what is to be colored
c : color
d : some effects
h : handle of the richedit control
s : what is to be colored
c : color
d : some effects
Code: Select all
private function fb_setcolor(h As HWND,s As Integer,c As Integer,d As Integer) As Integer
'''#define WM_USER &h0400
'''#define EM_SETCHARFORMAT 1092 'wm_user+68
''#define CFM_COLOR &h40000000
''#define SCF_SELECTION 1
''#define SCF_WORD 2
''#define SCF_DEFAULT 0
''#define SCF_ALL 4
''#define CFE_AUTOCOLOR 1073741824
Dim lpcharformat As CHARFORMAT,selt As Integer
Select Case s
Case 0
selt=0 'set to the default format
Case 1
selt=SCF_ALL 'Applies the formatting to all text in the control.
Case 2
selt=SCF_SELECTION 'Applies the formatting to the current selection.
Case 3
selt=SCF_WORD Or SCF_SELECTION 'Applies the formatting to the selected word or words.
End Select
lpcharformat.cbsize=Len(charformat)
lpcharformat.crtextcolor=c
lpcharformat.dwmask= CFM_UNDERLINE Or CFM_BOLD Or CFM_COLOR Or CFM_ITALIC
If d=1 Then
lpcharformat.dweffects=CFE_AUTOCOLOR
ElseIf d=2 Then
lpcharformat.dweffects=CFE_UNDERLINE Or CFE_BOLD 'Or STRIKEOUT'
ElseIf d=3 Then
' lpcharformat.dweffects=CFE_ITALIC
End If
If sendmessage(h,EM_SETCHARFORMAT,selt,Cast(LPARAM,@lpcharformat))=0 Then
fb_message("ERROR","Set color format")
Return FALSE
Else
Return TRUE
End If
End Function
Re: RichEdit syntax coloring
What to say ..thank you very much on that!
Ok this is for all words but how colorize specific word or few words?
Ok this is for all words but how colorize specific word or few words?
Re: RichEdit syntax coloring
Hi Aurel,
What SARG posted is permanent colouring, i.e. changing the file content - that is how RichMasm works (which has, btw, a plug-in for compiling FB sources).
In case you look for "instant" colouring, google for iczelion syntax highlighting
What SARG posted is permanent colouring, i.e. changing the file content - that is how RichMasm works (which has, btw, a plug-in for compiling FB sources).
In case you look for "instant" colouring, google for iczelion syntax highlighting
Re: RichEdit syntax coloring
You have to select the word or any part of the text and then play with parameter 's' SCF_WORD Or SCF_SELECTION.aurelVZAB wrote:What to say ..thank you very much on that!
Ok this is for all words but how colorize specific word or few words?
What do you mean ?jj2007 wrote:*permanent colouring, i.e. changing the file content
Re: RichEdit syntax coloring
Hi jj
yes i need both from loading file and instant using EN_CHANGE event
by the way i found one but is in PureBasic ...you may look into that forum...
it work fine even i am not ssure that i understand how complete code work due to
little bit crazy syntax of purebasic but all SendMessage apis are same ...
yes i need both from loading file and instant using EN_CHANGE event
by the way i found one but is in PureBasic ...you may look into that forum...
it work fine even i am not ssure that i understand how complete code work due to
little bit crazy syntax of purebasic but all SendMessage apis are same ...
Re: RichEdit syntax coloring
Your code uses the permanent formatting functions of the RichEdit control; Iczelion's version changes the way it is drawn, based on syntax rules.SARG wrote:What do you mean ?jj2007 wrote:*permanent colouring, i.e. changing the file content
For your inspiration: TinyIDE for FreeBasic (permanent formatting that gets saved with the file; scroll down to see the BATCH$)
-
- Posts: 8586
- Joined: May 28, 2005 3:28
- Contact:
Re: RichEdit syntax coloring
setting the font and color for a text range is simple:
The hardest part is to find out what are comments, numbers, preprocessor, keywords, strings etc.
and is currently a single or multiline comment active is an string parsing active ...Don't worry about the slow loading the complete file are colourized !
Normally you colourize onyl the visible part of the RichEdit control or if you edit a single line !
Joshy
You MUST save this file as "ide.bas" it will syntax highlighting it self :-)
Code: Select all
if Preproc.Find(Key) then
SetCharFormat(hCtrl,@cfPreproc)
elseif Datatype.Find(Key) then
SetCharFormat(hCtrl,@cfDatatype)
elseif Language.Find(Key) then
SetCharFormat(hCtrl,@cfLanguage)
elseif Runtime.Find(Key) then
SetCharFormat(hCtrl,@cfRuntime)
elseif Assembler.Find(Key) then
SetCharFormat(hCtrl,@cfAssembler)
else
' unknow ident
SetCharFormat(hCtrl,@cfDefault)
end if
and is currently a single or multiline comment active is an string parsing active ...
Code: Select all
' colorize a buffer
sub SYNTAX_T.ColorizeBuffer(hCtrl as HWND, _
pBuf as ubyte ptr, _
iChars as integer, _
iOffset as integer)
static as integer MComment=0
dim as integer InString,InHex,InNumber,InIdent,SComment
dim as integer iStart,iEnd,i
dim as single p1
dim as integer op
dim as HWND hWin
if iChars>4096 then
hWin = GetParent(hCtrl)
p1=iChars/10
end if
while (pBuf[i]<>0)
' is multi line comment are active ?
if (MComment=0) then
MComment = ((pBuf[i]=asc("/")) AndAlso (pBuf[i+1]=asc("'")))
end if
' start of single line comment
if (SComment=0) AndAlso (MComment=0) AndAlso (InString=0) then SComment = (pBuf[i]=asc("'"))
' any comment active ?
if (MComment<>0) or (SComment<>0) then
SendMessage(hCtrl,EM_SETSEL,iOffset+i,iOffset+i+1)
SetCharformat(hCtrl,@cfComment)
if (MComment<>0) then
' end of multi line comment
if ((pBuf[i]=asc("/")) andalso (pBuf[i-1]=asc("'"))) then
MComment=0:SComment=0
end if
end if
' end of single line comment ?
if (SComment<>0) AndAlso (pBuf[i]=13) then SComment=0
else
' "
if (InString=0) AndAlso (pBuf[i]=34) then
InString=1:iStart=i:iEnd=i
end if
if InString then
' end of string
if (i>iStart) andalso (pBuf[i]=34) then
InString=0
SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
SetCharformat(hCtrl,@cfString)
else
iEnd+=1
end if
else
' no multi or single line comment and no string
if (InNumber=0) AndAlso (InHex=0) AndAlso (InIdent=0) then
' must not be preproc e.g. print #1,...
if (pBuf[i]=asc("#")) AndAlso (IsNumber(pBuf[i+1])=0) AndAlso (IsDelimiter(pBuf[i+1])=0) then
InIdent=1:iStart=i:iEnd=i
elseif (chr(pBuf[i])="&") AndAlso (lcase(chr(pBuf[i+1]))="h") then
InHex=i+2:iStart=i:iEnd=i+1
elseif IsNumber(pBuf[i]) then
InNumber=1:iStart=i:iEnd=i
else
InIdent = (IsDelimiter(pBuf[i])=0)
if InIdent then iStart=i:iEnd=i
end if
end if
if InHex then
' end of hex ?
if (i>iStart) then InHex=IsHex(pBuf[i+1])
if (InHex=0) then
SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
SetCharformat(hCtrl,@cfNumber)
else
iEnd+=1
endif
elseif InNumber then
' end of number ?
InNumber=IsNumber(pBuf[i+1])
if InNumber=0 then
SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
SetCharformat(hCtrl,@cfNumber)
else
iEnd+=1
endif
elseif (InIdent<>0) then
' end of ident ?
if IsDelimiter(pBuf[i+1]) then
dim as string Ident
SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
for p as integer = iStart to iEnd
Ident &= lcase(chr(pBuf[p]))
next
if Ident<>"rem" then
' what is it ?
dim as uinteger Key=crc32(strptr(Ident),len(Ident))
if Preproc.Find(Key) then
SetCharFormat(hCtrl,@cfPreproc)
elseif Datatype.Find(Key) then
SetCharFormat(hCtrl,@cfDatatype)
elseif Language.Find(Key) then
SetCharFormat(hCtrl,@cfLanguage)
elseif Runtime.Find(Key) then
SetCharFormat(hCtrl,@cfRuntime)
elseif Assembler.Find(Key) then
SetCharFormat(hCtrl,@cfAssembler)
else
' unknow ident
SetCharFormat(hCtrl,@cfDefault)
end if
InIdent = 0
else
' 'rem' single line comment
SComment = 1
InIdent = 0
i-=3
end if
else
iEnd+=1
end if
else
' must be an delimiter
SendMessage(hCtrl,EM_SETSEL,iOffset+i,iOffset+i+1)
SetCharFormat(hCtrl,@cfDelimiter)
end if
end if
end if
i+=1
' large file parsing active ?
if (hWin<>NULL) then
dim as integer p = int(i/p1)
if p<>op then
dim as string msg = "File parsing " & string(p,"|")
SendMessage(hWin,WM_SETTEXT,0,cast(LPARAM,strptr(msg)))
op=p
end if
end if
wend
' file pasrsing active
if (hWin<>NULL) then
dim as string msg = "Syntax colorize with CRC32()"
SendMessage(hWin,WM_SETTEXT,0,cast(LPARAM,strptr(msg)))
end if
end sub
Normally you colourize onyl the visible part of the RichEdit control or if you edit a single line !
Joshy
You MUST save this file as "ide.bas" it will syntax highlighting it self :-)
Code: Select all
#define WIN_INCLUDEALL
#include "windows.bi"
#include "win/commctrl.bi"
#include "win/richedit.bi"
' missing in "richedit.bi" usefull for CHARFORMAT2
#ifndef CFM_WEIGHT
#define CFM_WEIGHT &H00400000
#endif
'#define DEBUG ' !!!
#ifdef DEBUG
#define DPRINT(msg) OPEN CONS FOR OUTPUT AS #99: PRINT #99,msg:CLOSE #99 :
#define WPRINT(msg) DPRINT("warning: " & msg)
#define EPRINT(msg) OPEN ERR FOR OUTPUT AS #99: PRINT #99,"error: " & msg:CLOSE #99 :beep:sleep:end 1 :
#else
#define DPRINT(msg) :
#define WPRINT(msg) :
#define EPRINT(msg) :
#endif
#define RGB24(r,g,b) (b shl 16) or (g shl 8) or (r)
#define CLR_PLAIN RGB24( 32, 32, 32)
#define CLR_PAPER RGB24(255,255,255)
#define CLR_STRING RGB24(192, 0, 0)
#define CLR_COMMENT RGB24( 32,128, 32)
#define CLR_PREPROC RGB24(192,128, 32)
#define CLR_NUMBER RGB24( 0,168,168)
#define CLR_LANGUAGE RGB24( 32, 32,196)
#define CLR_DATATYPE RGB24( 0, 0,216)
#define CLR_RUNTIME RGB24( 0, 0,196)
#define CLR_ASSEMBLER RGB24(128, 0,128)
#define CLR_DELIMITER RGB24(128,128,128)
rem single line comment
' single line comment
/'
multiline
line
comment
'/
type KEYWORDTABLE_T
declare constructor
declare destructor
declare sub Add(Key as ulong)
declare function Find(Key as ulong) as boolean
private:
as ulong ptr Keys
end type
constructor KEYWORDTABLE_T
dprint("KEYWORDTABLE_T()")
Keys = callocate(sizeof(ulong))
end constructor
destructor KEYWORDTABLE_T
if (Keys<>NULL) then deallocate Keys
dprint("KEYWORDTABLE_T~")
end destructor
sub KEYWORDTABLE_T.Add(Key as ulong)
' don't add it again
if find(Key) then return
Keys[0]+=1
Keys = reallocate(Keys,(Keys[0]+1)*sizeof(ulong))
Keys[Keys[0]]=Key
end sub
function KEYWORDTABLE_T.Find(Key as ulong) as boolean
if Keys[0]<1 then return false
for i as integer=1 to Keys[0]
if Keys[i]=Key then return true
next
return false
end function
type SYNTAX_T
declare constructor
declare destructor
declare sub Colorize(hCtrl as HWND,iStart as integer, iEnd as integer)
private:
declare function CRC32(pBuffer as any Ptr, _
nBufferSize as integer) as ulong
declare sub AddKeywords(table as KEYWORDTABLE_T, _
KeyWords() as string)
declare sub InitKeywords
declare sub AddPreproc
declare sub AddDatatype
declare sub AddLanguage
declare sub AddRuntime
declare sub AddAssembler
declare sub ColorizeBuffer(hCtrl as HWND, _
pBuf as ubyte ptr, _
nChars as integer, _
nOffset as integer)
declare function IsWhite (char as ubyte) as boolean
declare function IsNumber (char as ubyte) as boolean
declare function IsHex (char as ubyte) as boolean
declare function IsDelimiter(char as ubyte) as boolean
declare function IsOperator (char as ubyte) as boolean
declare sub SetCharFormat(hCtrl as HWND, _
pcf as CHARFORMAT ptr)
const as integer S_FLAG = SCF_SELECTION
as CHARFORMAT cfDefault
as CHARFORMAT cfComment
as CHARFORMAT cfString
as CHARFORMAT cfNumber
as CHARFORMAT cfDelimiter
as CHARFORMAT cfPreproc
as CHARFORMAT cfDatatype
as CHARFORMAT cfLanguage
as CHARFORMAT cfRuntime
as CHARFORMAT cfAssembler
as KEYWORDTABLE_T Preproc
as KEYWORDTABLE_T Datatype
as KEYWORDTABLE_T Language
as KEYWORDTABLE_T Runtime
as KEYWORDTABLE_T Assembler
end type
dim shared as SYNTAX_T ptr Syntax
constructor SYNTAX_T
dprint("SYNTAX_T()")
with cfDefault
.cbSize = sizeof(CHARFORMAT)
.dwMask = CFM_CHARSET or _
CFM_FACE or _
CFM_SIZE or _
CFM_OFFSET or _
CFM_COLOR
.dwEffects = 0
.yHeight = 12 * 20 ' pts * 20 twips/point = n twips
.bCharSet = ANSI_CHARSET
.bPitchAndFamily = FIXED_PITCH or FF_MODERN
.yOffset = 0
.szFaceName = "Courier New"
end with
cfComment = cfDefault
cfString = cfDefault
cfNumber = cfDefault
cfDelimiter = cfDefault
cfPreproc = cfDefault
cfDatatype = cfDefault
cfLanguage = cfDefault
cfRuntime = cfDefault
cfAssembler = cfDefault
cfDefault.crTextColor = CLR_PLAIN
cfComment.crTextColor = CLR_COMMENT
cfString.crTextColor = CLR_STRING
cfNumber.crTextColor = CLR_NUMBER
cfDelimiter.crTextColor = CLR_DELIMITER
cfPreproc.crTextColor = CLR_PREPROC
cfDatatype.crTextColor = CLR_DATATYPE
cfLanguage.crTextColor = CLR_LANGUAGE
cfRuntime.crTextColor = CLR_RUNTIME
cfAssembler.crTextColor = CLR_ASSEMBLER
InitKeywords()
end constructor
destructor SYNTAX_T
dprint("SYNTAX_T~")
end destructor
' create a unic 32 bit id from any buffer or string
function SYNTAX_T.CRC32(byval pBuffer As any Ptr, _
byval nBufferSize As Integer) As ULong
Static Table(255) As ULong => { _
&H00000000, &H77073096, &HEE0E612C, &H990951BA, _
&H076DC419, &H706AF48F, &HE963A535, &H9E6495A3, _
&H0EDB8832, &H79DCB8A4, &HE0D5E91E, &H97D2D988, _
&H09B64C2B, &H7EB17CBD, &HE7B82D07, &H90BF1D91, _
&H1DB71064, &H6AB020F2, &HF3B97148, &H84BE41DE, _
&H1ADAD47D, &H6DDDE4EB, &HF4D4B551, &H83D385C7, _
&H136C9856, &H646BA8C0, &HFD62F97A, &H8A65C9EC, _
&H14015C4F, &H63066CD9, &HFA0F3D63, &H8D080DF5, _
&H3B6E20C8, &H4C69105E, &HD56041E4, &HA2677172, _
&H3C03E4D1, &H4B04D447, &HD20D85FD, &HA50AB56B, _
&H35B5A8FA, &H42B2986C, &HDBBBC9D6, &HACBCF940, _
&H32D86CE3, &H45DF5C75, &HDCD60DCF, &HABD13D59, _
&H26D930AC, &H51DE003A, &HC8D75180, &HBFD06116, _
&H21B4F4B5, &H56B3C423, &HCFBA9599, &HB8BDA50F, _
&H2802B89E, &H5F058808, &HC60CD9B2, &HB10BE924, _
&H2F6F7C87, &H58684C11, &HC1611DAB, &HB6662D3D, _
&H76DC4190, &H01DB7106, &H98D220BC, &HEFD5102A, _
&H71B18589, &H06B6B51F, &H9FBFE4A5, &HE8B8D433, _
&H7807C9A2, &H0F00F934, &H9609A88E, &HE10E9818, _
&H7F6A0DBB, &H086D3D2D, &H91646C97, &HE6635C01, _
&H6B6B51F4, &H1C6C6162, &H856530D8, &HF262004E, _
&H6C0695ED, &H1B01A57B, &H8208F4C1, &HF50FC457, _
&H65B0D9C6, &H12B7E950, &H8BBEB8EA, &HFCB9887C, _
&H62DD1DDF, &H15DA2D49, &H8CD37CF3, &HFBD44C65, _
&H4DB26158, &H3AB551CE, &HA3BC0074, &HD4BB30E2, _
&H4ADFA541, &H3DD895D7, &HA4D1C46D, &HD3D6F4FB, _
&H4369E96A, &H346ED9FC, &HAD678846, &HDA60B8D0, _
&H44042D73, &H33031DE5, &HAA0A4C5F, &HDD0D7CC9, _
&H5005713C, &H270241AA, &HBE0B1010, &HC90C2086, _
&H5768B525, &H206F85B3, &HB966D409, &HCE61E49F, _
&H5EDEF90E, &H29D9C998, &HB0D09822, &HC7D7A8B4, _
&H59B33D17, &H2EB40D81, &HB7BD5C3B, &HC0BA6CAD, _
&HEDB88320, &H9ABFB3B6, &H03B6E20C, &H74B1D29A, _
&HEAD54739, &H9DD277AF, &H04DB2615, &H73DC1683, _
&HE3630B12, &H94643B84, &H0D6D6A3E, &H7A6A5AA8, _
&HE40ECF0B, &H9309FF9D, &H0A00AE27, &H7D079EB1, _
&HF00F9344, &H8708A3D2, &H1E01F268, &H6906C2FE, _
&HF762575D, &H806567CB, &H196C3671, &H6E6B06E7, _
&HFED41B76, &H89D32BE0, &H10DA7A5A, &H67DD4ACC, _
&HF9B9DF6F, &H8EBEEFF9, &H17B7BE43, &H60B08ED5, _
&HD6D6A3E8, &HA1D1937E, &H38D8C2C4, &H4FDFF252, _
&HD1BB67F1, &HA6BC5767, &H3FB506DD, &H48B2364B, _
&HD80D2BDA, &HAF0A1B4C, &H36034AF6, &H41047A60, _
&HDF60EFC3, &HA867DF55, &H316E8EEF, &H4669BE79, _
&HCB61B38C, &HBC66831A, &H256FD2A0, &H5268E236, _
&HCC0C7795, &HBB0B4703, &H220216B9, &H5505262F, _
&HC5BA3BBE, &HB2BD0B28, &H2BB45A92, &H5CB36A04, _
&HC2D7FFA7, &HB5D0CF31, &H2CD99E8B, &H5BDEAE1D, _
&H9B64C2B0, &HEC63F226, &H756AA39C, &H026D930A, _
&H9C0906A9, &HEB0E363F, &H72076785, &H05005713, _
&H95BF4A82, &HE2B87A14, &H7BB12BAE, &H0CB61B38, _
&H92D28E9B, &HE5D5BE0D, &H7CDCEFB7, &H0BDBDF21, _
&H86D3D2D4, &HF1D4E242, &H68DDB3F8, &H1FDA836E, _
&H81BE16CD, &HF6B9265B, &H6FB077E1, &H18B74777, _
&H88085AE6, &HFF0F6A70, &H66063BCA, &H11010B5C, _
&H8F659EFF, &HF862AE69, &H616BFFD3, &H166CCF45, _
&HA00AE278, &HD70DD2EE, &H4E048354, &H3903B3C2, _
&HA7672661, &HD06016F7, &H4969474D, &H3E6E77DB, _
&HAED16A4A, &HD9D65ADC, &H40DF0B66, &H37D83BF0, _
&HA9BCAE53, &HDEBB9EC5, &H47B2CF7F, &H30B5FFE9, _
&HBDBDF21C, &HCABAC28A, &H53B39330, &H24B4A3A6, _
&HBAD03605, &HCDD70693, &H54DE5729, &H23D967BF, _
&HB3667A2E, &HC4614AB8, &H5D681B02, &H2A6F2B94, _
&HB40BBE37, &HC30C8EA1, &H5A05DF1B, &H2D02EF8D }
if (pBuffer=0) orelse (nBufferSize<1) then return 0
dim as ubyte ptr p = pBuffer
dim as ubyte ptr e = p + nBufferSize
dim as ulong crc = &HFFFFFFFF
while (p<e)
crc = Table((crc xor *p) and &HFF) xor (crc shr 8)
p+=1
wend
return crc xor &HFFFFFFFF
if 0 then ' not used it's only to colorize inline assembler
dim as ulong ptr t=@Table(0)
asm
mov edi,[pBuffer]
mov esi,[t]
mov ecx,[nBufferSize]
mov eax,&HFFFFFFFF
mov edx,&HFF
push ebp
mov ebp,edx
xor edx,edx
loop_it:
mov dl,[edi]
mov ebx,eax
xor eax,edx
and eax,ebp
shr ebx,8
mov eax,[esi+eax*4]
inc edi
xor eax,ebx
dec ecx
jnz loop_it
pop ebp
xor eax,&HFFFFFFFF
mov [function],eax
end asm
end if
end function
' add some groups of keywords
sub SYNTAX_T.InitKeywords
AddPreproc()
AddDatatype()
AddLanguage()
AddRuntime()
AddAssembler()
end sub
' create a crc32 ulong table from array with keywords
sub SYNTAX_T.AddKeywords(table as KEYWORDTABLE_T,KeyWords() as string)
dim as integer nKeys = ubound(KeyWords)+1
for i as integer = 0 to nKeys-1
dim as integer nChars = len(KeyWords(i))
if nChars>0 then table.Add(crc32(strptr(KeyWords(i)),nChars))
next
end sub
' can be replaced with keyword file loading
sub SYNTAX_T.AddPreproc
dim as string keywords(...) = { _
"#define","defined", _
"#else","#elseif","#endif","#endmacro","#error", _
"#if","#ifdef","#ifndef","#include","#inclib", _
"#lang","#libpath","#line", _
"#macro", _
"#pragma","#print", _
"#undef", _
"__fb_debug__", _
"__fb_lang__", _
"__fb_version__", _
"__fb_win32__", _
"__fb_linux__", _
"__fb_dos__" }
AddKeywords(Preproc,KeyWords())
end sub
' can be replaced with keyword file loading
sub SYNTAX_T.AddDatatype
dim as string keywords(...) = { _
"any",_
"byte",_
"double",_
"integer",_
"long","longint",_
"ptr",_
"short","single","string",_
"ubyte","ushort","uinteger",_
"var",_
"wstring",_
"zstring"}
AddKeywords(Datatype,KeyWords())
end sub
' can be replaced with keyword file loading
sub SYNTAX_T.AddLanguage
dim as string keywords(...) = { _
"as","and","andalso","asm", _
"case","cast","cint","cdbl","class","const","constructor","cptr", _
"data","declare","delete","destructor","dim","do", _
"else","end","enum","export", _
"function","for", _
"goto","gosub", _
"if","iif","int", _
"new","not", _
"operator","or", _
"private","public", _
"read","restore","return", _
"select","sizeof","static","sub", _
"then","type", _
"wend","while","with", _
"xor" }
AddKeywords(Language,KeyWords())
end sub
' can be replaced with keyword file loading
sub SYNTAX_T.AddRuntime
dim as string keywords(...) = { _
"abs","access","acos","allocate","alpha","atan2","atn", _
"bin","binary", _
"chr","close","cls","cons","cos","condbroadcast","condcreate","conddestroy","condwait", _
"deallocate","dir", _
"get","getmouse", _
"err","exp", _
"fix","frac", _
"hex", _
"input","int","imagecreate","imagedestroy","imageinfo", _
"lcase","left","len","line","locate","log","lpt", _
"mid","mod","mutexcreate","mutexdestroy","mutexlock","mutexunlock" , _
"oct","open","output", _
"pipe","pmap","pset","print","put", _
"randomize","reallocate","rgb","rgba","right","rnd", _
"scrn","screen","screeninfo","screenres","sin","sgn","sqr","str","strptr", _
"tan","threadcreate","threadwait", _
"ucase", _
"val","varptr","view", _
"wbin","wchr","width","whex","woct","write","wstr", _
"window"}
AddKeywords(Runtime,KeyWords())
end sub
' can be replaced with keyword file loading
sub SYNTAX_T.AddAssembler
dim as string keywords(...) = { _
"ah","al","ax", _
"bh","bl","bx", _
"call","ch","cl","cx", _
"cmova","cmovae","cmovb","cmovbe","cmovc", _
"cmove","cmovg","cmovge","cmovl","cmovle", _
"cmovna","cmovnae","cmovnb","cmovnbe", _
"cmovnc","cmovne","cmovng","cmovnge","cmovnl", _
"cmovnle","cmovno","cmovnp","cmovns","cmovnz", _
"cmovo","cmovp","cmovpe","cmovpo","cmovs","cmovz", _
"dec","dh","dl","dx", _
"eax","ebp","ebx","ecx","edx","edi","esi","esp", _
"inc", _
"ja","jae","jb","jbe","jc","jcxz","je","jecxz", _
"jg","jge","jl","jle","jmp","jna", _
"jnae","jnb","jnbe","jnc","jne","jng","jnge","jnl", _
"jnle","jno","jnp","jns","jnz", _
"jo","jp","jpe","jpo","js","jz", _
"loop","loope","loopne","loopnz","loopz", _
"mm0","mm1","mm2","mm3","mm4","mm5","mm6","mm7", _
"mov", _
"pop","push", _
"seta","setae","setb","setbe","setc","sete", _
"setg","setge","setl","setle","setna","setnae", _
"setnb","setnbe","setnc","setne","setng","setnge", _
"setnl","setnle","setno","setnp","setns","setnz", _
"seto","setp","setpe","setpo","sets","setz", _
"st0","st1","st2","st3","st4","st5","st6","st7", _
"xmm0","xmm1","xmm2","xmm3","xmm4","xmm5","xmm6","xmm7"}
AddKeywords(Assembler,KeyWords())
end sub
' is current char a white char
function SYNTAX_T.IsWhite(c as ubyte) as boolean
return ((c=9) or (c=32) or (c=10) or (c=13))
end function
' is current char a number char
function SYNTAX_T.IsNumber(c as ubyte) as boolean
return ((c>=asc("0")) AndAlso (c<=asc("9")))
end function
' is current char a hex char
function SYNTAX_T.IsHex(c as ubyte) as boolean
if IsNumber(c) then return true
select case lcase(chr(c))
case "a" to "f" : return true
case else : return false
end select
end function
' is current char an operator
function SYNTAX_T.IsOperator(c as ubyte) as boolean
select case chr(c)
case "=","<",">","*","/","\","-","+","&","@":return true
case else : return false
end select
end function
' is the char a delimiter
function SYNTAX_T.IsDelimiter(c as ubyte) as boolean
if IsWhite(c) then return true
if IsOperator(c) then return true
select case chr(c)
case "(",")","[","]",",",".",":":return true
case else : return false
end select
end function
' set font,size,style,color to the curent selection
sub SYNTAX_T.SetCharFormat(hCtrl as HWND,pcf as CHARFORMAT ptr)
SendMessage(hCtrl,EM_SETCHARFORMAT,S_FLAG,cast(LPARAM,pcf))
end sub
' colorize a range of chars
sub SYNTAX_T.Colorize(hCtrl as HWND, iStart as integer, iEnd as integer)
dim as integer nChars
if iStart=iEnd then return
if (iStart = 0) AndAlso (iEnd = -1) then
nChars = SendMessage(hCtrl,WM_GETTEXTLENGTH,0,0)
SendMessage(hCtrl,EM_SETSEL,0,nChars)
else
nChars = iEnd - iStart
SendMessage(hCtrl,EM_SETSEL,iStart,iEnd)
end if
dim as ubyte ptr pBuf = new ubyte[nChars+1]
pBuf[nChars] = 0
dim as integer nRet = SendMessage(hCtrl,EM_GETSELTEXT,0,cast(LPARAM,pBuf))
SetCharFormat(hCtrl,@cfDefault)
ColorizeBuffer(hCtrl,pBuf,nRet,iStart)
delete pBuf
end sub
' colorize a '0' terminated buffer
sub SYNTAX_T.ColorizeBuffer(hCtrl as HWND, _
pBuf as ubyte ptr, _
iChars as integer, _
iOffset as integer)
static as boolean bMultiLineComment=false
dim as boolean bString,bHex,bNumber,bIdent,bSingleLineComment
dim as integer iStart,iEnd,i
dim as single p1
dim as integer op
dim as HWND hWin
if iChars>4096 then
hWin = GetParent(hCtrl)
p1 = iChars/10
end if
while (pBuf[i]<>0)
' is multi line "/'" comment ?
if (bMultiLineComment=false) then
bMultiLineComment = ((pBuf[i]=asc("/")) AndAlso (pBuf[i+1]=asc("'")))
end if
' single "'" line comment ?
if (bSingleLineComment=false) AndAlso (bMultiLineComment=false) AndAlso (bString=false) then
bSingleLineComment = (pBuf[i]=asc("'"))
end if
' any comment active ?
if (bMultiLineComment=true) or (bSingleLineComment=true) then
SendMessage(hCtrl,EM_SETSEL,iOffset+i,iOffset+i+1)
SetCharformat(hCtrl,@cfComment)
if (bMultiLineComment=true) then
' end of multi line "'/" comment ?
if ((pBuf[i]=asc("/")) andalso (pBuf[i-1]=asc("'"))) then
bMultiLineComment=false : bSingleLineComment=false
end if
end if
' end of single line comment ?
if (bSingleLineComment=true) AndAlso (pBuf[i]=13) then
bSingleLineComment=false
end if
else ' if we are here no comment are active
' is it a '"' string ?
if (bString=false) AndAlso (pBuf[i]=34) then
bString=true : iStart=i : iEnd=i ' start of selection range
end if
if (bString=true) then
' end of string
if (i>iStart) andalso (pBuf[i]=34) then
bString=false
SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
SetCharformat(hCtrl,@cfString)
else
iEnd+=1 ' increase selection range
end if
else
' if we are here there are no multi or single line comment and no string active
' no number no hex no ident
if (bNumber=false) AndAlso (bHex=false) AndAlso (bIdent=false) then
' must not be preproc e.g. print #1,... close #hFile
if cbool(pBuf[i]=asc("#")) AndAlso (IsNumber(pBuf[i+1])=false) AndAlso (IsDelimiter(pBuf[i+1])=false) then
bIdent=true : iStart=i : iEnd=i ' start of selection range
' is "&H" hex = ?
elseif (chr(pBuf[i])="&") AndAlso (lcase(chr(pBuf[i+1]))="h") then
bHex=true : iStart=i : iEnd=i + 1 ' start of selection range + "h"
' is number ?
elseif IsNumber(pBuf[i]) then
bNumber=true : iStart=i : iEnd=i ' start of selection range
' is not a delimiter it nust be an ident !
elseif (IsDelimiter(pBuf[i])=false) then
bIdent=true : iStart=i : iEnd=i ' start of selection range
end if
end if
if (bHex=true) then
' end of hex ?
if (i>iStart) then bHex=IsHex(pBuf[i+1])
if (bHex=false) then
SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
SetCharformat(hCtrl,@cfNumber)
else
iEnd+=1 ' increase selection range
endif
elseif (bNumber=true) then
' end of number ?
if (IsNumber(pBuf[i+1])=false) then
bNumber=false
SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
SetCharformat(hCtrl,@cfNumber)
else
iEnd+=1 ' increase selection range
endif
elseif (bIdent=true) then
' end of ident ?
if (IsDelimiter(pBuf[i+1])=true) then
dim as string Ident
SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
for p as integer = iStart to iEnd
Ident &= lcase(chr(pBuf[p]))
next
' not the "old" comment ident
if Ident<>"rem" then
' what is it ?
dim as ulong Key=crc32(strptr(Ident),len(Ident))
if Preproc.Find(Key) then
SetCharFormat(hCtrl,@cfPreproc)
elseif Datatype.Find(Key) then
SetCharFormat(hCtrl,@cfDatatype)
elseif Language.Find(Key) then
SetCharFormat(hCtrl,@cfLanguage)
elseif Runtime.Find(Key) then
SetCharFormat(hCtrl,@cfRuntime)
elseif Assembler.Find(Key) then
SetCharFormat(hCtrl,@cfAssembler)
else
' unknow ident
SetCharFormat(hCtrl,@cfDefault)
end if
bIdent = false
else
' it's 'rem' single line comment
bSingleLineComment = true
bIdent = false
i-=3
end if
else
iEnd+=1 ' increase selection range
end if
else
' must be an delimiter
SendMessage(hCtrl,EM_SETSEL,iOffset+i,iOffset+i+1)
SetCharFormat(hCtrl,@cfDelimiter)
end if
end if
end if
i+=1 ' next char pos in buffer
' large file parsing active ?
if (hWin<>NULL) then
dim as integer p = int(i/p1)
if p<>op then
dim as string msg = "File parsing " & string(p,"|")
SendMessage(hWin,WM_SETTEXT,0,cast(LPARAM,strptr(msg)))
op=p
end if
end if
wend
' file pasrsing active
if (hWin<>NULL) then
dim as string msg = "Syntax colorize with CRC32()"
SendMessage(hWin,WM_SETTEXT,0,cast(LPARAM,strptr(msg)))
end if
end sub
const IDC_RICHEDIT = 1000
enum MENU_IDS
IDM_NEW = 1100
IDM_OPEN
IDM_SAVE
IDM_SAVE_AS
IDM_QUIT
IDM_UNDO
IDM_COPY
IDM_PASTE
IDM_CUT
IDM_SEARCH
IDM_NEXT
IDM_REPLACE
IDM_COMPILE
IDM_RUN
IDM_EXECUTE
IDM_HELP
IDM_ABOUT
end enum
type MENU_T
public:
declare constructor(hParent as HWND)
declare destructor
declare function AddMenu (Title as string,_
flag as integer=0) as HMENU
declare function BeginSubMenu(Title as string,_
flag as integer=0) as HMENU
declare sub EndSubMenu (oldMenu as HMENU)
declare function AddItem (Text as string, _
ID as integer,_
flag as integer=0) as HMENU
declare function AddAccelItem(Text as string, _
ID as integer, _
vMod as integer, _
vKey as integer, _
flag as integer=0) as HMENU
declare function AddAltItem (Text as string, _
ID as integer,_
vKey as integer,_
flag as integer=0) as HMENU
declare function AddCtrlItem (Text as string, _
ID as integer,_
vKey as integer,_
flag as integer=0) as HMENU
declare function AddShiftItem(Text as string,_
ID as integer,_
vKey as integer,_
flag as integer=0) as HMENU
declare function AddKeyItem (Text as string,_
ID as integer,_
vKey as integer,_
flag as integer=0) as HMENU
declare function Separator as HMENU
declare function Finalize (hParent as HWND) as integer
as HACCEL hAccel
private:
declare function VKeyToText(vKey as integer) as string
as HWND hParent
as HMENU hMenuBar
as HMENU curMenu
as integer nAccels
as LPACCEL pAccels
end type
constructor MENU_T(hParent as HWND)
dprint("MENU_T()")
hMenuBar = CreateMenu()
AddMenu "&File"
AddCtrlItem "&New" ,IDM_NEW ,VK_N ,MF_GRAYED
Separator
AddCtrlItem "&Open ..." ,IDM_OPEN ,VK_O ,MF_GRAYED
Separator
AddCtrlItem "&Save" ,IDM_SAVE ,VK_S ,MF_GRAYED
AddItem "Save &as ...",IDM_SAVE_AS ,MF_GRAYED
Separator
AddCtrlItem "&Quit" ,IDM_QUIT ,VK_Q
AddMenu "&Edit"
AddCtrlItem "Undo" ,IDM_UNDO ,VK_Z ,MF_GRAYED
Separator
AddCtrlItem "Copy" ,IDM_COPY ,VK_C ,MF_GRAYED
AddCtrlItem "Paste" ,IDM_PASTE ,VK_V ,MF_GRAYED
Separator
AddCtrlItem "Cut" ,IDM_CUT ,VK_X ,MF_GRAYED
AddMenu "Search"
AddCtrlItem "Find" ,IDM_SEARCH ,VK_F ,MF_GRAYED
AddKeyItem "Find next" ,IDM_NEXT ,VK_F3,MF_GRAYED
AddCtrlItem "Replace" ,IDM_REPLACE,VK_H ,MF_GRAYED
AddMenu "Build"
AddKeyItem "Compile" ,IDM_COMPILE,VK_F5,MF_GRAYED
AddKeyItem "Run" ,IDM_RUN ,VK_F6,MF_GRAYED
AddKeyItem "Build & Run" ,IDM_EXECUTE,VK_F7,MF_GRAYED
AddMenu "Help"
AddKeyItem "Context Help",IDM_HELP ,VK_F1,MF_GRAYED
AddItem "About ..." ,IDM_ABOUT ,MF_GRAYED
Finalize(hParent)
end constructor
destructor MENU_T
if (hAccel <>NULL) then DestroyAcceleratorTable(hAccel)
if (pAccels <>NULL) then deallocate pAccels
if (hMenuBar<>NULL) then DestroyMenu(hMenuBar)
dprint("MENU_T~")
end destructor
function MENU_T.VKeyToText(vKey as integer) as string
select case vKey
' VK_0 ... VK_9
case &H30 to &H39: return chr(vKey)
' VK_A ... VK_Z
case &H41 to &H5A: return chr(vKey)
' VK_F1 ...VK_FVK_F24
case &H70 to &H87: return "F" & trim(str(vKey-&H6F))
end select
end function
function MENU_T.AddMenu(Title as string,_
flag as integer) as HMENU
curMenu = CreatePopupMenu()
AppendMenu(hMenuBar, _
MF_STRING Or MF_POPUP or flag, _
cast(UINT_PTR ,curMenu), Title)
return curMenu
end function
function MENU_T.BeginSubMenu(Title as string,_
flag as integer) as HMENU
function = curMenu
dim as HMENU subMenu = CreatePopupMenu()
AppendMenu(curMenu, _
MF_STRING Or MF_POPUP or flag, _
cast(UINT_PTR ,subMenu), Title)
curMenu = subMenu
end function
sub MENU_T.EndSubMenu(oldMenu as HMENU)
curMenu = oldMenu
end sub
function MENU_T.AddItem(Text as string, _
ID as integer,_
flag as integer) as HMENU
AppendMenu(curMenu,MF_STRING or flag,ID,Text)
return curMenu
end function
function MENU_T.AddAccelItem(Text as string, _
ID as integer, _
vMod as integer, _
vKey as integer,_
flag as integer) as HMENU
select case vMod
case FALT : Text &= !"\tAlt + "
case FCONTROL : Text &= !"\tCtrl + "
case FSHIFT : Text &= !"\tShift + "
case else : Text &= !"\t"
end select
Text &= VKeyToText(vKey)
AppendMenu(curMenu,MF_STRING or flag,ID,Text)
nAccels+=1
pAccels = reallocate(pAccels,sizeof(ACCEL)*nAccels)
pAccels[nAccels-1].fVirt = FNOINVERT or FVIRTKEY or vMod
pAccels[nAccels-1].Key = vKey
pAccels[nAccels-1].Cmd = ID
return curMenu
end function
function MENU_T.AddAltItem(Text as string, _
ID as integer, _
vKey as integer,_
flag as integer) as HMENU
return AddAccelItem(Text,ID,FALT,vKey,flag)
end function
function MENU_T.AddCtrlItem(Text as string, _
ID as integer,_
vKey as integer,_
flag as integer) as HMENU
return AddAccelItem(Text,ID,FCONTROL,vKey, flag)
end function
function MENU_T.AddShiftItem(Text as string, _
ID as integer, _
vKey as integer,_
flag as integer) as HMENU
return AddAccelItem(Text,ID,FSHIFT,vKey,flag)
end function
function MENU_T.AddKeyItem(Text as string, _
ID as integer, _
vKey as integer,_
flag as integer) as HMENU
return AddAccelItem(Text,ID,0,vKey,flag)
end function
function MENU_T.Separator as HMENU
AppendMenu(curMenu,MF_SEPARATOR,0,NULL)
return curMenu
end function
function MENU_T.Finalize(hParent as HWND) as integer
if nAccels>0 then
hAccel = CreateAcceleratorTable(pAccels,nAccels)
end if
function = SetMenu(hParent,hMenuBar)
DrawMenuBar hParent
end function
type FORM_T
declare constructor (sTitle as string = "", _
iLeft as integer = CW_USEDEFAULT, _
iTop as integer = CW_USEDEFAULT, _
iWidth as integer = CW_USEDEFAULT, _
iHeight as integer = CW_USEDEFAULT)
declare destructor
declare static function FormProc(hWnd as HWND , _
uMsg as UINT , _
wParam as WPARAM, _
lParam as LPARAM ) as LRESULT
as HINSTANCE hInstance
as HWND hForm
as string WindowClass
end type
constructor FORM_T(sTitle as string, _
iLeft as integer, _
iTop as integer, _
iWidth as integer, _
iHeight as integer)
static as integer ID = 0
dprint("FORM_T()")
ID+=1
WindowClass = "FORM" & ID
hInstance = GetModuleHandle(NULL)
dim as WNDCLASSEX wcex
with wcex
.cbSize = sizeof(WNDCLASSEX)
.style = CS_VREDRAW or CS_HREDRAW or CS_DBLCLKS
.lpfnWndProc = @FormProc
.cbClsExtra = 0
.cbWndExtra = 0
.hInstance = hInstance
.hIcon = LoadIcon(NULL, IDI_APPLICATION)
.hCursor = LoadCursor(0, IDC_ARROW)
.hbrBackground = cast(HBRUSH,COLOR_BTNFACE + 1)
.lpszMenuName = NULL
.lpszClassName = strptr(WindowClass)
.hIconSm = LoadIcon(NULL, IDI_APPLICATION)
end with
RegisterClassEx(@wcex)
if sTitle="" then sTitle=WindowClass
hForm = CreateWindowEx(WS_EX_CONTROLPARENT or _
WS_EX_WINDOWEDGE or _
WS_EX_LEFT or _
WS_EX_LTRREADING, _
WindowClass, _
sTitle, _
WS_OVERLAPPEDWINDOW or WS_VISIBLE, _
iLeft, iTop, iWidth, iHeight, _
0 , _ ' no parent
NULL, _
hInstance, _
cast(any ptr,@this))
end constructor
destructor FORM_T
dprint("FORM~")
end destructor
function FORM_T.FormProc(hWin as HWND, _
uMsg as UINT, _
wParam as WPARAM, _
lParam as LPARAM ) as LRESULT
static as integer nCreates =0
select case uMsg
case WM_GETMINMAXINFO
' lpmmi = caast(LPMINMAXINFO,lParam)
case WM_NCCREATE
' lpcs = cast(LPCREATESTRUCT,lParam)
case WM_NCCALCSIZE
' fCalcValidRects = wParam
' TRUE lpncsp = cast(LPNCCALCSIZE_PARAMS,lParam)
' FALSE lpncsp = cast(LPRECT,lParam)
case WM_CREATE ' after WM_NCCREATE
#ifndef __FB_64BIT__
SetWindowLong(hWin,GWL_USERDATA,*cptr(integer ptr,lParam) )
#else
SetWindowLongPtr(hWin, GWLP_USERDATA, lParam)
#endif
nCreates+=1
case WM_SHOWWINDOW
' fShow = wParam
' fnStatus = cast(integer,lParam)
case WM_WINDOWPOSCHANGING
' lpwp = cast(LPWINDOWPOS,lParam)
case WM_ACTIVATEAPP
'fActive = wParam
'dwThreadID = cast(DWORD,lParam)
case WM_NCACTIVATE
'fActive = wParam
case WM_GETICON
' fType = wParam
' ICON_BIG or ICON_SMALL
case WM_ACTIVATE
' fActive = LOWORD(wParam)
' fMinimized = HIWORD(wParam)
' hwndPrevious = cast(HWND,lParam)
case WM_SETFOCUS
'hwndLoseFocus = cast(HWND,wParam)
case WM_NCPAINT
'hdc = GetDCEx(hwnd, cast(HRGN,wParam, DCX_WINDOW or DCX_INTERSECTRGN)
' Paint into this DC
'ReleaseDC(hwnd, hdc)
case WM_ERASEBKGND
' hdc = cast(HDC,wParam)
case WM_SIZE
dim as HWND hCtrl = GetDlgItem(hWin,IDC_RICHEDIT)
if (hCtrl<>NULL) then
' fwSizeType = wParam
dim as integer nWidth = LOWORD(lParam)-20
dim as integer nHeight = HIWORD(lParam)-20
MoveWindow(hCtrl,10,10,nWidth,nHeight,1)
end if
case WM_MOVE
' xClientPos = LOWORD(lParam)
' yClientPos = HIWORD(lParam)
case WM_CLOSE
case WM_DESTROY
nCreates-=1
if nCreates<1 then PostQuitMessage(0):return 0
case WM_NCDESTROY
case WM_NCHITTEST 'position of cursor
' xPos = LOWORD(lParam)
' yPos = HIWORD(lParam)
case WM_SETCURSOR
' hwnd = cast(HWND,wParam)
' nHittest = LOWORD(lParam)
' MouseMsg = HIWORD(lParam)
case WM_COMMAND
dim as integer wNotifyCode = HIWORD(wParam)
dim as integer wID = LOWORD(wParam)
select case wNotifyCode
case 0
select case wID
case IDM_NEW : dprint("IDM_NEW")
case IDM_OPEN : dprint("IDM_OPEN")
case IDM_SAVE : dprint("IDM_SAVE")
case IDM_SAVE_AS : dprint("IDM_SAVE_AS")
case IDM_QUIT : dprint("IDM_QUIT")
SendMessage(hWin,WM_CLOSE,wParam,lParam)
case IDM_UNDO
case IDM_COPY : dprint("IDM_COPY")
case IDM_PASTE : dprint("IDM_PASTE")
case IDM_CUT : dprint("IDM_CUT")
case IDM_SEARCH : dprint("IDM_SEARCH")
case IDM_NEXT : dprint("IDM_NEXT")
case IDM_REPLACE : dprint("IDM_REPLACE")
case IDM_HELP : dprint("IDM_CONTEXT")
case IDM_ABOUT : dprint("IDM_ABOUT")
end select
case 1
' redirect accel's as 'normal' menu message
SendMessage(hWin,WM_COMMAND,wID,lParam)
case else
if wID = IDC_RICHEDIT then
dim as HWND hCtrl= cast(HWND,lParam)
dim as integer LineIndex
dim as integer CharIndex
dim as integer LineLength
select case wNotifyCode
case EN_SETFOCUS : dprint("IDC_RICHEDIT EN_SETFOCUS")
case EN_KILLFOCUS : dprint("IDC_RICHEDIT EN_KILLFOCUS")
case EN_CHANGE
if (Syntax<>NULL) then
CharIndex = SendMessage(hCtrl,EM_LINEINDEX, -1,0)
LineLength = SendMessage(hCtrl,EM_LINELENGTH, -1,0)
dim as CHARRANGE cr
SendMessage(hCtrl,EM_EXGETSEL,0,cast(uinteger,@cr))
Syntax->Colorize(hCtrl,CharIndex,CharIndex + LineLength)
SendMessage(hCtrl,EM_EXSETSEL,0,cast(uinteger,@cr))
end if
case EN_UPDATE : dprint("IDC_RICHEDIT EN_UPDATE")
case else : dprint("IDC_RICHEDIT " & wNotifyCode)
end select
else
dprint("WM_COMMAND " & wID & "," & wNotifyCode)
end if
end select
case WM_SYSCOMMAND
dim as integer uCmdType = (wParam and &HFFF0)
select case uCmdType
case SC_CLOSE
dprint("hWin WM_SYSCOMMAND SC_CLOSE")
SendMessage(hWin,WM_CLOSE,wParam,lParam)
end select
end select
return DefWindowProc(hWin, uMsg, wParam, lParam)
end function
type EDIT_T
declare constructor(hParent as HWND)
declare destructor
declare function GetLineCount as integer
declare function GetLine(row as integer) as string
declare function Load(FileName as string) as integer
as HWND hEdit
private:
#ifndef __FB_64BIT__
declare static function ReadStreamCallback(dwUser as DWORD , _
pBuf as LPBYTE, _
nBytes as LONG , _
pReaded as LONG ptr) as DWORD
#else
declare static function ReadStreamCallback(dwUser as DWORD_PTR , _
pBuf as LPBYTE, _
nBytes as LONG , _
pReaded as LONG ptr) as DWORD
#endif
end type
constructor EDIT_T(hParent as HWND)
dprint("EDIT_T()")
dim as RECT rec
GetClientRect(hParent,@rec)
dim as integer w = rec.right-rec.left
dim as integer h = rec.bottom-rec.top
dim as string EditClass
' first try V2.0
dim as HMODULE hLib = LoadLibrary("RICHED20.Dll")
if (hLib<>NULL) then
EditClass ="RICHEDIT20A"
dprint("RichEdit control V2.0")
else
' fall back V1.0
hLib = LoadLibrary("RICHED32.Dll")
If (hLib<>NULL) then
EditClass ="RICHEDIT"
dprint("RichEdit control V1.0 with 64K limit !")
else
EPRINT("InitControls() can't load RichEdit <= V2.0 !")
end if
end if
hEdit = CreateWindowEx(WS_EX_CLIENTEDGE or _
WS_EX_LEFT or _
WS_EX_LTRREADING or _
WS_EX_RIGHTSCROLLBAR, _
EditClass, _
"file not loaded ...", _
WS_CHILD or _
WS_VISIBLE or _
WS_HSCROLL or _
WS_VSCROLL or _
WS_TABSTOP or _
ES_LEFT or _
ES_MULTILINE or _
ES_AUTOHSCROLL or _
ES_AUTOVSCROLL or _
ES_WANTRETURN, _
10,10,w-20,h-20, _
hParent, _
cast(HMENU,IDC_RICHEDIT), _
GetModuleHandle(0), _
NULL)
' no 64K Limit on V2.0
SendMessage(hEdit,EM_LIMITTEXT,-1,0)
#if 0
dim as CHARFORMAT cf
with cf
.cbSize = sizeof(CHARFORMAT)
.dwMask = CFM_CHARSET or _
CFM_FACE or _
CFM_SIZE or _
CFM_OFFSET or _
CFM_COLOR
.dwEffects = 0
.yHeight = 10 * 20 ' pts * 20 twips/point = n twips
.bCharSet = ANSI_CHARSET
.bPitchAndFamily = FIXED_PITCH or FF_MODERN
.yOffset = 0
.szFaceName = "Courier New"
.crTextColor = &HCC0000
end with
SendMessage(hEdit, EM_SETCHARFORMAT,SCF_ALL, cast(LPARAM,@cf))
#endif
SendMessage(hEdit, EM_SETBKGNDCOLOR,FALSE , cast(LPARAM,CLR_PAPER))
end constructor
destructor EDIT_T
DPRINT("EDIT_T~")
end destructor
function EDIT_T.GetLineCount as integer
return SendMessage(hEdit,EM_GETLINECOUNT,0,0)
end function
function EDIT_T.GetLine(row as integer) as string
if row<0 then return ""
if row>=GetLineCount() then return ""
dim as string ret
dim as ubyte ptr pTmp = allocate(4096)
*cptr(ushort ptr,ptmp) = 4096
dim as integer nChars = SendMessage(hEdit,EM_GETLINE,row,cast(LPARAM,pTmp))
if nChars>0 then
ret = space(nChars)
for i as integer=0 to nChars-1
ret[i]=ptmp[i]
next
end if
function = ret
deallocate ptmp
end function
#ifndef __FB_64BIT__
function EDIT_T.ReadStreamCallback(dwUser as DWORD , _
pBuf as LPBYTE, _
nBytes as LONG , _
pReaded as LONG ptr) as DWORD
#else
function EDIT_T.ReadStreamCallback(dwUser as DWORD_PTR, _
pBuf as LPBYTE, _
nBytes as LONG , _
pReaded as LONG ptr) as DWORD
#endif
dim as integer size
get #dwUser,,*pBuf,nBytes,size
*pReaded=size
return 0
end function
function EDIT_T.Load(FileName as string) as integer
dim as EDITSTREAM es
dim as integer hFile = FreeFile()
if 0=open(FileName,for binary access read,as #hFile) then
with es
.dwCookie = hFile
.pfnCallback = @ReadStreamCallback
end with
SendMessage(hEdit, EM_STREAMIN, SF_TEXT, cast(LPARAM,@es))
close #hFile
return 1
end if
return 0
end function
type APPLICATION_T
declare constructor
declare destructor
declare function run as integer
as FORM_T ptr form
as MENU_T ptr menu
as EDIT_T ptr edit
end type
constructor APPLICATION_T
DPRINT("APPLICATION_T()")
dim as INITCOMMONCONTROLSEX IccEx
with IccEx
.dwSize = sizeof(INITCOMMONCONTROLSEX)
.dwICC = ICC_WIN95_CLASSES or _ ' &H000000FF
ICC_DATE_CLASSES or _ ' &H00000100
ICC_USEREX_CLASSES or _ ' &H00000200
ICC_COOL_CLASSES or _ ' &H00000400
ICC_INTERNET_CLASSES or _ ' &H00000800
ICC_PAGESCROLLER_CLASS or _ ' &H00001000
ICC_NATIVEFNTCTL_CLASS or _ ' &H00002000
ICC_STANDARD_CLASSES or _ ' &H00004000
ICC_LINK_CLASS ' &H00008000
end with
InitCommonControlsEx @IccEx
syntax = new SYNTAX_T
form = new FORM_T(command(0),100,100,640,480)
menu = new MENU_T(form->hForm)
edit = new EDIT_T(form->hForm)
chdir ExePath
' diable redrawing
' SendMessage(edit->hEdit,WM_SETREDRAW,false,0)
' set hourglas
dim as HANDLE oldCursor = SetCursor(LoadCursor(NULL, IDC_WAIT))
' disable change events
SendMessage(edit->hEdit,EM_SETEVENTMASK,0,ENM_NONE)
' load source code and colorize it
if edit->Load("ide.bas") then
syntax->Colorize(edit->hEdit,0,-1)
end if
' enable change events
SendMessage(edit->hEdit,EM_SETEVENTMASK,0,ENM_CHANGE)
' set old mouse icon
SetCursor(oldCursor)
' enable redrawing
' SendMessage(edit->hEdit,WM_SETREDRAW,true,0)
' trigger client redraw
' RedrawWindow(edit->hEdit,NULL,NULL,RDW_INVALIDATE or RDW_UPDATENOW or RDW_ERASE)
end constructor
destructor APPLICATION_T
if edit then delete edit
if menu then delete menu
if form then delete form
if syntax then delete syntax
DPRINT("APPLICATION_T~")
end destructor
function APPLICATION_T.Run as integer
DPRINT("APPLICATION_T.Run")
dim as MSG msg
dim as integer blnIgnore
while GetMessage(@msg, NULL, 0, 0)
if (msg.hwnd<>NULL) then
if (Menu<>NULL) AndAlso (Menu->hAccel<>NULL) then
blnIgnore=TranslateAccelerator(msg.hwnd, _
Menu->hAccel,_
@msg)
end if
end if
if (blnIgnore=0) then
TranslateMessage(@msg)
DispatchMessage(@msg)
end if
wend
return msg.wParam
end function
'
' start your engine :-)
'
function main as integer
dim as APPLICATION_T app
return app.run
end function
end main()
Last edited by D.J.Peters on Sep 08, 2020 1:46, edited 3 times in total.
Re: RichEdit syntax coloring
undefined reference to `BufferSize'
If I comment out line 266, ' mov ecx,[BufferSize], it compiles and I see a window saying "file not loaded". I don't understand the joke...
If I comment out line 266, ' mov ecx,[BufferSize], it compiles and I see a window saying "file not loaded". I don't understand the joke...
-
- Posts: 8586
- Joined: May 28, 2005 3:28
- Contact:
Re: RichEdit syntax coloring
BufferSize must be nBufferSizejj2007 wrote:I don't understand the joke...
Get the source code again the inline assembler code are not used it's only to colorize it !
The demo comes from a time where FreeBASIC was only 32-bit but I fixed that should work now !
I tested both 32 and 64 bit
fbc ide.bas -w pendantic -asm intel
Joshy
Re: RichEdit syntax coloring
WOW
thanks Joshy
it works great just take few secons for parsing ..
it is complex program i don't get that assembly at all...shame on me ...
Also may i ask why subs are UDT ?
is that "must be " for this program or not?
and only one Sendmessage others are inside functions if i inderstand it
ufff i really need time with this program ....
thanks Joshy
it works great just take few secons for parsing ..
it is complex program i don't get that assembly at all...shame on me ...
Also may i ask why subs are UDT ?
is that "must be " for this program or not?
and only one Sendmessage others are inside functions if i inderstand it
ufff i really need time with this program ....
Re: RichEdit syntax coloring
@aurelVZAB
Sorry I didn't fully understand your request. In fbdebugger I did also syntax coloring but it's too slow for biggest source codes.
@jj2007
Now that's clearer ;-)
@D.J.Peters
Maybe I would use your code. Do you agree ?
Sorry I didn't fully understand your request. In fbdebugger I did also syntax coloring but it's too slow for biggest source codes.
@jj2007
Now that's clearer ;-)
@D.J.Peters
Maybe I would use your code. Do you agree ?
Re: RichEdit syntax coloring
Joshy,
It works now: the file loads when I start the exe from the source's folder. Compliments, well done!
It works now: the file loads when I start the exe from the source's folder. Compliments, well done!
-
- Posts: 8586
- Joined: May 28, 2005 3:28
- Contact:
Re: RichEdit syntax coloring
@aurelVZAB the inline assembler stuf isn't needed at all you can delete it "if 0 then bla bla" will never executed :-)
This isn't a real editor it was only a test for the richedit control I wrote many years ago.
I never code windows only stuff !
Why not using FLTK-c for your project ?
(it will run on Windows and Linux 32/64 bit)
Joshy
This isn't a real editor it was only a test for the richedit control I wrote many years ago.
I never code windows only stuff !
Why not using FLTK-c for your project ?
(it will run on Windows and Linux 32/64 bit)
Joshy
-
- Posts: 8586
- Joined: May 28, 2005 3:28
- Contact:
Re: RichEdit syntax coloring
again for all here :-)
You can remove the inline assembler stuff
if you delete it "fbc ide.bas" will work :-)
Joshy
You can remove the inline assembler stuff
if you delete it "fbc ide.bas" will work :-)
Joshy