Нашел свой старый проект на RapidQ Basic -редактор с подсветкой синтаксиса.
Один исходник на чистом RapidQ (приложил в файле HLEditor2.bas)
Код
'Based on "Very simple notepad like editor, in less than 200 lines of code! (by William Yu)" 'parser based on RQB2HTML - Rapid-Q BASIC source code to HTML converter by William Yu 'Syntax hilight based on example from Iczelion's Win32 Assembly Tutorial part 35 'http://spiff.tripnet.se/~iczelion/tut35.html 'diakin 'May 2004
'Not complete, for example only. 'known parser bugs - with esc sequences, with tabs (for fix tabs replaced by spaces) 'colors choose is not completed. ' not fast, but better then SelStart\SelText.
Потом сделал dll на FreeBasic, см файл HiLightDllv67.bas, вызывается из RapidQ.
Парсер для подсветки ... мягко говоря.. такой себе, работает кое-как ) Если у кого-то есть силы сделать нормальный - было бы здорово.
'Based on "Very simple notepad like editor, in less than 200 lines of code! (by William Yu)" 'parser based on RQB2HTML - Rapid-Q BASIC source code to HTML converter by William Yu 'Syntax hilight based on example from Iczelion's Win32 Assembly Tutorial part 35 'http://spiff.tripnet.se/~iczelion/tut35.html ' 'May 2004
'Not complete, for example only. 'known parser bugs - with esc sequences, with tabs (for fix tabs replaced by spaces) 'colors choose is not completed. ' not fast, but better then SelStart\SelText.
Код
$APPTYPE GUI $INCLUDE "RAPIDQ.INC" '' You don't need them all in this example.
DECLARE FUNCTION SetWindowLongAPI LIB "user32" ALIAS "SetWindowLongA" (ByVal hWnd AS LONG, ByVal nIndex AS LONG, ByVal dwNewLong AS LONG) AS LONG
Private Declare Function HideCaret Lib "user32" ALIAS "HideCaret" (ByVal hwnd As Long) As Long Private Declare Function ShowCaret Lib "user32" ALIAS "ShowCaret" (ByVal hwnd As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _ (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, _ ByVal lParam As Long) As Long
DECLARE FUNCTION SendMessageApi LIB "user32.dll" ALIAS "SendMessageA" (hWnd AS LONG, Msg AS LONG, wParam AS LONG, lParam AS LONG) AS LONG
Declare Function GetDC Lib "user32" Alias "GetDC"(ByVal hWnd As Long) As Long Declare Function SetBkMode Lib "gdi32" Alias "SetBkMode" (ByVal hdc As Long, ByVal nBkMode As Long) As Long Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Declare Function SelectObject Lib "gdi32" Alias "SelectObject" (ByVal hdc As Long, ByVal hObject As Long) As Long Declare Function SetTextColor Lib "gdi32" Alias "SetTextColor" (ByVal hdc As Long, ByVal crColor As Long) As Long
'!!! ------------------------ RichEditWndProc ------------------------------ declare FUNCTION RichEditWndProc (hWnd AS LONG, uMsg AS LONG, wParam AS LONG, lParam AS LONG) AS LONG
dim VisRect as QRect dim VisPoint as Point dim VisPoint1 as Point
dim HiLiteFont as QFont dim HiLiteFont1 as QFont HiLiteFont.bold=0 HiLiteFont.Name="FixedSys"
defint hdc '-- device handle'
DIM M AS QMEMORYSTREAM defint FIRSTVISIBLELINE,LastVISIBLELINE
defint FirstChar
'---------------------------------------------'
DIM MainForm AS QForm DIM DialogBox AS QForm DIM EditBox AS QEdit DIM RichEdit AS QRichEdit
DIM MainMenu AS QMainMenu DIM File AS QMenuItem, Edit AS QMenuItem DIM New AS QMenuItem, Open AS QMenuItem, ReOpen AS QMenuItem DIM ReOpen1 AS QMenuItem, ReOpen2 AS QMenuItem, ReOpen3 AS QMenuItem DIM Save AS QMenuItem, SaveAs AS QmenuItem DIM Break1 AS QMenuItem DIM ExitEditor AS QMenuItem DIM Copy AS QMenuItem, Cut AS QMenuItem, Paste AS QMenuItem, SelectAll AS QMenuItem DIM Search AS QMenuItem, Find AS QMenuItem
DIM FileName AS STRING FileName = "UNTiTLED"
DIM CountFiles AS BYTE CountFiles = 0
DIM StatusBar AS QStatusBar StatusBar.Parent = MainForm StatusBar.AddPanels "","" StatusBar.Panel(0).Width = 100 StatusBar.Panel(0).Alignment = taCenter '--********************************* SUB ExitEditorClick '' Exit item clicked MainForm.Close END SUB
'--********************************* SUB NewClick '' New item clicked RichEdit.Clear FileName = "UNTiTLED" END SUB
'--********************************* SUB OpenClick '' Open item clicked DIM OpenDialog AS QOpenDialog OpenDialog.InitialDir=curdir$ IF OpenDialog.Execute THEN FileName = OpenDialog.FileName RichEdit.LoadFromFile FileName richedit.text=REPLACESUBSTR$(richedit.text,chr$(9)," ") '-- заменяем табуляции пробелами' IF CountFiles = 0 THEN ReOpen.Enabled = True ReOpen1.Caption = "&1. "+FileName ReOpen.Insert 0, ReOpen1 ELSEIF CountFiles = 1 THEN ReOpen2.Caption = "&2. "+FileName ReOpen.Insert 1, ReOpen2 ELSEIF CountFiles = 2 THEN ReOpen3.Caption = "&3. "+FileName ReOpen.Insert 2, ReOpen3 ELSE CountFiles = CountFiles - 1 ReOpen1.Caption = "&1. "+RIGHT$(ReOpen2.Caption, LEN(ReOpen2.Caption)-4) ReOpen2.Caption = "&2. "+RIGHT$(ReOpen3.Caption, LEN(ReOpen3.Caption)-4) ReOpen3.Caption = "&3. "+FileName END IF CountFiles = CountFiles + 1 RichEdit.Modified = False END IF END SUB
'--********************************* SUB SaveAsClick '' SaveAs item clicked DIM SaveDialog AS QSaveDialog
IF SaveDialog.Execute THEN RichEdit.SaveToFile SaveDialog.FileName END IF END SUB
'--********************************* SUB SaveClick IF FileName = "UNTiTLED" THEN SaveAsClick ELSE RichEdit.SaveToFile FileName END IF END SUB
SUB CopyClick: RichEdit.CopyToClipBoard: END SUB '' Oh yeah, that was easy SUB CutClick: RichEdit.CutToClipBoard: END SUB SUB PasteClick: RichEdit.PasteFromClipBoard: END SUB SUB SelectAllClick: RichEdit.SelectAll: END SUB
'--********************************* SUB Reopen1Click IF RichEdit.Modified THEN SHOWMESSAGE "Abandoning changes" END IF RichEdit.LoadFromFile RIGHT$(ReOpen1.Caption, LEN(ReOpen1.Caption)-4) RichEdit.Modified = False END SUB
'--********************************* SUB Reopen2Click IF RichEdit.Modified THEN SHOWMESSAGE "Abandoning changes" END IF RichEdit.LoadFromFile RIGHT$(ReOpen2.Caption, LEN(ReOpen2.Caption)-4) RichEdit.Modified = False END SUB
'--********************************* SUB Reopen3Click IF RichEdit.Modified THEN SHOWMESSAGE "Abandoning changes" END IF RichEdit.LoadFromFile RIGHT$(ReOpen3.Caption, LEN(ReOpen3.Caption)-4) RichEdit.Modified = False END SUB
'--********************************* SUB FindText '' Primitive search... RichEdit.SelStart = INSTR(UCASE$(RichEdit.Text), UCASE$(EditBox.Text))-1 IF RichEdit.SelStart > 0 THEN DIM Font AS QFont Font.AddStyles(fsBold, fsItalic)
RichEdit.SelLength = LEN(EditBox.Text) RichEdit.SelAttributes = Font DialogBox.Close ELSE SHOWMESSAGE EditBox.Text+" not found." END IF END SUB
'--********************************* SUB FindClick DIM Button AS QButton
IF fileExists(fullPath$+"keyword.lst") = 0 THEN '' PRINT "ERROR can't find file keyword.lst "+fullPath$+"keyword.lst" END ELSE '' PRINT "Load file keyword.lst "+fullPath$+"keyword.lst" keyList.LoadFromFile(fullPath$+"keyword.lst") END IF
'--- New WinProc RichEdit --------------------------------------- FUNCTION RichEditWndProc (hWnd AS LONG, uMsg AS LONG, wParam AS LONG, lParam AS LONG) AS LONG Result = CallWindowProc(OldRichEditWndProc, hWnd, uMsg, wParam, lParam)
SELECT CASE uMsg CASE WM_PAINT '---- <-------------------------------------- 'print "RichEdit WM_PAINT=",WM_PAINT 'HideCaret hWnd
hdc=GetDC(hWnd) : 'print "hdc=" ,hdc
'__ Set the bitmap's backmode to transparent 'previous_background_mode=SetBkMode (hDC, TRANSPARENT) previous_background_mode=SetBkMode (hDC, OPAQUE) '__ select font Curent = SelectObject(hdc, HiLiteFont.Handle) rgbPrev = SetTextColor(hdc, HiLiteFont.color)
'__ Get point structure (may be not needed) VisPoint.Left=VisRect.Left VisPoint.Top=VisRect.Top M.Position = 0 M.WriteUDT(VisPoint) M.Position = 0 '__Get char index from begin lchar=SendMessageAPI (hWnd,EM_CHARFROMPOS,0,M.Pointer) '__ get first visible line line_number= SendMessageAPI (hWnd,EM_LINEFROMCHAR,lchar,0 ) '__ Hehe, more easy (get first visible line ) FIRSTVISIBLELINE= SendMessageAPI (hWnd,EM_GETFIRSTVISIBLELINE,0,0) FirstChar=SendMessageAPI (hWnd,EM_LINEINDEX,line_number,0)
'__ get LastVISIBLELINE LastVISIBLELINE=SendMessageAPI (hWnd,EM_LINEFROMCHAR,Lastchar,0 ) 'print "LastVISIBLELINE=" ,LastVISIBLELINE
bas2Html '-<<<<<<<<<<<<<<<<<<<<<<<<' END SELECT
END FUNCTION
'-- ***************************************************************************************************************** SUB bas2Html DEFINT useEscapes = FALSE
DIM i AS LONG DIM j AS LONG DIM quote AS BYTE DIM ch AS STRING * 1 DIM token AS STRING '---------- dim CurPos AS LONG '-- char pos from file beginning dim StrPos AS LONG '-- firs char in current line position (from file beginning)
StrPos=FirstChar CurPos=0 j=0 i=0
RhWnd=RichEdit.Handle '-- use richedit.line() FOR i =FIRSTVISIBLELINE TO LastVISIBLELINE '- quote = FALSE token = "" FOR j = 1 TO len(richedit.line(i)) '- CurPos=j +StrPos '- ch = richedit.line(i) [j]IF instr("+-=<>()\/^&*[]:;?,' "+chr$(34)+chr$(9), ch) THEN '- IF ch = chr$(34) THEN '--- ------- if quote ----------- token = "" kk=0 '------------------------- SendMessageAPI (rhWnd,EM_POSFROMCHAR, VisPoint1,CurPos-1) rgbPrev = SetTextColor(hdc, clGreen) TextOut(hdc, VisPoint1.left, VisPoint1.top, ch, len(ch)) '------------------------- FOR j = j+1 TO len(richedit.line(i)) '--- begin string type CurPos=j +StrPos ch = richedit.line(i) IF ch = chr$(34) THEN '--- ------- if quote -----------
'------------------------- SendMessageAPI (rhWnd,EM_POSFROMCHAR, VisPoint1,CurPos-1) rgbPrev = SetTextColor(hdc, clGreen) TextOut(hdc, VisPoint1.left, VisPoint1.top, ch, len(ch)) '------------------------- kk=1 EXIT FOR ELSEif ch="'" then RemFlg=1 kk=1 exit for else IF ch = "<" THEN token = token +ch'' "<" ELSE token = token + ch END IF END IF NEXT '--- end string type '------------------------- SendMessageAPI (rhWnd,EM_POSFROMCHAR,VisPoint1,CurPos-len(token)-kk) rgbPrev = SetTextColor(hdc, clOrange) 'previous_background_mode=SetBkMode (hDC, clGreen) TextOut(hdc, VisPoint1.left, VisPoint1.top, token, len(token)) '------------------------- if RemFlg=1 then RemFlg=0 : goto RemF
А это точно надо? А то ведь раскрашивать бейсик‐подобный синтаксис умеет даже Far Manager и Notepad++. Если вы решили сделать полноценную среду разработки «с нуля», то желаю вам удачи!
Declare Function SendMessageA LIB "user32" Alias "SendMessageA" _ (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, byref lParam As any ) As Integer
Declare Function GetDC Lib "user32" Alias "GetDC"(ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" Alias "ReleaseDC" _ (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function SetBkMode Lib "gdi32" Alias "SetBkMode" (ByVal hdc As Long, ByVal nBkMode As Long) As Long Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, byref lpString As any, ByVal nCount As Long) As Long
Declare Function SelectObject Lib "gdi32" Alias "SelectObject" (ByVal hdc As Long, ByVal hObject As Long) As Long Declare Function SetTextColor Lib "gdi32" Alias "SetTextColor" (ByVal hdc As Long, ByVal crColor As Long) As Long
Declare Function FillRect Lib "user32" Alias "FillRect" _ (ByVal hdc As Long, lpRect As QRect, ByVal hBrush As Long) As Long
Declare Function GetBkColor Lib "gdi32" Alias "GetBkColor" (ByVal hdc As Long) As Long Declare Function SetBkColor Lib "gdi32" Alias "SetBkColor" (ByVal hdc As Long, ByVal crColor As Long) As Long
Declare Function DrawText Lib "user32" Alias "DrawTextA" _ (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _ lpRect As QRECT, ByVal wFormat As Long) As Long
Declare Function CreateSolidBrush Lib "gdi32" Alias "CreateSolidBrush" (ByVal crColor As Long) As Long
'declare function HiLight alias "HiLight" (byval RhWnd as long, byval HiLiteFontHandle as long) as long 'declare function HiLight alias "HiLight" (byval RhWnd as long, byval HiLiteFontHandle as long, byval ptrKeyList As byte ptr, byval hthl as long) as long 'declare function HiLight alias "HiLight" (byval RhWnd as long, byval HiLiteFontHandle as long,byval HiLiteFontBoldHandle as long, byval ptrKeyList As byte ptr, byval hthl as long) as long
declare function HiLight alias "HiLight" (byval RhWnd as long, byval HiLiteFontHandle as long, ptrHLClrs as long ptr, byval ptrKeyList As byte ptr, byval hthl as long) as long
' ---$include: 'DllMain.bi' '-- ***************************************************************************************************************** Function HiLight (byval RhWnd as long, byval HiLiteFontHandle as long, ptrHLClrs as long ptr, byval ptrKeyList As byte ptr, byval hthl as long) as long export
DIM xp As long Ptr: xp = @ptrHLClrs : DIM HiLiteColors(0 to 15) AS long : MEMCPY(@HiLiteColors(0), xp, 16 * SIZEOF(long)) 'DIM xp As Single Ptr: xp = @lpxr : DIM xr(n) AS SINGLE : MEMCPY(@xr(0), xp, n * SIZEOF(SINGLE))
'print "ptrKeyList="; ptrKeyList 'dim hBrush as long 'hBrush = CreateSolidBrush(clLBlue)
dim VisPoint as QPoint dim VisPoint1 as QPoint dim VisRect as QRect
dim VisRectPtr as QRect ptr VisRectPtr=@VisRect
dim hdc as integer '-- device handle' dim previous_background_mode as long,rgbPrev as long dim Curent as integer dim result1 as integer ,kk as long,RemFlg as long,RemPos as long,RemPos1 as long,RemFlg1 as long dim bgcolor as long
dim keyListText as string 'keyListText=LoadString ("keyword.lst") keyListText=string$(3048,"-") 'print "1 keyListText=" ;len(keyListText) keyListText= *ptrKeyList
'print "2 keyListText=" ;len(keyListText)
'"DIM CREATE"
DIM i AS LONG DIM j AS LONG , j1 as long DIM quote AS BYTE DIM ch AS STRING'' * 1 DIM token AS STRING '---------- dim CurPos AS LONG '-- char pos from file beginning dim StrPos AS LONG '-- firs char in current line position (from file beginning)
dim lchar AS LONG dim line_number AS LONG ,LINELENGTH AS LONG dim FirstChar AS LONG dim LastChar AS LONG dim FIRSTVISIBLELINE AS LONG dim LastVISIBLELINE AS LONG dim richeditline as string dim rline as byte ptr
'__ Get point structure (may be not needed) VisPoint.Left=VisRect.Left VisPoint.Top=VisRect.Top
'__Get char index from begin lchar=SendMessageA (rhWnd,EM_CHARFROMPOS,0,VisPoint)
'__ get first visible line line_number= SendMessageA (rhWnd,EM_LINEFROMCHAR,byval lchar,0 )
'__ Hehe, more easy (get first visible line ) FIRSTVISIBLELINE= SendMessageA (rhWnd,EM_GETFIRSTVISIBLELINE,0,0) FirstChar=SendMessageA (rhWnd,EM_LINEINDEX,byval line_number,0)
FOR i =FIRSTVISIBLELINE TO LastVISIBLELINE '- quote = FALSE token = "" FirstChar=SendMessageA (byval rhWnd,EM_LINEINDEX, i,0) LINELENGTH =SendMessageA (byval rhWnd,EM_LINELENGTH ,byval FirstChar,0) 'print "LINELENGTH="; LINELENGTH if LINELENGTH >0 then richeditline=string$(LINELENGTH,"-") ' create buffer rline=sadd (richeditline) else richeditline="" rline=sadd (richeditline) goto nexti end if SendMessageA (rhWnd,EM_GETLINE, byval i, byval rline) novFlag=0
' print"richeditline=";richeditline
FOR j = 1 TO len(richeditline) '- Curent = SelectObject(hdc, HiLiteFontHandle)
CurPos=j +StrPos '- ch = mid$(richeditline,j,1) IF instr("#!@$%{}~`+-=<>()\/^&*[]:;?,' "+chr$(34)+chr$(9), ch) >0 THEN '-
novFlag=0 '!! no value flag
IF ch = chr$(34) THEN '--- ------- if quote ----------- token = "" kk=0 '------------------------- SendMessageA (rhWnd,EM_POSFROMCHAR,byval @VisPoint1,byval CurPos-1) SetTextColor(hdc, HiLiteColors(2) ) ' clPurple) '''дЁ®«Ґв
TextOut(hdc, byval VisPoint1.left, byval VisPoint1.top, byval ch, byval len(ch)) '------------------------- FOR j1 = j+1 TO len(richeditline) '--- begin string type CurPos=j1 +StrPos ch = mid$(richeditline,j1,1) IF ch = chr$(34) THEN '--- ------- if quote ----------- '------------------------- SendMessageA (rhWnd,EM_POSFROMCHAR, @VisPoint1, byval CurPos-1) SetTextColor(hdc, HiLiteColors(2) ) 'clPurple) TextOut(hdc, byval VisPoint1.left, byval VisPoint1.top, byval ch, byval len(ch)) '------------------------- kk=1 EXIT FOR ELSEif ch="'" then RemFlg=1 kk=1 exit for else IF ch = "<" THEN token = token +ch'' "<" ELSE token = token + ch END IF END IF NEXT j1 j=j1 '--- end string type '------------------------- SendMessageA (byval rhWnd,EM_POSFROMCHAR,byval @VisPoint,byval CurPos-len(token)-kk) SetTextColor(hdc, HiLiteColors(7) ) 'clOrange) 'previous_background_mode=SetBkMode (hDC, clGreen) TextOut(hdc, VisPoint.left, VisPoint.top, byval token, byval len(token)) '------------------------- 'token = "" ' подсветили строковы токен и обнулили его
if RemFlg=1 then RemFlg=0 : goto RemF
ELSEIF ch = "'" THEN '-- comment --------------- RemF: '---first comment pos RemPos=CurPos-1 IF token <> "" THEN '- if token before - save it if instr(keyListText,ucase$(token))>0 then '------------------------- SendMessageA (rhWnd,EM_POSFROMCHAR,byval @VisPoint,byval CurPos-len(token)-1) 'VisRect.left=VisPoint.left 'VisRect.top=VisPoint.top 'VisRect.right=VisPoint.left+10 'VisRect.bottom=VisPoint.top+8 'FillRect hdc, VisRect, hBrush SetTextColor(hdc, HiLiteColors(1) ) 'clblue) TextOut(hdc, VisPoint.left, VisPoint.top, byval token, byval len(token)) '------------------------- ELSE END IF END IF
noht: 'ELSEIF len(token <> "" THEN ELSEIF len(token) > 1 THEN '!! нашли конец токена и подсвечиваем его if instr(keyListText,ucase$(token))>0 then '------------------------- SendMessageA (byval rhWnd,EM_POSFROMCHAR,byval @VisPoint,byval CurPos-len(token)-1) 'Curent = SelectObject(hdc, HiLiteFontBoldHandle) SetTextColor(hdc, HiLiteColors(1) ) 'clBlue) TextOut(hdc, VisPoint.left, VisPoint.top, byval token, len(token)) '------------------------- ELSE END IF
ELSEIF ch = "/" THEN '-- comment --------------- if RemFlg1=0 then RemFlg1=1 elseif RemFlg1=1 then RemFlg1=0 RemFlg=1 goto RemF END IF else RemFlg1=0 END IF
ELSEif instr("0123456789 ", ch)>0 and novFlag=0 THEN '! value 'print"ch=";ch vFlag=1 token = token + ch ELSE vFlag=0 novFlag=1 token = token + ch END IF NEXT j
if vFlag=1 then '!! value SendMessageA (rhWnd,EM_POSFROMCHAR, byval @VisPoint,byval CurPos-len(token)) SetTextColor(hdc, HiLiteColors(8) ) 'clDPurple) TextOut(hdc, VisPoint.left, VisPoint.top, byval token, byval len(token)) token = "" vFlag=0 END IF
IF len(token) > 1 THEN if instr(keyListText,ucase$(token))>0 then '------------------------- SendMessageA (rhWnd,EM_POSFROMCHAR, byval @VisPoint,byval CurPos-len(token)) SetTextColor(hdc, HiLiteColors(2) ) 'clblue) TextOut(hdc, VisPoint.left, VisPoint.top, byval token, byval len(token)) token = ""
ELSEIF ucase$(token)="SHL" or ucase$(token)="SHR" or ucase$(token)="MOD" or ucase$(token)="INV" _ or ucase$(token)="NOT" or ucase$(token)="AND" or ucase$(token)="OR" or ucase$(token)="XOR" THEN '!!------------------------- operators ------ SendMessageA (rhWnd,EM_POSFROMCHAR, byval @VisPoint,byval CurPos-len(token)) SetTextColor(hdc, HiLiteColors(2) ) 'clDPurple) TextOut(hdc, VisPoint.left, VisPoint.top, byval token, byval len(token)) token = ""
ELSE 'ELSEIF instr("0123456789", token)>0 THEN '*' fOut.write(token) END IF else
END IF nexti:
StrPos=StrPos+len(richeditline)+2'StrPos+j NEXT i ReleaseDC(rhWnd, hDC) END function
Сообщение отредактировал diakin - Воскресенье, 15.05.2022, 12:51
