unit UTslMemo; {** @explan(说明) 文本控件库 %% **} interface uses utslvclauxiliary,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; 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 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 datatype(fOnAdded)=7 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 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 , ) **} static ecNone; static ecViewCommandFirs; static ecViewCommandLast; static ecEditCommandFirs; static ecEditCommandLast; static ecLeft; static ecRight; static ecUp; static ecDown; static ecWordLeft; static ecWordRight; static ecLineStart; static ecLineEnd; static ecPageUp; static ecPageDown; static ecPageLeft; static ecPageRight; static ecPageTop; static ecPageBottom; static ecEditorTop; static ecEditorBottom; static ecGotoXY; {** @param(ecGotoXY)() 跳转光标到指定位置,对应参数为 array(y,x) %% @param(ecSelGotoXY)() 选中文本到指定位置,对应参数为 array(y,x) %% @param(ecCopy)() 复制选中文本到剪切板,无对应参数 %% @param(ecPaste)() 粘贴剪切板文本,无对应参数 %% @param(ecString)() 插入字符串,对应参数为 字符串 %% **} static ecSelection; static ecSelLeft; static ecSelRight; static ecSelUp; static ecSelDown; static ecSelWordLeft; static ecSelWordRight; static ecSelLineStart; static ecSelLineEnd; static ecSelPageUp; static ecSelPageDown; static ecSelPageLeft; static ecSelPageRight; static ecSelPageTop; static ecSelPageBottom; static ecSelEditorTop; static ecSelEditorBottom; static ecSelGotoXY; static ecSelectAll; static ecCopy; static ecScrollUp; static ecScrollDown; static ecScrollLeft; static ecScrollRight; static ecInsertMode; static ecOverwriteMode; static ecToggleMode; static ecNormalSelect; static ecColumnSelect; static ecLineSelect; static ecMatchBracket; {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 ecDeleteLastChar; static ecDeleteChar; static ecDeleteWord; static ecDeleteLastWord; static ecDeleteBOL; static ecDeleteEOL; static ecDeleteLine; static ecClearAll; static ecLineBreak; static ecInsertLine; static ecChar; static ecImeStr; static ecUndo; static ecRedo; static ecCut; static ecPaste; static ecBlockIndent; static ecBlockUnindent; static ecTab; static ecShiftTab; static ecAutoCompletion; static ecComment; static ecUnComment; static ecNextBlock; static ecPrevBlock; static ecNextJumpOut; static ecPrevJumpOut; static ecUserFirst; static ecFind; static ecReplace; static ecSearchAgain; static ecFindAll; static ecString; static ecSearchUpAgain; protected class function InitCommandConst(); begin ecNone := 0; // Nothing. Useful for user event to handle command ecViewCommandFirst := 0; ecViewCommandLast := 500; ecEditCommandFirst := 501; ecEditCommandLast := 1000; ecLeft := 1; // Move cursor left one char ecRight := 2; // Move cursor right one char ecUp := 3; // Move cursor up one line ecDown := 4; // Move cursor down one line ecWordLeft := 5; // Move cursor left one word ecWordRight := 6; // Move cursor right one word ecLineStart := 7; // Move cursor to beginning of line ecLineEnd := 8; // Move cursor to end of line ecPageUp := 9; // Move cursor up one page ecPageDown := 10; // Move cursor down one page ecPageLeft := 11; // Move cursor right one page ecPageRight := 12; // Move cursor left one page ecPageTop := 13; // Move cursor to top of page ecPageBottom := 14; // Move cursor to bottom of page ecEditorTop := 15; // Move cursor to absolute beginning ecEditorBottom := 16; // Move cursor to absolute end ecGotoXY := 17; // Move cursor to specific coordinates, Data := PPoint //****************************************************************************** // Maybe the command processor should just take a boolean that signifies if // selection is affected or not? //****************************************************************************** ecSelection := 100; // Add this to ecXXX command to get equivalent // command, but with selection enabled. This is not // a command itself. // Same as commands above, except they affect selection, too ecSelLeft := ecLeft+ecSelection; ecSelRight := ecRight+ecSelection; ecSelUp := ecUp+ecSelection; ecSelDown := ecDown+ecSelection; ecSelWordLeft := ecWordLeft+ecSelection; ecSelWordRight := ecWordRight+ecSelection; ecSelLineStart := ecLineStart+ecSelection; ecSelLineEnd := ecLineEnd+ecSelection; ecSelPageUp := ecPageUp+ecSelection; ecSelPageDown := ecPageDown+ecSelection; ecSelPageLeft := ecPageLeft+ecSelection; ecSelPageRight := ecPageRight+ecSelection; ecSelPageTop := ecPageTop+ecSelection; ecSelPageBottom := ecPageBottom+ecSelection; ecSelEditorTop := ecEditorTop+ecSelection; ecSelEditorBottom := ecEditorBottom+ecSelection; ecSelGotoXY := ecGotoXY+ecSelection; // Data := PPoint ecSelectAll := 199; // Select entire contents of editor, cursor to end ecCopy := 201; // Copy selection to clipboard ecScrollUp := 211; // Scroll up one line leaving cursor position unchanged. ecScrollDown := 212; // Scroll down one line leaving cursor position unchanged. ecScrollLeft := 213; // Scroll left one char leaving cursor position unchanged. ecScrollRight := 214; // Scroll right one char leaving cursor position unchanged. ecInsertMode := 221; // Set insert mode ecOverwriteMode := 222; // Set overwrite mode ecToggleMode := 223; // Toggle ins/ovr mode ecNormalSelect := 231; // Normal selection mode ecColumnSelect := 232; // Column selection mode ecLineSelect := 233; // Line selection mode ecMatchBracket := 250; // Go to matching bracket {ecGotoMarker0 := 301; // Goto marker ecGotoMarker1 := 302; // Goto marker ecGotoMarker2 := 303; // Goto marker ecGotoMarker3 := 304; // Goto marker ecGotoMarker4 := 305; // Goto marker ecGotoMarker5 := 306; // Goto marker ecGotoMarker6 := 307; // Goto marker ecGotoMarker7 := 308; // Goto marker ecGotoMarker8 := 309; // Goto marker ecGotoMarker9 := 310; // Goto marker ecSetMarker0 := 351; // Set marker, Data := PPoint - X, Y Pos ecSetMarker1 := 352; // Set marker, Data := PPoint - X, Y Pos ecSetMarker2 := 353; // Set marker, Data := PPoint - X, Y Pos ecSetMarker3 := 354; // Set marker, Data := PPoint - X, Y Pos ecSetMarker4 := 355; // Set marker, Data := PPoint - X, Y Pos ecSetMarker5 := 356; // Set marker, Data := PPoint - X, Y Pos ecSetMarker6 := 357; // Set marker, Data := PPoint - X, Y Pos ecSetMarker7 := 358; // Set marker, Data := PPoint - X, Y Pos ecSetMarker8 := 359; // Set marker, Data := PPoint - X, Y Pos ecSetMarker9 := 360; // Set marker, Data := PPoint - X, Y Pos } ecDeleteLastChar := 501; // Delete last char (i.e. backspace key) ecDeleteChar := 502; // Delete char at cursor (i.e. delete key) ecDeleteWord := 503; // Delete from cursor to end of word ecDeleteLastWord := 504; // Delete from cursor to start of word ecDeleteBOL := 505; // Delete from cursor to beginning of line ecDeleteEOL := 506; // Delete from cursor to end of line ecDeleteLine := 507; // Delete current line ecClearAll := 508; // Delete everything ecLineBreak := 509; // Break line at current position, move caret to new line ecInsertLine := 510; // Break line at current position, leave caret ecChar := 511; // Insert a character at current position ecImeStr := 550; // Insert character(s) from IME ecUndo := 601; // Perform undo if available ecRedo := 602; // Perform redo if available ecCut := 603; // Cut selection to clipboard ecPaste := 604; // Paste clipboard to current position ecBlockIndent := 610; // Indent selection ecBlockUnindent := 611; // Unindent selection ecTab := 612; // Tab key ecShiftTab := 613; // Shift+Tab key ecAutoCompletion := 650; ecComment := 651; ecUnComment := 652; ecNextBlock := 701; ecPrevBlock := 702; ecNextJumpOut := 703; ecPrevJumpOut := 704; ecUserFirst := 1001; // Start of user-defined commands ecFind := ecUserFirst+1; ecReplace := ecUserFirst+2; ecSearchAgain := ecUserFirst+3; ecFindAll := ecUserFirst+4; ecString := ecUserFirst+5; ecSearchUpAgain := ecUserFirst+6; end end type TCustomMemo = class(TCustomScrollControl,TCustomMemoCmd) {** @explan(说明) 带滚动条的编辑控件 %% **} private Fecruningto; //调试运行到 FLineInterval; FSetPostioned; FIsCaretShow; FCaretCareted; fForceCaret; FCharsInWindow; // fTextHeight; fLinesInWindow; // fMaxCharsInRow; FRowHeight; // FCharHeight; FCharWidth; FLeftChar; FTopLine; //首行 FScroolChanged; FGutterCharCount; FGutter; FMarginTop; FLines; fLastCaretY; fCaretLineNeedPaint; fCaretX; fCaretY; fBlockBegin:TPoint; fBlockEnd:TPoint; FScrollTimer; FMouseIsDown; FInPutCache; FSelectionMode; FCopyer; FReadOnly; fUndoList; //撤销 fRedoList; //反撤销 //************** static crInsert; static crPaste; static crDragDropInsert; static crDeleteAfterCursor; static crDelete; static crLineBreak; static crIndent; static crUnindent; static crSilentDelete; static crSilentDeleteAfterCursor; static crNothing; static smNormal,smLine,smColumn; //**************** protected function SetControlFont(v);override; begin inherited; FCharWidth := Font.width; FGutter.Width := 1+FGutterCharCount * FCharWidth; 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; 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; dc.brush.Color := 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 := rcDraw; r[1]:= rcDraw[1]+fTextHeight * iy; r[2]-= 10; r[3]:= r[1]+fTextHeight; it := flines[i]; if it and it.FMarked then begin dc.brush.Color := 0xFF00FF; tr := r; tr[0]+= 1; tr[1]+= 1; tr[3]-= 1; 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 cvs.Brush.Color := rgb(232,232,255); cvs.FillRect(r); end if bb then begin if i >= bb[0]-1 and i <= ee[0]-1 then begin cvs.Brush.Color := 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 PaintLiensText(RC,FirstLine,LastLine,FirstCol,LastCol); 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 PaintLiensText(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 function sinit();override; begin crInsert := 1; crPaste := 2; crDragDropInsert := 3; crDeleteAfterCursor := 4; crDelete := 5; crLineBreak := 6; crIndent := 6; crUnindent := 7; crSilentDelete := 8; crSilentDeleteAfterCursor := 9; crNothing := 10; smNormal := 0; smLine := 1; smColumn := 2; InitCommandConst(); inherited; 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; FReadOnly := false; FLineInterval := 4; FGutterCharCount := 7; FSelectionMode := smNormal; FGutter := new TMemoGutter(self); FGutter.Width := 1+Font.Width * FGutterCharCount; 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(); 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 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 ComputeCaret(e.xpos,e.ypos); ClearSelBlock(); ClipCursor(); end TrySetFoucs(); UpDateCaret(); end else if e.Button()=mbRight then begin ComputeCaret(e.xpos,e.ypos); end finally DecPaintLock(); end ; end function MouseMove(o,e);override; begin return MouseMOVESel(e.xpos,e.ypos); end function WMIMECHAR(o,e):WM_IME_CHAR; 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 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 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; 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(); DoTextChanged(bb); end function DoTextChanged(p);virtual; begin //改变 end function DoCaretPosChanged();virtual; begin end function ClearUndo(); begin fUndoList.Clear(); fRedoList.Clear(); end function ClearAll(); begin fLines.text := ""; FCaretX := FCaretY := 1; FSelBegin := array(1,1); FSelEnd := array(1,1); ClearUndo(); DoTextChanged(array(1,1)); end function Undo(); begin if fUndoList.CanUndo then begin UndoItem(); end end function Redo(); begin if fRedoList.CanUndo then RedoItem(); 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 "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 i1 then begin if fCaretY= 1 and p2[1]>= 1)then return; SetCaretXY(p2); IncPaintLock(); 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; {** @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 UpDateCaret(); begin if IsUpDating()then return fForceCaret := true; fForceCaret := false; if not FCaretCareted 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 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]; ivi := ord(vi); {if (ivi<=0x2f) or (ivi>122 and ivi<=127) then begin 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]; ivi := ord(vi); //if (ivi<=0x2f) or (ivi>122 and ivi<=127) then break; 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 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 SetGutterCharCnt(n); begin if not(n>=0 ) then return ; nn := integer(n); if nn<>FGutterCharCount then begin FGutterCharCount := nn; FGutter.Width := 1+FGutterCharCount*FCharWidth; 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 if not FCopyer then begin FCopyer := new TcustomClipBoard(self); end FCopyer.text := r; return true; end end function PasteFromClipboard(); begin //if ReadOnly then return ; if not FCopyer then begin FCopyer := new TcustomClipBoard(self); end //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); //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 xbb[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 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 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(); DoTextChanged(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]10 then n := fMaxCharsInRow; else n := 10; return((FLines.RowMaxLength/n)+0.5)* n; end function CreateCaret(); //构造光标 begin if FReadOnly then return; if FCaretCareted then return; h := Font.Height; hd := Handle; _wapi.CreateCaret(hd,nil,1,h); _wapi.ShowCaret(hd); FCaretCareted := true; end function DestroyCaret(); //销毁光标 begin if FCaretCareted then begin _wapi.HideCaret(self.Handle); _wapi.DestroyCaret(); end FCaretCareted := false; FIsCaretShow := false; end FHasFocus; //buffer 处理 function buffer_DeleteChars(bb,ee); //删除选择 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); //插入 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 rc := GetIdxRect(idx); c := ClientRect; if rc[1]c[3] then begin SetYpos( 1+GetYPos()+(rc[3]-c[3]+1)/GetYScrollDelta()); end 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 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; {$ifdef linux} //处理避免闪烁 {$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(); if visible then begin if s then begin SetFilter(s); end else Visible := false; end else begin if s 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 linux} 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() 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 flFIgnoreCase then begin FIgnoreCase := nv; FJump.IgnoreCase := nv; end end function SetMemo(M); begin if M<>FMemo then begin 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) //语法高亮类型 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 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; 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 Flines; FMemo; end type TSynCustomMemo = class(TCustomMemo) {** @explan(说明) 语法编辑器 %% **} function DoTextChanged(p);override;//文本改变 begin 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; 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 PaintLiensText(RC, FirstLine, LastLine, FirstCol, LastCol); override; begin if not Highlighter then return inherited; cvs := canvas; bfontname := cvs.font.facename; 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; 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 := 0; if (selt and selt = lowercase(val))or(seltcj and seltcj=v.FMate) then begin cvs.Font.bkColor := 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 := 0; cvs.Font.bkmode := TRANSPARENT; end function GetCaretPos(x,y);//获得光标位置 begin y := (CaretY-GetYpos())*GetYScrollDelta(); x := (CaretX-GetXpos())*GetXScrollDelta(); end property Highlighter read FHighlighter write SetHighlighter; //语法高亮 property Completion read FCompletion write SetCompletion; //自动完成 property TabChar read FTabChar write SetTabChar; private 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; if e.delta<0 then begin if fw>8 then begin font := array("width":fw-2,"height":font.height-4); end end else begin if fw<18 then begin font := array("width":fw+2,"height":font.height+4); end end ReCreateCaret(); return; end inherited; end private FSheetTabFlage; end Implementation function CreateATslMemoUndoItem(AReason,AStart,AEnd,ChangeText,SelMode); begin return new TTslMemoUndoItem(AReason,AStart,AEnd,ChangeText,SelMode); end type TCanvsRgnClipAutoSave=class {** @expan(说明) 裁剪canvas区域,销毁时还原 %% **} function Create(cvs,rec); begin {** @explan(说明)构造裁剪对象 %% @param(cvs)(tcustomcanvas) canvas 对象 %% @param(rec)(array(左上右下))区域 %% **} if(cvs is class(tcustomcanvas))and cvs.HandleAllocated()and ifarray(rec)then begin FW32api := cvs._wapi; FCvsHandle := cvs.Handle; FCrg := FW32api.CreateRectRgn(rec[0],rec[1],rec[2],rec[3]); FBKrg := FW32api.SelectClipRgn(FCvsHandle,FCrg); //裁剪区域 end end function Destroy(); begin if FW32api and FCvsHandle and FBKrg and FCrg then begin FW32api.SelectClipRgn(FCvsHandle,FBKrg); //恢复区域 FW32api.DeleteObject(FCrg); //销毁区域 end FW32api := nil; end private FBKrg; FCrg; FCvsHandle; FW32api; end InitialIzation end.