liujianjun
/
tslediter
3
0
Fork 1
Code Issues Pull Requests Projects Releases Wiki Activity
tslediter/funcext/tvclib/utslmemo.tsf

4370 lines
128 KiB
Plaintext
Raw Blame History

unit UTslMemo;
{**
@explan(说明) 文本控件库 %%
**}
{$ifdef linux}
{$define linuxpop123}
{$endif}
interface
uses utslvclauxiliary,utslvclmemstruct,utslvclgdi,utslvclstdctl;
type TMemoLineItem=class() //编辑字符串行对象
function Create(s);
begin
if ifstring(s)then FStr := s;
else FStr := "";
end
function StrLength();
begin
return length(FStr);
end
FMarked;
FStr;
end
TYPE TMemoLineList=class(tnumindexarray) //编辑器行集合
function Create(Aedit);override;
begin
FEdit := Aedit;
class(tnumindexarray).create();
FRowMaxLength := 1;
Flock := true;
end
function Clear();
begin
splices(nil,nil,array(new TMemoLineItem("")));
FRowMaxLength := 1;
end
function SetStringByIndex(idx,v);virtual; //设置行
begin
if not ifstring(v)then return;
o := GetValueByIndex(idx);
if o then
begin
o.FStr := v;
UpDateMaxStringLength(length(v));
if Flock then
begin
FEdit.InvalidateLines(idx+1,idx+1);
end
end
end
function SetLineNumByIndex(idx,v);virtual;
begin
end
function GetLineNumByIndex(idx,v);virtual;
begin
end
function SetValueByIndex(idx,v);override;//设置行内人
begin
if ifstring(v)then return SetStringByIndex(idx,v);
//inherited;
//if Flock then FEdit.InvalidateLines(idx+1,idx+1);
end
function GetStringByIndex(idx);virtual; //获得行内容
begin
o := GetValueByIndex(idx);
if o then return o.FStr;
end
function LengthChanged(n);override; //长度改变
begin
if(Flock)then
begin
//echo "+++\r\n";
FEdit.UpDateScroll();
end
end
function ModifyMaxRowLength(); //修正宽度
begin
fRowMaxLength := 1;
for i := 0 to self.Length()-1 do
begin
vi := GetStringByIndex(i);
fRowMaxLength := max(fRowMaxLength,length(vi));
end
end
function UpDateMaxStringLength(L); //最大宽度改变
begin
if FRowMaxLength<L then
begin
FRowMaxLength := L;
DoColumnIncreased();
end
end
property Text read GetText write SetText;
property OnAdded read FOnAdded write FOnAdded;
property OnChange read FOnChange write FOnChange;
property OnChanging read FOnChanging write FOnChanging;
property OnCleared read FOnCleared write FOnCleared;
Property OnDeleted read FOnDeleted write FOnDeleted;
PROPERTY OnPutted READ fOnPutted write fOnPutted;
//property OnMaxLengthIncrease read FOnMaxLengthIncrease write FOnMaxLengthIncrease;
Property RowMaxLength read fRowMaxLength;
private
Flock;
FRowMaxLength;
weakref
FOnAdded;
FOnChange;
FOnChanging;
FOnCleared;
FOnDeleted;
fOnPutted;
FOnMaxLengthIncrease;
FEdit;
autoref
function DoColumnIncreased();
begin
//echo "\r\nIncreate:",FRowMaxLength;
//if iffuncptr(FOnMaxLengthIncrease) then Call(FOnMaxLengthIncrease);
//echo "\r\nincrease:",FRowMaxLength;
end
function SetText(s);
begin
Clear();
//push(new TMemoLineItem(""));
//return FEdit.ExecuteCommand(ecString,s);
if not(s and ifstring(s))then return;
vs := str2array(s,"\n");
if not vs then vs := array("");
Flock := false;
for i,vi in vs do
begin
if vi="\r" then continue;
if not vi then
begin
push(new TMemoLineItem(vi));
end else
begin
lv := length(vi);
UpDateMaxStringLength(lv);
if vi[lv]="\r" then
begin
push(new TMemoLineItem(vi[1:lv-1]));
end else
begin
Push(new TMemoLineItem(vi));
end
end
end
Flock := true;
end
function GetText();
begin
r := "";
d := Data;
len := Length(d)-1;
for i,v in d do
begin
r += v.FStr;
if i <> len then r += "\r\n";
end
return r;
end
end
type TMemoGutter=class() //行号列
function Create(AEdit);
begin
FWidth := 60;
FEdit := AEdit;
end
function PaintLiens(rc,FirstLine,LastLine);
begin
end
property Width read FWidth write FWidth;
private
function GetWidth();
begin
return 20+FEdit.Font.width * 5;
end
FWidth;
[weakref]FEdit;
end
type TTslMemoUndoItem=class
FReason;
FSelMode;
FStartPos;
FEndPos;
FStr;
FLinkItem; //两步操作的项目
function Create(AReason:TSynChangeReason;AStart,AEnd:TPoint;ChangeText:string;SelMode:TSynSelectionMode);
begin
FReason := AReason;
FSelMode := SelMode;
FStartPos := AStart;
FEndPos := AEnd;
FStr := ChangeText;
end
function Clone();
begin
return new TTslMemoUndoItem(FReason,FStartPos,FEndPos,FStr,FSelMode);
end
end
type TTslMenoUndoList=class() //undolist
private //sbs 2000-11-19
fBlockCount:integer; //sbs 2000-11-19
fFullUndoImposible:boolean; //mh 2000-10-03
fItems:TList;
fLockCount:integer;
fMaxUndoActions;
function GetCanUndo():boolean;
begin
return fItems.length()>0;
end
procedure EnsureMaxEntries(); //达到最大数量处理
begin
if fItems.length()>fMaxUndoActions then
begin //mh 2000-10-03
fFullUndoImposible := TRUE; //mh 2000-10-03
while fItems.length()>fMaxUndoActions do
begin
fItems.Unshift();
end;
end;
end
function GetItemCount():integer;//数量
begin
return fItems.length();
end
procedure SetMaxUndoActions(Value:integer);
begin
if not(Value>0)then Value := 0;
if Value <> fMaxUndoActions then
begin
fMaxUndoActions := Value;
EnsureMaxEntries();
end;
end
public
function Create();
begin
fLockCount := 0;
fItems := new tnumindexarray();
fMaxUndoActions := 1024;
fBlockChangeNumber := 0;
fNextChangeNumber := 1;
end
function Destroy();
begin
Clear();
end
procedure AddChange(AReason:TSynChangeReason;AStart,AEnd:TPoint;ChangeText:string;SelMode:TSynSelectionMode);
begin
if fLockCount=0 then
begin
if ifobj(AReason)then
begin
PushItem(AReason.Clone());
end else
PushItem(CreateATslMemoUndoItem(AReason,AStart,AEnd,ChangeText,SelMode));
end;
end
procedure Clear();
begin
if fItems.length()>0 then
fItems.splices(nil,nil,array());
fFullUndoImposible := FALSE;
end
procedure Lock();//锁住
begin
fLockCount++;
end
procedure Unlock(); //解锁
begin
if fLockCount>0 then fLockCount--;
return fLockCount;
end
function PeekItem():TSynEditUndoItem; //取得
begin
iLast := fItems.length()-1;
if iLast >= 0 then return fItems[iLast];
return nil;
end
function PopItem():TSynEditUndoItem;//弹出
begin
if fLockCount>0 then return nil;
if fItems.length()then return fItems.Pop();
return nil;
end
procedure PushItem(Item); //插入
begin
if fLockCount>0 then return nil;
fItems.push(Item);
if iffuncptr(fOnAdded) then call(fOnAdded,Self(true));
end
public
function MergeReplaceItem(); //合并操作
begin
if fItems.Length()>= 2 then
begin
it := PopItem();
pit := PeekItem();
pitl := pit.FLinkItem;
while pitl do
begin
pit := pitl;
pitl := pit.FLinkItem;
end
pit.FLinkItem := it;
end
end
property LockCount read fLockCount;
property CanUndo:boolean read GetCanUndo;
property ItemCount:integer read GetItemCount;
property MaxUndoActions:integer read fMaxUndoActions write SetMaxUndoActions;
// property OnAddedUndo: TNotifyEvent read fOnAdded write fOnAdded;
end;
type TCustomMemoCmd=class() //编辑器操作码类
{**
@explan(说明)编辑器控件操作码类%%
**}
public
{**
@ignoremembers(
ecNone ,
ecViewCommandFirs ,
ecViewCommandLast ,
ecEditCommandFirs ,
ecEditCommandLast ,
ecPageLeft ,
ecPageRight ,
ecPageTop ,
ecPageBottom ,
ecEditorBottom ,
ecSelPageUp ,
ecSelPageDown ,
ecSelPageLeft ,
ecSelPageRight ,
ecSelPageBottom ,
ecScrollUp ,
ecScrollDown ,
ecScrollLeft ,
ecScrollRight ,
ecInsertMode ,
ecOverwriteMode ,
ecToggleMode ,
ecNormalSelect ,
ecColumnSelect ,
ecLineSelect ,
ecMatchBracket ,
ecGotoMarker0 ,
ecGotoMarker1 ,
ecGotoMarker2 ,
ecGotoMarker3 ,
ecGotoMarker4 ,
ecGotoMarker5 ,
ecGotoMarker6 ,
ecGotoMarker7 ,
ecGotoMarker8 ,
ecGotoMarker9 ,
ecSetMarker0 ,
ecSetMarker1 ,
ecSetMarker2 ,
ecSetMarker3 ,
ecSetMarker4 ,
ecSetMarker5 ,
ecSetMarker6 ,
ecSetMarker7 ,
ecSetMarker8 ,
ecSetMarker9 ,
ecDeleteLastChar ,
ecDeleteChar ,
ecDeleteWord ,
ecDeleteLastWord ,
ecDeleteBOL ,
ecDeleteEOL ,
ecLineBreak ,
ecInsertLine ,
ecChar ,
ecImeStr ,
ecBlockIndent ,
ecBlockUnindent ,
ecTab ,
ecShiftTab ,
ecAutoCompletion ,
ecComment ,
ecUnComment ,
ecNextBlock ,
ecPrevBlock ,
ecNextJumpOut ,
ecPrevJumpOut ,
ecUserFirst ,
ecFind ,
ecReplace ,
ecSearchAgain ,
ecFindAll ,
ecSearchUpAgain ,
)
**}
{**
@param(ecGotoXY)() 跳转光标到指定位置,对应参数为 array(y,x) %%
@param(ecSelGotoXY)() 选中文本到指定位置,对应参数为 array(y,x) %%
@param(ecCopy)() 复制选中文本到剪切板,无对应参数 %%
@param(ecPaste)() 粘贴剪切板文本,无对应参数 %%
@param(ecString)() 插入字符串,对应参数为 字符串 %%
**}
{static ecGotoMarker0;
static ecGotoMarker1;
static ecGotoMarker2;
static ecGotoMarker3;
static ecGotoMarker4;
static ecGotoMarker5;
static ecGotoMarker6;
static ecGotoMarker7;
static ecGotoMarker8;
static ecGotoMarker9;
static ecSetMarker0;
static ecSetMarker1;
static ecSetMarker2;
static ecSetMarker3;
static ecSetMarker4;
static ecSetMarker5;
static ecSetMarker6;
static ecSetMarker7;
static ecSetMarker8;
static ecSetMarker9;}
static const ecNone=0x0;static const ecViewCommandFirs=NIL;
static const ecViewCommandLast=0x1F4;static const ecEditCommandFirs=NIL;static const ecEditCommandLast=0x3E8;
static const ecLeft=0x1;static const ecRight=0x2;static const ecUp=0x3;
static const ecDown=0x4;static const ecWordLeft=0x5;static const ecWordRight=0x6;
static const ecLineStart=0x7;static const ecLineEnd=0x8;static const ecPageUp=0x9;
static const ecPageDown=0xA;static const ecPageLeft=0xB;static const ecPageRight=0xC;
static const ecPageTop=0xD;static const ecPageBottom=0xE;static const ecEditorTop=0xF;
static const ecEditorBottom=0x10;static const ecGotoXY=0x11;static const ecSelection=0x64;
static const ecSelLeft=0x65;static const ecSelRight=0x66;static const ecSelUp=0x67;
static const ecSelDown=0x68;static const ecSelWordLeft=0x69;static const ecSelWordRight=0x6A;
static const ecSelLineStart=0x6B;static const ecSelLineEnd=0x6C;static const ecSelPageUp=0x6D;
static const ecSelPageDown=0x6E;static const ecSelPageLeft=0x6F;static const ecSelPageRight=0x70;
static const ecSelPageTop=0x71;static const ecSelPageBottom=0x72;static const ecSelEditorTop=0x73;
static const ecSelEditorBottom=0x74;static const ecSelGotoXY=0x75;static const ecSelectAll=0xC7;
static const ecCopy=0xC9;static const ecScrollUp=0xD3;static const ecScrollDown=0xD4;
static const ecScrollLeft=0xD5;static const ecScrollRight=0xD6;static const ecInsertMode=0xDD;
static const ecOverwriteMode=0xDE;static const ecToggleMode=0xDF;static const ecNormalSelect=0xE7;
static const ecColumnSelect=0xE8;static const ecLineSelect=0xE9;static const ecMatchBracket=0xFA;
static const ecDeleteLastChar=0x1F5;static const ecDeleteChar=0x1F6;static const ecDeleteWord=0x1F7;
static const ecDeleteLastWord=0x1F8;static const ecDeleteBOL=0x1F9;static const ecDeleteEOL=0x1FA;
static const ecDeleteLine=0x1FB;static const ecClearAll=0x1FC;static const ecLineBreak=0x1FD;
static const ecInsertLine=0x1FE;static const ecChar=0x1FF;static const ecImeStr=0x226;
static const ecUndo=0x259;static const ecRedo=0x25A;static const ecCut=0x25B;
static const ecPaste=0x25C;static const ecBlockIndent=0x262;static const ecBlockUnindent=0x263;
static const ecTab=0x264;static const ecShiftTab=0x265;static const ecAutoCompletion=0x28A;
static const ecComment=0x28B;static const ecUnComment=0x28C;static const ecNextBlock=0x2BD;
static const ecPrevBlock=0x2BE;static const ecNextJumpOut=0x2BF;static const ecPrevJumpOut=0x2C0;
static const ecUserFirst=0x3E9;static const ecFind=0x3EA;static const ecReplace=0x3EB;
static const ecSearchAgain=0x3EC;static const ecFindAll=0x3ED;static const ecString=0x3EE;
static const ecSearchUpAgain=0x3EF;
end
type TCustomMemo = class(TCustomScrollControl,TCustomMemoCmd) //编辑器基类
{**
@explan(说明) 带滚动条的编辑控件 %%
**}
private
FSymchars;
[weakref]fongutterclick;//点击
[weakref]fonchanged;//文本改变
[weakref]foncaretposchanged;//光标位置改变
ftmemlockv;
fundoing; //清空unredo标记
fredoing; //清空unredo标记
fselectbkcolor;//rgb(192,192,192);
fcurrentLineColor;//rgb(232,232,255);
fguttercolor;
Fecruningto; //调试运行到行
FLineInterval; //行间距
FSetPostioned; //位置改变
FIsCaretShow; //光标可见
fcaretcreated; //光标已经构造成功
fForceCaret;
FCharsInWindow; //
fTextHeight; //行高
fLinesInWindow; //能显示的行数
fMaxCharsInRow; //行容纳字符数目
FCharHeight; //字符高度
FCharWidth; //字符宽度
FLeftChar; //左边隐藏的字符数
FTopLine; //首行
FScroolChanged; //滚动了
FGutterCharCount; //gutter 字符个数
Fautogutterwidth; //自动设置gutter宽度
FGutter; //gutter
FMarginTop;
FLines;
fLastCaretY; //最新y位置
//fCaretLineNeedPaint;
fCaretX; //光标位置
fCaretY; //光标位置
fBlockBegin:TPoint; //选中位置
fBlockEnd:TPoint; //选中位置
//FScrollTimer;
FMouseIsDown;
FInPutCache; //汉字输入缓存
FSelectionMode; //选中模式
[weakref]FCopyer; //剪切板
FReadOnly; //只读
fUndoList; //撤销
fRedoList; //反撤销
//******操作标记********
static const crInsert = 1;
static const crPaste = 2;
static const crDragDropInsert = 3;
static const crDeleteAfterCursor = 4;
static const crDelete = 5;
static const crLineBreak = 6;
static const crIndent = 6;
static const crUnindent = 7;
static const crSilentDelete = 8;
static const crSilentDeleteAfterCursor = 9;
static const crNothing = 10;
static const smNormal = 0;
static const smLine = 1;
static const smColumn = 2;
//****************
protected
{function SetControlFont(v);override;
begin
inherited;
FCharWidth := Font.width;
FGutter.Width := (5*(FGutterCharCount>0))+FGutterCharCount * FCharWidth+1;
FCharHeight := Font.Height;
fTextHeight := FCharHeight+FLineInterval;
UpDateScroll();
end}
function GetClientXCapacity();override; //宽度容量
begin
return integer(ClientRect[2]/GetXScrollDelta());
end
function GetClientYCapacity();override; //高度容量
begin
return integer(ClientRect[3]/GetYScrollDelta());
end
function GetClientXCount();override; //宽度间隔
begin
return integer((GetMaxCharsInRow()* FCharWidth+FGutter.Width)/GetXScrollDelta());
end
function GetYScrollDelta();virtual;
begin
return fTextHeight;
end
function GetXScrollDelta();virtual; //水平间隔
begin
return FCharWidth;
end
function GetClientYCount();virtual; //高度项
begin
h := fTextHeight * fLines.Length;
return integer(h/GetYScrollDelta());
end
function DoEndUpDate();override;
begin
if not(IsUpDating())then
begin
if FScroolChanged then
begin
FScroolChanged := false;
UpDateScroll();
end
if fForceCaret then
begin
fForceCaret := false;
UpDateCaret();
end
end
inherited;
end
function Paint();override;
begin
xpos := GetXpos();
ypos := GetYPos();
// 计算需要重绘的区域
ps := PAINTSTRUCT().rcPaint;
tp := ps[1];
bo := ps[3];
FirstLine := integer(max(0,yPos+(tp-FMarginTop)/GetYScrollDelta()));
LastLine := integer(min(FLines.Length()-1,yPos+(bo-FMarginTop)/GetYScrollDelta()));
if FGutterCharCount>0 and(ps[0]<FGutter.Width)then
begin
rc := ps;
rc[2]:= FGutter.Width;
PaintGutter(rc,FirstLine,LastLine);
end
if ps[2]>FGutter.Width then
begin
FirstCol := integer(max(0,xPos+(ps[0]-FGutter.Width)/GetXScrollDelta()));
LastCol := integer(min(GetMaxCharsInRow()-1,xPos+(ps[2]-FGutter.Width)/GetXScrollDelta()));
rc := ps;
rc[0]:= Max(rc[0],FGutter.Width);
//echo tostn(array(FirstLine, LastLine, FirstCol, LastCol));
cvs := Canvas;
cvs.Font := font;
bcvs := new TCanvsRgnClipAutoSave(cvs,rc);
PaintTextLines(RC,FirstLine,LastLine,FirstCol,LastCol);
end
PluginsAfterPaint(self.Canvas,ps,FirstLine,LastLine);
end
function PaintGutter(rcDraw,nL1,nL2);
begin
dc := Canvas;
if ifnumber(FGutterColor) then
begin
c := FGutterColor;
end else
if ifobj(FGutterColor) then c := FGutterColor.color;
else c := rgb(228,228,228);
dc.brush.Color :=c ;//rgb(228,228,228);
rc := rcDraw;
rc[2]-= 6;
dc.FillRect(rc);
cvs := Canvas;
iy := 0;
cvs.Font := font;
//cvs.Font.Color := 1;
for i := nL1 to nL2 do
begin
r := rc;//rcDraw;
r[1]:= rcDraw[1]+fTextHeight * iy;
r[2]-= 4;
r[3]:= r[1]+fTextHeight;
it := flines[i];
if it and it.FMarked then
begin
dc.brush.Color := 0x12a4f6;//0xFF00FF;
tr := r;
tr[0]+= 1;
tr[1]+= 2;
tr[3]-= 4;
dc.FillRect(tr);
end
if i=Fecruningto then
begin
dc.brush.Color := 0x00ff00;
tr := r;
tr[2]+= 2;
tr[0]:= tr[2]-(tr[3]-tr[1]);
tr[1]+= 2;
tr[3]-= 2;
dc.draw("ellipse",array(tr[0:1],tr[2:3]))
end
cvs.DrawText(inttostr(i+1),r,DT_RIGHT);
iy++;
end
end
function PluginsAfterPaint(cvs,rcDraw,FirstLine,LastLine);
begin
end
function PaintTextLines(RC,FirstLine,LastLine,FirstCol,LastCol);//virtual;
begin
cvs := Canvas;
iy := 0;
cvs.TextTabLength := 1;
if fBlockBegin <> fBlockEnd and fBlockBegin and fBlockEnd then
begin
bb := GetBlockBegin();
ee := GetBlockEnd();
end
//rcs := rc;
//rcs := FGutter.width-(FLeftChar-1)*FCharWidth;
for i := FirstLine to LastLine do
begin
r := RC;
r[0]:= FGutter.width-(FLeftChar-1)* FCharWidth;
r[1]:= RC[1]+fTextHeight * iy;
iy++;
r[3]:= r[1]+fTextHeight;
if i+1=fCaretY then
begin
if Color<>fcurrentLineColor then
begin
cvs.Brush.Color := fcurrentLineColor;//rgb(232,232,255);
cvs.FillRect(r);
end
end
if bb then
begin
if i >= bb[0]-1 and i <= ee[0]-1 then
begin
cvs.Brush.Color := fselectbkcolor;//rgb(192,192,192);
src := r;
if FSelectionMode=smLine then
begin
end else
begin
if bb[0]=ee[0]then //同一行
begin
src[0]+= fCharWidth *(bb[1]-1);
src[2]:= src[0]+fCharWidth *(ee[1]-bb[1]);
end else
begin
if bb[0]-1=i then
begin
src[0]+= fCharWidth *(bb[1]-1);
end
if ee[0]-1=i then
begin
src[2]:= src[0]+fCharWidth *(ee[1]-1);
end
end
end
cvs.FillRect(src);
end
end
end
paintlinestext(RC,FirstLine,LastLine,FirstCol,LastCol);
end
{function DrawLongString2(cvs,dtx,tl,r,rnzf);
begin
if tl<1 then return ;
bt := 0;
ft := cvs.Font;
if rnzf>tl then
begin
qmzfs := 1;
ct := tl-1;
end else
begin
qmzfs := max(1,integer((0-r[0])/FCharWidth));
if qmzfs>3 and qmzfs<tl then
begin
if bytetype(dtx,qmzfs)=2 then qmzfs -= 1;
end
ct := min(tl-qmzfs+1,rnzf);
end
idx := qmzfs;
nqmzfs := qmzfs+ct;
qgqy := array((qmzfs,bt));
lqgqy := 1;
while idx<=(nqmzfs) do
begin
nbt := bytetype(dtx,idx)?1:0;
if nbt<>bt then
begin
qgqy[lqgqy++] := array(idx,nbt);
bt := nbt;
end
idx++;
end
qgqy[lqgqy] := array(nqmzfs+1,bt);
bn := ft.charset ;
for i:= 0 to lqgqy-1 do
begin
ks := qgqy[i][0];
jz := qgqy[i+1][0];
ct := jz-ks;
if ct then
begin
r2 := r;
dtx2 := copy(dtx,ks,ct);
r2[0]+=(ks-1)* FCharWidth;
r2[2]:= r2[0]+ct * FCharWidth;
if qgqy[i][1] then
begin
ft.charset := 134;
end else
begin
ft.charset := bn;
end
//echo ">>draw:",dtx2," --- ",ft.charset;
cvs.DrawText(dtx2,r2,DT_NOPREFIX);
end
end
ft.charset := bn;
end
function DrawLongString(cvs,dtx,tl,r,rnzf);
begin
bn := 100000;
ft := cvs.Font;
if rnzf>tl then
begin
for i := 1 to tl step 2 do
begin
if bytetype(dtx,i)<> 0 then
begin
bn := ft.charset;
ft.charset := 134;
break;
end
end
cvs.DrawText(dtx,r,DT_NOPREFIX);
end else
begin
qmzfs := max(1,integer((0-r[0])/FCharWidth));
if qmzfs>3 and qmzfs<tl then
begin
if bytetype(dtx,qmzfs)=2 then qmzfs -= 1;
end
ct := min(tl-qmzfs+1,rnzf);
for i := qmzfs to qmzfs+ct step 2 do
begin
if bytetype(dtx,i)<> 0 then
begin
bn := ft.charset;
ft.charset := 134;
break;
end
end
dtx2 := copy(dtx,qmzfs,ct);
r[0]+=(qmzfs-1)* FCharWidth;
r[2]:= r[0]+ct * FCharWidth;
cvs.DrawText(dtx2,r,DT_NOPREFIX);
end
if bn <> 100000 then
begin
ft.charset := bn;
end
end}
function DrawLongString(cvs,dtx,tl,r,rnzf);
begin
bn := 100000;
ft := cvs.Font;
if rnzf>tl then
begin
for i := 1 to tl step 2 do
begin
if bytetype(dtx,i)<> 0 then
begin
bn := ft.charset;
ft.charset := 134;
break;
end
end
cvs.DrawText(dtx,r,DT_NOPREFIX);
end else
begin
qmzfs := max(1,integer((0-r[0])/FCharWidth));
if qmzfs>3 and qmzfs<tl then
begin
if bytetype(dtx,qmzfs)=2 then qmzfs -= 1;
end
ct := min(tl-qmzfs+1,rnzf);
for i := qmzfs to qmzfs+ct step 2 do
begin
if bytetype(dtx,i)<> 0 then
begin
bn := ft.charset;
ft.charset := 134;
break;
end
end
dtx2 := copy(dtx,qmzfs,ct);
r[0]+=(qmzfs-1)* FCharWidth;
r[2]:= r[0]+ct * FCharWidth;
cvs.DrawText(dtx2,r,DT_NOPREFIX);
end
if bn <> 100000 then
begin
ft.charset := bn;
end
end
function paintlinestext(RC,FirstLine,LastLine,FirstCol,LastCol);virtual;
begin
cvs := canvas;
cvs.font := font;
crect := ClientRect;
rnzf := integer(crect[2]/FCharWidth)+10;
for i := FirstLine to LastLine do
begin
r := RC;
r[0]:= FGutter.width-(FLeftChar-1)* FCharWidth;
r[1]:= RC[1]+fTextHeight * iy;
iy++;
r[3]:= r[1]+fTextHeight;
dtx := fLines.GetStringByIndex(i);
tl := length(dtx);
DrawLongString(cvs,dtx,tl,r,rnzf);
end
end
function PositionChanged();virtual;
begin
tp := GetYpos();
flg := false;
if FTopLine <> tp+1 then
begin
FTopLine := tp+1;
flg .|= 1;
end
tp := GetXpos();
if tp+1 <> FLeftChar then
begin
FLeftChar := tp+1;
flg .|= 2;
end
if flg or FSetPostioned then
begin
//echo "\r\nupdate:",flg," ",datetimetostr(now());
UpdateCaret();
end
FSetPostioned := 0;
InvalidateRect(nil,false);
end
public //滚动刷新,构造
function IncPaintLock();
begin
BeginUpdate();
end
function DecPaintLock();
begin
EndUpdate();
end
function UpDateScroll();
begin
DoControlAlign();
end
Function DoControlAlign();override;
begin
if(IsUpDating())then
begin
FScroolChanged := true;
end else
begin
rc := ClientRect;
fCharsInWindow := integer((rc[2]-rc[0]-FGutter.width)/FCharWidth);
fLinesInWindow := integer((rc[3]-rc[1])/fTextHeight);
InitialScroll();
CaretXY := CaretXY;
UpdateCaret();
end
end
function Create(AOwner);override;
begin
inherited;
FSymchars := array();
ftmemlockv := new tcountkernel();
FGutterColor := rgb(228,228,228);
fcurrentLineColor := rgb(232,232,255);
fselectbkcolor := rgb(192,192,192);
FReadOnly := false;
FLineInterval := 4;
FGutterCharCount := 4;
Fautogutterwidth := false;
FSelectionMode := smNormal;
FGutter := new TMemoGutter(self);
FGutter.Width := 5+Font.Width * FGutterCharCount+1;
fLines := new TMemoLineList(self(true));
FInPutCache := 0;
fLines.Text := "";
AutoScroll := 3;
ThumbTrack := TRUE;
fMaxCharsInRow := 64; //128; //默认宽度
FCharHeight := Font.Height;
FCharWidth := Font.Width;
fTextHeight := FCharHeight+6;
rc := ClientRect;
fCharsInWindow := integer((rc[2]-rc[0])/FCharWidth);
fLinesInWindow := integer((rc[3]-rc[1])/fTextHeight);
FTopLine := 1;
FLeftChar := 1;
FMarginTop := 0;
fCaretX := 1;
fCaretY := 1;
FSetPostioned := 0;
fBlockBegin := array(1,1);
fBlockEnd := array(1,1);
//*********************************
fUndoList := new TTslMenoUndoList();
fRedoList := new TTslMenoUndoList();
end
function ClipCursor(); //固定光标区域
begin
FMouseIsDown := true;
crect := ClientRect;
ps := array(clienttoscreen(crect[0],crect[1]),clienttoscreen(crect[2],crect[3]));
_wapi.clipcursor(ps);
end
function UnClipCursor(); //解除固定区域
begin
if FMouseIsDown then
begin
FMouseIsDown := false;
_wapi.ClipCursor(0);
end
end
function ComputeAndSelToCaret(y,x);//计算光标位置
begin
xy := PixelsToRowColumn(x,y);
ExecuteCommand(ecSelGotoXY,xy);
end
function ClearSelBlock(); //清楚选中
begin
bg := BlockBegin;
ed := BlockEnd;
fBlockBegin := array(FCaretY,FCaretX);
fBlockEnd := array(FCaretY,FCaretX);
if (bg and ed) and bg<>ed then
begin
//InvalidateLines(bg[0],ed[0]);
InvalidateRect(nil,false);
end
end
function TrySetFoucs(); //设置focus
begin
if not FHasFocus then SetFocus();
end
function MouseMoveSel(x,y);//移动鼠标选择
begin
if FMouseIsDown then
begin
rc := ClientRect;
//x := e.xpos;
if x>rc[2]-5 then
begin
x +=FCharWidth+5;
end else
if x<5 then
begin
x-=FCharWidth-5;
end
//y := e.ypos;
if y>rc[3]-5 then
begin
y +=FCharWidth+5;
end else
if y<5 then
begin
y-=fTextHeight;
end
MoveCaretAndSelection(fBlockBegin,PixelsToRowColumn(x,y),true);
return ;
end
end
function MouseDown(o,e);override; //按下鼠标
begin
if ftmemlockv.locked then return ;
inherited;
if e.skip then return ;
IncPaintLock();
try
if e.Button() = mbLeft then
begin
if ssShift in e.Shiftstate() then
begin
ComputeAndSelToCaret(e.ypos,e.xpos);
end else
begin
x := e.xpos;
if fongutterclick and x>2 and x<(GutterWidth-10) then
begin
callgcall := true;
end
ComputeCaret(x,e.ypos);
ClearSelBlock();
ClipCursor();
end
TrySetFoucs();
UpDateCaret();
end else
if e.Button()=mbRight then
begin
ComputeCaret(e.xpos,e.ypos);
end
finally
DecPaintLock();
end ;
if callgcall then
begin
if fongutterclick then
begin
CallMessgeFunction(fongutterclick,o,e);
end
//echo "\r\n callgutter->:",CaretY;
end
end
function MouseMove(o,e);override;//移动
begin
return MouseMOVESel(e.xpos,e.ypos);
end
function WMIMECHAR(o,e):WM_IME_CHAR;//imechar处理,无用到
begin
return;
r := " ";
w := e.wparam;
msk :=(_shl(1,8)-1);
r[2]:= chr(w .& msk);
r[1]:= chr(_shr(w,8).& msk);
//echo r,"\r\n";
//ExecuteCommand(ecString,r);
//echo "\r\nime:",e.wparam;
end
function MouseUp(o,e);override;
begin
if ftmemlockv.locked then return ;
inherited;
if e.skip then return;
UnClipCursor();
end
function dosetfocus(o,e);override; //获得焦点
begin
FHasFocus := true;
CreateCaret();
UpDateCaret();
end
function dokillfocus(o,e);override; //失却焦点
begin
FHasFocus := false;
DestroyCaret();
end
function ReCreateCaret();
begin
if FHasFocus then
begin
DestroyCaret();
CreateCaret();
UpDateCaret();
end
end
function keypress(o,e);override; //输入字符
begin
if ftmemlockv.locked then return ;
if e.skip then return;
c := e.wparam;
if ReadOnly then return;
if c=13 then return CharInput("\r\n");
if c<32 and not(c in array(9))then return;
cc := e.char;
//if e.CharCode=VK_TAB then return inherited;
/////////////////处理特殊的gbk编码的字符比如:弢//20240429////////////////////////////
if FInPutCache then
begin
cc := FInPutCache+cc;
FInPutCache:=0;
end else
if (c .& 0x80)<> 0 then
begin
FInPutCache := cc;
return ;
end
CharInput(cc);
return inherited;
/////////////gbk汉字编码可能存在不全面/////////////////////////////////////
if(c .& 0x80)<> 0 then
begin
if FInPutCache then
begin
cc := FInPutCache+cc;
FInPutCache := 0;
CharInput(cc);
end else
begin
FInPutCache := cc;
return;
end
end else
begin
FInPutCache := 0; //修正char 猜可能出现问题
CharInput(cc);
end
inherited;
//////////////////////////////////////////////////
end
function InsertChars(s);virtual;//当前位置插入字符
begin
if not(ifstring(s) {and s})then return;
if SelAvail then
begin
SelText := s;
return;
end
if not s then return;
bb := array(fCaretY,fCaretX);
r := buffer_InsertChars(bb,s);
fUndoList.AddChange(crInsert,bb,r,s,0);
SetCaretXY(r);
UpdateCaret();
memtextchanged(bb);
end
function DoTextChanged(p);virtual;//文本改变
begin
//改变
if fonchanged then
begin
e := new tuieventbase(0,0,0,0);
CallMessgeFunction(fonchanged,self(true),e);
end
end
function DoCaretPosChanged();virtual;//caret位置改变
begin
if foncaretposchanged and ( fcaretcreated or ReadOnly) then
begin
e := new tuieventbase(0,0,0,0);
CallMessgeFunction(foncaretposchanged,self(true),e);
end
end
function ClearUndo(); //清空undo
begin
fUndoList.Clear();
fRedoList.Clear();
end
function ClearAll();//清空
begin
fLines.text := "";
FCaretX := FCaretY := 1;
fBlockBegin := array(1,1);
fBlockEnd := array(1,1);
ClearUndo();
memtextchanged(array(1,1));
end
function Undo();
begin
if fUndoList.CanUndo then
begin
lk := new tcountlocker(ftmemlockv);
try
UndoItem();
except
ClearUndo();
end
end
end
function Redo();
begin
if fRedoList.CanUndo then
begin
lk := new tcountlocker(ftmemlockv);
try
RedoItem();
except
ClearUndo();
end
end
end
function CharInput(c);virtual;//插入字符
begin
if not ReadOnly then return InsertChars(c);
end
function ExecuteCommand(cmd,data);override;//执行命令
begin
{**
@explan(说明) 执行操作 %%
@param(cmd)(TCustomMemoCmd) 操作码 %%
@param(data)(any) 操作码对应的数据 %%
**}
IncPaintLock();
try
case cmd of
"symchars":
begin
if ifstring(data) then
begin
FSymchars := array();
for i := 1 to length(data) do
begin
vi := data[i];
if vi= "\t" or vi="\r" or vi="\n" or vi="\b" then
begin
continue;
end
FSymchars[vi] := true;
end
return ;
end
r := "";
for i,v in FSymchars do r+=i;
return r;
end
"ecruningto":
begin
if Fecruningto <> data then
begin
Fecruningto := data;
InvalidateRect(nil,false);
end
end
ecTab:
begin
if ifstring(data)and data then
begin
b1 := BlockBegin;
b2 := BlockEnd;
endb := 1;
if ifarray(b1)and ifarray(b2)and b2[0]>b1[0]then
begin
odm := FSelectionMode;
FSelectionMode := smLine;
s := SelText;
ss := str2array(s,"\r\n");
ins := "";
len := length(ss)-1;
for i,v in ss do
begin
ins += data+v;
if i<len then ins += "\r\n";
else
begin
endb := length(v)+length(data)+1;
end
end
SelText := ins;
FSelectionMode := odm;
fBlockBegin := array(b1[0],1);
fBlockEnd := array(b2[0],endb);
end
end
end
ecShiftTab:
begin
if formatShiftTab(data)then
begin
b1 := BlockBegin;
b2 := BlockEnd;
if ifarray(b1)and ifarray(b2)and b2[0]>b1[0]then
begin
odm := FSelectionMode;
FSelectionMode := smLine;
s := SelText;
ss := str2array(s,"\r\n");
ins := "";
len := length(ss)-1;
endb := 1;
for i,v in ss do
begin
lv := length(v);
indata := false;
for idata,vdata in data do
begin
if pos(vdata,v)=1 then
begin
ldata := length(vdata);
if ldata=lv then
begin
end else
begin
ins += v[ldata+1:];
end
endb := lv-ldata+1;
indata := true;
break;
end
end
if not indata then
begin
ins += v;
endb := lv+1;
end
if i<len then ins += "\r\n";
end
if s=ins then return FSelectionMode := odm;
SelText := ins;
FSelectionMode := odm;
fBlockBegin := array(b1[0],1);
fBlockEnd := array(b2[0],endb);
end
end
end
ecClearAll:
begin
ClearAll();
end
ecLineBreak:
begin
InsertChars("\r\n");
end
ecEditorTop,ecSelEditorTop:
begin
MoveCaretAndSelection(array(fCaretY,fCaretX),array(1,1),ecSelEditorTop=cmd);
end
ecEditorBottom,ecSelEditorBottom:
begin
cn := array(fLines.length(),1);
cn[1]:= fLines[cn[0]-1].StrLength()+1;
MoveCaretAndSelection(array(fCaretY,fCaretX),cn,ecSelEditorBottom=cmd);
end
ecString:
begin
InsertChars(data);
end
ecLineEnd,ecSelLineEnd:
begin
s := fLines.GetStringByIndex(fCaretY-1); //[fCaretY-1];
if not ifstring(s)then return;
MoveCaretAndSelection(array(fCaretY,fCaretX),array(fCaretY,length(s)+1),ecSelLineEnd=cmd);
end
ecLineStart,ecSelLineStart:
begin
nx := 1;
//////////////20230323 回到非空白行首/////////////////////////////////
if FSelectionMode=smNormal then
begin
s := fLines.GetStringByIndex(fCaretY-1); //[fCaretY-1];
if ifstring(s) and s then
begin
for i := 1 to length(s) do
begin
vi := s[i];
if vi<>" " or vi="\t" then
begin
nx := i;
if fCaretX = nx then nx := 1;
break;
end
end
end
end
//////////////////////////////
MoveCaretAndSelection(array(fCaretY,fCaretX),array(fCaretY,nx),ecSelLineStart=cmd);
end
ecLeft,ecSelLeft:
begin
MoveCaretHorz(-1,ecSelLeft=cmd);
end
ecRight,ecSelRight:
begin
MoveCaretHorz(1,ecSelRight=cmd);
end
ecDown,ecSelDown:
begin
MoveCaretVert(1,cmd=ecSelDown);
end
ecUp,ecSelUp:
begin
MoveCaretVert(-1,cmd=ecSelUp);
end
ecPageTop,ecSelPageTop:
begin
MoveCaretAndSelection(self.CaretXY,array(fCaretY,FTopLine),cmd=ecSelPageTop);
end
ecPageDown:
begin
MoveCaretVert(GetClientYCapacity(),nil);
end
ecPageUp:
begin
MoveCaretVert(0-GetClientYCapacity(),nil);
end
ecGotoXY,ecSelGotoXY:
begin
MoveCaretAndSelection(GetCaretXY(),data,cmd=ecSelGotoXY);
end
ecWordLeft,ecSelWordLeft:
begin
nxy := PrevWordPos();
MoveCaretAndSelection(GetCaretXY(),nxy,cmd=ecSelWordLeft);
end
ecWordRight,ecSelWordRight:
begin
nxy := NextWordPos();
MoveCaretAndSelection(GetCaretXY(),nxy,cmd=ecSelWordRight);
end
ecSelectAll:
begin
SelectAll();
end
ecDeleteLastChar:
begin
if SelAvail then return SelText := "";
else
begin
ofsm := FSelectionMode;
FSelectionMode := smNormal;
SelectPrevChar();
SelText := "";
FSelectionMode := ofsm;
end
end
ecDeleteChar:
begin
if SelAvail then return SelText := "";
else
begin
ofsm := FSelectionMode;
FSelectionMode := smNormal;
SelectNextChar();
SelText := "";
FSelectionMode := ofsm;
end
end
ecDeleteLine:
begin
LL := fLines.Length();
if fCaretY=1 and LL=1 then
begin
SelectAll();
//ECHO "==",tostn(array(fBlockBegin,fBlockEnd));
SelText := "";
end else
if LL>1 then
begin
if fCaretY<LL then
begin
fBlockBegin := array(fCaretY,1);
fBlockEnd := array(fCaretY+1,1);
end else
begin
fBlockBegin := array(fCaretY-1,(fLines[fCaretY-2].StrLength())+1);
fBlockEnd := array(fCaretY,(fLines[fCaretY-1].StrLength())+1);
//echo tostn(array(fBlockBegin,fBlockEnd));
end
SelText := "";
//fLines.splices(fCaretY-1,1,array());
//SetCaretXY(array(fCaretY,1));
end
UpdateCaret();
end
ecUndo:
begin
Undo();
end
ecRedo:
begin
Redo();
end
ecCut:
begin
CutToClipboard();
end
ecPaste:
begin
PasteFromClipboard();
end
ecCopy:
begin
CopyToClipboard();
end
end
finally
DecPaintLock();
end;
end
function MoveCaretAndSelection(p1,p2,sel);//移动选择
begin
if not(ifarray(p2)and ifarray(p1)and p2[0]>= 1 and p2[1]>= 1)then return;
IncPaintLock();
SetCaretXY(p2);
if Sel then
begin
if not SelAvail then fBlockBegin := p1;
fBlockEnd := CaretXY;
InvalidateRect(nil,false); //20220729 修改刷新
{bg := GetBlockBegin();
ed := GetBlockEnd();
if ifarray(bg) and ifarray(ed) then
InvalidateLines(bg[0],ed[0]);}
end else
begin
if SelAvail then
begin
bg := GetBlockBegin()[0];
ed := GetBlockEnd()[0];
InvalidateLines(bg,ed);
end
fBlockBegin := CaretXY;
fBlockEnd := CaretXY;
end
UpDateCaret();
DecPaintLock();
end
published
property ReadOnly:bool read FReadOnly write setreadolny; //只读
property SelAvail read GetSelAvail;
property Text:text read GetMemoText write SetMemoText; //文本
property TopLine read FTopLine write SetTopLine; //首行
property LeftChar read FLeftChar write SetLeftChar;
property CharsInWindow:Integer read fCharsInWindow;
property LinesInWindow:Integer read fLinesInWindow;
property LineHeight read fTextHeight; //行高
property BlockBegin:TPoint read GetBlockBegin write SetBlockBegin;
property BlockEnd:TPoint read GetBlockEnd write SetBlockEnd;
property CaretX:Integer read fCaretX write SetCaretX;
property CaretY:Integer read fCaretY write SetCaretY;
property CaretXY:TPoint read GetCaretXY write SetCaretXY;
property SelText read GetSelText write SetSelTextExternal; //选中文本
property LineText:AnsiString read GetLineText write SetLineText; //当前行
property Lines read fLines; //文本集合
property SelectionMode read FSelectionMode write SetSelectionMode;
property GutterWidth read GetGutterWidth;
property LineInterval read FLineInterval write SetLineInterval;//行间距
property GutterCharCnt:integer read FGutterCharCount write SetGutterCharCnt;
property autogutterwidth:bool read Fautogutterwidth write setautogutterwidth;
property currentLineColor:color read fcurrentLineColor write setcurrentLineColor;
property guttercolor:color read fguttercolor write setguttercolor; //行标颜色
property selectbkcolor:color read fselectbkcolor write setselectbkcolor; //选中的颜色
property ongutterclick:eventhandler read fongutterclick write fongutterclick;
property onchanged:eventhandler read fonchanged write fonchanged;
property oncaretposchanged:eventhandler read foncaretposchanged write foncaretposchanged;
{**
@param(ReadOnly)(bool) 是否只读%%
@param(Text)(string) 文本%%
@param(CaretX)(integer) 光标x坐标%%
@param(CaretY)(integer) 光标y坐标%%
@param(SelText)(string) 选中的字符串%%
@param(LineText)(string) 当前行字符串%%
@param(GutterCharCnt)(integer) 行号的宽度%%
**}
public
function FontChanged(o);override;
begin
inherited;
FCharWidth := Font.width;
FGutter.Width := (5*(FGutterCharCount>0))+FGutterCharCount * FCharWidth+1;
FCharHeight := Font.Height;
fTextHeight := FCharHeight+FLineInterval;
ReCreateCaret();
UpDateScroll();
end
function UpDateCaret(); //更新光标
begin
if IsUpDating()then return fForceCaret := true;
fForceCaret := false;
if not fcaretcreated then return;
if HandleAllocated()then
begin
if fCaretX >= fLeftChar and(fCaretX<fCharsInWindow+fLeftChar)and FTopLine <= fCaretY and fCaretY<FTopLine+fLinesInWindow then
begin
_wapi.SetCaretPos(FGutter.Width+FCharWidth *(FCaretX-FLeftChar),(fTextHeight *(fCaretY-FTopLine)+3));
//_wapi.ShowCaret(self.Handle);
if not FIsCaretShow then
begin
_wapi.ShowCaret(self.Handle);
FIsCaretShow := true;
end
end else
begin
if FIsCaretShow then
begin
_wapi.HideCaret(self.Handle);
FIsCaretShow := false;
end
end
end
end
function InvalidateLines(FirstLine,LastLine:integer);virtual;//刷新行
begin
if not HandleAllocated()then return;
fy :=(FirstLine-FTopLine)* fTextHeight;
ly :=(LastLine-FTopLine+1)* fTextHeight;
r := ClientRect;
if ly<r[1]then return;
if fy>r[3]then return;
r[0]:= FGutter.Width;
r[1]:= max(0,fy);
r[3]:= min(r[3],ly);
InvalidateRect(r,false);
end
function DestroyHandle();override; //销毁句柄
begin
DestroyCaret();
FHasFocus := false;
inherited;
end
function MergeLastUndo(); //合并最近的两次操作
begin
fUndoList.MergeReplaceItem(); //
end
function Recycling();override;
begin
fongutterclick := nil;
inherited;
end
protected
function PrevWordPos(); //处理选择截断
begin
cy := FCaretY;
cx := FCaretX;
bx := cx;
if cy<1 then cy := 1;
if cy>fLines.Length()then cy := fLines.Length();
s := fLines[cy-1].FStr;
ls := length(s);
cx := min(ls+1,cx);
ci := 0;
while cx>1 do
begin
cx--;
//vi := s[cx];
//if FSymchars[vi] then continue;
//ivi := ord(vi);
ivi := getchar(s,cx);
{if (ivi<=0x2f) or (ivi>122 and ivi<=127) then
begin
ci++;
break;
end }
if if_c_sym(s,cx,ls,lx) then //处理中文符号
begin
cx++;
ci--;
break;
end
if(ivi<48)or(ivi>57 and ivi<65)or(ivi>90 and ivi<95)or(ivi>95 and ivi<97)or(ivi>122 and ivi <= 127)then
begin
ci++;
break;
end
end
rcx := cx+(ci?1:0);
if rcx=bx and rcx>1 then rcx--;
return array(cy,rcx);
end
function NextWordPos(); //处理选择截断
begin
cy := FCaretY;
cx := FCaretX;
if cy<1 then cy := 1;
if cy>fLines.Length()then cy := fLines.Length();
s := fLines[cy-1].FStr;
ls := length(s);
cx := min(ls+1,cx);
ci := 0;
while cx <= ls do
begin
//vi := s[cx];
//if FSymchars[vi] then continue;
//ivi := ord(vi);
ivi := getchar(s,cx);
//if (ivi<=0x2f) or (ivi>122 and ivi<=127) then break;
if if_c_sym(s,cx,ls) then //处理中文符号
begin
break;
end
if(ivi<48)or(ivi>57 and ivi<65)or(ivi>90 and ivi<95)or(ivi>95 and ivi<97)or(ivi>122 and ivi <= 127)then break;
ci++;
cx++;
end
return array(cy,cx+(ci?(0):1));
end
private //属性设置函数
function getclipboard();//获得clipbord
begin
if not FCopyer then
begin
FCopyer := new TcustomClipBoard(self);
end
end
function memtextchanged(p);
begin
if not(fundoing or fredoing) then
begin
fRedoList.Clear();
end
autosetgtwidth();
return DoTextChanged(p);
end
function setcurrentLineColor(c);
begin
if ifnumber(c) and c<>fcurrentLineColor then
begin
fcurrentLineColor := c;
r := carety;
InvalidateLines(r,r);
end
end
function setguttercolor(c);
begin
if ifnumber(c) and c<>fguttercolor then
begin
fguttercolor := c;
InvalidateRect(nil,false);
end
end
function setselectbkcolor(c);
begin
if c<>fselectbkcolor then
begin
fselectbkcolor := c;
b1 := BlockBegin;
b2 := BlockEnd;
if b1<>b2 then
begin
InvalidateRect(nil,false);
end
end
end
function setreadolny(n);
begin
nv := n?true:false;
if nv<>FReadOnly then
begin
FReadOnly := nv;
if FHasFocus then
begin
if FReadOnly then
begin
DestroyCaret();
end else
begin
CreateCaret();
UpDateCaret();
end
end
end
end
function SetLineInterval(n);
begin
if not(n>=0) then return n;
nn := integer(n);
if nn<>FLineinterval then
begin
FLineinterval := nn;
fTextHeight := FCharHeight+FLineInterval;
IncPAintLock();
UpDateScroll();
DecPaintLock();
end
end
function autosetgtwidth();//调整行号宽度
begin
if not Fautogutterwidth then return ;
n := Lines.Length();
nccnt := max(integer(n~10)+2,3);
if FGutterCharCount <> nccnt then
begin
SetGutterCharCnt(nccnt,true);
end
end
function setautogutterwidth(v);//设置自动调整宽度
begin
nv := v?true:false;
if nv<>Fautogutterwidth then
begin
Fautogutterwidth := nv;
if nv then
begin
autosetgtwidth();
end
end
end
function SetGutterCharCnt(n,f); //设置行号宽度
begin
if Fautogutterwidth and ifnil(f) then return ;
if not(n>=0 ) then return ;
nn := integer(n);
if nn<>FGutterCharCount then
begin
FGutterCharCount := nn;
FGutter.Width := (5*(FGutterCharCount>0))+FGutterCharCount*FCharWidth+1;
InValidateRect(nil,false);
end
end
function formatShiftTab(d);
begin
if ifarray(d)and d then
begin
for i,v in d do
begin
if not ifstring(v)then return 0;
if not v then return 0;
end
return true;
end
return 0;
end
function SelectAll(); //全选
begin
fBlockBegin := array(1,1);
fBlockEnd := fBlockBegin;
len := fLines.Length();
if len>0 then
begin
fBlockEnd := array(len,1+fLines[len-1].StrLength());
InvalidateRect(nil,false);
end else
end
function CopyToClipboard(); //复制选择
begin
r := GetSelText();
if r then
begin
getclipboard();
FCopyer.text := r;
return true;
end
end
function PasteFromClipboard();
begin
//if ReadOnly then return ;
getclipboard();
//s := FCopyer.Text;
//echo length(s),"\r\n";
if SelAvail then SelText := FCopyer.Text;
else InsertChars(FCopyer.Text);
end
function CutToClipboard();
begin
if SelAvail then
begin
s := SelText;
CopyToClipboard();
SelText := "";
//缓存
end
end
function SetSelectionMode(v);
begin
if(v <> FSelectionMode)and(v in array(smNormal,smLine))then FSelectionMode := v;
end
function MoveCaretHorz(stp,sel);
begin
if stp<0 and fCaretX <= 1 then return;
s := fLines[fCaretY-1].FStr;
if not ifstring(s)then return;
ls := length(s);
if stp>0 and fCaretX >= ls+1 then return;
nx := stp+fCaretX;
if stp>0 then
begin
if nx>ls then nx := ls+1;
else if bytetype(s,nx)=2 then nx := nx+1;
end else
begin
if nx <= 1 then nx := 1;
if bytetype(s,nx)=2 then nx -= 1;
end
MoveCaretAndSelection(array(fCaretY,fCaretX),array(fCaretY,nx),sel);
//UpdateCaret();
end
function MoveCaretVert(stp,sel);
begin
return MoveCaretAndSelection(array(fCaretY,fCaretX),array(max(1,fCaretY+stp),fCaretX),sel);
if SelAvail then
begin
bg := GetBlockBegin();
ed := GetBlockEnd();
fBlockBegin := CaretXY;
fBlockEnd := CaretXY;
InvalidateLines(bg[0],ed[0]);
end
//SetCaretXY(array(fCaretY+stp,fCaretX));
//UpdateCaret();
end
function GetGutterWidth();
begin
return FGutter.Width;
end
function UndoItem();
begin
item := fUndoList.PopItem();
if not item then return;
IncPaintLock();
tarr := array();
idx := 0;
while item do
begin
tarr[idx]:= item;
item := item.FLinkItem;
idx++;
end
for i := length(tarr)-1 downto 0 do
begin
fRedoList.AddChange(tarr[i]);
if i<idx-1 then
begin
fRedoList.MergeReplaceItem();
end
end
fUndoList.Lock();
fundoing := true;
for i := length(tarr)-1 downto 0 do
begin
item := tarr[i];
case item.FReason of
crInsert:
begin
//删除
fBlockBegin := item.FStartPos;
fBlockEnd := item.FEndPos;
SelText := "";
end
crDelete:
begin
//插入
SetCaretXY(item.FStartPos);
InsertChars(item.FStr);
//echo tostn(item);
end
end
end
fUndoList.UnLock();
fundoing := false;
DecPaintLock();
//处理
end
function RedoItem();
begin
item := fRedoList.PopItem();
if not item then return;
IncPaintLock();
tarr := array();
idx := 0;
while item do
begin
tarr[idx]:= item;
item := item.FLinkItem;
idx++;
end
fredoing := true;
for i := length(tarr)-1 downto 0 do
begin
item := tarr[i];
case item.FReason of
crInsert: //插入
begin
SetCaretXY(item.FStartPos);
InsertChars(item.FStr);
end
crDelete: //删除
begin
fBlockBegin := item.FStartPos;
fBlockEnd := item.FEndPos;
SelText := "";
end
end;
if i<idx-1 then
begin
fUndoList.MergeReplaceItem();
end
end
fredoing := false;
DecPaintLock();
end
function GetLineText();
begin
if fCaretY>0 and fCaretY <= fLines.Length()then return fLines.GetStringByIndex(fCaretY-1);
return "";
end
function SetLineText(s);
begin
if ifstring(s)and fCaretY>0 and fCaretY <= fLines.Length()then
begin
fLines.SetValueByIndex(fCaretY-1,s);
memtextchanged(array(fcarety,1));
//InvalidateLines(fCaretY-1,fCaretY-1);
end
end
function EnsureCursorPosVisible();
begin
IncPaintLock();
try
lct := max(1,LinesInWindow);
if FCaretX<LeftChar then
begin
LeftChar := FCaretX;
end else
if FCaretX>CharsInWindow+LeftChar-1 then
begin
LeftChar := FCaretX-CharsInWindow+1;
end
{if FCaretY < TopLine then
begin
TopLine := max(1,FCaretY-1); // -1
end
else if FCaretY > TopLine + Max(1, LinesInWindow) - 1 then
begin
TopLine := max(1,FCaretY - (LinesInWindow - 1)+1); //+1
end else
else
begin
//if fCaretLineNeedPaint then InvalidateLines(FCaretY,FCaretY);
fCaretLineNeedPaint := false;
end }
tl := TopLine;
vl := tl+lct;
if fCaretY >= tl and fCaretY <= vl then
begin
//fCaretLineNeedPaint := false;
end else
begin
TopLine := fCaretY;
end
finally
DecPaintLock();
end;
end
function GetCaretXY();
begin
return array(fCaretY,fCaretX);
end
function SetCaretXY(cxy);
begin
if not(ifarray(cxy)and cxy[0]>0 and cxy[1]>0)then return;
if cxy[0]>fLines.length()then cxy[0]:= fLines.Length();
cxy[1]:= Column2StrPos(cxy[0],cxy[1]);
docc := 0;
if cxy[1]<> fCaretX or cxy[0]<> fCaretY then
begin
IncPaintLock();
try
if fCaretX <> cxy[1]then
begin
docc := 1;
fCaretX := cxy[1];
end
if fCaretY <> cxy[0]then
begin
docc := 2;
fCaretY := cxy[0];
if fLastCaretY <> fCaretY then
begin
if fLastCaretY then InvalidateLines(fLastCaretY,fLastCaretY);
InvalidateLines(fCaretY,fCaretY);
end
fLastCaretY := fCaretY;
end
EnsureCursorPosVisible();
if docc then DoCaretPosChanged(); //之前在finally后
finally
DecPaintLock();
end;
end
end
function getcurrentselpos(pa,pb);
begin
pa := BlockBegin;
pb := BlockEnd;
end
function SetBlockBegin(p);
begin
if not(ifarray(p)and p[0]>0 and p[1]>0)then return;
np := p[0:1];
if np=fBlockBegin then return;
getcurrentselpos(bg,ed);
y := min(fLines.length(),p[0]);
x := Column2StrPos(y,p[1]);
fBlockBegin := array(y,x);
IncPaintLock();
if bg and ed and pg<>ed then
begin
InvalidateLines(bg[0],ed[0]);
end
getcurrentselpos(bg,ed);
if bg and ed and pg<>ed then
begin
InvalidateLines(bg[0],ed[0]);
end
DecPaintLock();
end
function SetBlockEnd(p);
begin
if not(ifarray(p)and p[0]>0 and p[1]>0)then return;
np := p[0:1];
if np=fBlockEnd then return;
getcurrentselpos(bg,ed);
y := min(fLines.length(),p[0]);
x := Column2StrPos(y,p[1]);
fBlockEnd := array(y,x);
IncPaintLock();
if bg and ed and pg<>ed then
begin
InvalidateLines(bg[0],ed[0]);
end
getcurrentselpos(bg,ed);
if bg and ed and pg<>ed then
begin
InvalidateLines(bg[0],ed[0]);
end
DecPaintLock();
//if fBlockBegin <> fBlockEnd then InvalidateRect(nil,false);
end
function ComputeCaret(X,Y:Integer);
begin
xy := PixelsToRowColumn(x,y);
SetCaretXY(xy);
end
function PixelsToRowColumn(x,y);
begin
r := max(1,min(fLines.Length(),FTopLine+Integer(y/fTextHeight)));
if x<FGutter.Width then
begin
c := 1;
end else
begin
c := Column2StrPos(r,Integer((x-FGutter.Width)/fCharWidth+0.5)+FLeftChar);
end
return array(r,max(1,c));
end
function Column2StrPos(r,c);
begin
rs := FLines.GetStringByIndex(r-1); //fLines[r-1].FStr;
if not ifstring(rs)then return 1;
if length(rs)+1<c then c := length(rs)+1;
case bytetype(rs,c)of
//1: return c+1;
2:return c+1;
end
return c;
end
function GetSelText();
begin
if not GetSelAvail()then return "";
bb := GetBlockBegin();
ee := GetBlockEnd();
return buffer_getchars(bb,ee,FSelectionMode);
end
function SetCaretX(cx);
begin
x := integer(cx);
if x<1 then return;
if x <> FCaretX then SetCaretXY(array(FCaretY,x));
end
function SetCaretY(cy);
begin
y := Integer(cy);
if y<1 then return;
if y <> FCaretY then SetCaretXY(array(y,FCaretX));
end
function SetLeftChar(v);
begin
if v <> FLeftChar and v>0 then
begin
FLeftChar := v;
FSetPostioned .|= 2;
SetXPos(FLeftChar-1);
end
end
function SetTopLine(TL);
begin
if TL <> FTopLine and TL>0 then
begin
FTopLine := TL;
FSetPostioned .|= 1;
SetYPos(FTopLine-1);
end
end
function GetSelAvail();
begin
return fBlockBegin <> fBlockEnd and fBlockBegin and fBlockEnd;
end
function SelectNextChar(); //选取后一个字符
begin
s := fLines.GetStringByIndex(fCaretY-1);
ls := length(s);
fBlockBegin := array(fCaretY,fCaretX);
fBlockEnd := array(fCaretY,fCaretX);
if fCaretX <= ls then
begin
bc := 1;
if bytetype(s,fCaretX)=1 then
begin
bc := 2;
end
fBlockEnd := array(fCaretY,fCaretX+bc);
end else
if fCaretY<fLines.Length()-1 then
begin
fBlockEnd := array(fCaretY+1,1);
end
end
function SelectPrevChar(); //选取前一个字符
begin
fBlockBegin := array(fCaretY,fCaretX);
if fCaretX>1 then
begin
s := fLines.GetStringByIndex(fCaretY-1);
bc := 1;
if bytetype(s,fCaretX-1)=2 then
begin
bc := 2;
end
fBlockEnd := array(fCaretY,fCaretX-bc);
//fBlockBegin := array(fCaretY, fCaretX-bc);
end else
if fCaretY>1 then
begin
s := fLines.GetStringByIndex(fCaretY-2);
fBlockEnd := array(CaretY-1,length(s)+1);
end
end
function SetSelTextExternal(v);
begin
if ifstring(v)and SelAvail then
begin
if SelText=v then return;
IncPaintLock();
ee := GetBlockEnd();
bb := DeleteSel();
up := false;
if bb[0]=ee[0]then
begin
//InvalidateLines(bb[0],bb[0]);
end else
begin
up := true;
end
if v then
begin
bb2 := buffer_InsertChars(bb,v);
fUndoList.AddChange(crInsert,bb,bb2,v,0);
fUndoList.MergeReplaceItem();
fBlockEnd := bb2;
if bb2[0]<> bb[0]then up := true;
end else
bb2 := bb;
ExecuteCommand(ecGotoXY,bb2);
//SetCaretXY(bb2);
//if up then UpDateScroll();
//UpDateCaret();
DecPaintLock();
memtextchanged(bb);
end
end
function DeleteSel(); //删除选择
begin
//if ReadOnly then return 0;
if not GetSelAvail()then return 0;
bb := GetBlockBegin();
ee := GetBlockEnd();
if FSelectionMode=smLine then
begin
bb[1]:= 1;
ee[1]:= fLines[ee[0]-1].StrLength()+1;
end
fUndoList.AddChange(crDelete,bb,ee,GetSelText(),0);
buffer_DeleteChars(bb,ee);
fBlockBegin := fBlockEnd := bb;
return bb;
end
function GetBlockBegin();
begin
if GetSelAvail()then
begin
if fBlockEnd[0]<fBlockBegin[0]or(fBlockEnd[0]=fBlockBegin[0]and fBlockEnd[1]<fBlockBegin[1])then return fBlockEnd;
else return fBlockBegin;
end
end
function GetBlockEnd();
begin
if GetSelAvail()then
begin
if fBlockEnd[0]<fBlockBegin[0]or(fBlockEnd[0]=fBlockBegin[0]and fBlockEnd[1]<fBlockBegin[1])then return fBlockBegin;
else return fBlockEnd;
end
end
function GetMemoText();
begin
return fLines.Text;
end
function SetMemoText(v);
begin
if not ifstring(v)then return;
IncPaintLock();
//FLines.Text := v;
ExecuteCommand(ecSelectAll);
ExecuteCommand(ecString,v);
ExecuteCommand(ecGotoXY,array(0,0));
DecPaintLock();
//UpDateScroll();
end
function GetMaxCharsInRow();
begin
if fMaxCharsInRow>5 then n := fMaxCharsInRow;
else n := 5;
//return((FLines.RowMaxLength/n)+0.5)* n;
return(ceil((FLines.RowMaxLength+1)/n))* n;
end
function CreateCaret(); //构造光标
begin
if FReadOnly then return;
if fcaretcreated then return;
h := Font.Height;
hd := Handle;
_wapi.CreateCaret(hd,nil,1,h);
_wapi.ShowCaret(hd);
fcaretcreated := true;
end
function DestroyCaret(); //销毁光标
begin
if fcaretcreated then
begin
_wapi.HideCaret(self.Handle);
_wapi.DestroyCaret();
end
fcaretcreated := false;
FIsCaretShow := false;
end
FHasFocus;
//buffer 处理
function buffer_getchars(bb,ee,sm);
begin
r := "";
if sm=smLine then
begin
len := ee[0];
for i := bb[0]to ee[0] do
begin
r += fLines[i-1].FStr;
if i<len then r += "\r\n";
end
end else
begin
if bb[0]=ee[0]then
begin
s := fLines[bb[0]-1].FStr;
if not s then return "";
bg := min(bb[1],ee[1]);
ed := max(bb[1],ee[1]);
if bg<ed then return s[bg:(ed-1)]; //2023078 出错
return "";
{if ee[1]>bb[1]and ee[1]>1 then
try
r := s[bb[1]:ee[1]-1]; //可能出错,添加try
except
r := "";
end;}
end else
begin
//第一行
s := fLines[bb[0]-1].FStr;
if bb[1]<= length(s)then r += s[bb[1]:];
r += "\r\n";
//中间
for i := bb[0]to ee[0]-2 do
begin
r += fLines[i].FStr;
r += "\r\n";
end
//最后一行
s := fLines[ee[0]-1].FStr;
if s and ee[1]>1 then r += s[1:ee[1]-1];
end
end
return r;
end
function buffer_DeleteChars(bb,ee,sm); //删除选择
begin
if bb=ee then return;
if bb[0]=ee[0]then //删除一行中的
begin
str := fLines.GetStringByIndex(bb[0]-1);
str[bb[1]:ee[1]-1]:= "";
fLines.SetValueByIndex(bb[0]-1,str);
end else //多行
begin
//删除后半
str := fLines.GetStringByIndex(bb[0]-1);
if str and length(str)>= bb[1]then str[bb[1]:]:= "";
//删除前半
str2 := fLines.GetStringByIndex(ee[0]-1);
if ee[1]>1 and str2 then str2[1:ee[1]-1]:= "";
fLines.SetValueByIndex(bb[0]-1,str+str2);
//删除中间
fLines.splices(bb[0],ee[0]-bb[0],array());
end
end
function buffer_InsertChars(cxy,str,sm); //插入
begin
if not(ifstring(str)and str)then return;
ss := str2array(str,"\n");
hs := array();
for i := 0 to length(ss)-1 do
begin
v := ss[i];
lv := length(v);
if v and v[lv]="\r" then v[lv:lv]:= "";
hs[i]:= v;
fLines.UpDateMaxStringLength(length(v));
end
cx := cxy[1];
cy := cxy[0];
lenss := length(ss)-1;
ncx := cx;
ncy := cy;
//插入的行
si := fLines.GetStringByIndex(cy-1);
lsi := length(si);
if ncx>1 then
begin
si1 := si[1:ncx-1];
if lsi >= ncx then si2 := si[ncx:];
else si2 := "";
end else
begin
si1 := "";
si2 := si;
end
if length(hs)=1 then
begin
fLines.SetStringByIndex(cy-1,si1+hs[0]+si2);
ncx := cx+length(hs[0]);
end else
begin
hs[0]:= si1+hs[0];
ncx := 1+length(hs[length(hs)-1]);
if si2 then hs[length(hs)-1]+= si2;
//ncx := 1;//length(hs[length(hs)-1]);
ncy += length(hs)-1;
hs1 := array();
for i,v in hs do hs1[i]:= new TMemoLineItem(v);
fLines.splices(cy-1,1,hs1);
end
return array(ncy,ncx);
end
end
type TSynCompletionList = class(TcustomListBox) //展示list
function Create(AOwner);override;
begin
inherited;
end
function CheckListItem(s);override;
begin
return true;
end
function GetItemText(i);override;
begin
r := GetItem(i);
if ifarray(r) then
begin
r := r["caption"];
if ifstring(r) then return r;
end
return r;
end
function ItemIndexInc(); //向下
begin
ItemIndex+=1;
idx := ItemIndex;
InsureItemVisible(idx);
end
function ItemIndexDec(); //向上
begin
ItemIndex-=1;
idx := ItemIndex;
InsureItemVisible(idx);
end
property ItemIndex read getCurrentSelection write SetCurrentSelection; //当前
private
function InsureItemVisible(idx); //移动当前的格子
begin
return InsureIdxInClient(idx);
end
end
type TSynCompletion = class(TSynCompletionList)
{**
@explan(说明) 语法提示自动完成 %%
**}
type TJumpPanel = class(TSynCompletionList) //跳转列表对象
function Create(AOwner);override;
begin
inherited;
FFilter := "";
color := rgb(230,230,220);
FIgnoreCase := true;
visible := false;
FJumpData := array();
end
function SetJumpData(s);
begin
FJumpData := s;
FFilter :="";
end
function Recycling();override;
begin
FJumpData := array();
OnJumpChoosed := nil;
inherited;
end
[weakref]OnJumpChoosed;
function CanJump(); //是否一跳转,可以跳转返回跳转的字符串
begin
p := parent;
if not p then return ;
s := p.CaretWords();
SetFilter(s);
if ItemCount>0 then return s;
return ;
end
function TryJump(s);//预备跳转
begin
p := parent;
if not p then return ;
if not ifstring(s) then
begin
s := p.CaretWords();
end
if not s then return ;
SetFilter(s);
ct := ItemCount;
if ct<1 then return ;
if ct = 1 then
begin
CallJump();
return;
end
mh := p.height;
w :=3+FCurrentWidth*GetXscrollDelta();
dh := GetYscrollDelta();
h := 3+dh*min(self.ItemCount,4);
p.GetCaretPos(x,y);
if y+h>mh then
begin
SetBoundsRect(array(x,y-h,x+w,y)) ;
end else
SetBoundsRect(array(x,y-dh,x+w,y+h-dh)) ;
Show();
end
function CallJump();
begin
visible := false;
it := GetItem(GetCurrentSelection());
if it then
begin
CallMessgeFunction(OnJumpChoosed,self.Owner,it);
end
end
function CancelJump(); //取消选中
begin
if Visible then Visible := false;
end
function MouseUp(o,e);override;
begin
inherited;
calljump();
end
function SetFilter(s);
begin
if not FJumpData then return ;
if not(ifstring(s) and s) then return ;
if FFilter= s then return ;
ls := lowercase(s);
lsl := length(ls);
if FIgnoreCase then
begin
cs := ls;
cindex := "lvalue";
if (lowercase(FFilter) = ls) then return ;
end else
begin
cs := s;
cindex := "value";
end
FFilter := s;
d := array();
ld :=0;
FCurrentWidth := 10;
for i,v in FJumpData do
begin
vi := v[cindex];
if vi= cs then
begin
d[ld++] := v;
FCurrentWidth := max(FCurrentWidth,v["clen"]);
end
end
SetData(d);
if d then
SetCurrentSelection(0);
else visible := false;
end
property IgnoreCase read FIgnoreCase Write SetIgnoreCase;
private
FCurrentWidth;
FIgnoreCase;
FJumpData;
FFilter;
function SetIgnoreCase(v);
begin
nv := v?true:false;
if nv<>FIgnoreCase then
begin
FIgnoreCase := nv;
end
end
end
function Create(AOwner);override;
begin
inherited;
fminmatch := 1;
fmatchfirst := true;
{$ifdef linuxpop} //处理避免闪烁
{$else}
WsPopUp := true;
{$endif}
FFilter := "";
FIgnoreCase := true;
visible := false;
FJump := new TJumpPanel(self);
end
function Mouseup(o,e);override;
begin
inherited;
FinishCompletion();
end
function PrepareCompletion(c);virtual; //获得数据
begin
//通过SetCompData 设置数据
if Not FMemo then return ;
s := FMemo.Text;
parseregexpr("[A-Zaz0-9_]+",s,"mi",mched,mchpos,mathlen);
r := array();
for ri,v in mched do
begin
v0 := v[0];
lv := lowercase(v0);
if r[lv] then continue;
r[lv] := v0;
end
d := array();
i := 0;
for lv,v in r do
begin
d[i,"caption"] := v;
d[i,"value"] := v;
d[i,"lvalue"] := lv;
cl := length(v);
d[i,"clen"] := cl;
d[i,"vlen"] := cl;
i++;
end
SetCompData(d);
end
function SetCompData(d);virtual;
begin
if FCompData = d then return ;
FCompData := array();
try
{ for i := 0 to length(d)-1 do
begin
viv := d[i,"value"];
vic := d[i,"caption"];
d["lvalue"] := lowercase(vic);
d["vlen"] := length(viv);
d["clen"] := length(vic);
end }
FCompData := select * from d order by ["vlen"],["order"] end;
JD := select * from d where ["jump"] end;
FJump.SetJumpData(JD);
except
FCompData := array();
end;
FFilter := "";
end
function TryCompletion(); //
begin
//查找字符
//存在就显示
//s := PrevWordPos
//SetFilter();
s := Memo.PrevWord();
sl := length(s);
if visible then
begin
if s and (sl>=fminmatch) then
begin
SetFilter(s);
end
else Visible := false;
end else
begin
if s and (sl>=fminmatch) then
begin
SetFilter(s);
if ItemCount>0 then
begin
mh := Memo.height;
w :=3+FCurrentWidth*GetXscrollDelta();
dh := GetYscrollDelta();
h := 3+dh*min(self.ItemCount,8);
Memo.GetCaretPos(x,y);
{$ifdef linuxpop}
xy := array(x,y);//
{$else}
xy := Memo.ClientToscreen(x,y);
{$endif }
if y+h>mh then
begin
begin
x := xy[0]; y := xy[1];
SetBoundsRect(array(x,y-dh-h-5,x+w,y-dh-5)) ;
end
end else
begin
x := xy[0]; y := xy[1];
SetBoundsRect(array(x,y,x+w,y+h)) ;
end
Show(SW_SHOWNOACTIVATE);
//Visible := true;
//Memo.SetFocus(); //setfocus
end
end
end
end
function CancelCompletion();
begin
FJump.Visible := false;
visible := false;
end
function FinishCompletion();//完成
begin
if Visible then
begin
it := GetItem(self.ItemIndex);
if not it then return false ;
s := it["value"];
fl := length(FFilter);
ls := length(s);
if it["prefix"] then
begin
end else
begin
if {completedCase()}true then
begin
if s<>FFiltero and s and ls and fl then
begin
cxy := Memo.CaretXY;
cxy[1]-=fl;
Memo.ExecuteCommand(Memo.ecSelGotoXY,cxy);
Memo.ExecuteCommand(Memo.ecString,s);
end
end else
begin
if fl<ls then
begin
ips := s[fl+1:];
Memo.ExecuteCommand(Memo.ecString,ips);
end
end
end
visible := false;
exts := it["valueext"];
if ifstring(exts) and exts then
begin
extss := str2array(exts,"\r\n");
cxy := Memo.CaretXY;
cxy[1]-=fl;
if it["prefix"] then
Memo.ExecuteCommand(Memo.ecSelGotoXY,cxy);
kgct := cxy[1];
kgcts :="";
for i := 1 to kgct-1 do
begin
kgcts+=" ";
end
s := "";
for i,v in extss do
begin
if i=0 then
begin
s+=v;
end else
begin
s+=kgcts+v;
end
s+="\r\n";
{if i=0 and it["prefix"] then
begin
cxy := Memo.CaretXY;
cxy[1]-=fl;
Memo.ExecuteCommand(Memo.ecSelGotoXY,cxy);
Memo.ExecuteCommand(Memo.ecString,v);
end else
begin
Memo.ExecuteCommand(Memo.ecString,v);
end
Memo.InsertChars("\r\n");}
end
Memo.ExecuteCommand(Memo.ecString,s);
end
return true;
end
return false;
end
{function completedCase();virtual; //区分大小写
begin
return true;
end }
function SetFilter(s); //筛选
begin
if not FCompData then return ;
if not(ifstring(s) and s) then return ;
if FFilter = s then return ;
ls := lowercase(s);
lsl := length(ls);
FFiltero := s;
if FIgnoreCase then
begin
cs := ls;
cindex := "lvalue";
if (lowercase(FFilter) = ls) then return ;
end else
begin
cs := s;
cindex := "value";
end
FFilter := s;
d := array();
ld :=0;
wd := 10;
for i,v in FCompData do
begin
vi := v[cindex];
ps := pos(cs,vi);
if (fmatchfirst?(ps=1):(ps>=1)) then
begin
d[ld++] := v;
wd := max(wd,v["clen"]);
end
end
FCurrentWidth := wd;
SetData(d);
if d then
SetCurrentSelection(0);
else visible := false;
end
function Recycling();override;
begin
SetMemo(nil);
inherited;
FCompData := array();
end
function TryJump(s); //跳转
begin
if Visible then Visible := false;
FJump.TryJump(s);
end
function CanJump(); //取消跳转
begin
return FJump.Canjump();
end
property Memo Read FMemo write SetMemo; //编辑器
property IgnoreCase read FIgnoreCase Write SetIgnoreCase; //忽略大小写
property OnJumpChoosed read GetJumpChoosed write SetJumpChoosed;
property matchfirst read fmatchfirst write fmatchfirst ;//匹配首字母
property minmatch read fminmatch write setminmatch ;//最小匹配长度
private
fminmatch;
fmatchfirst;
FCurrentWidth;
FCompData;
[weakref]FMemo;
FJump;
FIgnoreCase;
FFilter;
FFiltero;
private
function setminmatch(v);
begin
if v>=1 and v<>fminmatch then
begin
fminmatch := v;
end
end
function GetJumpChoosed();
begin
return FJump.OnjumpChoosed ;
end
function SetJumpChoosed(v);
begin
FJump.OnJumpChoosed := v;
end
function SetIgnoreCase(v);
begin
nv := v?true:false;
if nv<>FIgnoreCase then
begin
FIgnoreCase := nv;
FJump.IgnoreCase := nv;
end
end
function SetMemo(M);
begin
if M<>FMemo then
begin
tm := FMemo;
if tm then tm.Completion := nil;
FMemo := M;
IF M IS CLASS(TSynCustomMemo) then
begin
M.Completion:= self(true);
end else FMemo:= nil;
parent := FMemo;
FJump.Parent := FMemo;
//if FJump.Parent<>FMemo then FJump.Parent := FMemo;
end
end
end
type TSynHighLighter = class(TComponent) //语法高亮类型
public
hightercolor;
type thtcolor = class()
function create(cl);
begin
if cl>0 or cl<=0 then FColor := cl;
else FColor := 0;
end
property color read fcolor write fcolor;
private
fcolor;
end
Type TToken = class()
FValue; //值
FPos; //位置
FLen; //长度
FFColor; //颜色
FBKColor; //背景色
FMate; //伙伴,配对高亮
FFfacename;
FFCharset;
{static FTokenCount;
function Create();
begin
FTokenCount++;
end
function Destroy();
begin
FTokenCount--;
end }
end
function CreateAToken();virtual;
begin
return New TTOken();
end
function Create(AOwner);
begin
FCacheTokens := array();
inherited;
end
function SetInValidateIndex(idx); virtual; //当前改变的行
begin
if idx<=1 then
begin
return FCacheTokens := array();
end
ValidIndexs := array();
for i,v in FCacheTokens do
begin
if i>=idx-1 then
begin
ValidIndexs[i] := nil;
end
end
reindex(FCacheTokens,ValidIndexs);
end
function InsureTokenParserd(LastLine); virtual; //确保解析的行
begin
end
function GetLineTokens(ridx);virtual;
begin
if not Flines then return nil;
r := FCacheTokens[ridx];
if r then return r;
s := Flines.GetSTringByIndex(ridx);
if not ifstring(s) then return;
idx := 1;
len := length(s);
tks := array();
ctk :="";
while idx<= len do
begin
vi := s[idx];
if CharInSyn(vi)>0 then
begin
SetTToken(tks,ctk,idx-1);
SetTToken(tks,vi,idx);
end else
if pos(vi," \t")>0 then
begin
SetTToken(tks,ctk,idx-1);
end else
if if_c_sym(s,idx,len) then
begin
SetTToken(tks,ctk,idx-1);
ctk := s[idx:(idx+1)];
idx++;
SetTToken(tks,ctk,idx);
end else
begin
ctk+=vi;
end
idx++;
end
SetTToken(tks,ctk,idx-1);
FCacheTokens[ridx] := tks;
return tks;
end
function CharInSyn(v);virtual;
begin
if not(FSyns) then FSyns := "'~`!@#$%^&*()-+=[]{}|\\?/':;,.><"+'"';
return pos(v,FSyns);
end
function Clean();virtual;
begin
FCacheTokens := array();
end
function Recycling();virtual;
begin
SetMemo(nil);
inherited;
FCacheTokens := array();
end
property Memo read FMemo write SetMemo;
property lines read FLines;
protected
function SetTToken(tokens,ttk,idx,ext);virtual; //设置token
begin
if not ttk then return ;
lttk := length(ttk);
d := CreateAToken();
D.FValue := ttk;
d.FLen := lttk;
d.FPos := idx-lttk+1;
{
d.FFCharset := 0;
for i:= 2 to ttk step 2 do
begin
if bytetype(ttk,i)<>0 then
begin
d.FFCharset := 134;
break;
end
end }
tokens[length(tokens)] := d;
ttk := "";
return d;
end
private
FCacheTokens;
FSyns; //符号
function SetMemo(M);
begin
if Memo<>M then
begin
tfm := FMemo;
if tfm then tfm.Highlighter := nil;
FMemo := M;
if M is Class(TSynCustomMemo) then
begin
FMemo.Highlighter := self(true);
Flines := FMemo.Lines;
end else
begin
FMemo := nil;
Flines := nil;
end
//if tfm is Class(TSynCustomMemo) then tfm.Highlighter := nil;
SetInValidateIndex(1);
end
end
weakref
Flines;
FMemo;
autoref
end
type tcustomsynhighlighter = class(TSynHighLighter)
{**
@explan(说明) 通用的语法高亮类
支持单行注释,块注释,配对,字符串定义,关键字,符号%%
@data(20220915)
**}
function create(AOwner);
begin
inherited;
fsymcolor := 0xa000a0;
fnumbercolor := 0x666666;
fkeywordcolor := 0x0000ff;
fsysfuncolor := 0xff0000;
fstringcolor := 0xff00ff;
//fannotationcolor := 0xff0000;
fannotationcolor := 0xaa3300;
fignorecase := false;//忽略大小写
FChangeDeal := true;
FTokens := array();
fregs := array();
setkeyword(array("null","true","false","goto","break","for","to","while","do"));
setblockannote(array(
("/*","*/"),
));
setrowannote(array("//"));
setsyms(array("+","-","*","/",";","(",")","{","}",":"));
setstring(array(
("'","\\"),
('"',"\\"),
));
setpairs(array(
("(",")"),
("[","]"),
("{","}"),
));
setsysfun(array());
clean();
end
function ExecuteCommand(cmd,pm);override;
begin
{**
@explan(说明) 对外接口 %%
@param(cmd)(string) 命令%%
@param(pm)(array) 参数 %%
**}
case cmd of
"strings":
begin
return setstring(pm);
end
"rowannotes":
begin
return setrowannote(pm);
end
"blockannotes":
begin
return setblockannote(pm);
end
"keywords":
begin
return setkeyword(pm);
end
"syms":
begin
return setsyms(pm);
end
"sysfun":
begin
return setsysfun(pm);
end
"pairs":
begin
return setpairs(pm);
end
"regs":
begin
return setregs(pm);
end
"getcurrentpairstate":
begin
if fcbgestate then
begin
return fcbgestate[pm];
end
return nil;
end
end ;
return inherited;
end
function SetInValidateIndex(idx);override; //当前改变的行
begin
idx := max(1,idx);
fdolastline := idx-2;
if not(FChangeDeal)and idx>FSatesCount then return;
if length(FSates)>= idx then FSatesCount := idx;
else FSatesCount := length(FSates)-1;
if FSatesCount=1 then clean();
FChangeDeal := false;
end
function InsureTokenParserd(LastLine);override; //解析
begin
ls := Lines;
FChangeDeal := true;
if fdolastline>=LastLine then return ;
fdolastline := LastLine;
if hightercolor then
begin
fsymcolor := hightercolor.symcolor();
fnumbercolor := hightercolor.numcolor();
fkeywordcolor := hightercolor.keycolor();
fsysfuncolor := hightercolor.sysfunccolor();
fstringcolor := hightercolor.strcolor();
fannotationcolor := hightercolor.commentcolor();
end
for i := FSatesCount-1 to LastLine do
begin
if i<0 then continue;
s := ls.GetStringByIndex(i);
cst := FSates[i];
tks := array();
fcbgestate := array();
for jj,j in mrows(Fbgedstates,1) do
begin
v := Fbgedstates[j][i];
vj := v.Clone;
fcbgestate[j]:= vj;
Fbgedstates[j][i+1]:= vj;
end
FSates[i+1]:= ParserTokenLines(s,1,length(s),cst,tks);
FSatesCount := i+1;
FTokens[i]:= tks;
end
end
function GetLineTokens(idx);override;
begin
if idx<FSatesCount then return FTokens[idx];
end
function SetTToken(tokens,ttk,idx,ext);override; //设置token
begin
bttk := ttk;
d := inherited;
if not d then return ;
if not ext then
begin
if ifkeywords(bttk) then
begin
d.FFColor := fkeywordcolor;
end else
if ifsysfun(bttk) then
begin
d.FFColor := fsysfuncolor ;
end else
begin
dereg(d,bttk);
end
dopair(d,bttk);
end else
if ifarray(ext) then
begin
if ext[0]="str" then
begin
d.FFColor := fstringcolor;
end else
if ext[0] = "annote" then
begin
d.FFColor := fannotationcolor;
end else
if ext[0]= "sym" then
begin
d.FFColor := fsymcolor;
dopair(d,bttk);
end
end
return d;
end
function clean();override; //初始化
begin
FTokens := array();
FSates := array(0);
Fbgedstates := array();
FSatesCount := 0;
for i,v in fswordpairs do
begin
Fbgedstates[i,0]:= new tpairstate(i);
end
inherited;
end
property keywordcolor:color read fkeywordcolor write fkeywordcolor;
property sysfuncolor:color read fsysfuncolor write fsysfuncolor;
property stringcolor:color read fstringcolor write fstringcolor;
property annotationcolor:color read fannotationcolor write fannotationcolor;
property symcolor:color read fsymcolor write fsymcolor;
property numbercolor:color read fnumbercolor write fnumbercolor;
property ignorecase:bool read fignorecase write setignorecase;
private
function setignorecase(i);
begin
ni := i?true:false;
if ni<>FIgnoreCase then
begin
FIgnoreCase := ni;
for i,v in array(fstrstires ,
fkeystires,
fblockstiresa,
fblockstiresb,
frowstires,
fsysfuntires,
fsymstires) do
begin
for j,vj in v do
begin
vj.ignorecase := ni;
end
end
if fswordpairshashdata then
begin
td := fswordpairshashdata;
setpairs(td);
end
end
end
function dereg(d,ttk);
begin
for i,v in fregs do
begin
if parseregexpr(i,ttk,"",r,mp,ml)=1 then
begin
d.FFColor := v;
return ;
end
end
end
function dopair(d,bttk); //处理配对信息
begin
if FIgnoreCase then
begin
lttk := lowercase(bttk);
end else
begin
lttk := bttk;
end
n := fswordpairshash[lttk];
if n then
begin
st := fcbgestate[n];
if fswordpairs[n,2] then
begin
if st.state then
begin
st.GetRight();
end else
begin
st.GetLeft();
end
end else
begin
if fswordpairs[n][1]=lttk then
begin
st.GetRight();
end else
begin
st.GetLeft();
end
end
d.FMATe := st.GetSate();
end
end
function ParserTokenLines(s,b,e,cst,tokens); //解析字符
begin
label L_XCDG;
if cst=0 then //普通情况
begin
idx := b;
ttk := "";
while idx <= e do
begin
vi := s[idx];
if vi=" " or vi="\t" then //分隔符
begin
SetTToken(tokens,ttk,idx-1);
end else
if ifrowannote(s,e,idx,oidx,ostr) then
begin
SetTToken(tokens,ttk,idx-1);
bostr := ostr;
SetTToken(tokens,ostr,oidx-1,array("annote",bostr));
if oidx<=e then
begin
SetTToken(tokens,s[oidx:],e,array("annote",bostr));
end
return 0;
end else
if ifblockannote(s,e,idx,oidx,ostr) then //查找块注释
begin
SetTToken(tokens,ttk,idx-1);
bostr := ostr;
ncost := array("annote",bostr,fblockstiresb[bostr]);
SetTToken(tokens,ostr,oidx-1,array("annote"));
idx := oidx-1;
return ParserTokenLines(s,idx+1,e,ncost,tokens);
end else
if ifstringstart(s,e,idx,oidx,ostr) then //查找字符串
begin
SetTToken(tokens,ttk,idx-1);
bostr := ostr;
ncost := array("str",bostr,fstrstires[bostr],fstrstires_zy[bostr]);
SetTToken(tokens,ostr,oidx-1,ncost);
idx := oidx-1;
return ParserTokenLines(s,idx+1,e,ncost,tokens);
end else
if ifdefsym(s,e,idx,oidx,ostr) then //符号
begin
SetTToken(tokens,ttk,idx-1);
SetTToken(tokens,ostr,oidx-1,array("sym",ostr));
idx := oidx-1;
end else
begin
ttk+=vi;
end
idx++;
end
SetTToken(tokens,ttk,idx-1);
end else //查找
begin
if b>e then return cst;
if ifarray(cst) and (cst[0]="str" or cst[0]="annote") then
begin
r := FindRightChar(cst[2],s,b,e,cst[3]);
if r=0 then //没找到
begin
Setttoken(tokens,s[b:],e,cst);
return cst;
end else //找到
if r <= e then
begin
if b<r then
begin
Setttoken(tokens,s[b:r-1],r-1,cst);
end
if cst[0]="annote" then
begin
cstL := fblockstiresc[cst[1]];
end else
begin
cst1 := cst[1];
cstL := length(cst1);
end
Setttoken(tokens,s[r:(r-1+cstL)],(r-1+cstL),cst);
if r<e then
begin
//消除递归
b := r+cstL;
cst := 0;
goto L_XCDG;
//return ParserTokenLines(s,r+1,e,0,tokens); //递归方式
end
end
end
end
end
function setstring(d); //设置字符串信息
begin
fstrstires := array();
fstrstires_zy := array();
if not ifarray(d) then return ;
for i,v in d do
begin
if not ifarray(v) then continue;
v0 := v[0];
v1 := v[1];
if ifstring(v0) and v0 then
begin
st := new TTire();
fstrstires[v0] := st;
st.add(v0);
fstrstires_zy[v0] := v1;
end
end
end
function setkeyword(ws); //设置关键字
begin
st := new TTire();
for i,v in ws do
begin
if v and ifstring(v) then st.add(v);
end
fkeystires := array(st);
end
function setblockannote(d); //设置块注释
begin
fblockstiresa := array();
fblockstiresb := array();
fblockstiresc := array();
if not ifarray(d) then return ;
for i,v in d do
begin
if not ifarray(d) then continue ;
v0 := v[0];
v1 := v[1];
if ifstring(v0) and ifstring(v1) and v0 and v1 then
begin
st := new TTire();
st.add(v0);
fblockstiresa[v0] := st;
st := new TTire();
st.add(v1);
fblockstiresb[v0] := st;
fblockstiresc[v0] := length(v1);
end
end
end
function setrowannote(d);//设置行注释
begin
frowstires := array();
if not ifarray(d) then return ;
for i,v in d do
begin
if v and ifstring(v) then
begin
st := new TTire();
frowstires[v] := st;
st.add(v);
end
end
end
function setsysfun(d);//设置系统函数
begin
st := new TTire();
fsysfuntires := array(st);
if not ifarray(d) then return ;
for i,v in d do
begin
if ifstring(v) and v then
begin
st.add(v);
end
end
end
function setsyms(d);//设置符号
begin
st := new TTire();
fsymstires := array(st);
for i,v in d do
begin
if ifstring(v) and v then
begin
st.add(v);
end
end
end
function setregs(d);
begin
fregs := array();
for rg,v in d do
begin
if ifnil(v) then continue;
if not(rg and ifstring(rg)) then continue;
fregs[rg] := v
end
end
function setpairs(d);//设置配对
begin
fswordpairs := array();
fswordpairshash := array();
fswordpairshashdata := array();
if not ifarray(d) then return ;
for i,v in d do
begin
if not ifarray(v) then continue;
v0 := v[0];
v1 := v[1];
if FIgnoreCase then
begin
v0 := lowercase(v0);
v1 := lowercase(v1);
end
if ifstring(v0) and ifstring(v1) and v0 and v1 then
begin
fswordpairs[v1,0]:= v0;
fswordpairs[v1,1]:= v1;
fswordpairs[v1,2] := (v0=v1);
fswordpairshash[v0]:=v1;
fswordpairshash[v1]:=v1;
fswordpairshashdata[i] := v;
end
end
end
function cyclefind(cys,s,l,idx,oidx,ostr,tidx);
begin
r := 0;
if not ifarray(cys) then return r;
for i,v in cys do //字符串
begin
if v.find(s,l,idx,oidx,ostr) then
begin
r := 1;
tidx := i;
break;
end
end
return r;
end
function ifblockannote(s,l,idx,oidx,ostr,tidx);//是否为块注释
begin
return cyclefind(fblockstiresa,s,l,idx,oidx,ostr,tidx);
end
function ifrowannote(s,l,idx,oidx,ostr,tidx);//是为
begin
return cyclefind(frowstires,s,l,idx,oidx,ostr,tidx);
end
function ifstringstart(s,l,idx,oidx,ostr,tidx); //字符串判断
begin
return cyclefind(fstrstires,s,l,idx,oidx,ostr,tidx);
end
function ifkeywords(s);//关键字判断
begin
for i,v in fkeystires do
begin
if v.find(s,length(s),1,idx,ostr) and (ostr=s) then
return true;
end
end
function ifsysfun(s);//系统函数判断
begin
for i,v in fsysfuntires do
begin
if v.find(s,length(s),1,idx,ostr) and (ostr=s) then
return true;
end
end
function ifdefsym(s,l,idx,oidx,ostr,tidx); //符号判断
begin
return cyclefind(fsymstires,s,l,idx,oidx,ostr,tidx);
end
function FindRightChar(vo,s,b,e,zy); //查找封闭的字符
begin
i := b;
if not vo then return 1;
while i <= e do
begin
si := s[i];
if si=zy then
begin
i += 2;
if i>e then return 0;
continue;
end
if vo.find(s,e,i,oidx,ostr) then
begin
return i;
end
i++;
end
return 0; //没找到
end
private
FSatesCount ;// 状态行号
FChangeDeal;//改变flag
fignorecase; //忽略大小写
//前后匹配
Fbgedstates;
fcbgestate;//当前匹配
///
FSates; //当前状态
FTokens;
fdolastline; //已经处理到行
///////tire树/////////////
fkeystires;
fstrstires;
fstrstires_zy;
fsymstires;
fsysfuntires;
frowstires;
fblockstiresa;
fblockstiresb;
fblockstiresc;
fregs;
/////
fkeywordcolor;
fsysfuncolor;
fstringcolor;
fannotationcolor;
fsymcolor;
fnumbercolor;
//
fswordpairs;
fswordpairshash;
fswordpairshashdata;
end
type TSynCustomMemo = class(TCustomMemo)
{**
@explan(说明) 语法编辑器 %%
**}
function DoTextChanged(p);override;//文本改变
begin
inherited;
if Highlighter then
Highlighter.SetInValidateIndex(p[0]);
end
function MouseUp(o,e);override;
begin
inherited;
if e.Button() = mbRight then
begin
CallMessgeFunction(OnRClick,o,e);
end
end
function ExecuteCommand(cmd,data);override;
begin
case cmd of
ecLeft:
begin
if data=1 then
begin
xy := CaretXY;
y := xy[0];
x := xy[1];
if x=1 and y>1 then
begin
s := Lines.GetStringByIndex(y-2);
if ifstring(s) then
return ExecuteCommand(ecGotoXY,array(y-1,length(s)+1));
end
end
end
ecRight:
begin
if data=1 then
begin
xy := CaretXY;
y := xy[0];
if y<Lines.Length() then
begin
x := xy[1];
s := Lines.GetStringByIndex(y-1);
if ifstring(s) and (length(s)+1=x) then
begin
return ExecuteCommand(ecGotoXY,array(y+1,1));
end
end
end
end
ecDeleteLastChar:
begin
if data = 1 then
begin
tc := TabChar;
x := CaretX;
ltc := length(tc);
if x>ltc then
begin
s := LineText;
if tc = s[x-ltc:x-1] then
begin
ExecuteCommand(ecSelGotoXY,array(CaretY,x-ltc));
SelText:="";
return ;
end
end
end
return inherited ExecuteCommand(ecDeleteLastChar);
end
end
return inherited;
end
function PrepareCompletion(c);//准备完成
begin
if Completion then return Completion.PrepareCompletion(c);
end
function TryCompletion();//提示
begin
if Completion then return Completion.TryCompletion();
end
function TryJump(s); //跳转
begin
if Completion then return CompLEtion.TryJump(s);
end
function Canjump(); //是否可以跳转到当前字符串
begin
if Completion then return Completion.Canjump();
end
function FinishCompletion(); //完成填充
begin
if Completion and Completion.Visible then return Completion.FinishCompletion();
end
function CancelCompletion(); //取消填充
begin
if Completion then return Completion.CancelCompletion();
end
function CharInput(c);override; //字符输入
begin
if ReadOnly then return ;
if c="\r\n" then
begin
if FinishCompletion() then //确定键
begin
return ;
end else
begin
return inherited;
end
end else
if c="\t" then
begin
b1 := BlockBegin;
b2 := BlockEnd;
if ifarray(b1) and ifarray(b2) and b2[0]>b1[0] then return ExecuteCommand(ectab,FTabChar);
else return inherited CharInput(FTabChar);
end
inherited;
if Completion then
begin
Completion.TryCompletion();
end
end
function Completioning(); //正在准备填充
begin
return Completion and Completion.Visible;
end
function PrevWord(); //前一个词语
begin
p := PrevWordPos();
ls := Lines;
s := ls.GetStringByIndex(p[0]-1);
sl := length(s);
cx := CaretX;
cw := "";
if p[1]<=sl and cx>p[1] then
begin
cw := s[p[1]:cx-1];
cw := trim(cw);
end;
return cw;
end
function CaretWords(); //光标所在词语
begin
e := NextWordPos();
b := PrevWordPos();
ls := Lines;
s := Lines[b[0]-1];
r := "";
if s then
begin
try
s := s.FStr;
for i:= b[1] to e[1]-1 do
begin
ivi := ord(s[i]);
if(ivi<48) or (ivi>57 and ivi<65) or (ivi>90 and ivi<95) or(ivi>95 and ivi<97) or(ivi>122 and ivi<=127) then continue;
r+=s[i];
end
except
r := "";
end;
end
return r;
end
function Create(AOwner);//构造
begin
inherited;
FCOMPOSITIONFORM := new tagCOMPOSITIONFORM(nil);
FTabChar := " ";
end
function Recycling();override; //回收
begin
if FHighlighter then
begin
FHighlighter.Clean();
SetHighlighter(nil);
end
if FCompletion then
begin
SetCompletion(nil);
end
inherited;
end
function paintlinestext(RC, FirstLine, LastLine, FirstCol, LastCol); override;
begin
if not Highlighter then return inherited;
cvs := canvas;
bfontname := cvs.font.facename;
bfc := cvs.Font.color;
Highlighter.InsureTokenParserd(LastLine);
cw := GetXScrollDelta();
//********************处理**************************************8
bb := BlockBegin;
ee := BlockEnd;
if ifarray(bb) and ifarray(ee) and bb[0]=ee[0] and bb[1]<ee[1] then
begin
selt := SelText;
selbx := bb[1];
selby := bb[0];
end
if selt then
begin
selt := lowercase(selt);
tks := Highlighter.GetLineTokens(selby-1);
for i,v in tks do
begin
if v.FPos=selbx then
begin
seltcj := v.FMate;
break;
end
end
IF seltcj then
begin
Selt := 0;
end
end
crect := ClientRect;
rnzf := integer(crect[2]/cw)+20;
//***************************************************************************************
for i := FirstLine to LastLine do
begin
tks := Highlighter.GetLineTokens(i);
r := RC;
r0 := GutterWidth-(LeftChar-1)*cw;
r[1] := RC[1]+LineHeight*iy;
r[3] := r[1]+LineHeight;
iy++;
//r[3] := r[1]+LineHeight;
for j,v in tks do
begin
val := v.FValue;
vallength := length(val);
r[0] := r0+(v.FPos-1)*cw;
r[2] := r[0]+vallength*cw;
if r[2]<crect[0] then
begin
continue;
end
if r[0]>crect[2] then
begin
break;
end
c := V.FFColor;
if ifobj(c) then c := c.color;
if ifnil(c) then c := bfc;
fn := v.FFfacename;
//bfontname := cvs.font.facename;
cvs.Font.bkmode := TRANSPARENT;
if fn then
begin
cvs.Font.Facename := fn;
end else
begin
cvs.font.facename := bfontname;
end
if (c>0) then
begin
cvs.Font.Color := c;
end
else cvs.Font.Color := bfc;
if (selt and selt = lowercase(val))or(seltcj and seltcj=v.FMate) then
begin
cvs.Font.bkColor := selectbkcolor;//0xFFE2B0;
cvs.Font.bkmode := OPAQUE;
end
DrawLongString(cvs,val,vallength,r,rnzf);
//cvs.DrawText(val,r,DT_NOPREFIX);
end
end
cvs.font.facename := bfontname;
cvs.Font.Color := bfc;
cvs.Font.bkmode := TRANSPARENT;
end
function GetCaretPos(x,y);//获得光标位置
begin
y := (CaretY-GetYpos())*GetYScrollDelta();
x := (CaretX-GetXpos())*GetXScrollDelta();
end
published
property Highlighter:thighlighter read FHighlighter write SetHighlighter; //语法高亮
property Completion read FCompletion write SetCompletion; //自动完成
property TabChar read FTabChar write SetTabChar;
public //输入法相关
function WMIMESTARTCOMPOSITION(o,e):WM_IME_STARTCOMPOSITION;virtual;
begin
ime := ImmGetContext(self.Handle);
FCOMPOSITIONFORM.ptcurrentpos.cx := 200;
FCOMPOSITIONFORM.ptcurrentpos.cy := 200;
ImmSetCompositionWindow(ime,FCOMPOSITIONFORM._getptr_());
ImmReleaseContext(self.Handle,ime);
end
{$ifdef linux}
function ImmReleaseContext();
begin
end;
function ImmGetContext();
begin
end;
function ImmSetCompositionWindow();
begin
end;
function ImmSetStatusWindowPos();
begin
end;
{$else}
function ImmReleaseContext(h:pointer;ime:pointer):integer;stdcall;external "Imm32.dll" name "ImmReleaseContext";
function ImmGetContext(h:pointer):pointer;stdcall;external "Imm32.dll" name "ImmGetContext";
function ImmSetCompositionWindow(h:pointer;s:pointer):integer;stdcall;external "Imm32.dll" name "ImmSetCompositionWindow";
function ImmSetStatusWindowPos(h:pointer;s:pointer):integer;stdcall;external "Imm32.dll" name "ImmSetStatusWindowPos";
{$endif}
private
FCOMPOSITIONFORM;
FHighlighter;
FCompletion;
FTabChar;
function SetTabChar(s);
begin
if FTabChar<>s and s and ifstring(s) then
begin
FTabChar := s;
end
end
function SetHighlighter(v);
begin
if FHighlighter <>v then
begin
tv := FHighlighter;
FHighlighter := nil;
if tv is class(TSynHighLighter) then
begin
tv.Memo := nil;
end
FHighlighter := v;
if v is Class(TSynHighLighter) THEN
begin
v.Memo := self(true);
end else FHighlighter := nil;
InvalidateRect(nil,false);
end
end
function SetCompletion(v);
begin
if FCompletion<>v then
begin
tv := FCompletion ;
FCompletion := nil;
if tv is class(TSynCompletion) then
begin
tv.Memo := nil;
end
FCompletion := v;
if v is class(TSynCompletion) then
begin
v.Memo := self(true);
end else FCompletion := nil;
end
end
end
type TSynMemoNorm = class(TsynCustomMemo) //添加了常用快捷键的编辑器框
function Create(AOwner);override;
begin
inherited;
end
function keypress(o,e);override;
begin
if e.CharCode =VK_TAB then
begin
if FSheetTabFlage then return ;
end
inherited;
end
function KeyDown(o,e);override; //按键处理
begin
inherited;
if e.skip then return ;
FSheetTabFlage := false;
if ssCtrl in e.shiftstate then
begin
CancelCompletion();
case e.charcode of
ord("A") :
begin
ExecuteCommand( ecSelectAll);
end
ord("C"):
begin
ExecuteCommand(ecCopy);
end
ord("V"):
begin
if ReadOnly then return ;
ExecuteCommand(ecPaste);
end
ord("X"):
begin
//if (ssAlt in e.shiftstate) then return ExecuteCommand(ecRedo);
if ReadOnly then return ;
ExecuteCommand(ecCut);
end
ord("Y"),ord("L"):
begin
if ReadOnly then return ;
return ExecuteCommand(ecDeleteLine);
end
ord("Z"):
begin
if ReadOnly then return ;
return ExecuteCommand(ecUndo);
end
ord("U"):
begin
if ReadOnly then return ;
return ExecuteCommand(ecRedo);
end
VK_LEFT:
begin
if ssShift in e.shiftstate then return ExecuteCommand(ecSelWordLeft);
return ExecuteCommand(ecWordLeft);
end
VK_RIGHT:
begin
if ssShift in e.shiftstate then return ExecuteCommand(ecSelWordRight);
return ExecuteCommand(ecWordRight);
end
VK_END:
begin
if ssShift in e.shiftstate then return ExecuteCommand(ecSelEditorBottom);
return ExecuteCommand(ecEditorBottom);
end
VK_HOME:
begin
if ssShift in e.shiftstate then return ExecuteCommand(ecSelEditorTop);
return ExecuteCommand(ecEditorTop);
end
end ;
return ;
end
if ssShift in e.shiftstate then
begin
CancelCompletion();
case e.CharCode of
VK_TAB:
begin
if ReadOnly then return ;
FSheetTabFlage := true;
return ExecuteCommand(ecShifttab,array(TabChar,"\t"," "));
end
VK_DOWN:
begin
return ExecuteCommand(ecSelDown);
end
VK_END :
begin
return ExecuteCommand(ecSelLineEnd);
end
VK_HOME :
Begin
return ExecuteCommand(ecSelLIneStart);
end
VK_UP:
begin
return ExecuteCommand(ecSelUp);
end
VK_LEFT: ExecuteCommand(ecSelLeft);
VK_RIGHT: ExecuteCommand(ecSelRight);
end;
return ;
end
case e.CharCode of
34:
begin
return ExecuteCommand(ecPageDown,nil);
end
33:
begin
return ExecuteCommand(ecPageUp,nil);
end
VK_HOME:
begin
ExecuteCommand(ecLineStart);
return CancelCompletion();
end
VK_END:
begin
ExecuteCommand(ecLineEnd);
return CancelCompletion();
end
VK_LEFT:
begin
ExecuteCommand(ecLeft,1);
return CancelCompletion();
end
VK_RIGHT:
begin
ExecuteCommand(ecRight,1);
return CancelCompletion();
end
VK_UP:
begin
if Completioning() then return Completion.ItemIndexdec();
ExecuteCommand(ecUp);
end
VK_DOWN:
begin
if Completioning() then return Completion.ItemIndexinc();
return ExecuteCommand(ecDown);
end
VK_DELETE:
begin
if ReadOnly then return ;
ExecuteCommand(ecDeleteChar);
return CancelCompletion();
end
VK_BACK :
begin
if ReadOnly then return ;
ExecuteCommand(ecDeleteLastChar,1);
return CancelCompletion();
end
end;
end
function MouseDown(o,e);override;
begin
if e.button=mbLeft and e.shiftdouble then
begin
ExecuteCommand(ecWordLeft);
ExecuteCommand(ecSelWordRight);
end else
inherited;
CancelCompletion();
end
function DoMouseWheel(o,e);override;
begin
IF ssCtrl in e.shiftstate then
begin
fw := font.Width;
flg := false;
//echo "\r\n:",fw,"--",font.Height;
if e.delta<0 then
begin
if fw>6 then
begin
flg := true;
font := array("width":fw-1,"height":font.height-2);
end
end else
begin
if fw<18 then
begin
flg := true;
font := array("width":fw+1,"height":font.height+2);
end
end
e.skip := true;
return;
end
inherited;
end
private
FSheetTabFlage;
end
Implementation
function if_c_sym(s,idx,len,lx);//是否为中文符号
begin
if lx then //倒序
begin
if not(idx<=len) then return 0;
if idx<2 then return 0;
if ByteType(s,idx)<>2 then return 0;
c1 := getchar(s,idx-1);
c2 := getchar(s,idx);
end else //正序
begin
if not(idx<len ) then return 0;
if ByteType(s,idx)<>1 then return 0;
c1 := getchar(s,idx);
c2 := getchar(s,idx+1);
end
symv := static array(161,162,163,161,163,164,163,168,163,169,161,164,161,190,161,191,163,186,161,176,161,177,161,174,163,187,161,163,163,172);
for i:=0 to length(symv)-1 step 2 do
begin
if c1=symv[i] and c2=symv[i+1] then
begin
return 1;
end
end
end
function CreateATslMemoUndoItem(AReason,AStart,AEnd,ChangeText,SelMode);
begin
return new TTslMemoUndoItem(AReason,AStart,AEnd,ChangeText,SelMode);
end
InitialIzation
end.
Reference in New Issue View Git Blame Copy Permalink