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

3504 lines
101 KiB
Plaintext
Raw Blame History

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<L then
begin
FRowMaxLength := L;
DoColumnIncreased();
end
end
property Text read GetText write SetText;
property OnAdded read FOnAdded write FOnAdded;
property OnChange read FOnChange write FOnChange;
property OnChanging read FOnChanging write FOnChanging;
property OnCleared read FOnCleared write FOnCleared;
Property OnDeleted read FOnDeleted write FOnDeleted;
PROPERTY OnPutted READ fOnPutted write fOnPutted;
//property OnMaxLengthIncrease read FOnMaxLengthIncrease write FOnMaxLengthIncrease;
Property RowMaxLength read fRowMaxLength;
private
Flock;
FRowMaxLength;
FOnAdded;
FOnChange;
FOnChanging;
FOnCleared;
FOnDeleted;
fOnPutted;
FOnMaxLengthIncrease;
function DoColumnIncreased();
begin
//echo "\r\nIncreate:",FRowMaxLength;
//if Datatype(FOnMaxLengthIncrease)=7 then Call(FOnMaxLengthIncrease);
//echo "\r\nincrease:",FRowMaxLength;
end
FEdit;
function SetText(s);
begin
Clear();
//push(new TMemoLineItem(""));
//return FEdit.ExecuteCommand(ecString,s);
if not(s and ifstring(s))then return;
vs := str2array(s,"\n");
if not vs then vs := array("");
Flock := false;
for i,vi in vs do
begin
if vi="\r" then continue;
if not vi then
begin
push(new TMemoLineItem(vi));
end else
begin
lv := length(vi);
UpDateMaxStringLength(lv);
if vi[lv]="\r" then
begin
push(new TMemoLineItem(vi[1:lv-1]));
end else
begin
Push(new TMemoLineItem(vi));
end
end
end
Flock := true;
end
function GetText();
begin
r := "";
d := Data;
len := Length(d)-1;
for i,v in d do
begin
r += v.FStr;
if i <> len then r += "\r\n";
end
return r;
end
end
type TMemoGutter=class
function Create(AEdit);
begin
FWidth := 60;
FEdit := AEdit;
end
function PaintLiens(rc,FirstLine,LastLine);
begin
end
property Width read FWidth write FWidth;
private
function GetWidth();
begin
return 20+FEdit.Font.width * 5;
end
FWidth;
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
rc := ps;
rc[2]:= FGutter.Width;
PaintGutter(rc,FirstLine,LastLine);
end
if ps[2]>FGutter.Width then
begin
FirstCol := integer(max(0,xPos+(ps[0]-FGutter.Width)/GetXScrollDelta()));
LastCol := integer(min(GetMaxCharsInRow()-1,xPos+(ps[2]-FGutter.Width)/GetXScrollDelta()));
rc := ps;
rc[0]:= Max(rc[0],FGutter.Width);
//echo tostn(array(FirstLine, LastLine, FirstCol, LastCol));
cvs := Canvas;
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<tl then
begin
if bytetype(dtx,qmzfs)=2 then qmzfs -= 1;
end
ct := min(tl-qmzfs+1,rnzf);
for i := qmzfs to qmzfs+ct step 2 do
begin
if bytetype(dtx,i)<> 0 then
begin
bn := ft.charset;
ft.charset := 134;
break;
end
end
dtx2 := copy(dtx,qmzfs,ct);
r[0]+=(qmzfs-1)* FCharWidth;
r[2]:= r[0]+ct * FCharWidth;
cvs.DrawText(dtx2,r,DT_NOPREFIX);
end
if bn <> 100000 then
begin
ft.charset := bn;
end
end
function 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
fBlockBegin := array(FCaretY,FCaretX);
fBlockEnd := array(FCaretY,FCaretX);
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 ;
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
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 i<len then ins += "\r\n";
else
begin
endb := length(v)+length(data)+1;
end
end
SelText := ins;
FSelectionMode := odm;
fBlockBegin := array(b1[0],1);
fBlockEnd := array(b2[0],endb);
end
end
end
ecShiftTab:
begin
if formatShiftTab(data)then
begin
b1 := BlockBegin;
b2 := BlockEnd;
if ifarray(b1)and ifarray(b2)and b2[0]>b1[0]then
begin
odm := FSelectionMode;
FSelectionMode := smLine;
s := SelText;
ss := str2array(s,"\r\n");
ins := "";
len := length(ss)-1;
endb := 1;
for i,v in ss do
begin
lv := length(v);
indata := false;
for idata,vdata in data do
begin
if pos(vdata,v)=1 then
begin
ldata := length(vdata);
if ldata=lv then
begin
end else
begin
ins += v[ldata+1:];
end
endb := lv-ldata+1;
indata := true;
break;
end
end
if not indata then
begin
ins += v;
endb := lv+1;
end
if i<len then ins += "\r\n";
end
if s=ins then return FSelectionMode := odm;
SelText := ins;
FSelectionMode := odm;
fBlockBegin := array(b1[0],1);
fBlockEnd := array(b2[0],endb);
end
end
end
ecClearAll:
begin
ClearAll();
end
ecLineBreak:
begin
InsertChars("\r\n");
end
ecEditorTop,ecSelEditorTop:
begin
MoveCaretAndSelection(array(fCaretY,fCaretX),array(1,1),ecSelEditorTop=cmd);
end
ecEditorBottom,ecSelEditorBottom:
begin
cn := array(fLines.length(),1);
cn[1]:= fLines[cn[0]-1].StrLength()+1;
MoveCaretAndSelection(array(fCaretY,fCaretX),cn,ecSelEditorBottom=cmd);
end
ecString:
begin
InsertChars(data);
end
ecLineEnd,ecSelLineEnd:
begin
s := fLines.GetStringByIndex(fCaretY-1); //[fCaretY-1];
if not ifstring(s)then return;
MoveCaretAndSelection(array(fCaretY,fCaretX),array(fCaretY,length(s)+1),ecSelLineEnd=cmd);
end
ecLineStart,ecSelLineStart:
begin
MoveCaretAndSelection(array(fCaretY,fCaretX),array(fCaretY,1),ecSelLineStart=cmd);
end
ecLeft,ecSelLeft:
begin
MoveCaretHorz(-1,ecSelLeft=cmd);
end
ecRight,ecSelRight:
begin
MoveCaretHorz(1,ecSelRight=cmd);
end
ecDown,ecSelDown:
begin
MoveCaretVert(1,cmd=ecSelDown);
end
ecUp,ecSelUp:
begin
MoveCaretVert(-1,cmd=ecSelUp);
end
ecPageTop,ecSelPageTop:
begin
MoveCaretAndSelection(self.CaretXY,array(fCaretY,FTopLine),cmd=ecSelPageTop);
end
ecPageDown:
begin
MoveCaretVert(GetClientYCapacity(),nil);
end
ecPageUp:
begin
MoveCaretVert(0-GetClientYCapacity(),nil);
end
ecGotoXY,ecSelGotoXY:
begin
MoveCaretAndSelection(GetCaretXY(),data,cmd=ecSelGotoXY);
end
ecWordLeft,ecSelWordLeft:
begin
nxy := PrevWordPos();
MoveCaretAndSelection(GetCaretXY(),nxy,cmd=ecSelWordLeft);
end
ecWordRight,ecSelWordRight:
begin
nxy := NextWordPos();
MoveCaretAndSelection(GetCaretXY(),nxy,cmd=ecSelWordRight);
end
ecSelectAll:
begin
SelectAll();
end
ecDeleteLastChar:
begin
if SelAvail then return SelText := "";
else
begin
ofsm := FSelectionMode;
FSelectionMode := smNormal;
SelectPrevChar();
SelText := "";
FSelectionMode := ofsm;
end
end
ecDeleteChar:
begin
if SelAvail then return SelText := "";
else
begin
ofsm := FSelectionMode;
FSelectionMode := smNormal;
SelectNextChar();
SelText := "";
FSelectionMode := ofsm;
end
end
ecDeleteLine:
begin
LL := fLines.Length();
if fCaretY=1 and LL=1 then
begin
SelectAll();
//ECHO "==",tostn(array(fBlockBegin,fBlockEnd));
SelText := "";
end else
if LL>1 then
begin
if fCaretY<LL then
begin
fBlockBegin := array(fCaretY,1);
fBlockEnd := array(fCaretY+1,1);
end else
begin
fBlockBegin := array(fCaretY-1,(fLines[fCaretY-2].StrLength())+1);
fBlockEnd := array(fCaretY,(fLines[fCaretY-1].StrLength())+1);
//echo tostn(array(fBlockBegin,fBlockEnd));
end
SelText := "";
//fLines.splices(fCaretY-1,1,array());
//SetCaretXY(array(fCaretY,1));
end
UpdateCaret();
end
ecUndo:
begin
Undo();
end
ecRedo:
begin
Redo();
end
ecCut:
begin
CutToClipboard();
end
ecPaste:
begin
PasteFromClipboard();
end
ecCopy:
begin
CopyToClipboard();
end
end
finally
DecPaintLock();
end;
end
function MoveCaretAndSelection(p1,p2,sel);
begin
if not(ifarray(p2)and ifarray(p1)and p2[0]>= 1 and p2[1]>= 1)then return;
SetCaretXY(p2);
IncPaintLock();
if Sel then
begin
if not SelAvail then fBlockBegin := p1;
fBlockEnd := CaretXY;
InvalidateRect(nil,false);
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(fCaretX<fCharsInWindow+fLeftChar)and FTopLine <= fCaretY and fCaretY<FTopLine+fLinesInWindow then
begin
_wapi.SetCaretPos(FGutter.Width+FCharWidth *(FCaretX-FLeftChar),(fTextHeight *(fCaretY-FTopLine)+3));
//_wapi.ShowCaret(self.Handle);
if not FIsCaretShow then
begin
_wapi.ShowCaret(self.Handle);
FIsCaretShow := true;
end
end else
begin
if FIsCaretShow then
begin
_wapi.HideCaret(self.Handle);
FIsCaretShow := false;
end
end
end
end
function InvalidateLines(FirstLine,LastLine:integer);virtual;
begin
if not HandleAllocated()then return;
fy :=(FirstLine-FTopLine)* fTextHeight;
ly :=(LastLine-FTopLine+1)* fTextHeight;
r := ClientRect;
if ly<r[1]then return;
if fy>r[3]then return;
r[0]:= FGutter.Width;
r[1]:= max(0,fy);
r[3]:= min(r[3],ly);
InvalidateRect(r,false);
end
function DestroyHandle();override;
begin
DestroyCaret();
FHasFocus := false;
inherited;
end
function MergeLastUndo(); //合并最近的两次操作
begin
fUndoList.MergeReplaceItem(); //
end
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 i<idx-1 then
begin
fRedoList.MergeReplaceItem();
end
end
fUndoList.Lock();
for i := length(tarr)-1 downto 0 do
begin
item := tarr[i];
case item.FReason of
crInsert:
begin
//删除
fBlockBegin := item.FStartPos;
fBlockEnd := item.FEndPos;
SelText := "";
end
crDelete:
begin
//插入
SetCaretXY(item.FStartPos);
InsertChars(item.FStr);
//echo tostn(item);
end
end
end
fUndoList.UnLock();
DecPaintLock();
//处理
end
function RedoItem();
begin
item := fRedoList.PopItem();
if not item then return;
IncPaintLock();
tarr := array();
idx := 0;
while item do
begin
tarr[idx]:= item;
item := item.FLinkItem;
idx++;
end
for i := length(tarr)-1 downto 0 do
begin
item := tarr[i];
case item.FReason of
crInsert: //插入
begin
SetCaretXY(item.FStartPos);
InsertChars(item.FStr);
end
crDelete: //删除
begin
fBlockBegin := item.FStartPos;
fBlockEnd := item.FEndPos;
SelText := "";
end
end;
if i<idx-1 then
begin
fUndoList.MergeReplaceItem();
end
end
DecPaintLock();
end
function GetLineText();
begin
if fCaretY>0 and fCaretY <= fLines.Length()then return fLines.GetStringByIndex(fCaretY-1);
return "";
end
function SetLineText(s);
begin
if ifstring(s)and fCaretY>0 and fCaretY <= fLines.Length()then
begin
fLines.SetValueByIndex(fCaretY-1,s);
//InvalidateLines(fCaretY-1,fCaretY-1);
end
end
function EnsureCursorPosVisible();
begin
IncPaintLock();
try
lct := max(1,LinesInWindow);
if FCaretX<LeftChar then
begin
LeftChar := FCaretX;
end else
if FCaretX>CharsInWindow+LeftChar-1 then
begin
LeftChar := FCaretX-CharsInWindow+1;
end
{if FCaretY < TopLine then
begin
TopLine := max(1,FCaretY-1); // -1
end
else if FCaretY > TopLine + Max(1, LinesInWindow) - 1 then
begin
TopLine := max(1,FCaretY - (LinesInWindow - 1)+1); //+1
end else
else
begin
//if fCaretLineNeedPaint then InvalidateLines(FCaretY,FCaretY);
fCaretLineNeedPaint := false;
end }
tl := TopLine;
vl := tl+lct;
if fCaretY >= tl and fCaretY <= vl then
begin
fCaretLineNeedPaint := false;
end else
begin
TopLine := fCaretY;
end
finally
DecPaintLock();
end;
end
function GetCaretXY();
begin
return array(fCaretY,fCaretX);
end
function SetCaretXY(cxy);
begin
if not(ifarray(cxy)and cxy[0]>0 and cxy[1]>0)then return;
if cxy[0]>fLines.length()then cxy[0]:= fLines.Length();
cxy[1]:= Column2StrPos(cxy[0],cxy[1]);
docc := 0;
if cxy[1]<> fCaretX or cxy[0]<> fCaretY then
begin
IncPaintLock();
try
if fCaretX <> cxy[1]then
begin
docc := 1;
fCaretX := cxy[1];
end
if fCaretY <> cxy[0]then
begin
docc := 2;
fCaretY := cxy[0];
if fLastCaretY <> fCaretY then
begin
if fLastCaretY then InvalidateLines(fLastCaretY,fLastCaretY);
InvalidateLines(fCaretY,fCaretY);
end
fLastCaretY := fCaretY;
end
EnsureCursorPosVisible();
finally
DecPaintLock();
end;
if docc then DoCaretPosChanged();
end
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;
y := min(fLines.length(),p[0]);
x := Column2StrPos(y,p[1]);
fBlockBegin := array(y,x);
if fBlockBegin <> fBlockEnd then InvalidateRect(nil,false);
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;
y := min(fLines.length(),p[0]);
x := Column2StrPos(y,p[1]);
fBlockEnd := array(y,x);
if fBlockBegin <> fBlockEnd then InvalidateRect(nil,false);
end
function ComputeCaret(X,Y:Integer);
begin
xy := PixelsToRowColumn(x,y);
SetCaretXY(xy);
end
function PixelsToRowColumn(x,y);
begin
r := max(1,min(fLines.Length(),FTopLine+Integer(y/fTextHeight)));
if x<FGutter.Width then
begin
c := 1;
end else
begin
c := Column2StrPos(r,Integer((x-FGutter.Width)/fCharWidth+0.5)+FLeftChar);
end
return array(r,max(1,c));
end
function Column2StrPos(r,c);
begin
rs := FLines.GetStringByIndex(r-1); //fLines[r-1].FStr;
if not ifstring(rs)then return 1;
if length(rs)+1<c then c := length(rs)+1;
case bytetype(rs,c)of
//1: return c+1;
2:return c+1;
end
return c;
end
function GetSelText();
begin
r := "";
if not GetSelAvail()then return r;
bb := GetBlockBegin();
ee := GetBlockEnd();
if FSelectionMode=smLine then
begin
len := ee[0];
for i := bb[0]to ee[0] do
begin
r += fLines[i-1].FStr;
if i<len then r += "\r\n";
end
end else
begin
if bb[0]=ee[0]then
begin
s := fLines[bb[0]-1].FStr;
if ee[1]>bb[1]and ee[1]>1 then
try
r := s[bb[1]:ee[1]-1]; //可能出错,添加try
except
r := "";
end;
end else
begin
//第一行
s := fLines[bb[0]-1].FStr;
if bb[1]<= length(s)then r += s[bb[1]:];
r += "\r\n";
//中间
for i := bb[0]to ee[0]-2 do
begin
r += fLines[i].FStr;
r += "\r\n";
end
//最后一行
s := fLines[ee[0]-1].FStr;
if s and ee[1]>1 then r += s[1:ee[1]-1];
end
end
return r;
end
function SetCaretX(cx);
begin
x := integer(cx);
if x<1 then return;
if x <> FCaretX then SetCaretXY(array(FCaretY,x));
end
function SetCaretY(cy);
begin
y := Integer(cy);
if y<1 then return;
if y <> FCaretY then SetCaretXY(array(y,FCaretX));
end
function SetLeftChar(v);
begin
if v <> FLeftChar and v>0 then
begin
FLeftChar := v;
FSetPostioned .|= 2;
SetXPos(FLeftChar-1);
end
end
function SetTopLine(TL);
begin
if TL <> FTopLine and TL>0 then
begin
FTopLine := TL;
FSetPostioned .|= 1;
SetYPos(FTopLine-1);
end
end
function GetSelAvail();
begin
return fBlockBegin <> fBlockEnd and fBlockBegin and fBlockEnd;
end
function SelectNextChar(); //选取后一个字符
begin
s := fLines.GetStringByIndex(fCaretY-1);
ls := length(s);
fBlockBegin := array(fCaretY,fCaretX);
fBlockEnd := array(fCaretY,fCaretX);
if fCaretX <= ls then
begin
bc := 1;
if bytetype(s,fCaretX)=1 then
begin
bc := 2;
end
fBlockEnd := array(fCaretY,fCaretX+bc);
end else
if fCaretY<fLines.Length()-1 then
begin
fBlockEnd := array(fCaretY+1,1);
end
end
function SelectPrevChar(); //选取前一个字符
begin
fBlockBegin := array(fCaretY,fCaretX);
if fCaretX>1 then
begin
s := fLines.GetStringByIndex(fCaretY-1);
bc := 1;
if bytetype(s,fCaretX-1)=2 then
begin
bc := 2;
end
fBlockEnd := array(fCaretY,fCaretX-bc);
//fBlockBegin := array(fCaretY, fCaretX-bc);
end else
if fCaretY>1 then
begin
s := fLines.GetStringByIndex(fCaretY-2);
fBlockEnd := array(CaretY-1,length(s)+1);
end
end
function SetSelTextExternal(v);
begin
if ifstring(v)and SelAvail then
begin
if SelText=v then return;
IncPaintLock();
ee := GetBlockEnd();
bb := DeleteSel();
up := false;
if bb[0]=ee[0]then
begin
//InvalidateLines(bb[0],bb[0]);
end else
begin
up := true;
end
if v then
begin
bb2 := buffer_InsertChars(bb,v);
fUndoList.AddChange(crInsert,bb,bb2,v,0);
fUndoList.MergeReplaceItem();
fBlockEnd := bb2;
if bb2[0]<> bb[0]then up := true;
end else
bb2 := bb;
ExecuteCommand(ecGotoXY,bb2);
//SetCaretXY(bb2);
//if up then UpDateScroll();
//UpDateCaret();
DecPaintLock();
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]<fBlockBegin[0]or(fBlockEnd[0]=fBlockBegin[0]and fBlockEnd[1]<fBlockBegin[1])then return fBlockEnd;
else return fBlockBegin;
end
end
function GetBlockEnd();
begin
if GetSelAvail()then
begin
if fBlockEnd[0]<fBlockBegin[0]or(fBlockEnd[0]=fBlockBegin[0]and fBlockEnd[1]<fBlockBegin[1])then return fBlockBegin;
else return fBlockEnd;
end
end
function GetMemoText();
begin
return fLines.Text;
end
function SetMemoText(v);
begin
if not ifstring(v)then return;
IncPaintLock();
//FLines.Text := v;
ExecuteCommand(ecSelectAll);
ExecuteCommand(ecString,v);
ExecuteCommand(ecGotoXY,array(0,0));
DecPaintLock();
//UpDateScroll();
end
function GetMaxCharsInRow();
begin
if fMaxCharsInRow>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[1] then
begin
SetYpos( -1+GetYPos()+(rc[1]-c[1])/GetYScrollDelta());
end else
if rc[3]>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;
WsPopUp := true;
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);
xy := Memo.ClientToscreen(x,y);
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();
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 fl<ls then
begin
ips := s[fl+1:];
Memo.ExecuteCommand(Memo.ecString,ips);
end
end
end
visible := false;
exts := it["valueext"];
if ifstring(exts) and exts then
begin
extss := str2array(exts,"\r\n");
cxy := Memo.CaretXY;
cxy[1]-=fl;
if it["prefix"] then
Memo.ExecuteCommand(Memo.ecSelGotoXY,cxy);
kgct := cxy[1];
kgcts :="";
for i := 1 to kgct-1 do
begin
kgcts+=" ";
end
s := "";
for i,v in extss do
begin
if i=0 then
begin
s+=v;
end else
begin
s+=kgcts+v;
end
s+="\r\n";
{if i=0 and it["prefix"] then
begin
cxy := Memo.CaretXY;
cxy[1]-=fl;
Memo.ExecuteCommand(Memo.ecSelGotoXY,cxy);
Memo.ExecuteCommand(Memo.ecString,v);
end else
begin
Memo.ExecuteCommand(Memo.ecString,v);
end
Memo.InsertChars("\r\n");}
end
Memo.ExecuteCommand(Memo.ecString,s);
end
return true;
end
return false;
end
function completedCase();virtual; //区分大小写
begin
return true;
end
function SetFilter(s); //筛选
begin
if not FCompData then return ;
if not(ifstring(s) and s) then return ;
if FFilter = s then return ;
ls := lowercase(s);
lsl := length(ls);
FFiltero := s;
if FIgnoreCase then
begin
cs := ls;
cindex := "lvalue";
if (lowercase(FFilter) = ls) then return ;
end else
begin
cs := s;
cindex := "value";
end
FFilter := s;
d := array();
ld :=0;
wd := 10;
for i,v in FCompData do
begin
vi := v[cindex];
if pos(cs,vi)=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;
private
FCurrentWidth;
FCompData;
FMemo;
FJump;
FIgnoreCase;
FFilter;
FFiltero;
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
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 y<Lines.Length() then
begin
x := xy[1];
s := Lines.GetStringByIndex(y-1);
if ifstring(s) and (length(s)+1=x) then
begin
return ExecuteCommand(ecGotoXY,array(y+1,1));
end
end
end
end
ecDeleteLastChar:
begin
if data = 1 then
begin
tc := TabChar;
x := CaretX;
ltc := length(tc);
if x>ltc then
begin
s := LineText;
if tc = s[x-ltc:x-1] then
begin
ExecuteCommand(ecSelGotoXY,array(CaretY,x-ltc));
SelText:="";
return ;
end
end
end
return inherited ExecuteCommand(ecDeleteLastChar);
end
end
return inherited;
end
function PrepareCompletion(c);//准备完成
begin
if Completion then return Completion.PrepareCompletion(c);
end
function TryCompletion();//提示
begin
if Completion then return Completion.TryCompletion();
end
function TryJump(s); //跳转
begin
if Completion then return CompLEtion.TryJump(s);
end
function Canjump(); //是否可以跳转到当前字符串
begin
if Completion then return Completion.Canjump();
end
function FinishCompletion(); //完成填充
begin
if Completion and Completion.Visible then return Completion.FinishCompletion();
end
function CancelCompletion(); //取消填充
begin
if Completion then return Completion.CancelCompletion();
end
function CharInput(c);override; //字符输入
begin
if ReadOnly then return ;
if c="\r\n" then
begin
if FinishCompletion() then //确定键
begin
return ;
end else
begin
return inherited;
end
end else
if c="\t" then
begin
b1 := BlockBegin;
b2 := BlockEnd;
if ifarray(b1) and ifarray(b2) and b2[0]>b1[0] then return ExecuteCommand(ectab,FTabChar);
else return inherited CharInput(FTabChar);
end
inherited;
if Completion then
begin
Completion.TryCompletion();
end
end
function Completioning(); //正在准备填充
begin
return Completion and Completion.Visible;
end
function PrevWord(); //前一个词语
begin
p := PrevWordPos();
ls := Lines;
s := ls.GetStringByIndex(p[0]-1);
sl := length(s);
cx := CaretX;
cw := "";
if p[1]<=sl and cx>p[1] then
begin
cw := s[p[1]:cx-1];
cw := trim(cw);
end;
return cw;
end
function CaretWords(); //光标所在词语
begin
e := NextWordPos();
b := PrevWordPos();
ls := Lines;
s := Lines[b[0]-1];
r := "";
if s then
begin
try
s := s.FStr;
for i:= b[1] to e[1]-1 do
begin
ivi := ord(s[i]);
if(ivi<48) or (ivi>57 and ivi<65) or (ivi>90 and ivi<95) or(ivi>95 and ivi<97) or(ivi>122 and ivi<=127) then continue;
r+=s[i];
end
except
r := "";
end;
end
return r;
end
function Create(AOwner);//构造
begin
inherited;
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]<ee[1] then
begin
selt := SelText;
selbx := bb[1];
selby := bb[0];
end
if selt then
begin
selt := lowercase(selt);
tks := Highlighter.GetLineTokens(selby-1);
for i,v in tks do
begin
if v.FPos=selbx then
begin
seltcj := v.FMate;
break;
end
end
IF seltcj then
begin
Selt := 0;
end
end
crect := ClientRect;
//crect := ClientRect;
rnzf := integer(crect[2]/cw)+20;
//***************************************************************************************
for i := FirstLine to LastLine do
begin
tks := Highlighter.GetLineTokens(i);
r := RC;
r0 := GutterWidth-(LeftChar-1)*cw;
r[1] := RC[1]+LineHeight*iy;
r[3] := r[1]+LineHeight;
iy++;
//r[3] := r[1]+LineHeight;
for j,v in tks do
begin
val := v.FValue;
vallength := length(val);
r[0] := r0+(v.FPos-1)*cw;
r[2] := r[0]+vallength*cw;
if r[2]<crect[0] then
begin
continue;
end
if r[0]>crect[2] then
begin
break;
end
c := V.FFColor;
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.
Reference in New Issue View Git Blame Copy Permalink