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 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 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 qmzfsbt 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 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 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 ib1[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" " 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= 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(fCaretXr[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 i0 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 FCaretXCharsInWindow+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 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 fCaretY1 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]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 ibb[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=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 idxFIgnoreCase 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 be 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 yltc 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]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(idx1 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.