diff --git a/designer/tediterform.tsf b/designer/tediterform.tsf index 203fb74..d138c6a 100644 --- a/designer/tediterform.tsf +++ b/designer/tediterform.tsf @@ -1,5 +1,5 @@ type TEditerForm = class(TVCform) //编辑器主窗口 - uses tslvcl,UTslSynMemo,UtslCodeEditor; + uses utslvclauxiliary,tslvcl,UTslSynMemo,UtslCodeEditor; function WMACTIVATE(o,e):WM_ACTIVATE;override; //激活 begin inherited; diff --git a/designer/tslvcldesigner.tsf b/designer/tslvcldesigner.tsf index 3dd5708..4d43736 100644 --- a/designer/tslvcldesigner.tsf +++ b/designer/tslvcldesigner.tsf @@ -3,7 +3,7 @@ unit tslvclDesigner; @explan(说明)设计器库 %% **} interface -uses tslvcl,cstructurelib,UVCPropertyTypesPersistence,utslmemo,UDesignerProject; +uses cstructurelib,utslvclauxiliary,utslvclbase,utslvclgdi,tslvcl,UVCPropertyTypesPersistence,utslmemo,UDesignerProject; function initlib(); //*******设计控件基类********************** @@ -272,7 +272,7 @@ type TDComponent = class() ndp := nd.parent; if ndp then begin - dm := gettswin32api().MessageBoxA(nd.owner.handle,"即将删除:"+nd.Caption,"删除",0x1 .| 0x30); + dm := MessageBoxA("即将删除:"+nd.Caption,"删除",0x1 .| 0x30,nd.owner);// if dm<>1 then exit; wd := nd.Component.Cwnd; ds := nd.owner.Designer; @@ -5532,7 +5532,7 @@ type TGridCellBitmapEdit = class(TBtnCellDrawVTtype,TPropertyBitmap) {** @explan(说明) 绘制格子 %% **} - if ifarray(d) and (d["value"] is class(tbitmap) )then inherited; + if ifarray(d) and (d["value"] is class(TcustomBitmap) )then inherited; end function create(AOwner);override; @@ -5582,7 +5582,7 @@ type TGridCellIconEdit = class(TBtnCellDrawVTtype,TPropertyIcon) {** @explan(说明) 绘制格子 %% **} - if ifarray(d) and (d["value"] is class(ticon)) then inherited; + if ifarray(d) and (d["value"] is class(tcustomicon)) then inherited; end function create(AOwner);override; begin @@ -7555,7 +7555,7 @@ type TDesigImageList = class(TControlImageList) n := item.ClassName; id := FIconMaps[n]; bmp := item.bitmap(); - if (bmp is class(tbitmap)) and bmp.HandleAllocated() then + if (bmp is class(TcustomBitmap)) and bmp.HandleAllocated() then begin if id>=0 then begin @@ -8878,7 +8878,6 @@ F7A31439DD9B0EC80BCFCBD56CFE0506116665A7640DF50A54EEE2F8BDA750000 cwnd := cp.Cwnd; cwnd.PopupMenu := mu; xy := o.ClientToScreen(e.lolparamsigned,e.hilparamsigned); - //_send_(WM_CONTEXTMENU,self.handle,makeposition(xy[0],xy[1]),1); _send_(WM_CONTEXTMENU,cwnd.handle,makeposition(xy[0],xy[1]),1); return ; uf := TPM_LEFTALIGN .| TPM_TOPALIGN .| TPM_RIGHTBUTTON; @@ -9422,7 +9421,7 @@ type TBitmapGrid = class(TGridList) public function CheckItem(v);override; begin - return (v is class(tbitmap)) and inherited; + return (v is class(TcustomBitmap)) and inherited; end function create(AOwner);override; begin diff --git a/designer/udesignerproject.tsf b/designer/udesignerproject.tsf index c46db92..8123794 100644 --- a/designer/udesignerproject.tsf +++ b/designer/udesignerproject.tsf @@ -1,6 +1,6 @@ Unit UDesignerProject; interface -uses tslvcl,utslmemo,UTslSynMemo,UVCPropertyTypesPersistence,tslvclDesigner,UtslCodeEditor; +uses utslvclauxiliary,tslvcl,utslmemo,UTslSynMemo,UVCPropertyTypesPersistence,tslvclDesigner,UtslCodeEditor; function SetWndPostWithMouse(wnd,lft); type TProjectManagerForm = class(TVCForm) //工程管理 TCustomControl function Create(AOwner);override; diff --git a/designer/utslcodeeditor.tsf b/designer/utslcodeeditor.tsf index 513c977..7146015 100644 --- a/designer/utslcodeeditor.tsf +++ b/designer/utslcodeeditor.tsf @@ -1,540 +1,540 @@ unit UtslCodeEditor; - { - 编辑器相关的代码20220217修改 - } - interface - uses cstructurelib,tslvcl,UTslmemo,UTslSynMemo; - { - 1. page标签 - TPagees; TPageItem - 2. TMemoPages ,TMemoPageItem - 3. TEchoWnd - 4. TFindResultWnd - 5. FindStringWnd 查找框 - 5. TGotoLineWnd 跳转 +{ +编辑器相关的代码20220217修改 +} +interface +uses cstructurelib,utslvclauxiliary,utslvclmemstruct,utslvclgdi,tslvcl,UTslmemo,UTslSynMemo; +{ +1. page标签 +TPagees; TPageItem +2. TMemoPages ,TMemoPageItem +3. TEchoWnd +4. TFindResultWnd +5. FindStringWnd 查找框 +5. TGotoLineWnd 跳转 - } - function tdbgcallback(); //调试回调 - function gettslexe(); - type TPageItem=class //标签项 - function Create(AOwner); - begin - FCaption := ""; - FOwner := AOwner; - end - function Recycling();virtual; - begin - FBitmapA := nil; - FBitmapB := nil; - Tag := nil; - end - published - property Caption read FCaption write SetCaption; - property BitmapA read FBitmapA write SetBitmapA; - property BitmapB read FBitmapB write SetBitmapB; - tag; - Rect; - protected - function SetCaption(s); - begin - if s and ifstring(s)then - begin - FCaption := s; - if FOwner then FOwner.ItemCaptionChenged(self); - end - end - private - function SetBitmapA(Bmp); - begin - if FBitmapA <> Bmp then - begin - FBitmapA := Bmp; - if FOwner then FOwner.ItemBitmapAChenged(self); - end - end - function SetBitmapB(Bmp); - begin - if FBitmapB <> Bmp then - begin - FBitmapB := Bmp; - if FOwner then FOwner.ItemBitmapBChenged(self); - end - end - FBitmapB; - FBitmapA; - FCaption; - FOwner; +} +function tdbgcallback(); //调试回调 +function gettslexe(); +type TPageItem=class //标签项 + function Create(AOwner); + begin + FCaption := ""; + FOwner := AOwner; end - type TPage=class(TCustomControl) //标签 - function Create(AOwner) + function Recycling();virtual; + begin + FBitmapA := nil; + FBitmapB := nil; + Tag := nil; + end + published + property Caption read FCaption write SetCaption; + property BitmapA read FBitmapA write SetBitmapA; + property BitmapB read FBitmapB write SetBitmapB; + tag; + Rect; + protected + function SetCaption(s); + begin + if s and ifstring(s)then begin - Inherited; - FCloseBtn := false; - FPageItems := new TMyarrayB(); - FMultiLine := 1; - FLineHeight := 16; //font.Height+6; - FLines := 0; - FItemIndex :=-1; - FWill_Drag := true; - font := array("height":16,"width":8,"escapement":0,"orientation":0,"weight":400,"italic":0,"underline":0,"strikeout":0, - "charset":0,"outprecision":0,"clipprecision":0,"quality":1,"pitchandfamily":1,"facename":"Courier New","color":0); + FCaption := s; + if FOwner then FOwner.ItemCaptionChenged(self); end - function GetPageRect(); //获得标签区域 + end + private + function SetBitmapA(Bmp); + begin + if FBitmapA <> Bmp then begin - GetClientRect(); - return FPageRect; + FBitmapA := Bmp; + if FOwner then FOwner.ItemBitmapAChenged(self); end - function PosInCurrentItemSection(xy); //点击部分 + end + function SetBitmapB(Bmp); + begin + if FBitmapB <> Bmp then begin - if not FCurrentITem then return 0; - rc := FCurrentItem.Rect; - if not rc then return 0; - rc1 := rc; - rc1[2]:= rc1[0]+20; - if PointInrect(xy,rc1)then return 1; - rc1 := rc; - rc1[0]:= rc[2]-20; - if PointInrect(xy,rc1)then return 3; - if PointInRect(xy,rc)then return 2; + FBitmapB := Bmp; + if FOwner then FOwner.ItemBitmapBChenged(self); end - function DoControlAlign();override; + end + FBitmapB; + FBitmapA; + FCaption; + FOwner; +end +type TPage=class(TCustomControl) //标签 + function Create(AOwner) + begin + Inherited; + FCloseBtn := false; + FPageItems := new TMyarrayB(); + FMultiLine := 1; + FLineHeight := 16; //font.Height+6; + FLines := 0; + FItemIndex :=-1; + FWill_Drag := true; + font := array("height":16,"width":8,"escapement":0,"orientation":0,"weight":400,"italic":0,"underline":0,"strikeout":0, + "charset":0,"outprecision":0,"clipprecision":0,"quality":1,"pitchandfamily":1,"facename":"Courier New","color":0); + end + function GetPageRect(); //获得标签区域 + begin + GetClientRect(); + return FPageRect; + end + function PosInCurrentItemSection(xy); //点击部分 + begin + if not FCurrentITem then return 0; + rc := FCurrentItem.Rect; + if not rc then return 0; + rc1 := rc; + rc1[2]:= rc1[0]+20; + if PointInrect(xy,rc1)then return 1; + rc1 := rc; + rc1[0]:= rc[2]-20; + if PointInrect(xy,rc1)then return 3; + if PointInRect(xy,rc)then return 2; + end + function DoControlAlign();override; + begin + CalcPageItemRect(); + end + function CreateApageItem();virtual; + begin + return new TPageItem(self); + end + function itemcaptionchenged(it); + begin + if GetItemIndex(it)>= 0 then begin - CalcPageItemRect(); - end - function CreateApageItem();virtual; - begin - return new TPageItem(self); - end - function itemcaptionchenged(it); - begin - if GetItemIndex(it)>= 0 then - begin - DoControlAlign(); - InValidateRect(nil,false); - end - end - function ItemBitmapAChenged(it); - begin - if GetItemIndex(it)>= 0 then InValidateRect(it.Rect,false); - end - function ItemBitmapBChenged(it); - begin - if GetItemIndex(it)>= 0 then InValidateRect(it.Rect,false); - end - function FontChanged();override; - begin - FLineHeight := font.Height+6; - DoControlAlign(); - end - function IncPaintLock(); - begin - BeginUpdate(); - end - function DecPaintLock(); - begin - EndUpdate(); - end - function DoEndUpDate();override; - begin - DoControlAlign(); - inherited; - end - function GetClientRect();override; - begin - r := inherited; - FPageRect := R; - r[1]+= FLineHeight * FLines; //FLabelsheight; - FPageRect[3]:= r[1]; - return r; - end - function Paint();override; - begin - dc := Canvas; - ps := PAINTSTRUCT().rcPaint; - //dc.Pen.Color := rgb(180,180,100); - dc.Pen.Color := rgb(250,250,250); - dc.Pen.Width := 1; - dc.font := font; - for i := 0 to FPageItems.Length()-1 do - begin - it := FPageitems[i]; - rc := it.Rect; - if not rc then continue; - if Intersectrect(it.Rect,ps)then - begin - if FItemIndex=i then - begin - //dc.Brush.Color := rgb(244,205,205); - dc.Brush.Color := 0xFa901E; - end else - begin - dc.Brush.Color := rgb(238,238,228) //rgb(244,244,244); - end - dc.draw("roundrect",array(rc[0:1],rc[2:3],array(5,5))); - if it.BitmapB then - begin - rc1 := rc; - rc1[0]:= rc[2]-20; - rc1[2]-= 2; - rc1[1]+= 4; - rc1[3]-= 4; - dc.Stretchdraw(rc1,it.BitmapB); - end - if it.BitmapA then - begin - rc1 := rc; - rc1[2]:= rc1[0]+20; - rc1[0]+= 2; - rc1[2]-= 2; - rc1[1]+= 2; - rc1[3]-= 2; - dc.Stretchdraw(rc1,it.BitmapA); - end - rc[0]+= 20; - dc.DrawText(it.caption,rc,DT_nOPREFIX .| DT_LEFT .| DT_SINGLELINE .| DT_VCENTER); - end - end - if FCloseBtn and((FPageItems.Length()>0))then - begin - Closebmp(); - rc := ClientRect; - FBmpClose.Draw(dc,rc[2]-25,3,SRCAND); - //rc := ClientRect; - //rc := array(rc[2]-25,1,rc[2]-1,19); - //dc.Stretchdraw(rc,FBmpClose); - end - end - function SetSel(it); - begin - idx := GetItemIndex(it); - if idx >= 0 and idx <> FItemIndex then - begin - ItemIndex := idx; - end - end - function CloseAllItem(it); - begin - FItemINdex :=-1; - FCurrentITem := nil; - saveit := nil; - for i,v in FPageItems.Data do - begin - if v=it then - begin - saveit := it; - continue; - end - end - FPageItems.Splice(0,FPageItems.Length()); - if saveit then - begin - FItemINdex := 0; - FCurrentITem := it; - FPageItems.push(it); - end - //InValidateRect(nil,false); DoControlAlign(); InValidateRect(nil,false); end - function DeleteItemByIndex(idx);virtual; + end + function ItemBitmapAChenged(it); + begin + if GetItemIndex(it)>= 0 then InValidateRect(it.Rect,false); + end + function ItemBitmapBChenged(it); + begin + if GetItemIndex(it)>= 0 then InValidateRect(it.Rect,false); + end + function FontChanged();override; + begin + FLineHeight := font.Height+6; + DoControlAlign(); + end + function IncPaintLock(); + begin + BeginUpdate(); + end + function DecPaintLock(); + begin + EndUpdate(); + end + function DoEndUpDate();override; + begin + DoControlAlign(); + inherited; + end + function GetClientRect();override; + begin + r := inherited; + FPageRect := R; + r[1]+= FLineHeight * FLines; //FLabelsheight; + FPageRect[3]:= r[1]; + return r; + end + function Paint();override; + begin + dc := Canvas; + ps := PAINTSTRUCT().rcPaint; + //dc.Pen.Color := rgb(180,180,100); + dc.Pen.Color := rgb(250,250,250); + dc.Pen.Width := 1; + dc.font := font; + for i := 0 to FPageItems.Length()-1 do begin - if idx >= 0 and idx0))then begin - MouseDragDo(o,e); - inherited; + Closebmp(); + rc := ClientRect; + FBmpClose.Draw(dc,rc[2]-25,3,SRCAND); + //rc := ClientRect; + //rc := array(rc[2]-25,1,rc[2]-1,19); + //dc.Stretchdraw(rc,FBmpClose); end - function MouseDrageLeave(); //离开移动 + end + function SetSel(it); + begin + idx := GetItemIndex(it); + if idx >= 0 and idx <> FItemIndex then begin - if FIs_Draging then + ItemIndex := idx; + end + end + function CloseAllItem(it); + begin + FItemINdex :=-1; + FCurrentITem := nil; + saveit := nil; + for i,v in FPageItems.Data do + begin + if v=it then begin - FNot_DragLive := false; + saveit := it; + continue; + end + end + FPageItems.Splice(0,FPageItems.Length()); + if saveit then + begin + FItemINdex := 0; + FCurrentITem := it; + FPageItems.push(it); + end + //InValidateRect(nil,false); + DoControlAlign(); + InValidateRect(nil,false); + end + function DeleteItemByIndex(idx);virtual; + begin + if idx >= 0 and idx= 0 and FItemIndex <> idx then - begin - if FItemIndex=0 then - begin - e._Tag := FPageitems[idx]; - callDatafunction(fOnbmpbclick,o,e); - idx := GetItemIndex(FCurrentItem); - ItemIndex := idx; - return ; - end - end - if e.shiftdouble() then //处理新建 - begin - idx := GetItemIndexByPos(e.pos); - if idx=-1 then - begin - callDatafunction(OnDblClick,o,e); - end - return ; - end - if e.button=mbLeft then - begin - cidx := posinitembmpb(e.pos); - if cidx>=0 then - begin - e._Tag := FPageitems[cidx]; - callDatafunction(fOnbmpbclick,o,e); - idx := GetItemIndex(FCurrentItem); - ItemIndex := idx; - return ; - end - end - idx := GetItemIndexByPos(e.pos); - itemindex := idx; - FCloseBtnClicked := false; - if e.button=mbLeft and idx >= 0 then - begin - nxy := clienttowindow(e.xpos,e.ypos); - if FCanDraged and FWill_Drag then - begin - IncPaintLock(); - FWill_Drag := false; - FIs_Draging := true; - CreateImageList(); - _wapi.ImageList_BeginDrag(FDRageimglist,0,12,12); - FNot_DragLive := true; - //_wapi.ImageList_DragEnter(self.Handle,nxy[0],nxy[1]); - crect := GetPageRect(); - ps := array(clienttoscreen(crect[0],crect[1]),clienttoscreen(crect[2],crect[3])); - _wapi.clipcursor(ps); - end end else begin - rc := ClientRect; - rc := array(rc[2]-25,1,rc[2]-1,19); - if PointInRect(e.pos,rc)then + nxy := clienttowindow(e.xpos,e.ypos); + if FNot_DragLive then begin - FCloseBtnClicked := true; + _wapi.ImageList_DragEnter(self.Handle,nxy[0],nxy[1]); + FNot_DragLive := false; + end + _wapi.ImageList_DragMove(nxy[0],nxy[1]); + end + end + end + function MouseMove(o,e);override; + begin + MouseDragDo(o,e); + inherited; + end + function MouseDrageLeave(); //离开移动 + begin + if FIs_Draging then + begin + FNot_DragLive := false; + _wapi.ImageList_DragLeave(self.Handle); + _wapi.ImageList_EndDrag(); + FWill_Drag := true; + FIs_Draging := false; + _wapi.clipcursor(0); + end + end + function MouseUp(o,e);override; + begin + if e.button=mbLeft then + begin + if FIs_Draging then + begin + MouseDrageLeave(); + idx := GetItemIndexByPos(e.pos); + IF idx >= 0 and FItemIndex <> idx then + begin + if FItemIndex=0 then + begin + e._Tag := FPageitems[idx]; + callDatafunction(fOnbmpbclick,o,e); + idx := GetItemIndex(FCurrentItem); + ItemIndex := idx; + return ; + end + end + if e.shiftdouble() then //处理新建 + begin + idx := GetItemIndexByPos(e.pos); + if idx=-1 then + begin + callDatafunction(OnDblClick,o,e); + end + return ; + end + if e.button=mbLeft then + begin + cidx := posinitembmpb(e.pos); + if cidx>=0 then + begin + e._Tag := FPageitems[cidx]; + callDatafunction(fOnbmpbclick,o,e); + idx := GetItemIndex(FCurrentItem); + ItemIndex := idx; + return ; + end + end + idx := GetItemIndexByPos(e.pos); + itemindex := idx; + FCloseBtnClicked := false; + if e.button=mbLeft and idx >= 0 then + begin + nxy := clienttowindow(e.xpos,e.ypos); + if FCanDraged and FWill_Drag then + begin + IncPaintLock(); + FWill_Drag := false; + FIs_Draging := true; + CreateImageList(); + _wapi.ImageList_BeginDrag(FDRageimglist,0,12,12); + FNot_DragLive := true; + //_wapi.ImageList_DragEnter(self.Handle,nxy[0],nxy[1]); + crect := GetPageRect(); + ps := array(clienttoscreen(crect[0],crect[1]),clienttoscreen(crect[2],crect[3])); + _wapi.clipcursor(ps); + end + end else begin rc := ClientRect; rc := array(rc[2]-25,1,rc[2]-1,19); - return PointInRect(ps,rc); - end - function GetItemIndexByPos(xy); - begin - for i := 0 to FPageItems.Length()-1 do + if PointInRect(e.pos,rc)then begin - if PointInrect(xy,FPageItems[I].Rect)then return i; - end - return -1; - end - function posinitembmpb(xy); - begin - for i := 0 to FPageItems.Length()-1 do - begin - it := FPageItems[I]; - if not it.BitmapB then continue ; - ri := it.Rect; - ri[0] := ri[2]-18; - ri[1]+=2; - ri[3]-=2; - ri[2]-=2; - if PointInrect(xy,ri)then return i; - end - return -1; - end - Function GetItemIndex(it); - begin - for i := 0 to FPageItems.length()-1 do - begin - if it=FPageitems[i]then - begin - return i; - end - end - return -1; - end - function Recycling();override; - begin - FPageItems.Splice(0,FPageItems.Length()); - FOnSelChanged := nil; - FOnSelchanging := nil; - FCurrentItem := nil; - FItemIndex :=-1; - FOnCloseClick := nil; - fOnbmpbclick := nil; - inherited; - end - property CurrentItem read FCurrentItem; - property OnSelChanged read FOnSelChanged write FOnSelChanged; - property OnSelChanging read FOnSelChanging write FOnSelChanging; - property OnCloseClick read FOnCloseClick write FOnCloseClick; - property Onbmpbclick read FOnbmpbclick write fOnbmpbclick; - property MultiLine read FMultiLine write SetMultiLine; - property CloseBtn read FCloseBtn write SetCloseBtn; - property Lines read FLines; - property PageItems read FPageItems; - property ItemIndex read FItemIndex write SetItemIndex; - protected - function CallSelChanged();virtual; - begin - if not OnSelChanged then return false; - e := new tuieventbase(); - callDatafunction(OnSelChanged,self(true),e); - end - function CallSelChanging();virtual; - begin - if not FOnSelchanging then return false; - e := new tuieventbase(); - CallDatafunction(FOnSelchanging,self(true),e); - return e.skip; - end - function CalcPageItemRect(); - begin - li := 0; - cw := Font.Width; - r := class(TCustomControl).ClientRect; - x := 0; - xct := 0; - for i := 0 to FPageitems.Length()-1 do - begin - it := FPageitems[i]; - itwidth := length(it.Caption) * cw+40; - if xct>0 and(r[2]-(FCloseBtn?20:0)) FCloseBtn then - begin - FCloseBtn := nv; - DoControlAlign(); - end - end - function SetItemIndex(idx); - begin - if idx >= 0 and idx FItemIndex then - begin - if CallSelChanging()then return; - FItemIndex := idx; - FCurrentItem := FPageItems[idx]; - InValidateRect(nil,false); - CallSelChanged(); - end - end - FMultiLine; - FLineHeight; - FLines; - FOnSelChanged; - FOnCloseClick; - FOnSelchanging; - function SetMultiLine(); + return FBmpClose; + end + function SetCloseBtn(v); + begin + nv := v?true:false; + if nv <> FCloseBtn then begin + FCloseBtn := nv; + DoControlAlign(); end end - type TEditerAuxiliary=class(TPage) //辅助窗口 - function Create(AOwner); + function SetItemIndex(idx); + begin + if idx >= 0 and idx FItemIndex then begin - inherited; - Caption := "message:"; - Ftimer := new TTimer(self); - Ftimer.Interval := 200; - Ftimer.Ontimer := thisfunction(BdownTimeOut); - Ftimer.Enabled := false; - //FEchoItem := CreateApageItem(); - //FFileFindeItem := CreateApageItem(); - OnSelChanged := thisfunction(OnSelChangedCall); - CloseBtn := true; + if CallSelChanging()then return; + FItemIndex := idx; + FCurrentItem := FPageItems[idx]; + InValidateRect(nil,false); + CallSelChanged(); end - function WMNCLBUTTONDOWN(o,e):WM_NCLBUTTONDOWN;override; - begin - FIgnoreSize := true; - Ftimer.Enabled := true; - end - function BdownTimeOut(o,e); - begin - if(_wapi.GetAsyncKeyState(VK_LBUTTON).& 0xFF00)>0 then - begin - end else - begin - FIgnoreSize := false; - o.Enabled := false; - p := Parent; - if p then p.DoControlAlign(); - end - end - {function MouseDown(o,e);override; - begin - if CloseBtn then - begin - rc := ClientRect; - rc := rc := array(rc[2]-25,1,rc[2]-1,19); - if PointInRect(e.pos,rc) then - begin - callDatafunction(FOnCloseClick,o,e); - end - end + end + FMultiLine; + FLineHeight; + FLines; + FOnSelChanged; + FOnCloseClick; + FOnSelchanging; + function SetMultiLine(); + begin + end +end +type TEditerAuxiliary=class(TPage) //辅助窗口 + function Create(AOwner); + begin inherited; - end } - //property OnCloseClick read FOnCloseClick write FOnCloseClick; - function DoControlAlign();override; + Caption := "message:"; + Ftimer := new TTimer(self); + Ftimer.Interval := 200; + Ftimer.Ontimer := thisfunction(BdownTimeOut); + Ftimer.Enabled := false; + //FEchoItem := CreateApageItem(); + //FFileFindeItem := CreateApageItem(); + OnSelChanged := thisfunction(OnSelChangedCall); + CloseBtn := true; + end + function WMNCLBUTTONDOWN(o,e):WM_NCLBUTTONDOWN;override; + begin + FIgnoreSize := true; + Ftimer.Enabled := true; + end + function BdownTimeOut(o,e); + begin + if(_wapi.GetAsyncKeyState(VK_LBUTTON).& 0xFF00)>0 then begin - if FIgnoreSize then - begin - end - inherited; - rc := ClientRect; - //单独处理linux的情况 - {$ifdef linux} - rc[0]+= 2; - rc[2]-= 2; - rc[3]-= 2; - {$endif} - if CurrentItem then wnd := CurrentItem.Tag; - if wnd then wnd.SetBoundsRect(Rc); + end else + begin + FIgnoreSize := false; + o.Enabled := false; + p := Parent; + if p then p.DoControlAlign(); end - function ShowPopUp(); + end + {function MouseDown(o,e);override; + begin + if CloseBtn then + begin + rc := ClientRect; + rc := rc := array(rc[2]-25,1,rc[2]-1,19); + if PointInRect(e.pos,rc) then + begin + callDatafunction(FOnCloseClick,o,e); + end + end + inherited; + end } + //property OnCloseClick read FOnCloseClick write FOnCloseClick; + function DoControlAlign();override; + begin + if FIgnoreSize then begin + end + inherited; + rc := ClientRect; + //单独处理linux的情况 + {$ifdef linux} + rc[0]+= 2; + rc[2]-= 2; + rc[3]-= 2; + {$endif} + if CurrentItem then wnd := CurrentItem.Tag; + if wnd then wnd.SetBoundsRect(Rc); + end + function ShowPopUp(); + begin + if not WSpOPUp then + begin + WSpOPUp := true; + Parent.DoControlAlign(); + end + if not Visible then Visible := true; + end + function MouseDown(o,e);override; + begin + if e.shiftdouble()and e.button()=mbLeft then + begin + WSpOPUp := not WSpOPUp; + Parent.DoControlAlign(); if not WSpOPUp then begin - WSpOPUp := true; - Parent.DoControlAlign(); + _wapi.SetWindowPos(self.Handle,0,0,0,0,0,SWP_NOMOVE .| SWP_NOSIZE .| SWP_NOREDRAW .| SWP_NOSENDCHANGING); end - if not Visible then Visible := true; - end - function MouseDown(o,e);override; + end else + if GetItemIndexByPos(e.pos)>= 0 then begin - if e.shiftdouble()and e.button()=mbLeft then - begin - WSpOPUp := not WSpOPUp; - Parent.DoControlAlign(); - if not WSpOPUp then - begin - _wapi.SetWindowPos(self.Handle,0,0,0,0,0,SWP_NOMOVE .| SWP_NOSIZE .| SWP_NOREDRAW .| SWP_NOSENDCHANGING); - end - end else - if GetItemIndexByPos(e.pos)>= 0 then - begin - inherited; - end else - if PostInCloseRect(e.pos)then - begin - //echo "------------\r\n"; - inherited; - end else - begin - if WSpOPUp then _send_(WM_SYSCOMMAND,0xF012,0); - end - end - function Recycling();override; - begin - Ftimer := nil; - FEchoWnd := nil; - FFileFindWnd := nil; - FOnCloseClick := nil; inherited; - //FOnCloseClick := nil; - end - function ShowByTag(tg); //显示 + end else + if PostInCloseRect(e.pos)then begin - its := Pageitems; - for i := 0 to its.Length()-1 do + //echo "------------\r\n"; + inherited; + end else + begin + if WSpOPUp then _send_(WM_SYSCOMMAND,0xF012,0); + end + end + function Recycling();override; + begin + Ftimer := nil; + FEchoWnd := nil; + FFileFindWnd := nil; + FOnCloseClick := nil; + inherited; + //FOnCloseClick := nil; + end + function ShowByTag(tg); //显示 + begin + its := Pageitems; + for i := 0 to its.Length()-1 do + begin + if its[i].tag=tg then begin - if its[i].tag=tg then - begin - ItemIndex := i; - //visible := true; - return; - end + ItemIndex := i; + //visible := true; + return; end end - function OnSelChangedCall(o,e); + end + function OnSelChangedCall(o,e); + begin + if not CurrentItem then Caption := "--"; + rc := ClientRect; + its := PageItems; + for i := 0 to its.Length()-1 do + begin + it := its[i]; + if CurrentItem=it then + begin + it.tag.SetboundsRect(rc); + it.tag.Visible := true; + caption := it.Tag.Caption; + end else + it.tag.Visible := false; + end + end + function AddWnd(wnd); + begin + if wnd is class(TWincontrol)then begin - if not CurrentItem then Caption := "--"; - rc := ClientRect; its := PageItems; for i := 0 to its.Length()-1 do begin it := its[i]; - if CurrentItem=it then - begin - it.tag.SetboundsRect(rc); - it.tag.Visible := true; - caption := it.Tag.Caption; - end else - it.tag.Visible := false; + if it.tag=wnd then return; end - end - function AddWnd(wnd); - begin - if wnd is class(TWincontrol)then + IncPaintLock(); + it := CreateApAgeItem(); + it.Caption := wnd.Caption; + it.tag := wnd; + wnd.visible := 0; + wnd.Parent := self; + PageItems.Push(it); + if PageItems.Length()=1 then begin - its := PageItems; - for i := 0 to its.Length()-1 do - begin - it := its[i]; - if it.tag=wnd then return; - end - IncPaintLock(); - it := CreateApAgeItem(); - it.Caption := wnd.Caption; - it.tag := wnd; - wnd.visible := 0; - wnd.Parent := self; - PageItems.Push(it); - if PageItems.Length()=1 then - begin - itemIndex := 0; - end - DecPaintLock(); + itemIndex := 0; end + DecPaintLock(); end - FEchoWnd; - FFileFindWnd; - FOnCloseClick; - private - Ftimer; - FIgnoreSize; end - type TExecuteEditer=class(TCustomControl) //执行编辑器 - Protected - Type TExecuteMemoComp=class(TSynCompletion) - function Create(AOwner); - begin - inherited; - IgnoreCase := false; - end - function PrepareCompletion(c);override; //获得数据 - begin - //通过SetCompData 设置数据 - if Not Memo then return; - d := array(); - for i,v in array("FULL_CURRENT_PATH","CURRENT_DIRECTORY","SEARCH_PATH","TSL_EXE") do - begin - d[i,"caption"]:= v; - d[i,"value"]:= v; - d[i,"lvalue"]:= lowercase(v); - cl := length(v); - d[i,"clen"]:= cl; - d[i,"vlen"]:= cl; - end - SetCompData(d); - end - end - type TListBoxb=class(TListBOx) - function Create(AOwner); - begin - inherited; - end - function CheckListItem(it);override; - begin - return ifobj(it); - end - function GetItemText(i);override; - begin - it := GetItem(i); - if it then return it.FCaption; - return ""; - end - 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 - function GetItemIndex();virtual; - begin - return inherited; - end - function SetItemIndex(idx);virtual; - begin - inherited; - FListBox.InsureItemVisible(idx); - end - end - type TComboBoxb=class(TCombobox) - function Create(AOwner); - begin - INherited; - end - function CreateAlist();override; - begin - return new TListBoxb(self); - end - end - type TCobItem=class - function Create(d); - begin - FCaption := ""; - FExe := ""; - if not ifarray(d)then return; - FCaption := d["caption"]; - FExe := d["exe"]; - end - FCaption; - FExe; - end - public - function showexeediter(); - begin - FMemo.ExecuteCommand(FMemo.ecGotoXY,array(1,1)); - FMemO.SetFocus(); - show(); - end + FEchoWnd; + FFileFindWnd; + FOnCloseClick; + private + Ftimer; + FIgnoreSize; +end +type TExecuteEditer=class(TCustomControl) //执行编辑器 + Protected + Type TExecuteMemoComp=class(TSynCompletion) function Create(AOwner); begin inherited; - WSsYSMenu := true; - WsDlgModalFrame := true; - WsSizeBox := true; - WSpOPUp := true; - FItems := new TMyArrayB(); - caption := "编辑 Execute....."; - SetBoundsRect(array(50,50,930,201)); - FMemo := new TSynMemoNorm(self); - FMemo.OnKeyPress := function(o,e) + IgnoreCase := false; + end + function PrepareCompletion(c);override; //获得数据 + begin + //通过SetCompData 设置数据 + if Not Memo then return; + d := array(); + for i,v in array("FULL_CURRENT_PATH","CURRENT_DIRECTORY","SEARCH_PATH","TSL_EXE") do begin - if 13=e.charcode then - begin - e.skip := true; - doSaveCurrentName(); - end - end - {FMemo.OnKeyDown := function(o,e) - begin - case e.charcode of - VK_DOWN: - begin - e.skip := true; - FChooser.ItemIndex += 1; - end - VK_UP: - begin - e.skip := true; - FChooser.ItemIndex -= 1; - end - end; - end} - - FMemo.Border := true; - FMemo.parent := self; - FChooser := new TComboBoxb(self); //new TEditList(self); - FChooser.ReadOnly := false; - FChooser.parent := self; - FOkBtn := new TBtn(self); - FCancelBtn := new TBtn(self); - FEgnorBtn := new TBtn(self); - cp := new TExecuteMemoComp(self); - FMemo.Completion := cp; - cp.PrepareCompletion(); - OnClose := function(o,e) - begin - e.skip := true; - o.visible := false; + d[i,"caption"]:= v; + d[i,"value"]:= v; + d[i,"lvalue"]:= lowercase(v); + cl := length(v); + d[i,"clen"]:= cl; + d[i,"vlen"]:= cl; end - FOkBtn.Caption := "保存/添加"; - FCancelBtn.Caption := "删除当前"; - FEgnorBtn.caption := "取消"; - FOkBtn.parent := self; - FCancelBtn.parent := self; - FEgnorBtn.parent := self; - FMemo.parent := self; - FChooser.OnSelChanged := thisfunction(OnChooserChanged); - FCancelBtn.OnClick := thisfunction(DeleteCurrent); - FOkBtn.OnClick := thisfunction(doSaveCurrentName); - FEGnorBtn.OnClick := thisfunction(OnIgnore); - end - function Recycling();override; - begin - inherited; - FMemo := nil; - FChooser := nil; - FCancelBtn := nil; - FOkBtn := nil; - FEgnorBtn := nil; - Fonsaveclk := nil; - end - function DeleteCurrent(); - begin - if length(FChooser.Items)<2 then return ; - FChooser.DeleteItem(FChooser.ItemIndex); - end - function DoControlAlign();override; - begin - if FMemo and FChooser and FCancelBtn and FOkBtn and FEgnorBtn then - begin - r := clientRect; - r1 := r; - r1[3]-= 30; - FMemo.SetBoundsRect(r1); - tp := r1[3]+2; - wd := 200; - x := 50; - FChooser.SetBoundsRect(array(x,tp,x+200,tp+26)); - x += 200; - FCancelBtn.SetBoundsRect(array(x+20,tp,x+20+100,tp+26)); - x += 120; - FOkBtn.SetBoundsRect(array(x+20,tp,x+100,tp+26)); - x += 120; - FEgnorBtn.SetBoundsRect(array(x+20,tp,x+100,tp+26)); - x += 120; - end - end - function OnIgnore(); - begin - idx := FChooser.ItemIndex; - if idx >= 0 then - begin - it := FChooser.GetItem(idx); - FChooser.Editer.Text := it.FCaption; - FMemo.Text := it.FExe; - end - Visible := false; - end - function GetCurrentExuteparams(f); - begin - return ParserCommandLine(GetCurrentExuteString(f)); - end - function getcurrentcommandline(); - begin - idx := FChooser.ItemIndex; - if not(idx >= 0)then return ""; - s := FChooser.GetItem(idx).fexe; - if not ifstring(s)then return ""; - return s; - end - function GetCurrentExuteString(f); //获得当前的执行字符串 - begin - if not ifstring(f)then return ""; - if not fileexists("",f)then return ""; - idx := FChooser.ItemIndex; - if not(idx >= 0)then return ""; - s := FChooser.GetItem(idx).fexe; - if not ifstring(s)then return ""; - s := replacetext(s,"$(FULL_CURRENT_PATH)",f); - dir := ""; - sp := ioFileseparator(); - for i := length(f)downto 1 do - begin - if f[i]=sp then - begin - dir := f[1:i-1]; - break; - end - end - s := replacetext(s,"$(CURRENT_DIRECTORY)",dir); - s := replacetext(s,"$(SEARCH_PATH)",owner.getlibpathstr()); - s := replacetext(s,"$(TSL_EXE)",gettslexe()); - return s; - end - function doSaveCurrentName(); - begin - Visible := false; - s := FChooser.Editer.Text; - its := FChooser.Items; - len := Length(its); - for i,v in its do - begin - if v.FCaption=s then - begin - v.FExe := FMemo.Text; - return callDatafunction( Fonsaveclk,self,self); - end - end - if cannotadd then return ; - FChooser.InsertItem(new TCobItem(array("caption":s,"exe":FMemo.Text)),0); - FChooser.ItemIndex := 0; - callDatafunction( Fonsaveclk,self,self); - end - function OnChooserChanged(o,e); - begin - idx := o.ItemIndex; - if idx >= 0 then - begin - it := O.GetItem(idx); - FMemo.Text := it.fexe; - end else - FMemo.Text := ""; - FMemo.ClearUndo(); - end - function GetData(); //获得数据 - begin - r := array(); - its := FChooser.Items; - if not(its)then return r; - r["itemindex"]:= FChooser.ItemIndex; - for i,v in its do - begin - r["items"][i]:= array("caption":v.FCaption,"exe":v.FExe); - end - return r; - end - function SetData(d); //设置数据 - begin - if ifarray(d)then - begin - SetItems(d["items"]); - FChooser.ItemIndex := d["itemindex"]; - end - end - property Items read FItems Write SetItems; - property onsaveclk read Fonsaveclk write Fonsaveclk; - property cannotadd read FCannotadd write FCannotadd; - private - FCannotadd; - Fonsaveclk; - FMemo; - FChooser; - FCancelBtn; - FOkBtn; - FItems; - FEgnorBtn; - private - function GetItemIndex(); - begin - return FChooser.Items; - end - function SetItems(its); //设置信息 - begin - vs := array(); - for i,v in its do - begin - if ifarray(v)and ifstring(v["caption"])and ifstring(v["exe"])then - begin - vi := new TCobItem(v); - vs[length(vs)]:= vi; - end - end - FChooser.Items := vs; + SetCompData(d); end end - type TEditList=class(TComboBox) - function Create(AOwner);override; + type TListBoxb=class(TListBOx) + function Create(AOwner); begin inherited; - width := 280; - maxListItemShow := 30; - FMaxCoder := 20; - ReadONly := false; - Editer.OnKeyDown := function(o,e) - begin - case e.charcode of - VK_UP: - begin - ItemIndex -= 1; - e.skip := true; - end - VK_DOWN: - begin - ItemIndex += 1; - e.skip := true; - end - 13: - begin - Calldatafunction(OnEnterUp,self(true),e); - e.skip := true; - end - VK_ESCAPE: - begin - oer := o.owner.owner; - if oer then oer.Visible := false; - end - ord("A"): - begin - if ssCtrl in e.Shiftstate()then - begin - e.skip := true; - o.SetSel(0,length(o.text)); - end - end - end; - end end - function Recycling();override; + function CheckListItem(it);override; begin - inherited; - FOnEnterUp := nil; + return ifobj(it); end - function Pushitem(s); + function GetItemText(i);override; begin - if not ifstring(s)and s then return; - if s in Items then return 0; - insertItem(s,0); - if getItemCount()>FMaxCoder then - begin - deleteItem(FMaxCoder); - end - end - property OnEnterUp read FOnEnterUp write FOnEnterUp; - property MaxCoder read FMaxCoder write FMaxCoder; - private - FMaxCoder; - FOnEnterUp; - end - type TFindWnd=class(TPage) - type TFindBtn=class(TBtn) - function Create(AOwner); - begin - inherited; - left := 425; - width := 160; - height := 25; - end - end - type TFindCheck=class(TCheckBtn) - function Create(AOwner); - begin - inherited; - left := 25; - width := 160; - height := 25; - end - end - function CreateWndInfo(btn,sec); //触发 - begin - r := GetInfo(); - if sec then r["section"]:= sec; - r["btn"]:= btn; - end - function Create(AOwner);override; - begin - inherited; - OnClose := function(o,e) - begin - Parent.EndFind(); - o.visible := false; - e.Skip := true; - end - WsDlgModalFrame := true; - Visible := false; - WsPopUp := true; - WsCaption := true; - WSsYSMenu := true; - //WsSizeBox := true; - caption := "查找"; - SetBoundsRect(array(300,300,920,680)); - IncPaintLock(); - for i,v in array("查找","替换","文件查找") do - begin - it := CreateApageItem(); - it.Caption := v; - PageItems.Push(it); - end - DecPaintLock(); - lg := 30; - FEdit_Target := new TEditList(self); - FEdit_repace := new TEditList(self); - FEdit_Type := new TEditList(self); - FEdit_dir := new TEditList(self); - FDirChooser := new TFolderChooseADlg(self); - FEdit_dir_btn := new TBtn(self); - flabels := array(); - for i,v in array("查找目标:"," 替换为:","文件类型:"," 目录:") do - begin - lb := new TLabel(self); - lb.TextAlign := AL9_CENTERRIGHT; - lb.caption := v; - lb.Top :=(i+1) * lg; - lb.Height := 25; - lb.Left := 20; - lb.Width := 120; - lb.Parent := self; - //lb.border := true; - flabels[i]:= lb; - end - FEdit_Target.left := 140; - FEdit_Target.top := lg; - FEdit_target.parent := self; - FEdit_target.Editer.OnKeyPress := thisfunction(EditerEnter); - FEdit_repace.left := 140; - FEdit_repace.top := lg+lg; - FEdit_repace.parent := self; - FEdit_type.left := 140; - FEdit_type.top := lg+lg+lg; - FEdit_type.Editer.Text := "*.tsf;*.tsl;"; - FEdit_type.parent := self; - FEdit_dir.left := 140; - FEdit_dir.Width := FEdit_dir.Width-20; - FEdit_dir_btn.Caption := ".."; - FEdit_dir_btn.top := lg+lg+lg+lg; - FEdit_dir_btn.Width := 18; - FEdit_dir_btn.left := 140+FEdit_dir.Width+2; - FEdit_dir_btn.height := 24; - FEdit_dir.top := lg+lg+lg+lg; - FEdit_dir.parent := self; - FEdit_dir_btn.OnClick := function(o,e) - begin - if FDirChooser.OpenDlg()then - begin - FEdit_dir.Editer.text := FDirChooser.Folder; - end - end - FBtn_Find := new TFindBtn(self); - FBtn_replace := new TFindBtn(self); - FBtn_Count := new TFindBtn(self); // 计数 - FBtn_replaceall := new TFindBtn(self); - FBtn_Find.caption := "查找"; - FBtn_replace.caption := "替换"; - FBtn_Count.caption := "全部查找"; - FBtn_replaceall.caption := "全部替换"; - FBtn_Find.top := lg; - FBtn_Find.parent := self; - FBtn_replace.top := lg+lg; - FBtn_replace.parent := self; - FBtn_replaceall.top := lg+lg+lg; - FBtn_replaceall.parent := self; - FBtn_Find.OnClick := thisfunction(FindBtnClick); - FBtn_replace.OnClick := thisfunction(FindBtnClick); - FBtn_Count.OnClick := thisfunction(FindBtnClick); - FBtn_replaceall.OnClick := thisfunction(FindBtnClick); - FBtn_Count.top := lg+lg+lg+lg; - FBtn_Count.parent := self; - FDirChooser.parent := self; - FCheck_revers := new TFindCheck(self); - FCheck_wrap := new TFindCheck(self); - FCheck_case := new TFindCheck(self); - FCheck_cycle := new TFindCheck(self); - FCheck_reg := new TFindCheck(self); - FCheck_subdir := new TFindCheck(self); - FCheck_gt := new TFindCheck(self); - FCheck_subdir.checked := true; - FCheck_subdir.Left := 425; - FCheck_subdir.top := lg+lg+lg+lg; - FCheck_subdir.Caption := "包含子目录"; - FCheck_revers.caption := "反向查找"; - FCheck_revers.top := lg * 5; - FCheck_revers.parent := self; - FCheck_wrap.caption := "全词匹配"; - FCheck_wrap.top := lg * 6; - FCheck_wrap.parent := self; - FEdit_dir_btn.parent := self; - FCheck_case.caption := "忽略大小写"; - FCheck_case.Checked := true; - FCheck_case.top := lg * 7; - FCheck_case.parent := self; - FCheck_cycle.caption := "循环查找"; - FCheck_cycle.Checked := true; - FCheck_cycle.top := lg * 8; - FCheck_cycle.parent := self; - FCheck_reg.caption := "正则匹配"; - FCheck_reg.Enabled := false; - FCheck_reg.top := lg * 9; - FCheck_reg.parent := self; - FCheck_gt.caption := "\\t转义tab"; - FCheck_gt.Checked := false; - FCheck_gt.top := lg * 9; - FCheck_gt.Left := FCheck_reg.width+FCheck_reg.Left+10; - FCheck_gt.parent := self; - FCheck_subdir.parent := self; - FCheck_reg.OnClick := function(o,e) - begin - FCheck_revers.Enabled := not(o.Checked); - FCheck_wrap.Enabled := not(o.Checked); - FCheck_case.Enabled := not(o.Checked); - end - FStatus := new TStatusBar(self); - //FStatus.Align := alNone; - FStatus.Items := array(("text":"","width":700)); - FStatus.Parent := self; - OnSelChanged := thisfunction(DoSelChanged); - ItemIndex := 0; - //SetStatusText("查找"); - end - function FindBtnClick(o,e); - begin - r := GetInfo(); - r["btn"]:= o.Caption; - Owner.DoFind(r,self); - end - function EditErEnter(o,e); - begin - if e.CharCode=13 then - begin - e.skip := true; - r := GetInfo(); - r["btn"]:= "查找"; - OWner.DoFind(r,self); - end - end - function GetInfo(); - begin - r := array(); - r["section"]:= CurrentITem.Caption; - s := FEdit_target.Editer.Text; - if FCheck_gt.Checked then - begin - s := Replacestr(s,"\\t","\t"); - end - r["target"]:= s; - s := FEdit_repace.Editer.Text; - if FCheck_gt.Checked then - begin - s := Replacestr(s,"\\t","\t"); - end - r["replace"]:= s; - r["filetype"]:= FEdit_type.Editer.Text; - r["dir"]:= FEdit_dir.Editer.Text; - r["c_revers"]:= FCheck_revers.Checked; - r["c_cycle"]:= FCheck_cycle.Checked; - r["c_wrap"]:= FCheck_wrap.Checked; - r["c_case"]:= FCheck_case.Checked; - r["c_reg"]:= FCheck_reg.Checked; - r["c_dir"]:= FCheck_subdir.Checked; - return r; - end - function SetStatusText(s); - begin - if ifstring(s)then FStatus.SetItemText(s,0); - end - function OpenFind(); - begin - ItemIndex := 0; - end - function OpenReplace(); - begin - ItemIndex := 1; - end - function Show(f);override; - begin - it := Owner.GetCurrentEditer(); - if it then - begin - s1 := it.SelText; - if s1 and length(s1)<20 and not(pos("\n",s1))then - begin - s := s1; - end else - s := it.CaretWords(); - if s then SetFindText(s); - FEdit_target.Editer.SetFocus(); - end - inherited; - end - Function SetFindText(s); //设置查找的字符串 - begin - FEdit_target.Editer.Text := s; - FEdit_target.Editer.SetSel(0,length(s)); - end - function SaveCurrentEditer(); //保存一下数据 - begin - for i,v in array(FEdit_target,FEdit_dir,FEdit_type,FEdit_repace) do - begin - v.PushItem(v.Editer.Text); - end - //if e then e.PushItem(e.Editer.Text); - end - function DoSelChanged(o,e); - begin - if CurrentItem then Caption := CurrentItem.Caption; - case Caption of - "查找": - begin - for i := 1 to 3 do flabels[i].Visible := false; - FEdit_dir.visible := false; - FEdit_dir_btn.visible := false; - FEdit_type.visible := false; - FEdit_repace.visible := false; - FBtn_replace.visible := false; - FBtn_count.Visible := true; - FBtn_Replaceall.Visible := false; - FCheck_subdir.visible := false; - FCheck_Revers.visible := true; - FCheck_cycle.Visible := true; - end - "替换": - begin - flabels[1].Visible := true; - for i := 2 to 3 do flabels[i].Visible := false; - FEdit_dir.visible := false; - FEdit_dir_btn.visible := false; - FEdit_type.visible := false; - FEdit_repace.visible := true; - FBtn_replace.visible := true; - FBtn_count.Visible := false; - FBtn_Replaceall.Visible := true; - FCheck_subdir.visible := false; - FCheck_Revers.visible := false; - FCheck_cycle.Visible := true; - end - "文件查找": - begin - for i := 1 to 3 do flabels[i].Visible := true; - FEdit_dir.visible := true; - FEdit_dir_btn.Visible := true; - FEdit_type.visible := true; - FEdit_repace.visible := true; - FBtn_replace.visible := false; - FBtn_count.Visible := false; - FBtn_Replaceall.Visible := true; - FCheck_subdir.visible := true; - FCheck_Revers.visible := false; - FCheck_cycle.Visible := false; - end - end - end - function DoControlAlign();override; - begin - inherited; - if not FStatus then return; - rc := ClientRect; - rc[1]:= rc[3]-30; - FStatus.SetBoundsRect(rc); - end - function recycling();override; - begin - inherited; - FStatus := nil; - end - function GetHistory(); - begin - r := array(); - r["finds"]:= FEdit_Target.Items; - r["repalces"]:= FEdit_repace.Items; - r["dirs"]:= FEdit_dir.items; - r["findfiletyps"] := FEdit_Type.items; - return r; - end - function SetHistory(d); - begin - if not ifarray(d)then return; - fds := d["finds"]; - if ifarray(fds)then - begin - FEdit_Target.Items := fds; - end - rps := d["repalces"]; - if ifarray(rps)then - begin - FEdit_repace.Items := rps; - end - dirs := d["dirs"]; - if ifarray(dirs)then - begin - FEdit_dir.items := dirs; - end - dirs := d["findfiletyps"]; - if ifarray(dirs)then - begin - FEdit_Type.items := dirs; - end - end - private - FStatus; - FDirChooser; - //查找 - FEdit_Target; - FEdit_repace; - FEdit_type; - FEdit_dir; - FEdit_dir_btn; - FBtn_Find; - FBtn_replace; - FBtn_Replaceall; - FBtn_Count; // 计数 - flabels; - FCheck_revers; - FCheck_wrap; - FCheck_case; - FCheck_cycle; - FCheck_reg; - FCheck_subdir; - FCheck_gt; - end - type TListPages=class(TListBox) - function Create(AOwner);override; - begin - inherited; - Visible := false; - WsPopUp := true; - end - function PaintIdx(idx,rc_,cvs);override; - begin - {** - @explan(说明)绘制项 %% - @param(item)(TCustomListItem) 项 %% - @param(rc)(array) 绘制区域%% - @param(cvs)(tcanvas) 画布 %% - **} - inherited; - if idx=getCurrentSelection()then - begin - rc := rc_; - rc[2:3]-= 1; - cvs.pen.Color := rgb(30,144,255); - cvs.draw("Polyline",array(rc[0:1],(rc[2],rc[1]),(rc[2],rc[3]),(rc[0],rc[3]),rc[0:1])); - end - end - function MouseUp(o,e);override; - begin - inherited; - visible := false; - end - function SetData(d);override; - begin - if not ifarray(d)then return; - height := ItemHeight * (1+min(15,length(d))); - x := 10; - for i,v in d do - begin - x := max(x,length(v)); - end - width := font.Width * (x+3); - inherited; + it := GetItem(i); + if it then return it.FCaption; + return ""; end function InsureItemVisible(idx); //移动当前的格子 begin @@ -1569,2782 +817,3513 @@ F47AC96526C21CCB26FD326A2180CC21F5CAC302CA5C842B865FD9D7003D1F17B SetYpos(1+GetYPos()+(rc[3]-c[3]+1)/GetYScrollDelta()); end end - function GetSelFileName; + function GetItemIndex();virtual; begin - r := GetItem(getCurrentSelection()); - if pos("*",r)then - begin - return r[2:]; - end - return r; - end - function IncIndex(f); - begin - if ifnil(f)then f :=-1; - idx := getCurrentSelection(); - ct := ItemCount; - nidx := idx-f; - if idx=ct-1 then nidx := 0; - else if idx=-1 then nidx := 1; - SetCurrentSelection(nidx); - InsureItemVisible(nidx); - end - end - type tagCOMPOSITIONFORM=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("dwstyle","int",4), - ("ptcurrentpos","intptr",0), - ("rcarea","int[4]",array(0,0,0,0))),nil,nil,1); - return SSTRUCT; - end - public - function create() - begin - inherited create(getstruct(),ptr); - FPonter := new TCPoint(); - _setvalue_("ptcurrentpos",FPonter._getptr_()); - end - property dwstyle index "dwstyle" read _getvalue_ write _setvalue_; - property ptcurrentpos read FPonter; - property rcarea index "rcarea" read _getvalue_ write _setvalue_; - private - FPonter; - end - type TFTSLScriptMemo=class(TSYNmemoNorm) - function Create(AOwner);override; - begin - inherited; - WsDlgModalFrame := true; - FChangedFlag := false; - FChangedLock := false; - Lineinterval := 3; - FCOMPOSITIONFORM := new tagCOMPOSITIONFORM(nil); - font := array("height":18,"width":9,"escapement":0,"orientation":0,"weight":400,"italic":0,"underline":0,"strikeout":0, - "charset":0,"outprecision":0,"clipprecision":0,"quality":1,"pitchandfamily":1,"facename":"Courier New","color":0); - //134 - //font := array("facename":"Courier New"); - end - function DoCaretPosChanged();override; - begin - if HandleAllocated()then calldatafunction(FOnCaretChanged,self(true),new tuieventbase(0,0,0,0)); - //echo tostn(self.CaretXY); - end - function WMIMESTARTCOMPOSITION(o,e):WM_IME_STARTCOMPOSITION;virtual; - begin - ime := ImmGetContext(self.Handle); - FCOMPOSITIONFORM.ptcurrentpos.cx := 200; - FCOMPOSITIONFORM.ptcurrentpos.cy := 200; - ImmSetCompositionWindow(ime,FCOMPOSITIONFORM._getptr_()); - ImmReleaseContext(self.Handle,ime); - end - {$ifdef linux} - function ImmReleaseContext(); - begin - end; - function ImmGetContext(); - begin - end; - function ImmSetCompositionWindow(); - begin - end; - function ImmSetStatusWindowPos(); - begin - end; - {$else} - function ImmReleaseContext(h:pointer;ime:pointer):integer;stdcall;external "Imm32.dll" name "ImmReleaseContext"; - function ImmGetContext(h:pointer):pointer;stdcall;external "Imm32.dll" name "ImmGetContext"; - function ImmSetCompositionWindow(h:pointer;s:pointer):integer;stdcall;external "Imm32.dll" name "ImmSetCompositionWindow"; - function ImmSetStatusWindowPos(h:pointer;s:pointer):integer;stdcall;external "Imm32.dll" name "ImmSetStatusWindowPos"; - {$endif} - function InvalidateLines(FirstLine,LastLine:integer);override; - begin - //return inherited; - if not HandleAllocated()then return; - if HighLighter is class(TTslSynHighLighter)then - begin - fy :=(FirstLine-TopLine) * TextHeight; - r := ClientRect; - if fyr[3]then return; - r[0]:= GutterWidth; - r[1]:= max(0,fy); - InvalidateRect(r,false); - end else return inherited; end - function MouseUp(o,e);override; + function SetItemIndex(idx);virtual; begin inherited; - end - function InsertChars(s);override; - begin - if(s="\r\n")then - begin - y := CaretY; - x := CaretX; - sl := Lines.GetStringByIndex(y-1); - if ifstring(sl)and sl then - begin - ins := ""; - for i := 1 to x-1 do - begin - si := sl[i]; - if si="\t" or si=" " then - begin - ins += si; - end else - break; - end - if ins then - begin - return inherited InsertChars(s+ins); - end - end - end - return inherited; - end - function KeyUp(o,e);override; - begin - e.Result := 1; - if Calldatafunction(FQuckKeys,self,e)then return; - inherited; - end - function ContextMenu(o,e);override; - begin - inherited; - e.skip := true; - end - function SwitchMarkLine(L); //此处处理断点问题 - begin - if not(L >= 0)then - begin - L := self.CaretY-1; - end - it := Lines[L]; - if it then - begin - it.FMarked := not(it.FMarked); - r := ClientRect; - r[2]:= GutterWidth()-1; - InValidateRect(r,false); - if _Tag then _Tag.markline(L,it.FMarked); - end - end - function KeyDown(o,e);override; - begin - e.Result := 0; - qc := Calldatafunction(FQuckKeys,self,e); - if qc then return; - if e.CharCode=VK_F5 then - begin - L := self.CaretY-1; - SwitchMarkLine(L); - return; - end - if e.CharCode=VK_F2 and(ssCtrl in e.shiftState())then - begin - L := self.CaretY-1; - SwitchMarkLine(L); - return; - end - if not(ssCtrl in e.shiftstate())and not(ssShift in e.shiftstate())then - begin - if e.CharCode=VK_F2 then - begin - y := CaretY-1; - len := Lines.length(); - for i := y+1 to len+y-1 do - begin - idx :=(i+len)mod len; - it := Lines[idx]; - if it and it.FMarked then - begin - return ExecuteCommand(ecGotoXY,array(idx+1,1)); - end - end - return; - end - end - inherited; - end - function WMSYSKEYUP(o,e):WM_SYSKEYUP;override; - begin - e.Result := 1; - if CallDatafunction(FQuckKeys,self,e)then return; - inherited; - end - Function WMSYSKEYDOWN(o,e):WM_SYSKEYDOWN;override; - begin - e.Result := 0; - if CallDatafunction(FQuckKeys,self,e)then return; - inherited; - end - function WMSETFOCUS(o,e):WM_SETFOCUS;override; - begin - inherited; - CallDataFunction(FOnTextSetFocus,self(true),e); - end - function DoTextChanged(p);override; - begin - n := Lines.Length(); - ccnt := GutterCharCnt; - nccnt := max(integer(n~10)+3,4); - if ccnt <> nccnt then - begin - GutterCharCnt := nccnt; - end - inherited; - SetChangeFlag(true); - end - function Recycling();override; - begin - FQuckKeys := nil; - FOnTextChanged := nil; - FOnTextSetFocus := nil; - FPageItem := nil; - FOnCaretChanged := nil; - inherited; - end - published - property OnCaretChanged read FOnCaretChanged write FOnCaretChanged; - property PageItem read FPageItem write FPageItem; - property OnTextChanged read FOnTextChanged write FOnTextChanged; //文本改变 - property QuckKeys read FQuckKeys write FQuckKeys; //快捷键 - property ChangedFlag read FChangedFlag write SetChangeFlag; - property ChangedLock read FChangedLock write FChangedLock; - property OnTextSetFocus read FOnTextSetFocus write FOnTextSetFocus; - private - function SetChangeFlag(v); - begin - nv := v?true:false; - if nv <> FChangedFlag then - begin - FChangedFlag := nv; - if FChangedLock then return; - calldatafunction(OnTextChanged,self(true),nv); - end - end - FPageItem; - FChangedLock; - FChangedFlag; - FOnTextChanged; - FOnTextSetFocus; - FQuckKeys; - FCOMPOSITIONFORM; - FOnCaretChanged; - end - type TPageEditerItem=class(TPageItem) - FPageOrderId; //序号有调用者使用 - FEditer; //编辑器 - FSynType; - FInitCompletion; - FDebuger; - fisnewfile; - function create(AOwner);override; - begin - inherited; - FSynType := ""; - FEnCode := "ANSI"; - FGetInfoText := ""; - FLastVersion := ""; - FEditer := new TFTSLScriptMemo(AOwner); - FEditer.Visible := false; - FEditer._Tag := self; - end - function Recycling();override; - begin - FDebuger := nil; - inherited; - FEditer.Recycling(); - FEditer := nil; - end - function markline(l,f); //标记被调用 - begin - if FDebuger then - begin - if f then - begin - FDebuger.addbreak(self,l); - end else - begin - FDebuger.removebreak(self,l); - end - end - end - function ScriptPathIs(v); - begin - return filenameIsTheSame(v,FScriptPath); - end - published - property ScriptPath read FScriptPath write SetScriptPath; //文件名 - property OrigScriptPath read FOrgScriptPath; - property TslSynText read FTslSynText write FTslSynText; - property LastText read FLastVersion; //最新的版本 - property EnCode read FEnCode; - RepreComple; - FISstm; - ///////////////////设计器相关////////////////////////////////////// - public - function Addfiled(fld); //添加成员变量 - begin - if not FTslParser then return 0; - if not(fld and ifstring(fld))then return; - nfld := lowercase(fld); - nt := str2array(nfld,":"); - nfld := nt[0]; - nfldt := nt[1]; - d := GetClassInfo(); - if not(d and ifarray(d))then return 0; - for i,v in d["filed"] do - begin - if v["name"]=nfld then return 1; - end - crec := GetCreateFunctionRec(d); - if crec then - begin - p := crec[0]; - if ifarray(p)then - begin - FEditer.ExecuteCommand(FEditer.ecGotoXY,p); - FEditer.ExecuteCommand(FEditer.ecString,fld+";\r\n "); - end - end - end - function GetCreateFunctionRec(d); //获得插入函数为位置 - begin - fi := d["funcsinfo"]; - for i,v in fi do - begin - if v["name"]="create" then - begin - return GetInfoRowCol(v); - end - end - return 0; - end - function Delfiled(fld,nn); //删除成员变量 - begin - if not FTslParser then return 0; - if not(fld and ifstring(fld))then return; - if not ifstring(nn)then nn := ""; - nfld := lowercase(fld); - d := GetClassInfo(); - if not(d and ifarray(d))then return 0; - for i,v in d["filed"] do - begin - if v["name"]=nfld then - begin - frec := GetInfoRowCol2(v); - if ifarray(frec[0])and ifarray(frec[1])then - begin - FEditer.ExecuteCommand(FEditer.ecGotoXY,frec[0]); - FEditer.ExecuteCommand(FEditer.ecSelGotoXY,frec[1]); - FEditer.SelText := nn?(nn+";"):""; - end - end - end - end - function GoToFunction(fn); - begin - if not(ifstring(fn))then return false; - nfld := lowercase(fn); - d := GetClassInfo(); - if not ifarray(d)then return 0; - for i,v in d["funcsinfo"] do - begin - if v["name"]=nfld then - begin - crec := GetInfoRowCol(v); - if ifarray(crec)and ifarray(crec[0])then - begin - FEditer.ExecuteCommand(FEditer.ecGotoXY,crec[0]); - end - return true; - end - end - end - function AddFunction(fn,finfo); //添加函数 - begin - if not FTslParser then return 0; - if not(ifstring(fn)and fn and ifstring(finfo))then return 0; - nfld := lowercase(fn); - d := GetClassInfo(); - if not ifarray(d)then return 0; - for i,v in d["funcsinfo"] do - begin - if v["name"]=nfld then - begin - crec := GetInfoRowCol(v); - if ifarray(crec)and ifarray(crec[0])then - begin - FEditer.ExecuteCommand(FEditer.ecGotoXY,crec[0]); - end - return true; - end - end - crec := GetCreateFunctionRec(d); - if crec then - begin - p := crec[1]; - if ifarray(p)then - begin - FEditer.ExecuteCommand(FEditer.ecGotoXY,p); - FEditer.ExecuteCommand(FEditer.ecString,"\r\n"+finfo+"\r\n "); - end - end - return true; - end - function GetLastLoadTime(); //最新时间 - begin - return FLastFileTime; - end - function ReGetLastLoadTime(); //重新获得时间 - begin - fi := FileList("",FScriptPath); - FLastFileTime := fi[0,"Time"]; - return FLastFileTime; - end - function PrePareSave(); //准备保存 - begin - if not FEditer.ChangedFlag then - begin - if RepreComple then itemPareCompletion(); - return false; - end - if FEditer.ReadOnly then - begin - if RepreComple then itemPareCompletion(); - return false; - end - t := FEditer.Text; - if FLastVersion=t then - begin - FEditer.ChangedFlag := false; - if RepreComple then itemPareCompletion(); - return false; - end - FLastVersion := t; - itemPareCompletion(); - //FEditer.PrePareCompletion(t); //准备自动完成 - FEditer.ChangedFlag := false; - return true; - end - function itemPareCompletion(); - begin - t := caption; - cp := FEditer.Completion; - if cp then cp.PrePareCompletion(t); - RepreComple := false; - end - function IsTextUTF8(str) - begin - {utf8规则 - 单字节: 0xxxxxxx - 二字节 110xxxxx 10xxxxxx - 三字节 1110xxxx 10xxxxxx 10xxxxxx - 四字节 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - 五字节 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx - 刘字节 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx - } - // 0 为ansi 编码,1 为utf8编码 -1 不能确定什么编码 - nBytes := 0; //UFT8可用1-6个字节编码,ASCII用一个字节 - DY := 0; - chr := ""; - bAllAscii := TRUE; //如果全部都是ASCII, 说明不是UTF-8 - for i := 1 to length(str) do - begin - chr := ord(str[i]); - if((chr .& 0x80)<> 0)then - begin // 判断是否ASCII编码,如果不是,说明有可能是UTF-8,ASCII用7位编码,但用一个字节存,最高位标记为0,o0xxxxxxx - bAllAscii := FALSE; - end - if(nBytes=0)then //如果不是ASCII码,应该是多字节符,计算字节数 - begin - if(chr >= 0x80)then - begin - if(chr >= 0xFC and chr <= 0xFD)then nBytes := 6; - else if(chr >= 0xF8)then nBytes := 5; - else if(chr >= 0xF0)then nBytes := 4; - else if(chr >= 0xE0)then nBytes := 3; - else if(chr >= 0xC0)then nBytes := 2; - else return 0; - DY := MAX(nBytes,DY); - nBytes--; - end - end else //多字节符的非首字节,应为 10xxxxxx - begin - if((chr .& 0xC0)<> 0x80)then return-1; - nBytes--; - end - end; - if(nBytes>0)then //违返规则 - return-1; - if(bAllAscii)then //如果全部都是ASCII, 说明不是UTF-8 - return 0; - //return 1; - return DY>2; - end - function ToUnicode_big(); - begin - if FEnCode="UCS2-big" then return; - FEnCode := "UCS2-big"; - FEditer.ChangedFlag := true; - FLastVersion := ""; - end - function ToUniocode_little(); - begin - if FEnCode="UCS2-little" then return; - FEnCode := "UCS2-little"; - FEditer.ChangedFlag := true; - FLastVersion := ""; - end - function ToUTF8(); - begin - if FEnCode="UTF8" then return; - FEnCode := "UTF8"; - FEditer.ChangedFlag := true; - FLastVersion := ""; - return; - end - function ToUTF8BOM(); - begin - if FEnCode="UTF8 BOM" then return; - FEditer.ChangedFlag := true; - FEnCode := "UTF8 BOM"; - FLastversion := ""; - end - function ToANSI(); - begin - if FEnCode="ANSI" then return; - FEditer.ChangedFlag := true; - FEnCode := "ANSI"; - FLastversion := ""; - end - function CurrentCodeIsUtf8(); - begin - if FEnCode="ANSI" then - begin - s := FEditer.Text; - try - s := UTF8toansi(s); - FEditer.Text := s; - FEnCode := "UTF8"; - except - end - end - end - function CurrentCodeIsAnsi(); - begin - if FEnCode="UTF8" then - begin - FEnCode := "ANSI"; - end - end - function SetLoadScript(s); //保存文件 - begin - if not ifstring(s)then return; - strcode := 0; - FEnCode := "ANSI"; - if(length(s)>= 2)and ord(s[1])=0xFE and ord(s[2])=0xFF then //ucs2-big - begin - strcode := 2; - FEnCode := "UCS2-big"; //要转换 - if length(s)=2 then s := ""; - else - begin - s1 := ""; - setlength(s1,length(s)-2); - for i := 3 to length(s)-1 step 2 do - begin - s1[i-2]:= s[i+1]; - s1[i-1]:= s[i]; - end - s := unicodetomultibyte(s1,936); - end - end else - if(length(s)>= 2)and ord(s[1])=0xFF and ord(s[2])=0xFE then //ucs2-little - begin - strcode := 4; - FEnCode := "UCS2-little"; - if length(s)=2 then s := ""; - else - begin - s := unicodetomultibyte(s[3:],936); - end - end else - if(length(s)>= 3)and ord(s[1])=0xEF and ord(s[2])=0xBB and ord(s[3])=0xBF then - begin - FEnCode := "UTF8 BOM"; - if length(s)=3 then s := ""; - else s := utf8toansi(s[4:]); - strcode := 1; - end - if(0=strcode)then - begin - if IsTextUTF8(s)=1 then - begin - FEnCode := "UTF8"; - strcode := 1; - s := utf8toansi(s); - end - end - FLastVersion := s; - FEditer.Text := s; - FEditer.ExecuteCommand(FEditer.ecGotoXY,array(1,1)); - FEditer.ClearUndo(); - FEditer.ChangedFlag := false; - if not FTslSynText then return; - if not(s)then return; - r := tsl_tokenizeex_2_(s,1); - cs := r["class"]; - if ifarray(cs)and cs[0]then - begin - lcs1 := lowercase(cs[0]); - if lcs1 in array("tdcreateform","tdcreatepanel")then - begin - try - if not FTslParser then FTslParser := new unit(UDesignerProject).tslparser(); #! end - except - end; - return; //返回 - end - end - FTslParser := nil; - end - function GetClassInfo(); //获得信息 - begin - if not FTslParser then return array(); - txt := FEditer.Text; - if txt <> FGetInfoText then - begin - FGetInfoText := txt; - FTslParser.Script := txt; - FGetInfoChace := FTslParser.GetClassInfo(1); - end - return FGetInfoChace; - end - private - FEnCode; - FLastFileTime; - FTslSynText; - function GetInfoRowCol(v); //获得行列 - begin - rs := PosToRowCol(FGetInfoText,array(v["startpos"]-1,v["endpos"])); - return rs; - end - function GetInfoRowCol2(v); //获得行列结尾 - begin - rs := PosToRowCol(FGetInfoText,array(v["beg"]-1,v["end"])); - return rs; - end - function PosToRowCol(s,ps); //位置换算 - begin - r := array(); - idx := 0; - pi := ps[idx]; - ri := ci := 1; - for i := 1 to length(s) do - begin - vi := s[i]; - if vi="\n" then - begin - ri++; - ci := 1; - end else - ci++; - if i=pi then - begin - r[idx]:= array(ri,ci); - idx++; - pi := ps[idx]; - end - end - return r; - end - FTslParser; // - FGetInfoChace; //class 信息 - FGetInfoText; //文本 - FLastVersion; //脚本 - FScriptPath; //路径 - FOrgScriptPath; //原始路径 - function SetScriptPath(v); - begin - sp := ioFileseparator(); - if ifstring(v)then - begin - for i := length(v)downto 1 do - begin - if v[i]=sp then - begin - Caption := v[i+1:]; - break; - end - if v[i]="." then - begin - if lowercase(v[i:])in array(".tsl",".tsf")then FTslSynText := true; - end - end - FScriptPath := v; - FOrgScriptPath := v; - FEditer.Caption := v; - end + FListBox.InsureItemVisible(idx); end end - type TPageEditer=class(TPage) //多页编辑 - function Create(AOwner);override; + type TComboBoxb=class(TCombobox) + function Create(AOwner); begin - inherited; + INherited; end - function MouseUp(o,e);override; + function CreateAlist();override; begin - inherited; - if e.button()=mbRight then - begin - return CallDatafunction(FPageItemOnRClick,self,e); - end + return new TListBoxb(self); end - function CallSelChanged();override; - begin - it := Currentitem; - if it then - begin - it.FEditer.SetBoundsRect(self.ClientRect); - it.FEditer.Visible := true; - it.FEditer.SetFocus(); - end - inherited; - end - function CallSelChanging();override; - begin - inherited; - it := CurrentItem; - if it and it.FEditer then it.FEditer.Visible := false; - end - function Recycling();override; - begin - inherited; - FCliper := nil; - FMenu := nil; - FPageItemOnRClick := nil; - end - function DoControlAlign();override; - begin - inherited; - it := CurrentItem; - if it then - begin - it.FEditer.SetBoundsRect(self.ClientRect); - end - end - property PageItemOnRClick read FPageItemOnRClick write FPageItemOnRClick; - private - FPageItemOnRClick; end - type TTslChmHelp=class - function SearchWord(s); + type TCobItem=class + function Create(d); begin - if not s then return; - pm := format('%s::/%s.htm',FTSLinterpPath+FChmName,s); //>mainwin - HtmlHelpA(GetDesktopWindow(),pm,0,nil); - return; + FCaption := ""; + FExe := ""; + if not ifarray(d)then return; + FCaption := d["caption"]; + FExe := d["exe"]; end - function ShowTslLangChm(); - begin - return HtmlHelpA(GetDesktopWindow(),FTSLinterpPath+FChmName,0,nil); - end - function Create(); - begin - FChmName := "help\\LANGUAGEGUIDE.CHM"; - FTSLinterpPath := ""; - n := pluginpath(); - for i := length(n)-1 downto 3 do - begin - if n[i]="\\" then - begin - FTSLinterpPath := n[1:i]; - break; - end - end - end - property ChmName read FChmName write FChmName; - private - FTSLinterpPath; - FHanle; - FChmName; + FCaption; + FExe; end - type TEditerEchoWnd=class(TSynMemoNorm) // - function Create(AOwner);override; + public + function showexeediter(); + begin + FMemo.ExecuteCommand(FMemo.ecGotoXY,array(1,1)); + FMemO.SetFocus(); + show(); + end + function Create(AOwner); + begin + inherited; + WSsYSMenu := true; + WsDlgModalFrame := true; + WsSizeBox := true; + WSpOPUp := true; + FItems := new TMyArrayB(); + caption := "编辑 Execute....."; + SetBoundsRect(array(50,50,930,201)); + FMemo := new TSynMemoNorm(self); + FMemo.OnKeyPress := function(o,e) begin - inherited; - FDoLockTime := 0; - FIsLocked := false; - height := 250; - ReadOnly := true; - WsSizeBox := true; - WsSysMenu := true; - OnClose := function(o,e) + if 13=e.charcode then begin - o.visible := false; e.skip := true; - end - m := new TPopUpMenu(self); - m1 := new TMenu(self); - m1.Caption := "清空"; - m1.parent := m; - {m2 := new TMenu(self); - m2.Caption := "选中字符高亮"; - m2.Checked := false; - m2.OnClick := function(o,e)begin - o.Checked := not(o.Checked); - self.HighLighter := (o.Checked) ?F_Highlighter :false; + doSaveCurrentName(); end - m2.Parent := m;} - PopUpMenu := m; - m1.OnClick := function(o,e) - begin - ClearAll(); - AppendString("ctrl+z 停止;ctrl+c 复制选择\r\n"); - end; - FProcess := new TCreateProcessA(); - FProcess.BufSize := 1024 * 5; - FProcess.OnEcho := thisfunction(TEchoToString); - AppendString("ctrl+z 停止;ctrl+c 复制选择\r\n"); - F_Highlighter := new TSynHighLighter(self); - //Highlighter := new TSynHighLighter(self); - end - function TEchoToString(o,s); + end + {FMemo.OnKeyDown := function(o,e) begin - //t := now(); - {if (t-FDoLockTime)>(0.3E-5) then - begin - FDoLockTime := t; - if FIsLocked then - begin - FIsLocked := false; - DecPaintLock(); - end else - begin - FIsLocked := true; - IncPaintLock(); - end - end } - AppendString(s); - //Visible := true; - return true; - end - function Exec(exe,cmd,h); - begin - //AppendString(format('"%s" %s\r\n',exe,cmd)); - self.HighLighter := nil; - AppendString(format('%s %s\r\n',exe,cmd)); - //EndExe(); - r := FProcess.CreateProcessWaitRead(exe,cmd,h); - AppendString(format("\r\n执行结束:endcode:%d\r\n",r)); - {if FIsLocked then - begin - FIsLocked := false; - DecPaintLock(); - end } - self.HighLighter := F_Highlighter; - h := 0; - return r; - end - function Exeing(); - begin - return FProcess.LastExeHandle; - end - function EndExe(); - begin - if FProcess.LastExeHandle then - begin - r := 1; - SysTerminate(r,FProcess.LastExeHandle); - end - end - function KeyDown(o,e);override; - begin - if ssCtrl in e.shiftstate then - begin - case e.charcode of - ord("Z"): - begin - EndExe(); - return; - end - ord("C"): - begin - ExecuteCommand(ecCopy); - return; - end + case e.charcode of + VK_DOWN: + begin + e.skip := true; + FChooser.ItemIndex += 1; end - end - inherited; - end - function AppendString(s); + VK_UP: + begin + e.skip := true; + FChooser.ItemIndex -= 1; + end + end; + end} + + FMemo.Border := true; + FMemo.parent := self; + FChooser := new TComboBoxb(self); //new TEditList(self); + FChooser.ReadOnly := false; + FChooser.parent := self; + FOkBtn := new TBtn(self); + FCancelBtn := new TBtn(self); + FEgnorBtn := new TBtn(self); + cp := new TExecuteMemoComp(self); + FMemo.Completion := cp; + cp.PrepareCompletion(); + OnClose := function(o,e) begin - if not(ifstring(s)and s)then return; - ct := Lines.Length(); - if ct>0 then - begin - ExecuteCommand(ecGoToXY,array(ct,1)); - ExecuteCommand(ecLineEnd); - ExecuteCommand(ecString,s); - end + e.skip := true; + o.visible := false; end - FExeHandle; - FProcess; - FIsLocked; - FDoLockTime; - F_Highlighter; + FOkBtn.Caption := "保存/添加"; + FCancelBtn.Caption := "删除当前"; + FEgnorBtn.caption := "取消"; + FOkBtn.parent := self; + FCancelBtn.parent := self; + FEgnorBtn.parent := self; + FMemo.parent := self; + FChooser.OnSelChanged := thisfunction(OnChooserChanged); + FCancelBtn.OnClick := thisfunction(DeleteCurrent); + FOkBtn.OnClick := thisfunction(doSaveCurrentName); + FEGnorBtn.OnClick := thisfunction(OnIgnore); end - type TTslDebug=class(TCustomControl) - private //成员变量 - FRuningfile; //执行脚本文件名 - FRuningItem; //执行的pageitem - FCurrentgotoitem; //当前运行到的pageitem - FDebughandle; //调试的句柄 - FDebugExe; //调试功能的exe - FConnectchannel; //调试的 通道 - FDebugaddr; //地址 - FDebugport; //调试的端口 - FDebugUsr; //用户名 - FDebugPwd; //密码 - FDebugtsfs; //当前工程对应的tsf文件 - FBtns; - FAttchedid; - FDebugtype; - fdbgselwnd; - FRemoteWait; //远程调试等待 - FValewnd; - FCmdHistory; - FCmdHistoryid; - FCmdHistorycount; - //////////////////// - Fdbgssybs; - Fdbgsybs; - Fdbgstack; - fdefaultdbger; //编辑器的调试器 - type tdbgwnd=class(TPanel) - uses tslvcl; - function Create(AOwner); - begin - inherited; - WsDlgModalFrame := false; - p1 := new TPairSplitter(self); - p1.Position := 310; - p2 := new TPairSplitter(self); - p2.Position := 310; - sd1 := new TPairSplitterSide(self); - sd2 := new TPairSplitterSide(self); - sd3 := new TPairSplitterSide(self); - sd3 := new TPairSplitterSide(self); - sd4 := new TPairSplitterSide(self); - p1.Align := alClient; - sd1.WsDlgModalFrame := false; - sd2.WsDlgModalFrame := false; - sd3.WsDlgModalFrame := false; - sd4.WsDlgModalFrame := false; - p1.WsDlgModalFrame := false; - p2.WsDlgModalFrame := false; - p1.parent := self; - sd1.parent := p1; - sd1.Border := false; - sd2.parent := p1; - p2.Align := alClient; - p2.parent := sd2; - sd3.parent := p2; - sd4.parent := p2; - sd4.Border := false; - fside1 := sd1; - fside2 := sd3; - fside3 := sd4; - end - function addwnds(stk,vlist,cmd,cmdshow); - begin - stk.Align := alClient; - stk.parent := fside1; - vlist.Align := alClient; - vlist.parent := fside2; - cmd.Align := alBottom; - cmd.parent := fside3; - cmdshow.Align := alClient; - cmdshow.parent := fside3; - end - function Recycling();override; - begin - inherited; - fside1 := nil; - fside2 := nil; - fside3 := nil; - end - fside1; - fside2; - fside3; + function Recycling();override; + begin + inherited; + FMemo := nil; + FChooser := nil; + FCancelBtn := nil; + FOkBtn := nil; + FEgnorBtn := nil; + Fonsaveclk := nil; + end + function DeleteCurrent(); + begin + if length(FChooser.Items)<2 then return ; + FChooser.DeleteItem(FChooser.ItemIndex); + end + function DoControlAlign();override; + begin + if FMemo and FChooser and FCancelBtn and FOkBtn and FEgnorBtn then + begin + r := clientRect; + r1 := r; + r1[3]-= 30; + FMemo.SetBoundsRect(r1); + tp := r1[3]+2; + wd := 200; + x := 50; + FChooser.SetBoundsRect(array(x,tp,x+200,tp+26)); + x += 200; + FCancelBtn.SetBoundsRect(array(x+20,tp,x+20+100,tp+26)); + x += 120; + FOkBtn.SetBoundsRect(array(x+20,tp,x+100,tp+26)); + x += 120; + FEgnorBtn.SetBoundsRect(array(x+20,tp,x+100,tp+26)); + x += 120; end - function cmdkeyup(o,e); + end + function OnIgnore(); + begin + idx := FChooser.ItemIndex; + if idx >= 0 then + begin + it := FChooser.GetItem(idx); + FChooser.Editer.Text := it.FCaption; + FMemo.Text := it.FExe; + end + Visible := false; + end + function GetCurrentExuteparams(f); + begin + return ParserCommandLine(GetCurrentExuteString(f)); + end + function getcurrentcommandline(); + begin + idx := FChooser.ItemIndex; + if not(idx >= 0)then return ""; + s := FChooser.GetItem(idx).fexe; + if not ifstring(s)then return ""; + return s; + end + function GetCurrentExuteString(f); //获得当前的执行字符串 + begin + if not ifstring(f)then return ""; + if not fileexists("",f)then return ""; + idx := FChooser.ItemIndex; + if not(idx >= 0)then return ""; + s := FChooser.GetItem(idx).fexe; + if not ifstring(s)then return ""; + s := replacetext(s,"$(FULL_CURRENT_PATH)",f); + dir := ""; + sp := ioFileseparator(); + for i := length(f)downto 1 do + begin + if f[i]=sp then + begin + dir := f[1:i-1]; + break; + end + end + s := replacetext(s,"$(CURRENT_DIRECTORY)",dir); + s := replacetext(s,"$(SEARCH_PATH)",owner.getlibpathstr()); + s := replacetext(s,"$(TSL_EXE)",gettslexe()); + return s; + end + function doSaveCurrentName(); + begin + Visible := false; + s := FChooser.Editer.Text; + its := FChooser.Items; + len := Length(its); + for i,v in its do + begin + if v.FCaption=s then + begin + v.FExe := FMemo.Text; + return callDatafunction( Fonsaveclk,self,self); + end + end + if cannotadd then return ; + FChooser.InsertItem(new TCobItem(array("caption":s,"exe":FMemo.Text)),0); + FChooser.ItemIndex := 0; + callDatafunction( Fonsaveclk,self,self); + end + function OnChooserChanged(o,e); + begin + idx := o.ItemIndex; + if idx >= 0 then + begin + it := O.GetItem(idx); + FMemo.Text := it.fexe; + end else + FMemo.Text := ""; + FMemo.ClearUndo(); + end + function GetData(); //获得数据 + begin + r := array(); + its := FChooser.Items; + if not(its)then return r; + r["itemindex"]:= FChooser.ItemIndex; + for i,v in its do + begin + r["items"][i]:= array("caption":v.FCaption,"exe":v.FExe); + end + return r; + end + function SetData(d); //设置数据 + begin + if ifarray(d)then + begin + SetItems(d["items"]); + FChooser.ItemIndex := d["itemindex"]; + end + end + property Items read FItems Write SetItems; + property onsaveclk read Fonsaveclk write Fonsaveclk; + property cannotadd read FCannotadd write FCannotadd; + private + FCannotadd; + Fonsaveclk; + FMemo; + FChooser; + FCancelBtn; + FOkBtn; + FItems; + FEgnorBtn; + private + function GetItemIndex(); + begin + return FChooser.Items; + end + function SetItems(its); //设置信息 + begin + vs := array(); + for i,v in its do + begin + if ifarray(v)and ifstring(v["caption"])and ifstring(v["exe"])then + begin + vi := new TCobItem(v); + vs[length(vs)]:= vi; + end + end + FChooser.Items := vs; + end +end +type TEditList=class(TComboBox) + function Create(AOwner);override; + begin + inherited; + width := 280; + maxListItemShow := 30; + FMaxCoder := 20; + ReadONly := false; + Editer.OnKeyDown := function(o,e) begin case e.charcode of VK_UP: begin - //return ; - if FCmdHistoryid <= 0 then return o.text := ""; - FCmdHistoryid--; - txt := FCmdHistory[FCmdHistoryid]; - if ifstring(txt)and txt then o.text := txt; + ItemIndex -= 1; + e.skip := true; end VK_DOWN: begin - if FCmdHistoryid >= Length(FCmdHistory)then return o.text := ""; - FCmdHistoryid++; - txt := FCmdHistory[FCmdHistoryid]; - if ifstring(txt)and txt then o.text := txt; + ItemIndex += 1; + e.skip := true; end 13: begin - //return ExecuteCommand("docmd"); - txt := trim(o.Text); - if txt then - begin - if length(FCmdHistory)>FCmdHistorycount then - begin - for i := 0 to FCmdHistorycount-1 do - begin - FCmdHistory[i]:= FCmdHistory[i+1]; - end - end - FCmdHistory[length(FCmdHistory)]:= txt; - FCmdHistoryid := length(FCmdHistory); - ExecuteCommand("docmd"); - end + Calldatafunction(OnEnterUp,self(true),e); e.skip := true; end - end - end - function getvalewnd(cp); - begin - if not FValewnd then - begin - FValewnd := new TTSLDataGrid(self); - FValewnd.Visible := false; - FValewnd.Caption := "Value"; - FValewnd.left := owner.left+100; - FValewnd.Width := 600; - FValewnd.Height := 500; - FValewnd.WSpOPUp := true; - FValewnd.WSsYSMenu := true; - FValewnd.WsSizeBox := true; - FValewnd.Parent := self; - FValewnd.OnClose := function(o,e) + VK_ESCAPE: begin - o.Visible := false; - o.TSLdata := array(); - end - end - if ifstring(cp)then FValewnd.Caption := cp; - return FValewnd; - end - function deletefuncacheini(); - begin - plg := pluginpath(); - {$ifdef linux} - sp := "/"; - {$else} - sp := "\\"; - {$endif} - for i := length(plg)-1 downto 1 do - begin - if plg[i]=sp then + oer := o.owner.owner; + if oer then oer.Visible := false; + end + ord("A"): begin - fn := plg[1:i]+"FunCache.ini"; - r := filedelete("",fn); - return r; - end - end - end - public - function addbtns(btns); //添加菜单 - begin - FBtns := btns; - for i,v in Fbtns do - begin - v.onClick := thisfunction(Dbgtooldo); - if v.Caption="添加/删除断点F5" then continue; - v.Visible := false; - end - end - function DbgNextLine(); //下一行 - begin - ExecuteCommand("dbgstepover"); - end - function serwnd_cclk(o,e); //取消 - begin - FRemoteWait := false; - cancelremotedbg(o,e,"取消调试"); - return; - end - function serwnd_oclk(o,e); //远程连接按钮 - begin - d := fdbgselwnd.GetData(); - addr := d["addr"]; - port := d["port"]; - if not(addr and port)then return MessageboxA("远程服务器信息不全","提示",0,self.Handle); - port := StrToIntDef(port,443); - usr := d["usr"]; - pwd := d["pwd"]; - //连接判断 - if checkconnected()then - begin - disconnectserver(); - end - if FDebugtype="remotewait" then //远程等待 - begin - FDebugaddr := addr; - FDebugport := port; - FDebugUsr := usr; - FDebugPwd := pwd; - FRemoteWait := true; - fdbgselwnd.Visible := false; - return _send_(WM_USER,0,0,1); - end - if 0 <> connectserver(addr,port)then return MessageboxA("远程服务器连接失败","提示",0,self.Handle); - if(usr and pwd)and 0 <> dbglogin(usr,pwd)then - begin - return MessageboxA("登陆用户失败","提示",0,self.Handle); - end - ExecuteCommand("dbgcreatechannel"); //构造channel - if FConnectchannel then - begin - dbglist(FConnectchannel); - end - end - function dbg_clk(o,e); - begin - file := o.getstartfilename(d); - item := nil; - if file=0 then //不存在脚本 - begin - if 1 <> MessageboxA("没找到本地对应的tsl\r\n是否继续调试","提示",1,self.Handle)then - begin - return serwnd_cclk(); - end - end else - begin - item := owner.OpenAndGotoFileByName(file,1); - end - o.Visible := false; - FRuningItem := item; - FCurrentgotoitem := item; - parsercurrentitem(item); - FAttchedid := d; - dbgattach(FConnectchannel,d["id"]); - //echo tostn(d); - end - function Debugremote(flg); - begin - {$ifdef linux} - return MessageboxA("linux目前不支持调试","提示",0,self.Handle); - {$endif} - if FRemoteWait then - begin - if flg then - begin - if 1=MessageboxA("远程调试等待中...\r\n点击确定停止等待..","提示",1,self.Handle)then + if ssCtrl in e.Shiftstate()then begin - FRemoteWait := false; - disconnectserver(); + e.skip := true; + o.SetSel(0,length(o.text)); end - return; - end else - begin - return MessageboxA("远程调试等待中...","提示",0,self.Handle); end - end else - begin - //if flg then return ; - if FConnectchannel then - begin - return MessageboxA("正在调试中...","提示",0,self.Handle); - end - end - if not fdbgselwnd then - begin - fdbgselwnd := new tdbgselwnd(self); - fdbgselwnd.Parent := self; - fdbgselwnd.FHistoryDir := owner.FHistoryDir; - fdbgselwnd.loaddata(); - fdbgselwnd.OnClose := thisfunction(serwnd_cclk); - fdbgselwnd.save_clk := thisfunction(serwnd_oclk); - fdbgselwnd.cancel_clk := thisfunction(serwnd_cclk); - fdbgselwnd.dbg_clk := thisfunction(dbg_clk); - end - fdbgselwnd.setlist(); - if flg then - begin - FDebugtype := "remotewait"; - fdbgselwnd.setattachwait(true); - end else - begin - FDebugtype := "remote"; - fdbgselwnd.setattachwait(false); - end - fdbgselwnd.show(); - return; + end; end - function Debuglocal(item); //调试脚本 + end + function Recycling();override; + begin + inherited; + FOnEnterUp := nil; + end + function Pushitem(s); + begin + if not ifstring(s)and s then return; + if s in Items then return 0; + insertItem(s,0); + if getItemCount()>FMaxCoder then begin - {$ifdef linux} - return MessageboxA("linux目前不支持调试","提示",0,self.Handle); - {$endif} - if not item then return 0; - if FConnectchannel then return MessageboxA("正在调试中","提示",0,self.Handle); - if FRemoteWait then return MessageboxA("远程调试等待中...","提示",0,self.Handle); - FDebugtype := "local"; - if checkconnected()then disconnectserver(); //断开连接 - FAttchedid := 0; - FDebugport := randomfrom(1 -> 600)+20000; - FDebugaddr := '127.0.0.1'; - FRuningItem := item; - FCurrentgotoitem := item; - dirs := owner.getlibpathstr(); - parsercurrentitem(item); - fio := ioFileseparator(); - FDebugUsr := 0; - FDebugPwd := 0; - deletefuncacheini(); - getdebuger(pms); - exestr := format('"%s" "%s" -DEBUGSERVER -DEBUGLOGIN 0 -WAITATTACH -DEBUGPORT %d -libpath "%s" ',FDebugExe,FRuningfile,FDebugport,dirs); - exestr += pms; - FDebughandle := sysexec(FDebugExe,exestr,nil,0,rcode,0); - if FDebughandle then - begin - ExecuteCommand("dbgcreatechannel"); - ExecuteCommand("showeval","调试程序:"+FDebugExe); - if FConnectchannel then - begin - dbgattachwait(FConnectchannel); - end - end - end - function wmuser(o,e):WM_USER;virtual; - begin - if FRemoteWait and not(checkconnected())then - begin - if(0 <> connectserver(FDebugaddr,FDebugport))then - begin - FRemoteWait := false; - messageboxa("连接服务器失败","错误",0,self); - return; - //sleep(100); - //_send_(WM_USER,0,0,1); - end else - begin - FRemoteWait := false; - FConnectchannel := dbgcreatechannel(); - setgdbcallback(); - if(FDebugUsr and FDebugPwd)and(0 <>(lgg := dbglogin(FDebugUsr,FDebugPwd)))then - begin - messageboxa("登陆失败\r\n用户名或者密码错误","登陆失败",0,self); - return disconnectserver(); - end - dbgattachwait(FConnectchannel); - FBtns["终止"].Visible := true; - end - end + deleteItem(FMaxCoder); end + end + property OnEnterUp read FOnEnterUp write FOnEnterUp; + property MaxCoder read FMaxCoder write FMaxCoder; + private + FMaxCoder; + FOnEnterUp; +end +type TFindWnd=class(TPage) + type TFindBtn=class(TBtn) function Create(AOwner); begin inherited; - FCmdHistory := array(); - FCmdHistoryid := 0; - FCmdHistorycount := 10; - FDebugExe := ""; - Caption := "tsl debug ..."; - {fimgelist := new tcontrolimagelist(self); - fimgelist.Width := 24; - fimgelist.height := 24; - fimgelist.DrawBimpFirst := true; - FToolbar := new TToolBar(self); - FToolbar.Visible := false; - idx := 0; - for i,v in dbugicos() do //工具条 - begin - bmp := new TBitmap(); - bmp.ReadVcon(HexformatStrToTsl( v)); - fimgelist.addbmp(bmp); - iti := new TToolButton(self); - iti.OnClick := thisfunction(Dbgtooldo); - iti.Caption := i; - iti.imageid := idx; - iti.Parent := FToolbar; - idx++; - end - - FToolbar.ImageList := fimgelist; - FToolbar.Parent := self; - } - dbwnd := new tdbgwnd(self); - dbwnd.Align := alClient; - dbwnd.Parent := self; - FStackList := new TListView(self); // new TListBox(self); //new tmemo(self);// - FStackList.ItemHeight := 23; - FStackList.Columns := array(("text":"line","width":40), - ("text":"function","width":250) //,("text":"type","width":70) - ); - //FStackList.ReadOnly := true; - //FStackList.Width := 300; - FStackList.Border := true; - //FStackList.Align := alLeft; - //FStackList.Parent := self; - FVaraiblesList := new TGroupGridA(self); - FVaraiblesList.Border := false; - FVaraiblesList.ItemHeight := 23; - FVaraiblesList.Columns := array(("text":"name","width":95), - ("text":"value","width":135), - ("text":"type","width":50) - ); - FCommandtext := new TEdit(self); - //FCommandtext.Border := true; - FCommandtext.placeholder := "命令输入框"; - FCommandtext.Height := 23; - //FCommandtext.Align := alBottom; - //FCommandtext.Parent := self; - FCommandtext.onkeyup := thisfunction(cmdkeyup); - FShowText := new tmemo(self); - FShowText.ReadOnly := true; - FShowText.Border := true; - //FShowText.Align := alClient; - //FShowText.Parent := self; - pmenu := new TPopUpMenu(self); - cmu := new TMenu(self); - cmu.OnClick := function(o,e) - begin - FShowText.Text := ""; - end; - cmu.Caption := "清除"; - cmu.Parent := pmenu; - FShowText.PopUpMenu := pmenu; - dbwnd.addwnds(FStackList,FVaraiblesList,FCommandtext,FShowText); - ExecuteCommand("clearall"); - getdefaultdbger(); + left := 425; + width := 160; + height := 25; end - function addbreak(item,idx,n); //添加断点 + end + type TFindCheck=class(TCheckBtn) + function Create(AOwner); begin - if not FConnectchannel then return; - parseriteminfo(item,idx,n,usr); - if n then + inherited; + left := 25; + width := 160; + height := 25; + end + end + function CreateWndInfo(btn,sec); //触发 + begin + r := GetInfo(); + if sec then r["section"]:= sec; + r["btn"]:= btn; + end + function Create(AOwner);override; + begin + inherited; + OnClose := function(o,e) + begin + Parent.EndFind(); + o.visible := false; + e.Skip := true; + end + WsDlgModalFrame := true; + Visible := false; + WsPopUp := true; + WsCaption := true; + WSsYSMenu := true; + //WsSizeBox := true; + caption := "查找"; + SetBoundsRect(array(300,300,920,680)); + IncPaintLock(); + for i,v in array("查找","替换","文件查找") do + begin + it := CreateApageItem(); + it.Caption := v; + PageItems.Push(it); + end + DecPaintLock(); + lg := 30; + FEdit_Target := new TEditList(self); + FEdit_repace := new TEditList(self); + FEdit_Type := new TEditList(self); + FEdit_dir := new TEditList(self); + FDirChooser := new TFolderChooseADlg(self); + FEdit_dir_btn := new TBtn(self); + flabels := array(); + for i,v in array("查找目标:"," 替换为:","文件类型:"," 目录:") do + begin + lb := new TLabel(self); + lb.TextAlign := AL9_CENTERRIGHT; + lb.caption := v; + lb.Top :=(i+1) * lg; + lb.Height := 25; + lb.Left := 20; + lb.Width := 120; + lb.Parent := self; + //lb.border := true; + flabels[i]:= lb; + end + FEdit_Target.left := 140; + FEdit_Target.top := lg; + FEdit_target.parent := self; + FEdit_target.Editer.OnKeyPress := thisfunction(EditerEnter); + FEdit_repace.left := 140; + FEdit_repace.top := lg+lg; + FEdit_repace.parent := self; + FEdit_type.left := 140; + FEdit_type.top := lg+lg+lg; + FEdit_type.Editer.Text := "*.tsf;*.tsl;"; + FEdit_type.parent := self; + FEdit_dir.left := 140; + FEdit_dir.Width := FEdit_dir.Width-20; + FEdit_dir_btn.Caption := ".."; + FEdit_dir_btn.top := lg+lg+lg+lg; + FEdit_dir_btn.Width := 18; + FEdit_dir_btn.left := 140+FEdit_dir.Width+2; + FEdit_dir_btn.height := 24; + FEdit_dir.top := lg+lg+lg+lg; + FEdit_dir.parent := self; + FEdit_dir_btn.OnClick := function(o,e) + begin + if FDirChooser.OpenDlg()then begin - //echo "\r\n====add:",usr,"====",n,"===",idx; - dbgsetbreak(FConnectchannel,usr,n,idx+1); + FEdit_dir.Editer.text := FDirChooser.Folder; end end - function removebreak(item,idx); //移除断点 + FBtn_Find := new TFindBtn(self); + FBtn_replace := new TFindBtn(self); + FBtn_Count := new TFindBtn(self); // 计数 + FBtn_replaceall := new TFindBtn(self); + FBtn_Find.caption := "查找"; + FBtn_replace.caption := "替换"; + FBtn_Count.caption := "全部查找"; + FBtn_replaceall.caption := "全部替换"; + FBtn_Find.top := lg; + FBtn_Find.parent := self; + FBtn_replace.top := lg+lg; + FBtn_replace.parent := self; + FBtn_replaceall.top := lg+lg+lg; + FBtn_replaceall.parent := self; + FBtn_Find.OnClick := thisfunction(FindBtnClick); + FBtn_replace.OnClick := thisfunction(FindBtnClick); + FBtn_Count.OnClick := thisfunction(FindBtnClick); + FBtn_replaceall.OnClick := thisfunction(FindBtnClick); + FBtn_Count.top := lg+lg+lg+lg; + FBtn_Count.parent := self; + FDirChooser.parent := self; + FCheck_revers := new TFindCheck(self); + FCheck_wrap := new TFindCheck(self); + FCheck_case := new TFindCheck(self); + FCheck_cycle := new TFindCheck(self); + FCheck_reg := new TFindCheck(self); + FCheck_subdir := new TFindCheck(self); + FCheck_gt := new TFindCheck(self); + FCheck_subdir.checked := true; + FCheck_subdir.Left := 425; + FCheck_subdir.top := lg+lg+lg+lg; + FCheck_subdir.Caption := "包含子目录"; + FCheck_revers.caption := "反向查找"; + FCheck_revers.top := lg * 5; + FCheck_revers.parent := self; + FCheck_wrap.caption := "全词匹配"; + FCheck_wrap.top := lg * 6; + FCheck_wrap.parent := self; + FEdit_dir_btn.parent := self; + FCheck_case.caption := "忽略大小写"; + FCheck_case.Checked := true; + FCheck_case.top := lg * 7; + FCheck_case.parent := self; + FCheck_cycle.caption := "循环查找"; + FCheck_cycle.Checked := true; + FCheck_cycle.top := lg * 8; + FCheck_cycle.parent := self; + FCheck_reg.caption := "正则匹配"; + FCheck_reg.Enabled := false; + FCheck_reg.top := lg * 9; + FCheck_reg.parent := self; + FCheck_gt.caption := "\\t转义tab"; + FCheck_gt.Checked := false; + FCheck_gt.top := lg * 9; + FCheck_gt.Left := FCheck_reg.width+FCheck_reg.Left+10; + FCheck_gt.parent := self; + FCheck_subdir.parent := self; + FCheck_reg.OnClick := function(o,e) begin - if not FConnectchannel then return; - parseriteminfo(item,idx,n,usr); - if n then + FCheck_revers.Enabled := not(o.Checked); + FCheck_wrap.Enabled := not(o.Checked); + FCheck_case.Enabled := not(o.Checked); + end + FStatus := new TStatusBar(self); + //FStatus.Align := alNone; + FStatus.Items := array(("text":"","width":700)); + FStatus.Parent := self; + OnSelChanged := thisfunction(DoSelChanged); + ItemIndex := 0; + //SetStatusText("查找"); + end + function FindBtnClick(o,e); + begin + r := GetInfo(); + r["btn"]:= o.Caption; + Owner.DoFind(r,self); + end + function EditErEnter(o,e); + begin + if e.CharCode=13 then + begin + e.skip := true; + r := GetInfo(); + r["btn"]:= "查找"; + OWner.DoFind(r,self); + end + end + function GetInfo(); + begin + r := array(); + r["section"]:= CurrentITem.Caption; + s := FEdit_target.Editer.Text; + if FCheck_gt.Checked then + begin + s := Replacestr(s,"\\t","\t"); + end + r["target"]:= s; + s := FEdit_repace.Editer.Text; + if FCheck_gt.Checked then + begin + s := Replacestr(s,"\\t","\t"); + end + r["replace"]:= s; + r["filetype"]:= FEdit_type.Editer.Text; + r["dir"]:= FEdit_dir.Editer.Text; + r["c_revers"]:= FCheck_revers.Checked; + r["c_cycle"]:= FCheck_cycle.Checked; + r["c_wrap"]:= FCheck_wrap.Checked; + r["c_case"]:= FCheck_case.Checked; + r["c_reg"]:= FCheck_reg.Checked; + r["c_dir"]:= FCheck_subdir.Checked; + return r; + end + function SetStatusText(s); + begin + if ifstring(s)then FStatus.SetItemText(s,0); + end + function OpenFind(); + begin + ItemIndex := 0; + end + function OpenReplace(); + begin + ItemIndex := 1; + end + function Show(f);override; + begin + it := Owner.GetCurrentEditer(); + if it then + begin + s1 := it.SelText; + if s1 and length(s1)<20 and not(pos("\n",s1))then begin - //echo "\r\n====remove:",usr,"====",n,"===",idx; - dbgunsetbreak(FConnectchannel,usr,n,idx+1); + s := s1; + end else + s := it.CaretWords(); + if s then SetFindText(s); + FEdit_target.Editer.SetFocus(); + end + inherited; + end + Function SetFindText(s); //设置查找的字符串 + begin + FEdit_target.Editer.Text := s; + FEdit_target.Editer.SetSel(0,length(s)); + end + function SaveCurrentEditer(); //保存一下数据 + begin + for i,v in array(FEdit_target,FEdit_dir,FEdit_type,FEdit_repace) do + begin + v.PushItem(v.Editer.Text); + end + //if e then e.PushItem(e.Editer.Text); + end + function DoSelChanged(o,e); + begin + if CurrentItem then Caption := CurrentItem.Caption; + case Caption of + "查找": + begin + for i := 1 to 3 do flabels[i].Visible := false; + FEdit_dir.visible := false; + FEdit_dir_btn.visible := false; + FEdit_type.visible := false; + FEdit_repace.visible := false; + FBtn_replace.visible := false; + FBtn_count.Visible := true; + FBtn_Replaceall.Visible := false; + FCheck_subdir.visible := false; + FCheck_Revers.visible := true; + FCheck_cycle.Visible := true; + end + "替换": + begin + flabels[1].Visible := true; + for i := 2 to 3 do flabels[i].Visible := false; + FEdit_dir.visible := false; + FEdit_dir_btn.visible := false; + FEdit_type.visible := false; + FEdit_repace.visible := true; + FBtn_replace.visible := true; + FBtn_count.Visible := false; + FBtn_Replaceall.Visible := true; + FCheck_subdir.visible := false; + FCheck_Revers.visible := false; + FCheck_cycle.Visible := true; + end + "文件查找": + begin + for i := 1 to 3 do flabels[i].Visible := true; + FEdit_dir.visible := true; + FEdit_dir_btn.Visible := true; + FEdit_type.visible := true; + FEdit_repace.visible := true; + FBtn_replace.visible := false; + FBtn_count.Visible := false; + FBtn_Replaceall.Visible := true; + FCheck_subdir.visible := true; + FCheck_Revers.visible := false; + FCheck_cycle.Visible := false; end end - function Dbgtooldo(o,e) + end + function DoControlAlign();override; + begin + inherited; + if not FStatus then return; + rc := ClientRect; + rc[1]:= rc[3]-30; + FStatus.SetBoundsRect(rc); + end + function recycling();override; + begin + inherited; + FStatus := nil; + end + function GetHistory(); + begin + r := array(); + r["finds"]:= FEdit_Target.Items; + r["repalces"]:= FEdit_repace.Items; + r["dirs"]:= FEdit_dir.items; + r["findfiletyps"] := FEdit_Type.items; + return r; + end + function SetHistory(d); + begin + if not ifarray(d)then return; + fds := d["finds"]; + if ifarray(fds)then begin - cp := o.Caption; - case cp of - "调试运行": - begin - //echo "调试运行"; - it := Owner.GetCurrentItem(); //Owner.GetAllPageItems(); - Debuglocal(it); - end - "添加/删除断点F5": - begin - it := Owner.GetCurrentItem(); - if it then - begin - it.FEditer.SwitchMarkLine(); - end - end - "暂停": - begin - ExecuteCommand("dbgpause"); - end - "进入": - begin - ExecuteCommand("dbgstep") - end - "单步": - begin - //dbgstep(); - end - "下一行(F8)": - begin - ExecuteCommand("dbgstepover"); - end - "跳出": - begin - ExecuteCommand("dbgstepout"); - end - "继续": - begin - toolbtnState("继续"); - if FCurrentgotoitem and FCurrentgotoitem.FEditer then FCurrentgotoitem.FEditer.ExecuteCommand("ecruningto",nil); - ExecuteCommand("dbgrun"); - end - "终止": - begin - ExecuteCommand("dbgreset"); - end - "单步": - begin - end - "刷新符号表": - begin - ExecuteCommand("dbggetallvalue"); - end - "刷新当前符号": - begin - ExecuteCommand("dbggetcurrentnode"); - end - "清除文本框": - begin - FShowText.Text := ""; - end - end; + FEdit_Target.Items := fds; end - function dbgeventcall(d); //回调 + rps := d["repalces"]; + if ifarray(rps)then begin - global g_tsldbgcallback_handle; - if not ifarray(d)then return; - if d["channel"]<> FConnectchannel then return; - recvtype := d["recvtype"]; - if recvtype=0 then + FEdit_repace.Items := rps; + end + dirs := d["dirs"]; + if ifarray(dirs)then + begin + FEdit_dir.items := dirs; + end + dirs := d["findfiletyps"]; + if ifarray(dirs)then + begin + FEdit_Type.items := dirs; + end + end + private + FStatus; + FDirChooser; + //查找 + FEdit_Target; + FEdit_repace; + FEdit_type; + FEdit_dir; + FEdit_dir_btn; + FBtn_Find; + FBtn_replace; + FBtn_Replaceall; + FBtn_Count; // 计数 + flabels; + FCheck_revers; + FCheck_wrap; + FCheck_case; + FCheck_cycle; + FCheck_reg; + FCheck_subdir; + FCheck_gt; +end +type TListPages=class(TListBox) + function Create(AOwner);override; + begin + inherited; + Visible := false; + WsPopUp := true; + end + function PaintIdx(idx,rc_,cvs);override; + begin + {** + @explan(说明)绘制项 %% + @param(item)(TCustomListItem) 项 %% + @param(rc)(array) 绘制区域%% + @param(cvs)(tcanvas) 画布 %% + **} + inherited; + if idx=getCurrentSelection()then + begin + rc := rc_; + rc[2:3]-= 1; + cvs.pen.Color := rgb(30,144,255); + cvs.draw("Polyline",array(rc[0:1],(rc[2],rc[1]),(rc[2],rc[3]),(rc[0],rc[3]),rc[0:1])); + end + end + function MouseUp(o,e);override; + begin + inherited; + visible := false; + end + function SetData(d);override; + begin + if not ifarray(d)then return; + height := ItemHeight * (1+min(15,length(d))); + x := 10; + for i,v in d do + begin + x := max(x,length(v)); + end + width := font.Width * (x+3); + inherited; + end + 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 + function GetSelFileName; + begin + r := GetItem(getCurrentSelection()); + if pos("*",r)then + begin + return r[2:]; + end + return r; + end + function IncIndex(f); + begin + if ifnil(f)then f :=-1; + idx := getCurrentSelection(); + ct := ItemCount; + nidx := idx-f; + if idx=ct-1 then nidx := 0; + else if idx=-1 then nidx := 1; + SetCurrentSelection(nidx); + InsureItemVisible(nidx); + end +end +type tagCOMPOSITIONFORM=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("dwstyle","int",4), + ("ptcurrentpos","intptr",0), + ("rcarea","int[4]",array(0,0,0,0))),nil,nil,1); + return SSTRUCT; + end + public + function create() + begin + inherited create(getstruct(),ptr); + FPonter := new TCPoint(); + _setvalue_("ptcurrentpos",FPonter._getptr_()); + end + property dwstyle index "dwstyle" read _getvalue_ write _setvalue_; + property ptcurrentpos read FPonter; + property rcarea index "rcarea" read _getvalue_ write _setvalue_; + private + FPonter; +end +type TFTSLScriptMemo=class(TSYNmemoNorm) + function Create(AOwner);override; + begin + inherited; + WsDlgModalFrame := true; + FChangedFlag := false; + FChangedLock := false; + Lineinterval := 3; + FCOMPOSITIONFORM := new tagCOMPOSITIONFORM(nil); + font := array("height":18,"width":9,"escapement":0,"orientation":0,"weight":400,"italic":0,"underline":0,"strikeout":0, + "charset":0,"outprecision":0,"clipprecision":0,"quality":1,"pitchandfamily":1,"facename":"Courier New","color":0); + //134 + //font := array("facename":"Courier New"); + end + function DoCaretPosChanged();override; + begin + if HandleAllocated()then calldatafunction(FOnCaretChanged,self(true),new tuieventbase(0,0,0,0)); + //echo tostn(self.CaretXY); + end + function WMIMESTARTCOMPOSITION(o,e):WM_IME_STARTCOMPOSITION;virtual; + begin + ime := ImmGetContext(self.Handle); + FCOMPOSITIONFORM.ptcurrentpos.cx := 200; + FCOMPOSITIONFORM.ptcurrentpos.cy := 200; + ImmSetCompositionWindow(ime,FCOMPOSITIONFORM._getptr_()); + ImmReleaseContext(self.Handle,ime); + end + {$ifdef linux} + function ImmReleaseContext(); + begin + end; + function ImmGetContext(); + begin + end; + function ImmSetCompositionWindow(); + begin + end; + function ImmSetStatusWindowPos(); + begin + end; + {$else} + function ImmReleaseContext(h:pointer;ime:pointer):integer;stdcall;external "Imm32.dll" name "ImmReleaseContext"; + function ImmGetContext(h:pointer):pointer;stdcall;external "Imm32.dll" name "ImmGetContext"; + function ImmSetCompositionWindow(h:pointer;s:pointer):integer;stdcall;external "Imm32.dll" name "ImmSetCompositionWindow"; + function ImmSetStatusWindowPos(h:pointer;s:pointer):integer;stdcall;external "Imm32.dll" name "ImmSetStatusWindowPos"; + {$endif} + function InvalidateLines(FirstLine,LastLine:integer);override; + begin + //return inherited; + if not HandleAllocated()then return; + if HighLighter is class(TTslSynHighLighter)then + begin + fy :=(FirstLine-TopLine) * TextHeight; + r := ClientRect; + if fyr[3]then return; + r[0]:= GutterWidth; + r[1]:= max(0,fy); + InvalidateRect(r,false); + end else + return inherited; + end + function MouseUp(o,e);override; + begin + inherited; + end + function InsertChars(s);override; + begin + if(s="\r\n")then + begin + y := CaretY; + x := CaretX; + sl := Lines.GetStringByIndex(y-1); + if ifstring(sl)and sl then begin - FRemoteWait := 0; - ExecuteCommand("showeval","调试结束"); - if FConnectchannel then dbgdeletechannel(FConnectchannel); - FConnectchannel := 0; - g_tsldbgcallback_handle := nil; - if FCurrentgotoitem and FCurrentgotoitem.FEditer then FCurrentgotoitem.FEditer.ExecuteCommand("ecruningto",nil); - FDebughandle := 0; - toolbtnState("停止"); - return; - end - //echo "\r\nrectype",format("0x%x",recvtype); - if 0x0401=recvtype then - begin - owner.echoAppendString(d["errmsg"]); - return; - end - if recvtype <> 0x402 then - begin - return; - end - case magicgetarray(d,array("result","CmdType"))of - "attachlist": + ins := ""; + for i := 1 to x-1 do begin - r := magicgetarray(d,array("result","CmdData")); - r :: + si := sl[i]; + if si="\t" or si=" " then begin - if mcol="createtm" then - begin - mcell := datetimetostr(mcell); - end - end - return fdbgselwnd.setlist(r); - //return echo tostn(r); - end - "attachwaitok","attachok": // 连接,默认 - begin - debuginitok(); - FVaraiblesList.SetNodeData(array()); - FStackList.DeleteAllItems(); - //dbgeval(FConnectchannel,getobjtransfunc()); - return; - end - "DebugInfo": //调试信息 - begin - if "dbgdetach"=remotewaitinit(d)then return; - toolbtnState("暂停"); - stk := magicgetarray(d,array("result","CmdData","CallStack")); //深度 - sybs := magicgetarray(d,array("result","CmdData","SymbolInfo")); //符号 - ssybs := magicgetarray(d,array("result","CmdData","EnvInfo")); //系统参数 - {if (ssybs = Fdbgssybs) and (sybs = Fdbgsybs) and (stk=Fdbgstack) then //值没变 - begin - return ; - end } - if(ssybs <> Fdbgssybs)or(sybs <> Fdbgsybs)then - begin - FVaraiblesList.SetNodeData(array()); - ddd := formatsysvlist(ssybs,nil); - FVaraiblesList.SetNodeData(ddd,true); - Fdbgssybs := ssybs; - ddd := formatvlist(sybs); - FVaraiblesList.SetNodeData(ddd,true); - Fdbgsybs := sybs; - end - if stk <> Fdbgstack then - begin - FStackList.DeleteAllItems(); - FStackList.appendItems(stk[:,array("LINE","NAME","USER")]); - //FStackList.text := array2str(stks,"\r\n"); - Fdbgstack := stk; - end - if ifarray(stk)then - begin - FVaraiblesList.celldbclk := thisfunction(vdbclk); - FVaraiblesList.celledit := thisfunction(vdoedit); - FVaraiblesList.Showarray := thisfunction(vdoshowarray); - FStackList.OnDblClick := thisfunction(stkdbclk); - it := opengoto(stk[0]); - //if not it then return; - if it and it <> FCurrentgotoitem then - begin - if FCurrentgotoitem and FCurrentgotoitem.FEditer then - begin - FCurrentgotoitem.FEditer.ExecuteCommand("ecruningto",nil); - end - FCurrentgotoitem := it; - end - if FCurrentgotoitem then - begin - FCurrentgotoitem.FEditer.ExecuteCommand("ecruningto",stk[0,"LINE"]-1); - end - end - return; - end - "detached": - begin - if FConnectchannel then - begin - dbgdeletechannel(FConnectchannel); - FConnectchannel := 0; - g_tsldbgcallback_handle := nil; - FAttchedid := 0; - end - FRemoteWait := 0; - if FCurrentgotoitem and FCurrentgotoitem.FEditer then FCurrentgotoitem.FEditer.ExecuteCommand("ecruningto",nil); - ExecuteCommand("showeval","调试结束"); - toolbtnState("停止"); - return; - end - "DebugSysParamValue": - begin - CmdTypeAux := magicgetarray(d,array("result","CmdTypeAux")); - ev := magicgetarray(d,array("result","CmdData")); - cp := magicgetarray(d,array("result","CmdParam")); - len :=-1; - if ifnumber(CmdTypeAux)and(CmdTypeAux .& 0x80000000)then - begin - len := _shr((int(CmdTypeAux).& 0xFFF0),4); - end - //echo "\r\n***",len," ",cp," ",tostn(ev); - if(cp="#DebugEval")or(cp="#Error")then - begin - return showevaldata(nil,ev); - end - if ifarray(ev)then - begin - ddd := formatsysvlist(array(cp:ev),len); - FVaraiblesList.SetNodeData(ddd,true); - for i,v in ev do - begin - if ifstring(i)then - begin - ncp := tostn(i); - ncp := replacetext(ncp,".","\\o"); - ncp := cp+".["+ncp+"]"; - end else - begin - ncp := cp+".["+tostn(i)+"]"; - end - magicsetarray(d,array("result","CmdParam"),ncp); - magicsetarray(d,array("result","CmdData"),v); - dbgeventcall(d); - end - return; + ins += si; end else - begin - ddd := formatsysvlist(array(cp:ev),len); - FVaraiblesList.SetNodeData(ddd,true); - end + break; end - "DebugValue": + if ins then begin - cp := magicgetarray(d,array("result","CmdParam")); - ev := magicgetarray(d,array("result","CmdData")); - if(cp="#DebugEval")or(cp="#Error")then - begin - return showevaldata(nil,ev); - end - if ifarray(ev)then - begin - //showevaldata(cp,ev); - ddd := formatvlist(array(cp:ev)); - FVaraiblesList.SetNodeData(ddd,true); - for i,v in ev do - begin - if ifstring(i)then - begin - ncp := tostn(i); - ncp := replacetext(ncp,".","\\o"); - ncp := cp+".["+ncp+"]"; - end else - begin - ncp := cp+".["+tostn(i)+"]"; - end - magicsetarray(d,array("result","CmdParam"),ncp); - magicsetarray(d,array("result","CmdData"),v); - dbgeventcall(d); - end - return; - end else - begin - ddd := formatvlist(array(cp:ev)); - FVaraiblesList.SetNodeData(ddd,true); - end - end - "noattachederror": - begin - return disconnectserver(); - FRemoteWait := 0; - ExecuteCommand("showeval","noattachederror"); - d["recvtype"]:= 0; //退出 - dbgeventcall(d); - return; - end else - begin - //echo tostn(d); + return inherited InsertChars(s+ins); end end + end + return inherited; + end + function KeyUp(o,e);override; + begin + e.Result := 1; + if Calldatafunction(FQuckKeys,self,e)then return; + inherited; + end + function ContextMenu(o,e);override; + begin + inherited; + e.skip := true; + end + function SwitchMarkLine(L); //此处处理断点问题 + begin + if not(L >= 0)then + begin + L := self.CaretY-1; + end + it := Lines[L]; + if it then + begin + it.FMarked := not(it.FMarked); + r := ClientRect; + r[2]:= GutterWidth()-1; + InValidateRect(r,false); + if _Tag then _Tag.markline(L,it.FMarked); + end + end + function KeyDown(o,e);override; + begin + e.Result := 0; + qc := Calldatafunction(FQuckKeys,self,e); + if qc then return; + if e.CharCode=VK_F5 then + begin + L := self.CaretY-1; + SwitchMarkLine(L); return; end - function showevaldata(cp_,ev); + if e.CharCode=VK_F2 and(ssCtrl in e.shiftState())then begin - cp := cp_; - if cp then + L := self.CaretY-1; + SwitchMarkLine(L); + return; + end + if not(ssCtrl in e.shiftstate())and not(ssShift in e.shiftstate())then + begin + if e.CharCode=VK_F2 then begin - if parseregexpr("\\(\\w+\\)\\.",cp,"r", function(a) - begin - return ""; - end - ,s)=1 then + y := CaretY-1; + len := Lines.length(); + for i := y+1 to len+y-1 do begin - cp := s; + idx :=(i+len)mod len; + it := Lines[idx]; + if it and it.FMarked then + begin + return ExecuteCommand(ecGotoXY,array(idx+1,1)); + end end - end - if ev and ifarray(ev)then - begin - fwnd := getvalewnd(cp); - fwnd.TSLdata := ev; - fwnd.Show(); - end else - begin - if cp then FShowText.Text += ">>"+cp+"\r\n"; - ExecuteCommand("showeval",ev); + return; end end - function ExecuteCommand(cmd,p);override; + inherited; + end + function WMSYSKEYUP(o,e):WM_SYSKEYUP;override; + begin + e.Result := 1; + if CallDatafunction(FQuckKeys,self,e)then return; + inherited; + end + Function WMSYSKEYDOWN(o,e):WM_SYSKEYDOWN;override; + begin + e.Result := 0; + if CallDatafunction(FQuckKeys,self,e)then return; + inherited; + end + function WMSETFOCUS(o,e):WM_SETFOCUS;override; + begin + inherited; + CallDataFunction(FOnTextSetFocus,self(true),e); + end + function DoTextChanged(p);override; + begin + n := Lines.Length(); + ccnt := GutterCharCnt; + nccnt := max(integer(n~10)+3,4); + if ccnt <> nccnt then begin - case cmd of - "dbgstate": + GutterCharCnt := nccnt; + end + inherited; + SetChangeFlag(true); + end + function Recycling();override; + begin + FQuckKeys := nil; + FOnTextChanged := nil; + FOnTextSetFocus := nil; + FPageItem := nil; + FOnCaretChanged := nil; + inherited; + end + published + property OnCaretChanged read FOnCaretChanged write FOnCaretChanged; + property PageItem read FPageItem write FPageItem; + property OnTextChanged read FOnTextChanged write FOnTextChanged; //文本改变 + property QuckKeys read FQuckKeys write FQuckKeys; //快捷键 + property ChangedFlag read FChangedFlag write SetChangeFlag; + property ChangedLock read FChangedLock write FChangedLock; + property OnTextSetFocus read FOnTextSetFocus write FOnTextSetFocus; + private + function SetChangeFlag(v); + begin + nv := v?true:false; + if nv <> FChangedFlag then + begin + FChangedFlag := nv; + if FChangedLock then return; + calldatafunction(OnTextChanged,self(true),nv); + end + end + FPageItem; + FChangedLock; + FChangedFlag; + FOnTextChanged; + FOnTextSetFocus; + FQuckKeys; + FCOMPOSITIONFORM; + FOnCaretChanged; +end +type TPageEditerItem=class(TPageItem) + FPageOrderId; //序号有调用者使用 + FEditer; //编辑器 + FSynType; + FInitCompletion; + FDebuger; + fisnewfile; + function create(AOwner);override; + begin + inherited; + FSynType := ""; + FEnCode := "ANSI"; + FGetInfoText := ""; + FLastVersion := ""; + FEditer := new TFTSLScriptMemo(AOwner); + FEditer.Visible := false; + FEditer._Tag := self; + end + function Recycling();override; + begin + FDebuger := nil; + inherited; + FEditer.Recycling(); + FEditer := nil; + end + function markline(l,f); //标记被调用 + begin + if FDebuger then + begin + if f then + begin + FDebuger.addbreak(self,l); + end else + begin + FDebuger.removebreak(self,l); + end + end + end + function ScriptPathIs(v); + begin + return filenameIsTheSame(v,FScriptPath); + end + published + property ScriptPath read FScriptPath write SetScriptPath; //文件名 + property OrigScriptPath read FOrgScriptPath; + property TslSynText read FTslSynText write FTslSynText; + property LastText read FLastVersion; //最新的版本 + property EnCode read FEnCode; + RepreComple; + FISstm; + ///////////////////设计器相关////////////////////////////////////// + public + function Addfiled(fld); //添加成员变量 + begin + if not FTslParser then return 0; + if not(fld and ifstring(fld))then return; + nfld := lowercase(fld); + nt := str2array(nfld,":"); + nfld := nt[0]; + nfldt := nt[1]; + d := GetClassInfo(); + if not(d and ifarray(d))then return 0; + for i,v in d["filed"] do + begin + if v["name"]=nfld then return 1; + end + crec := GetCreateFunctionRec(d); + if crec then + begin + p := crec[0]; + if ifarray(p)then + begin + FEditer.ExecuteCommand(FEditer.ecGotoXY,p); + FEditer.ExecuteCommand(FEditer.ecString,fld+";\r\n "); + end + end + end + function GetCreateFunctionRec(d); //获得插入函数为位置 + begin + fi := d["funcsinfo"]; + for i,v in fi do + begin + if v["name"]="create" then + begin + return GetInfoRowCol(v); + end + end + return 0; + end + function Delfiled(fld,nn); //删除成员变量 + begin + if not FTslParser then return 0; + if not(fld and ifstring(fld))then return; + if not ifstring(nn)then nn := ""; + nfld := lowercase(fld); + d := GetClassInfo(); + if not(d and ifarray(d))then return 0; + for i,v in d["filed"] do + begin + if v["name"]=nfld then + begin + frec := GetInfoRowCol2(v); + if ifarray(frec[0])and ifarray(frec[1])then begin - if ifnil(p)then return FdebugState; - end - "execommand": - begin - case p of - "#127": - begin - FShowText.Text := ""; - end - end; - end - "docmd": - begin - s := FCommandtext.Text; - if not s then return; - FCommandtext.Text := ""; - if s="#cls" then return ExecuteCommand("execommand",s); - FShowText.Text += ">>"+s+"\r\n"; - ExecuteCommand("dbgeval",s); - end - "clearall": //清除所有 - begin - //FStackList.items := array(); - //FStackList.text := ""; - FStackList.DeleteAllItems(); - FVaraiblesList.SetNodeData(array()); - if p then - begin - FShowText.Text := ""; - FCommandtext.Text := ""; - end - end - "showeval": - begin - FShowText.Text += "ans="+tostn(p)+"\r\n"; - FShowText.ExecuteCommand(FShowText.ecGotoXY,array(100000,1)); - end - "dbgcreatechannel": - begin - if not FConnectchannel then - begin - idx := 0; - if not checkconnected()then - begin - while(FDebugtype="local")and(0 <> connectserver(FDebugaddr,FDebugport)) do - begin - sleep(100); - idx++; - if idx>20 then - begin - return ExecuteCommand("debugconnecterr"); - end; - end - end - FConnectchannel := dbgcreatechannel(); - setgdbcallback(); - end - end - "dbggetallvalue": - begin - if FConnectchannel then - begin - dbggetallvalue(FConnectchannel); - end - end - "dbggetcurrentnode": - begin - FVaraiblesList.getcurrentnodedata(); - end - "dbgreset": //停止 - begin - if FConnectchannel then - begin - if FDebughandle then - begin - return SysTerminate(-1,FDebughandle); - end - if FAttchedid then - begin - //echo "\r\n终止"; - return dbgdetach(FConnectchannel); - end else - begin - if FDebugtype="remotewait" then //远程,断开连接 - begin - return disconnectserver(); - end - return dbgdetach(FConnectchannel); - //return dbgreset(FConnectchannel); - end - end - end - "dbgrun": //运行 - begin - if FConnectchannel then dbgrun(FConnectchannel); - end - "dbgstep": - begin - if FConnectchannel then dbgstep(FConnectchannel); - end - "dbgpause": //暂停 - begin - if FConnectchannel then dbgpause(FConnectchannel); - end - "dbgstepover": //下一行 - begin - if FConnectchannel then dbgstepover(FConnectchannel); - end - "dbgstepout": //跳出函数 - begin - if FConnectchannel then dbgstepout(FConnectchannel); - end - "dbgeval": //执行 - begin - if FConnectchannel and p and ifstring(p)then - begin - getvalewnd("ans"); - dbgeval(FConnectchannel,p); - end + FEditer.ExecuteCommand(FEditer.ecGotoXY,frec[0]); + FEditer.ExecuteCommand(FEditer.ecSelGotoXY,frec[1]); + FEditer.SelText := nn?(nn+";"):""; end end end + end + function GoToFunction(fn); + begin + if not(ifstring(fn))then return false; + nfld := lowercase(fn); + d := GetClassInfo(); + if not ifarray(d)then return 0; + for i,v in d["funcsinfo"] do + begin + if v["name"]=nfld then + begin + crec := GetInfoRowCol(v); + if ifarray(crec)and ifarray(crec[0])then + begin + FEditer.ExecuteCommand(FEditer.ecGotoXY,crec[0]); + end + return true; + end + end + end + function AddFunction(fn,finfo); //添加函数 + begin + if not FTslParser then return 0; + if not(ifstring(fn)and fn and ifstring(finfo))then return 0; + nfld := lowercase(fn); + d := GetClassInfo(); + if not ifarray(d)then return 0; + for i,v in d["funcsinfo"] do + begin + if v["name"]=nfld then + begin + crec := GetInfoRowCol(v); + if ifarray(crec)and ifarray(crec[0])then + begin + FEditer.ExecuteCommand(FEditer.ecGotoXY,crec[0]); + end + return true; + end + end + crec := GetCreateFunctionRec(d); + if crec then + begin + p := crec[1]; + if ifarray(p)then + begin + FEditer.ExecuteCommand(FEditer.ecGotoXY,p); + FEditer.ExecuteCommand(FEditer.ecString,"\r\n"+finfo+"\r\n "); + end + end + return true; + end + function GetLastLoadTime(); //最新时间 + begin + return FLastFileTime; + end + function ReGetLastLoadTime(); //重新获得时间 + begin + fi := FileList("",FScriptPath); + FLastFileTime := fi[0,"Time"]; + return FLastFileTime; + end + function PrePareSave(); //准备保存 + begin + if not FEditer.ChangedFlag then + begin + if RepreComple then itemPareCompletion(); + return false; + end + if FEditer.ReadOnly then + begin + if RepreComple then itemPareCompletion(); + return false; + end + t := FEditer.Text; + if FLastVersion=t then + begin + FEditer.ChangedFlag := false; + if RepreComple then itemPareCompletion(); + return false; + end + FLastVersion := t; + itemPareCompletion(); + //FEditer.PrePareCompletion(t); //准备自动完成 + FEditer.ChangedFlag := false; + return true; + end + function itemPareCompletion(); + begin + t := caption; + cp := FEditer.Completion; + if cp then cp.PrePareCompletion(t); + RepreComple := false; + end + function IsTextUTF8(str) + begin + {utf8规则 + 单字节: 0xxxxxxx + 二字节 110xxxxx 10xxxxxx + 三字节 1110xxxx 10xxxxxx 10xxxxxx + 四字节 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + 五字节 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx + 刘字节 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx + } + // 0 为ansi 编码,1 为utf8编码 -1 不能确定什么编码 + nBytes := 0; //UFT8可用1-6个字节编码,ASCII用一个字节 + DY := 0; + chr := ""; + bAllAscii := TRUE; //如果全部都是ASCII, 说明不是UTF-8 + for i := 1 to length(str) do + begin + chr := ord(str[i]); + if((chr .& 0x80)<> 0)then + begin // 判断是否ASCII编码,如果不是,说明有可能是UTF-8,ASCII用7位编码,但用一个字节存,最高位标记为0,o0xxxxxxx + bAllAscii := FALSE; + end + if(nBytes=0)then //如果不是ASCII码,应该是多字节符,计算字节数 + begin + if(chr >= 0x80)then + begin + if(chr >= 0xFC and chr <= 0xFD)then nBytes := 6; + else if(chr >= 0xF8)then nBytes := 5; + else if(chr >= 0xF0)then nBytes := 4; + else if(chr >= 0xE0)then nBytes := 3; + else if(chr >= 0xC0)then nBytes := 2; + else return 0; + DY := MAX(nBytes,DY); + nBytes--; + end + end else //多字节符的非首字节,应为 10xxxxxx + begin + if((chr .& 0xC0)<> 0x80)then return-1; + nBytes--; + end + end; + if(nBytes>0)then //违返规则 + return-1; + if(bAllAscii)then //如果全部都是ASCII, 说明不是UTF-8 + return 0; + //return 1; + return DY>2; + end + function ToUnicode_big(); + begin + if FEnCode="UCS2-big" then return; + FEnCode := "UCS2-big"; + FEditer.ChangedFlag := true; + FLastVersion := ""; + end + function ToUniocode_little(); + begin + if FEnCode="UCS2-little" then return; + FEnCode := "UCS2-little"; + FEditer.ChangedFlag := true; + FLastVersion := ""; + end + function ToUTF8(); + begin + if FEnCode="UTF8" then return; + FEnCode := "UTF8"; + FEditer.ChangedFlag := true; + FLastVersion := ""; + return; + end + function ToUTF8BOM(); + begin + if FEnCode="UTF8 BOM" then return; + FEditer.ChangedFlag := true; + FEnCode := "UTF8 BOM"; + FLastversion := ""; + end + function ToANSI(); + begin + if FEnCode="ANSI" then return; + FEditer.ChangedFlag := true; + FEnCode := "ANSI"; + FLastversion := ""; + end + function CurrentCodeIsUtf8(); + begin + if FEnCode="ANSI" then + begin + s := FEditer.Text; + try + s := UTF8toansi(s); + FEditer.Text := s; + FEnCode := "UTF8"; + except + end + end + end + function CurrentCodeIsAnsi(); + begin + if FEnCode="UTF8" then + begin + FEnCode := "ANSI"; + end + end + function SetLoadScript(s); //保存文件 + begin + if not ifstring(s)then return; + strcode := 0; + FEnCode := "ANSI"; + if(length(s)>= 2)and ord(s[1])=0xFE and ord(s[2])=0xFF then //ucs2-big + begin + strcode := 2; + FEnCode := "UCS2-big"; //要转换 + if length(s)=2 then s := ""; + else + begin + s1 := ""; + setlength(s1,length(s)-2); + for i := 3 to length(s)-1 step 2 do + begin + s1[i-2]:= s[i+1]; + s1[i-1]:= s[i]; + end + s := unicodetomultibyte(s1,936); + end + end else + if(length(s)>= 2)and ord(s[1])=0xFF and ord(s[2])=0xFE then //ucs2-little + begin + strcode := 4; + FEnCode := "UCS2-little"; + if length(s)=2 then s := ""; + else + begin + s := unicodetomultibyte(s[3:],936); + end + end else + if(length(s)>= 3)and ord(s[1])=0xEF and ord(s[2])=0xBB and ord(s[3])=0xBF then + begin + FEnCode := "UTF8 BOM"; + if length(s)=3 then s := ""; + else s := utf8toansi(s[4:]); + strcode := 1; + end + if(0=strcode)then + begin + if IsTextUTF8(s)=1 then + begin + FEnCode := "UTF8"; + strcode := 1; + s := utf8toansi(s); + end + end + FLastVersion := s; + FEditer.Text := s; + FEditer.ExecuteCommand(FEditer.ecGotoXY,array(1,1)); + FEditer.ClearUndo(); + FEditer.ChangedFlag := false; + if not FTslSynText then return; + if not(s)then return; + r := tsl_tokenizeex_2_(s,1); + cs := r["class"]; + if ifarray(cs)and cs[0]then + begin + lcs1 := lowercase(cs[0]); + if lcs1 in array("tdcreateform","tdcreatepanel")then + begin + try + if not FTslParser then FTslParser := new unit(UDesignerProject).tslparser(); #! end + except + end; + return; //返回 + end + end + FTslParser := nil; + end + function GetClassInfo(); //获得信息 + begin + if not FTslParser then return array(); + txt := FEditer.Text; + if txt <> FGetInfoText then + begin + FGetInfoText := txt; + FTslParser.Script := txt; + FGetInfoChace := FTslParser.GetClassInfo(1); + end + return FGetInfoChace; + end + private + FEnCode; + FLastFileTime; + FTslSynText; + function GetInfoRowCol(v); //获得行列 + begin + rs := PosToRowCol(FGetInfoText,array(v["startpos"]-1,v["endpos"])); + return rs; + end + function GetInfoRowCol2(v); //获得行列结尾 + begin + rs := PosToRowCol(FGetInfoText,array(v["beg"]-1,v["end"])); + return rs; + end + function PosToRowCol(s,ps); //位置换算 + begin + r := array(); + idx := 0; + pi := ps[idx]; + ri := ci := 1; + for i := 1 to length(s) do + begin + vi := s[i]; + if vi="\n" then + begin + ri++; + ci := 1; + end else + ci++; + if i=pi then + begin + r[idx]:= array(ri,ci); + idx++; + pi := ps[idx]; + end + end + return r; + end + FTslParser; // + FGetInfoChace; //class 信息 + FGetInfoText; //文本 + FLastVersion; //脚本 + FScriptPath; //路径 + FOrgScriptPath; //原始路径 + function SetScriptPath(v); + begin + sp := ioFileseparator(); + if ifstring(v)then + begin + for i := length(v)downto 1 do + begin + if v[i]=sp then + begin + Caption := v[i+1:]; + break; + end + if v[i]="." then + begin + if lowercase(v[i:])in array(".tsl",".tsf")then FTslSynText := true; + end + end + FScriptPath := v; + FOrgScriptPath := v; + FEditer.Caption := v; + end + end +end +type TPageEditer=class(TPage) //多页编辑 + function Create(AOwner);override; + begin + inherited; + end + function MouseUp(o,e);override; + begin + inherited; + if e.button()=mbRight then + begin + return CallDatafunction(FPageItemOnRClick,self,e); + end + end + function CallSelChanged();override; + begin + it := Currentitem; + if it then + begin + it.FEditer.SetBoundsRect(self.ClientRect); + it.FEditer.Visible := true; + it.FEditer.SetFocus(); + end + inherited; + end + function CallSelChanging();override; + begin + inherited; + it := CurrentItem; + if it and it.FEditer then it.FEditer.Visible := false; + end + function Recycling();override; + begin + inherited; + FCliper := nil; + FMenu := nil; + FPageItemOnRClick := nil; + end + function DoControlAlign();override; + begin + inherited; + it := CurrentItem; + if it then + begin + it.FEditer.SetBoundsRect(self.ClientRect); + end + end + property PageItemOnRClick read FPageItemOnRClick write FPageItemOnRClick; + private + FPageItemOnRClick; +end +type TTslChmHelp=class + function SearchWord(s); + begin + if not s then return; + pm := format('%s::/%s.htm',FTSLinterpPath+FChmName,s); //>mainwin + HtmlHelpA(GetDesktopWindow(),pm,0,nil); + return; + end + function ShowTslLangChm(); + begin + return HtmlHelpA(GetDesktopWindow(),FTSLinterpPath+FChmName,0,nil); + end + function Create(); + begin + FChmName := "help\\LANGUAGEGUIDE.CHM"; + FTSLinterpPath := ""; + n := pluginpath(); + for i := length(n)-1 downto 3 do + begin + if n[i]="\\" then + begin + FTSLinterpPath := n[1:i]; + break; + end + end + end + property ChmName read FChmName write FChmName; + private + FTSLinterpPath; + FHanle; + FChmName; +end +type TEditerEchoWnd=class(TSynMemoNorm) // + function Create(AOwner);override; + begin + inherited; + FDoLockTime := 0; + FIsLocked := false; + height := 250; + ReadOnly := true; + WsSizeBox := true; + WsSysMenu := true; + OnClose := function(o,e) + begin + o.visible := false; + e.skip := true; + end + m := new TPopUpMenu(self); + m1 := new TMenu(self); + m1.Caption := "清空"; + m1.parent := m; + {m2 := new TMenu(self); + m2.Caption := "选中字符高亮"; + m2.Checked := false; + m2.OnClick := function(o,e)begin + o.Checked := not(o.Checked); + self.HighLighter := (o.Checked) ?F_Highlighter :false; + end + m2.Parent := m;} + PopUpMenu := m; + m1.OnClick := function(o,e) + begin + ClearAll(); + AppendString("ctrl+z 停止;ctrl+c 复制选择\r\n"); + end; + FProcess := new TCreateProcessA(); + FProcess.BufSize := 1024 * 5; + FProcess.OnEcho := thisfunction(TEchoToString); + AppendString("ctrl+z 停止;ctrl+c 复制选择\r\n"); + F_Highlighter := new TSynHighLighter(self); + //Highlighter := new TSynHighLighter(self); + end + function TEchoToString(o,s); + begin + //t := now(); + {if (t-FDoLockTime)>(0.3E-5) then + begin + FDoLockTime := t; + if FIsLocked then + begin + FIsLocked := false; + DecPaintLock(); + end else + begin + FIsLocked := true; + IncPaintLock(); + end + end } + AppendString(s); + //Visible := true; + return true; + end + function Exec(exe,cmd,h); + begin + //AppendString(format('"%s" %s\r\n',exe,cmd)); + self.HighLighter := nil; + AppendString(format('%s %s\r\n',exe,cmd)); + //EndExe(); + r := FProcess.CreateProcessWaitRead(exe,cmd,h); + AppendString(format("\r\n执行结束:endcode:%d\r\n",r)); + {if FIsLocked then + begin + FIsLocked := false; + DecPaintLock(); + end } + self.HighLighter := F_Highlighter; + h := 0; + return r; + end + function Exeing(); + begin + return FProcess.LastExeHandle; + end + function EndExe(); + begin + if FProcess.LastExeHandle then + begin + r := 1; + SysTerminate(r,FProcess.LastExeHandle); + end + end + function KeyDown(o,e);override; + begin + if ssCtrl in e.shiftstate then + begin + case e.charcode of + ord("Z"): + begin + EndExe(); + return; + end + ord("C"): + begin + ExecuteCommand(ecCopy); + return; + end + end + end + inherited; + end + function AppendString(s); + begin + if not(ifstring(s)and s)then return; + ct := Lines.Length(); + if ct>0 then + begin + ExecuteCommand(ecGoToXY,array(ct,1)); + ExecuteCommand(ecLineEnd); + ExecuteCommand(ecString,s); + end + end + FExeHandle; + FProcess; + FIsLocked; + FDoLockTime; + F_Highlighter; +end +type TTslDebug=class(TCustomControl) + private //成员变量 + FRuningfile; //执行脚本文件名 + FRuningItem; //执行的pageitem + FCurrentgotoitem; //当前运行到的pageitem + FDebughandle; //调试的句柄 + FDebugExe; //调试功能的exe + FConnectchannel; //调试的 通道 + FDebugaddr; //地址 + FDebugport; //调试的端口 + FDebugUsr; //用户名 + FDebugPwd; //密码 + FDebugtsfs; //当前工程对应的tsf文件 + FBtns; + FAttchedid; + FDebugtype; + fdbgselwnd; + FRemoteWait; //远程调试等待 + FValewnd; + FCmdHistory; + FCmdHistoryid; + FCmdHistorycount; + //////////////////// + Fdbgssybs; + Fdbgsybs; + Fdbgstack; + fdefaultdbger; //编辑器的调试器 + type tdbgwnd=class(TPanel) + uses tslvcl; + function Create(AOwner); + begin + inherited; + WsDlgModalFrame := false; + p1 := new TPairSplitter(self); + p1.Position := 310; + p2 := new TPairSplitter(self); + p2.Position := 310; + sd1 := new TPairSplitterSide(self); + sd2 := new TPairSplitterSide(self); + sd3 := new TPairSplitterSide(self); + sd3 := new TPairSplitterSide(self); + sd4 := new TPairSplitterSide(self); + p1.Align := alClient; + sd1.WsDlgModalFrame := false; + sd2.WsDlgModalFrame := false; + sd3.WsDlgModalFrame := false; + sd4.WsDlgModalFrame := false; + p1.WsDlgModalFrame := false; + p2.WsDlgModalFrame := false; + p1.parent := self; + sd1.parent := p1; + sd1.Border := false; + sd2.parent := p1; + p2.Align := alClient; + p2.parent := sd2; + sd3.parent := p2; + sd4.parent := p2; + sd4.Border := false; + fside1 := sd1; + fside2 := sd3; + fside3 := sd4; + end + function addwnds(stk,vlist,cmd,cmdshow); + begin + stk.Align := alClient; + stk.parent := fside1; + vlist.Align := alClient; + vlist.parent := fside2; + cmd.Align := alBottom; + cmd.parent := fside3; + cmdshow.Align := alClient; + cmdshow.parent := fside3; + end function Recycling();override; begin - global g_tsldbgcallback_handle; - stopdebug(); inherited; - FStackList := nil; - FVaraiblesList := nil; - FToolbar := nil; - FCommandtext := nil; - FShowText := nil; - fimgelist := nil; - FBtns := nil; - g_tsldbgcallback_handle := nil; - fdbgselwnd := nil; + fside1 := nil; + fside2 := nil; + fside3 := nil; end - private - function getdefaultdbger(); - begin - fdefaultdbger := gettslexe(); - end - function getdebuger(pms); //获得调试程序 - begin - p := static pluginpath(); - FDebugExe := inireadstring("",p+"localediter.ini","debug","debuger",""); - pms := " "; - //if FDebugExe="1" then //默认获取参数 - // begin - ps := owner.getexecuteparams(FRuningfile); - if ps then + fside1; + fside2; + fside3; + end + function cmdkeyup(o,e); + begin + case e.charcode of + VK_UP: + begin + //return ; + if FCmdHistoryid <= 0 then return o.text := ""; + FCmdHistoryid--; + txt := FCmdHistory[FCmdHistoryid]; + if ifstring(txt)and txt then o.text := txt; + end + VK_DOWN: + begin + if FCmdHistoryid >= Length(FCmdHistory)then return o.text := ""; + FCmdHistoryid++; + txt := FCmdHistory[FCmdHistoryid]; + if ifstring(txt)and txt then o.text := txt; + end + 13: + begin + //return ExecuteCommand("docmd"); + txt := trim(o.Text); + if txt then begin - psi := ps[0]; - if fileexists("",psi)then + if length(FCmdHistory)>FCmdHistorycount then begin - cmdexe := psi; - end else - begin - if FDebugExe="1" then - ExecuteCommand("showeval","当前指定的执行程序不存在!!"); - end - psi := ps[1]; - if psi and fileexists("",psi)then - begin - end else - begin - pms += " "+tostn(psi); - end - idx := 2; - while idx"); - end else - if fileexists("",FDebugExe)then - begin - ExecuteCommand("showeval","<用配置文件给定的调试器>"); - end else - begin - FDebugExe := fdefaultdbger; - ExecuteCommand("showeval","<用编辑器自带的调试器b:>"); + e.skip := true; end end - function remotedbugok(); + end + function getvalewnd(cp); + begin + if not FValewnd then begin - if FAttchedid then + FValewnd := new TTSLDataGrid(self); + FValewnd.Visible := false; + FValewnd.Caption := "Value"; + FValewnd.left := owner.left+100; + FValewnd.Width := 600; + FValewnd.Height := 500; + FValewnd.WSpOPUp := true; + FValewnd.WSsYSMenu := true; + FValewnd.WsSizeBox := true; + FValewnd.Parent := self; + FValewnd.OnClose := function(o,e) begin - ExecuteCommand("showeval","远程启动脚本:"+FAttchedid["info"]); + o.Visible := false; + o.TSLdata := array(); end end - function remotewaitinit(d); + if ifstring(cp)then FValewnd.Caption := cp; + return FValewnd; + end + function deletefuncacheini(); + begin + plg := pluginpath(); + {$ifdef linux} + sp := "/"; + {$else} + sp := "\\"; + {$endif} + for i := length(plg)-1 downto 1 do begin - if FDebugtype <> "remotewait" then return; - if FAttchedid then return; - FAttchedid := magicgetarray(d,array("result","CmdData","StartInfo")); - file := fdbgselwnd.getstartfilename(FAttchedid); - item := nil; - if file=0 then //不存在脚本 + if plg[i]=sp then begin - if 1 <> MessageboxA("没找到本地对应的tsl\r\n是否继续调试","提示",1,self.Handle)then - begin - dbgdetach(FConnectchannel); - return "dbgdetach"; - //return serwnd_cclk(); - end - end else - begin - item := owner.OpenAndGotoFileByName(file,1); + fn := plg[1:i]+"FunCache.ini"; + r := filedelete("",fn); + return r; end - FRuningItem := item; - FCurrentgotoitem := item; - parsercurrentitem(item); - setbrks(); //设置断点 - remotedbugok(); end - function debuginitok(); + end + public + function addbtns(btns); //添加菜单 + begin + FBtns := btns; + for i,v in Fbtns do begin - if FDebugtype <> "remotewait" then setbrks(); //设置断点 - //showbtns(); //显示按钮 - ExecuteCommand("showeval","开始调试"); - //toolbtnState("暂停"); - remotedbugok(); - return; + v.onClick := thisfunction(Dbgtooldo); + if v.Caption="添加/删除断点F5" then continue; + v.Visible := false; end - function opengoto(v); + end + function DbgNextLine(); //下一行 + begin + ExecuteCommand("dbgstepover"); + end + function serwnd_cclk(o,e); //取消 + begin + FRemoteWait := false; + cancelremotedbg(o,e,"取消调试"); + return; + end + function serwnd_oclk(o,e); //远程连接按钮 + begin + d := fdbgselwnd.GetData(); + addr := d["addr"]; + port := d["port"]; + if not(addr and port)then return MessageboxA("远程服务器信息不全","提示",0,self.Handle); + port := StrToIntDef(port,443); + usr := d["usr"]; + pwd := d["pwd"]; + //连接判断 + if checkconnected()then begin - cn := v["NAME"]; - cnn := ""; - for ii := 1 to length(cn) do - begin - if cn[ii]in array(".",":")then - begin - cn := cnn; - break; - end - cnn += cn[ii]; - end - f := FDebugtsfs[lowercase(cn)]; - if not f then - begin - return ExecuteCommand("showeval","找不到代码:"+cn); - end - it := owner.OpenAndGotoFileByName(f,v["LINE"]); - return it; + disconnectserver(); end - function cancelremotedbg(o,e,s); + if FDebugtype="remotewait" then //远程等待 begin + FDebugaddr := addr; + FDebugport := port; + FDebugUsr := usr; + FDebugPwd := pwd; + FRemoteWait := true; fdbgselwnd.Visible := false; - if e then e.skip := true; + return _send_(WM_USER,0,0,1); + end + if 0 <> connectserver(addr,port)then return MessageboxA("远程服务器连接失败","提示",0,self.Handle); + if(usr and pwd)and 0 <> dbglogin(usr,pwd)then + begin + return MessageboxA("登陆用户失败","提示",0,self.Handle); + end + ExecuteCommand("dbgcreatechannel"); //构造channel + if FConnectchannel then + begin + dbglist(FConnectchannel); + end + end + function dbg_clk(o,e); + begin + file := o.getstartfilename(d); + item := nil; + if file=0 then //不存在脚本 + begin + if 1 <> MessageboxA("没找到本地对应的tsl\r\n是否继续调试","提示",1,self.Handle)then + begin + return serwnd_cclk(); + end + end else + begin + item := owner.OpenAndGotoFileByName(file,1); + end + o.Visible := false; + FRuningItem := item; + FCurrentgotoitem := item; + parsercurrentitem(item); + FAttchedid := d; + dbgattach(FConnectchannel,d["id"]); + //echo tostn(d); + end + function Debugremote(flg); + begin + {$ifdef linux} + return MessageboxA("linux目前不支持调试","提示",0,self.Handle); + {$endif} + if FRemoteWait then + begin + if flg then + begin + if 1=MessageboxA("远程调试等待中...\r\n点击确定停止等待..","提示",1,self.Handle)then + begin + FRemoteWait := false; + disconnectserver(); + end + return; + end else + begin + return MessageboxA("远程调试等待中...","提示",0,self.Handle); + end + end else + begin + //if flg then return ; + if FConnectchannel then + begin + return MessageboxA("正在调试中...","提示",0,self.Handle); + end + end + if not fdbgselwnd then + begin + fdbgselwnd := new tdbgselwnd(self); + fdbgselwnd.Parent := self; + fdbgselwnd.FHistoryDir := owner.FHistoryDir; + fdbgselwnd.loaddata(); + fdbgselwnd.OnClose := thisfunction(serwnd_cclk); + fdbgselwnd.save_clk := thisfunction(serwnd_oclk); + fdbgselwnd.cancel_clk := thisfunction(serwnd_cclk); + fdbgselwnd.dbg_clk := thisfunction(dbg_clk); + end + fdbgselwnd.setlist(); + if flg then + begin + FDebugtype := "remotewait"; + fdbgselwnd.setattachwait(true); + end else + begin + FDebugtype := "remote"; + fdbgselwnd.setattachwait(false); + end + fdbgselwnd.show(); + return; + end + function Debuglocal(item); //调试脚本 + begin + {$ifdef linux} + return MessageboxA("linux目前不支持调试","提示",0,self.Handle); + {$endif} + if not item then return 0; + if FConnectchannel then return MessageboxA("正在调试中","提示",0,self.Handle); + if FRemoteWait then return MessageboxA("远程调试等待中...","提示",0,self.Handle); + FDebugtype := "local"; + if checkconnected()then disconnectserver(); //断开连接 + FAttchedid := 0; + FDebugport := randomfrom(1 -> 600)+20000; + FDebugaddr := '127.0.0.1'; + FRuningItem := item; + FCurrentgotoitem := item; + dirs := owner.getlibpathstr(); + parsercurrentitem(item); + fio := ioFileseparator(); + FDebugUsr := 0; + FDebugPwd := 0; + deletefuncacheini(); + getdebuger(pms); + exestr := format('"%s" "%s" -DEBUGSERVER -DEBUGLOGIN 0 -WAITATTACH -DEBUGPORT %d -libpath "%s" ',FDebugExe,FRuningfile,FDebugport,dirs); + exestr += pms; + FDebughandle := sysexec(FDebugExe,exestr,nil,0,rcode,0); + if FDebughandle then + begin + ExecuteCommand("dbgcreatechannel"); + ExecuteCommand("showeval","调试程序:"+FDebugExe); + if FConnectchannel then + begin + dbgattachwait(FConnectchannel); + end + end + end + function wmuser(o,e):WM_USER;virtual; + begin + if FRemoteWait and not(checkconnected())then + begin + if(0 <> connectserver(FDebugaddr,FDebugport))then + begin + FRemoteWait := false; + messageboxa("连接服务器失败","错误",0,self); + return; + //sleep(100); + //_send_(WM_USER,0,0,1); + end else + begin + FRemoteWait := false; + FConnectchannel := dbgcreatechannel(); + setgdbcallback(); + if(FDebugUsr and FDebugPwd)and(0 <>(lgg := dbglogin(FDebugUsr,FDebugPwd)))then + begin + messageboxa("登陆失败\r\n用户名或者密码错误","登陆失败",0,self); + return disconnectserver(); + end + dbgattachwait(FConnectchannel); + FBtns["终止"].Visible := true; + end + end + end + function Create(AOwner); + begin + inherited; + FCmdHistory := array(); + FCmdHistoryid := 0; + FCmdHistorycount := 10; + FDebugExe := ""; + Caption := "tsl debug ..."; + {fimgelist := new tcontrolimagelist(self); + fimgelist.Width := 24; + fimgelist.height := 24; + fimgelist.DrawBimpFirst := true; + FToolbar := new TToolBar(self); + FToolbar.Visible := false; + idx := 0; + for i,v in dbugicos() do //工具条 + begin + bmp := new TBitmap(); + bmp.ReadVcon(HexformatStrToTsl( v)); + fimgelist.addbmp(bmp); + iti := new TToolButton(self); + iti.OnClick := thisfunction(Dbgtooldo); + iti.Caption := i; + iti.imageid := idx; + iti.Parent := FToolbar; + idx++; + end + + FToolbar.ImageList := fimgelist; + FToolbar.Parent := self; + } + dbwnd := new tdbgwnd(self); + dbwnd.Align := alClient; + dbwnd.Parent := self; + FStackList := new TListView(self); // new TListBox(self); //new tmemo(self);// + FStackList.ItemHeight := 23; + FStackList.Columns := array(("text":"line","width":40), + ("text":"function","width":250) //,("text":"type","width":70) + ); + //FStackList.ReadOnly := true; + //FStackList.Width := 300; + FStackList.Border := true; + //FStackList.Align := alLeft; + //FStackList.Parent := self; + FVaraiblesList := new TGroupGridA(self); + FVaraiblesList.Border := false; + FVaraiblesList.ItemHeight := 23; + FVaraiblesList.Columns := array(("text":"name","width":95), + ("text":"value","width":135), + ("text":"type","width":50) + ); + FCommandtext := new TEdit(self); + //FCommandtext.Border := true; + FCommandtext.placeholder := "命令输入框"; + FCommandtext.Height := 23; + //FCommandtext.Align := alBottom; + //FCommandtext.Parent := self; + FCommandtext.onkeyup := thisfunction(cmdkeyup); + FShowText := new tmemo(self); + FShowText.ReadOnly := true; + FShowText.Border := true; + //FShowText.Align := alClient; + //FShowText.Parent := self; + pmenu := new TPopUpMenu(self); + cmu := new TMenu(self); + cmu.OnClick := function(o,e) + begin + FShowText.Text := ""; + end; + cmu.Caption := "清除"; + cmu.Parent := pmenu; + FShowText.PopUpMenu := pmenu; + dbwnd.addwnds(FStackList,FVaraiblesList,FCommandtext,FShowText); + ExecuteCommand("clearall"); + getdefaultdbger(); + end + function addbreak(item,idx,n); //添加断点 + begin + if not FConnectchannel then return; + parseriteminfo(item,idx,n,usr); + if n then + begin + //echo "\r\n====add:",usr,"====",n,"===",idx; + dbgsetbreak(FConnectchannel,usr,n,idx+1); + end + end + function removebreak(item,idx); //移除断点 + begin + if not FConnectchannel then return; + parseriteminfo(item,idx,n,usr); + if n then + begin + //echo "\r\n====remove:",usr,"====",n,"===",idx; + dbgunsetbreak(FConnectchannel,usr,n,idx+1); + end + end + function Dbgtooldo(o,e) + begin + cp := o.Caption; + case cp of + "调试运行": + begin + //echo "调试运行"; + it := Owner.GetCurrentItem(); //Owner.GetAllPageItems(); + Debuglocal(it); + end + "添加/删除断点F5": + begin + it := Owner.GetCurrentItem(); + if it then + begin + it.FEditer.SwitchMarkLine(); + end + end + "暂停": + begin + ExecuteCommand("dbgpause"); + end + "进入": + begin + ExecuteCommand("dbgstep") + end + "单步": + begin + //dbgstep(); + end + "下一行(F8)": + begin + ExecuteCommand("dbgstepover"); + end + "跳出": + begin + ExecuteCommand("dbgstepout"); + end + "继续": + begin + toolbtnState("继续"); + if FCurrentgotoitem and FCurrentgotoitem.FEditer then FCurrentgotoitem.FEditer.ExecuteCommand("ecruningto",nil); + ExecuteCommand("dbgrun"); + end + "终止": + begin + ExecuteCommand("dbgreset"); + end + "单步": + begin + end + "刷新符号表": + begin + ExecuteCommand("dbggetallvalue"); + end + "刷新当前符号": + begin + ExecuteCommand("dbggetcurrentnode"); + end + "清除文本框": + begin + FShowText.Text := ""; + end + end; + end + function dbgeventcall(d); //回调 + begin + global g_tsldbgcallback_handle; + if not ifarray(d)then return; + if d["channel"]<> FConnectchannel then return; + recvtype := d["recvtype"]; + if recvtype=0 then + begin + FRemoteWait := 0; + ExecuteCommand("showeval","调试结束"); if FConnectchannel then dbgdeletechannel(FConnectchannel); FConnectchannel := 0; - ExecuteCommand("showeval",ifstring(s)?s:"取消远程调试..."); + g_tsldbgcallback_handle := nil; + if FCurrentgotoitem and FCurrentgotoitem.FEditer then FCurrentgotoitem.FEditer.ExecuteCommand("ecruningto",nil); + FDebughandle := 0; + toolbtnState("停止"); + return; end - function stkdbclk(o,e); + //echo "\r\nrectype",format("0x%x",recvtype); + if 0x0401=recvtype then begin - //echo "\r\n",o.SelectedId; - id := o.SelectedId; - if id >= 0 then + owner.echoAppendString(d["errmsg"]); + return; + end + if recvtype <> 0x402 then + begin + return; + end + case magicgetarray(d,array("result","CmdType"))of + "attachlist": begin - d := o.GetItem(id); - if d then + r := magicgetarray(d,array("result","CmdData")); + r :: begin - return opengoto(d); - end - end - end - function vdoshowarray(d); - begin - //echo tostn(d); - try - gp := d[3]; - if(gp[length(gp)]="+")and parseregexpr("\\+$",gp,"r", function(a) + if mcol="createtm" then begin - return ""; + mcell := datetimetostr(mcell); end - ,sgp)=1 then - begin - gp := "sysparams:"+sgp; end - showevaldata(gp,d[1]["value"]); - except - end; - end - function vdoedit(d,s); - begin - if not FConnectchannel then return; - gp := d[1][3]; - try - v := eval(&s); - except - v := nil; + return fdbgselwnd.setlist(r); + //return echo tostn(r); end + "attachwaitok","attachok": // 连接,默认 + begin + debuginitok(); + FVaraiblesList.SetNodeData(array()); + FStackList.DeleteAllItems(); + //dbgeval(FConnectchannel,getobjtransfunc()); + return; + end + "DebugInfo": //调试信息 + begin + if "dbgdetach"=remotewaitinit(d)then return; + toolbtnState("暂停"); + stk := magicgetarray(d,array("result","CmdData","CallStack")); //深度 + sybs := magicgetarray(d,array("result","CmdData","SymbolInfo")); //符号 + ssybs := magicgetarray(d,array("result","CmdData","EnvInfo")); //系统参数 + {if (ssybs = Fdbgssybs) and (sybs = Fdbgsybs) and (stk=Fdbgstack) then //值没变 + begin + return ; + end } + if(ssybs <> Fdbgssybs)or(sybs <> Fdbgsybs)then + begin + FVaraiblesList.SetNodeData(array()); + ddd := formatsysvlist(ssybs,nil); + FVaraiblesList.SetNodeData(ddd,true); + Fdbgssybs := ssybs; + ddd := formatvlist(sybs); + FVaraiblesList.SetNodeData(ddd,true); + Fdbgsybs := sybs; + end + if stk <> Fdbgstack then + begin + FStackList.DeleteAllItems(); + FStackList.appendItems(stk[:,array("LINE","NAME","USER")]); + //FStackList.text := array2str(stks,"\r\n"); + Fdbgstack := stk; + end + if ifarray(stk)then + begin + FVaraiblesList.celldbclk := thisfunction(vdbclk); + FVaraiblesList.celledit := thisfunction(vdoedit); + FVaraiblesList.Showarray := thisfunction(vdoshowarray); + FStackList.OnDblClick := thisfunction(stkdbclk); + it := opengoto(stk[0]); + //if not it then return; + if it and it <> FCurrentgotoitem then + begin + if FCurrentgotoitem and FCurrentgotoitem.FEditer then + begin + FCurrentgotoitem.FEditer.ExecuteCommand("ecruningto",nil); + end + FCurrentgotoitem := it; + end + if FCurrentgotoitem then + begin + FCurrentgotoitem.FEditer.ExecuteCommand("ecruningto",stk[0,"LINE"]-1); + end + end + return; + end + "detached": + begin + if FConnectchannel then + begin + dbgdeletechannel(FConnectchannel); + FConnectchannel := 0; + g_tsldbgcallback_handle := nil; + FAttchedid := 0; + end + FRemoteWait := 0; + if FCurrentgotoitem and FCurrentgotoitem.FEditer then FCurrentgotoitem.FEditer.ExecuteCommand("ecruningto",nil); + ExecuteCommand("showeval","调试结束"); + toolbtnState("停止"); + return; + end + "DebugSysParamValue": + begin + CmdTypeAux := magicgetarray(d,array("result","CmdTypeAux")); + ev := magicgetarray(d,array("result","CmdData")); + cp := magicgetarray(d,array("result","CmdParam")); + len :=-1; + if ifnumber(CmdTypeAux)and(CmdTypeAux .& 0x80000000)then + begin + len := _shr((int(CmdTypeAux).& 0xFFF0),4); + end + //echo "\r\n***",len," ",cp," ",tostn(ev); + if(cp="#DebugEval")or(cp="#Error")then + begin + return showevaldata(nil,ev); + end + if ifarray(ev)then + begin + ddd := formatsysvlist(array(cp:ev),len); + FVaraiblesList.SetNodeData(ddd,true); + for i,v in ev do + begin + if ifstring(i)then + begin + ncp := tostn(i); + ncp := replacetext(ncp,".","\\o"); + ncp := cp+".["+ncp+"]"; + end else + begin + ncp := cp+".["+tostn(i)+"]"; + end + magicsetarray(d,array("result","CmdParam"),ncp); + magicsetarray(d,array("result","CmdData"),v); + dbgeventcall(d); + end + return; + end else + begin + ddd := formatsysvlist(array(cp:ev),len); + FVaraiblesList.SetNodeData(ddd,true); + end + end + "DebugValue": + begin + cp := magicgetarray(d,array("result","CmdParam")); + ev := magicgetarray(d,array("result","CmdData")); + if(cp="#DebugEval")or(cp="#Error")then + begin + return showevaldata(nil,ev); + end + if ifarray(ev)then + begin + //showevaldata(cp,ev); + ddd := formatvlist(array(cp:ev)); + FVaraiblesList.SetNodeData(ddd,true); + for i,v in ev do + begin + if ifstring(i)then + begin + ncp := tostn(i); + ncp := replacetext(ncp,".","\\o"); + ncp := cp+".["+ncp+"]"; + end else + begin + ncp := cp+".["+tostn(i)+"]"; + end + magicsetarray(d,array("result","CmdParam"),ncp); + magicsetarray(d,array("result","CmdData"),v); + dbgeventcall(d); + end + return; + end else + begin + ddd := formatvlist(array(cp:ev)); + FVaraiblesList.SetNodeData(ddd,true); + end + end + "noattachederror": + begin + return disconnectserver(); + FRemoteWait := 0; + ExecuteCommand("showeval","noattachederror"); + d["recvtype"]:= 0; //退出 + dbgeventcall(d); + return; + end else + begin + //echo tostn(d); + end + end + return; + end + function showevaldata(cp_,ev); + begin + cp := cp_; + if cp then + begin + if parseregexpr("\\(\\w+\\)\\.",cp,"r", function(a) + begin + return ""; + end + ,s)=1 then + begin + cp := s; + end + end + if ev and ifarray(ev)then + begin + fwnd := getvalewnd(cp); + fwnd.TSLdata := ev; + fwnd.Show(); + end else + begin + if cp then FShowText.Text += ">>"+cp+"\r\n"; + ExecuteCommand("showeval",ev); + end + end + function ExecuteCommand(cmd,p);override; + begin + case cmd of + "dbgstate": + begin + if ifnil(p)then return FdebugState; + end + "execommand": + begin + case p of + "#127": + begin + FShowText.Text := ""; + end + end; + end + "docmd": + begin + s := FCommandtext.Text; + if not s then return; + FCommandtext.Text := ""; + if s="#cls" then return ExecuteCommand("execommand",s); + FShowText.Text += ">>"+s+"\r\n"; + ExecuteCommand("dbgeval",s); + end + "clearall": //清除所有 + begin + //FStackList.items := array(); + //FStackList.text := ""; + FStackList.DeleteAllItems(); + FVaraiblesList.SetNodeData(array()); + if p then + begin + FShowText.Text := ""; + FCommandtext.Text := ""; + end + end + "showeval": + begin + FShowText.Text += "ans="+tostn(p)+"\r\n"; + FShowText.ExecuteCommand(FShowText.ecGotoXY,array(100000,1)); + end + "dbgcreatechannel": + begin + if not FConnectchannel then + begin + idx := 0; + if not checkconnected()then + begin + while(FDebugtype="local")and(0 <> connectserver(FDebugaddr,FDebugport)) do + begin + sleep(100); + idx++; + if idx>20 then + begin + return ExecuteCommand("debugconnecterr"); + end; + end + end + FConnectchannel := dbgcreatechannel(); + setgdbcallback(); + end + end + "dbggetallvalue": + begin + if FConnectchannel then + begin + dbggetallvalue(FConnectchannel); + end + end + "dbggetcurrentnode": + begin + FVaraiblesList.getcurrentnodedata(); + end + "dbgreset": //停止 + begin + if FConnectchannel then + begin + if FDebughandle then + begin + return SysTerminate(-1,FDebughandle); + end + if FAttchedid then + begin + //echo "\r\n终止"; + return dbgdetach(FConnectchannel); + end else + begin + if FDebugtype="remotewait" then //远程,断开连接 + begin + return disconnectserver(); + end + return dbgdetach(FConnectchannel); + //return dbgreset(FConnectchannel); + end + end + end + "dbgrun": //运行 + begin + if FConnectchannel then dbgrun(FConnectchannel); + end + "dbgstep": + begin + if FConnectchannel then dbgstep(FConnectchannel); + end + "dbgpause": //暂停 + begin + if FConnectchannel then dbgpause(FConnectchannel); + end + "dbgstepover": //下一行 + begin + if FConnectchannel then dbgstepover(FConnectchannel); + end + "dbgstepout": //跳出函数 + begin + if FConnectchannel then dbgstepout(FConnectchannel); + end + "dbgeval": //执行 + begin + if FConnectchannel and p and ifstring(p)then + begin + getvalewnd("ans"); + dbgeval(FConnectchannel,p); + end + end + end + end + function Recycling();override; + begin + global g_tsldbgcallback_handle; + stopdebug(); + inherited; + FStackList := nil; + FVaraiblesList := nil; + FToolbar := nil; + FCommandtext := nil; + FShowText := nil; + fimgelist := nil; + FBtns := nil; + g_tsldbgcallback_handle := nil; + fdbgselwnd := nil; + end + private + function getdefaultdbger(); + begin + fdefaultdbger := gettslexe(); + end + function getdebuger(pms); //获得调试程序 + begin + p := static pluginpath(); + FDebugExe := inireadstring("",p+"localediter.ini","debug","debuger",""); + pms := " "; + //if FDebugExe="1" then //默认获取参数 + // begin + ps := owner.getexecuteparams(FRuningfile); + if ps then + begin + psi := ps[0]; + if fileexists("",psi)then + begin + cmdexe := psi; + end else + begin + if FDebugExe="1" then + ExecuteCommand("showeval","当前指定的执行程序不存在!!"); + end + psi := ps[1]; + if psi and fileexists("",psi)then + begin + end else + begin + pms += " "+tostn(psi); + end + idx := 2; + while idx"); + end else + if fileexists("",FDebugExe)then + begin + ExecuteCommand("showeval","<用配置文件给定的调试器>"); + end else + begin + FDebugExe := fdefaultdbger; + ExecuteCommand("showeval","<用编辑器自带的调试器b:>"); + end + end + function remotedbugok(); + begin + if FAttchedid then + begin + ExecuteCommand("showeval","远程启动脚本:"+FAttchedid["info"]); + end + end + function remotewaitinit(d); + begin + if FDebugtype <> "remotewait" then return; + if FAttchedid then return; + FAttchedid := magicgetarray(d,array("result","CmdData","StartInfo")); + file := fdbgselwnd.getstartfilename(FAttchedid); + item := nil; + if file=0 then //不存在脚本 + begin + if 1 <> MessageboxA("没找到本地对应的tsl\r\n是否继续调试","提示",1,self.Handle)then + begin + dbgdetach(FConnectchannel); + return "dbgdetach"; + //return serwnd_cclk(); + end + end else + begin + item := owner.OpenAndGotoFileByName(file,1); + end + FRuningItem := item; + FCurrentgotoitem := item; + parsercurrentitem(item); + setbrks(); //设置断点 + remotedbugok(); + end + function debuginitok(); + begin + if FDebugtype <> "remotewait" then setbrks(); //设置断点 + //showbtns(); //显示按钮 + ExecuteCommand("showeval","开始调试"); + //toolbtnState("暂停"); + remotedbugok(); + return; + end + function opengoto(v); + begin + cn := v["NAME"]; + cnn := ""; + for ii := 1 to length(cn) do + begin + if cn[ii]in array(".",":")then + begin + cn := cnn; + break; + end + cnn += cn[ii]; + end + f := FDebugtsfs[lowercase(cn)]; + if not f then + begin + return ExecuteCommand("showeval","找不到代码:"+cn); + end + it := owner.OpenAndGotoFileByName(f,v["LINE"]); + return it; + end + function cancelremotedbg(o,e,s); + begin + fdbgselwnd.Visible := false; + if e then e.skip := true; + if FConnectchannel then dbgdeletechannel(FConnectchannel); + FConnectchannel := 0; + ExecuteCommand("showeval",ifstring(s)?s:"取消远程调试..."); + end + function stkdbclk(o,e); + begin + //echo "\r\n",o.SelectedId; + id := o.SelectedId; + if id >= 0 then + begin + d := o.GetItem(id); + if d then + begin + return opengoto(d); + end + end + end + function vdoshowarray(d); + begin + //echo tostn(d); + try + gp := d[3]; if(gp[length(gp)]="+")and parseregexpr("\\+$",gp,"r", function(a) begin return ""; end ,sgp)=1 then begin - dbgsetvalue(FConnectchannel,sgp,d[1][5],v); - sleep(20); - dbggetvalue(FConnectchannel,sgp,d[1][5]); + gp := "sysparams:"+sgp; + end + showevaldata(gp,d[1]["value"]); + except + end; + end + function vdoedit(d,s); + begin + if not FConnectchannel then return; + gp := d[1][3]; + try + v := eval(&s); + except + v := nil; + end + if(gp[length(gp)]="+")and parseregexpr("\\+$",gp,"r", function(a) + begin + return ""; + end + ,sgp)=1 then + begin + dbgsetvalue(FConnectchannel,sgp,d[1][5],v); + sleep(20); + dbggetvalue(FConnectchannel,sgp,d[1][5]); + end else + begin + //echo "\r\nset: ",gp," ",v; + dbgsetvalue(FConnectchannel,gp,0,v); + sleep(20); + dbggetvalue(FConnectchannel,gp,0); + end + end + function vdbclk(o,e); + begin + if not FConnectchannel then return; + if(e[0]=1)and(e[1][2]="*")then + begin + gp := e[1][3]; + if gp="sysparams+" then return; + if(gp[length(gp)]="+")and parseregexpr("\\+$",gp,"r", function(a) + begin + return ""; + end + ,sgp)=1 then + begin + dbggetvalue(FConnectchannel,sgp,e[1][5]); end else begin - //echo "\r\nset: ",gp," ",v; - dbgsetvalue(FConnectchannel,gp,0,v); - sleep(20); dbggetvalue(FConnectchannel,gp,0); end end - function vdbclk(o,e); + end + function parsercurrentitem(item); //修正本地函数 + begin + FDebugtsfs := class(TTSLCompletion).getdirtsfs(); + if item then begin - if not FConnectchannel then return; - if(e[0]=1)and(e[1][2]="*")then + FRuningfile := item.OrigScriptPath; // %% E:\TSUIGROUP\script\tgdb.tsl%%; + FDebugtsfs["__main__"]:= FRuningfile; + ls := item.FEditer.lines; + d := tsl_tokenizeex_2_(item.FEditer.Text,0xffff); + for i,v in d["blcks"] do begin - gp := e[1][3]; - if gp="sysparams+" then return; - if(gp[length(gp)]="+")and parseregexpr("\\+$",gp,"r", function(a) + s := ls.GetStringByIndex(v["mbeg"]-1); + ctls := 0; + case v["mtype"]of //函数 + 11: begin - return ""; + ctls := "function\\s+(\\w+)\\("; end - ,sgp)=1 then - begin - dbggetvalue(FConnectchannel,sgp,e[1][5]); - end else - begin - dbggetvalue(FConnectchannel,gp,0); - end - end - end - function parsercurrentitem(item); //修正本地函数 - begin - FDebugtsfs := class(TTSLCompletion).getdirtsfs(); - if item then - begin - FRuningfile := item.OrigScriptPath; // %% E:\TSUIGROUP\script\tgdb.tsl%%; - FDebugtsfs["__main__"]:= FRuningfile; - ls := item.FEditer.lines; - d := tsl_tokenizeex_2_(item.FEditer.Text,0xffff); - for i,v in d["blcks"] do - begin - s := ls.GetStringByIndex(v["mbeg"]-1); - ctls := 0; - case v["mtype"]of //函数 - 11: - begin - ctls := "function\\s+(\\w+)\\("; - end - 3: - begin - ctls := "type\\s+(\\w+)\\s*=\\s*class" //类 - end - end; - if s and ctls and(parseregexpr(ctls,s,"si",m,mp,ml)=1)then + 3: begin - n := lowercase(m[0,1]); - FDebugtsfs[n]:= FRuningfile; + ctls := "type\\s+(\\w+)\\s*=\\s*class" //类 end + end; + if s and ctls and(parseregexpr(ctls,s,"si",m,mp,ml)=1)then + begin + n := lowercase(m[0,1]); + FDebugtsfs[n]:= FRuningfile; end end end - function toolbtnState(flg); + end + function toolbtnState(flg); + begin + case flg of + "启动","暂停": + begin + showbtns(); + FBtns["暂停"].Visible := false; + FBtns["刷新符号表"].Visible := true; + FBtns["刷新当前符号"].Visible := true; + end + "继续": + begin + //运行 + FBtns["继续"].Visible := false; + FBtns["进入"].Visible := false; + FBtns["跳出"].Visible := false; + FBtns["下一行(F8)"].Visible := false; + //FBtns["单步"].Visible := false; + FBtns["终止"].Visible := false; + FBtns["暂停"].Visible := true; + FBtns["刷新符号表"].Visible := false; + FBtns["刷新当前符号"].Visible := false; + end + "停止": + begin + hiddenbtns(); + end + end + end + function showbtns(); //显示 + begin + for i,v in FBtns do begin - case flg of - "启动","暂停": + V.Visible := true; + end + //FToolbar.Visible := true; + end + function hiddenbtns(); //隐藏 + begin + for i,v in FBtns do + begin + if v.Caption="添加/删除断点F5" then continue; + v.Visible := false; + end + //FToolbar.Visible := false; + end + function stopdebug(); //结束进程 + begin + if FDebughandle then + begin + SysTerminate(-1,FDebughandle); + FDebughandle := 0; + end + end + function parseriteminfo(item,idx,n,usr); + begin + if item=FRuningItem then + begin + usr := "local"; + n := "__main__"; + end else + begin + usr := "system"; + end + if not n then + begin + n := getscriptname(item.OrigScriptPath); + end + end + function getscriptname(nn); + begin + fio := ioFileseparator(); + n := ""; + for i := Length(nn)-1 downto 1 do + begin + if fio=nn[i]then + begin + n := nn[i+1:]; + idx := pos(".",n); + if idx then begin - showbtns(); - FBtns["暂停"].Visible := false; - FBtns["刷新符号表"].Visible := true; - FBtns["刷新当前符号"].Visible := true; + n := lowercase(n[1:idx-1]); end - "继续": + break; + end + end + return n; + end + function setbrks(); //初次添加断点 + begin + its := owner.GetAllPageItems().data; + for i,v in FDebugtsfs do + begin + delii :=-1; + for ii,vv in its do + begin + ifok := vv.ScriptPathIs(v); + if ifok then begin - //运行 - FBtns["继续"].Visible := false; - FBtns["进入"].Visible := false; - FBtns["跳出"].Visible := false; - FBtns["下一行(F8)"].Visible := false; - //FBtns["单步"].Visible := false; - FBtns["终止"].Visible := false; - FBtns["暂停"].Visible := true; - FBtns["刷新符号表"].Visible := false; - FBtns["刷新当前符号"].Visible := false; - end - "停止": - begin - hiddenbtns(); - end - end - end - function showbtns(); //显示 - begin - for i,v in FBtns do - begin - V.Visible := true; - end - //FToolbar.Visible := true; - end - function hiddenbtns(); //隐藏 - begin - for i,v in FBtns do - begin - if v.Caption="添加/删除断点F5" then continue; - v.Visible := false; - end - //FToolbar.Visible := false; - end - function stopdebug(); //结束进程 - begin - if FDebughandle then - begin - SysTerminate(-1,FDebughandle); - FDebughandle := 0; - end - end - function parseriteminfo(item,idx,n,usr); - begin - if item=FRuningItem then - begin - usr := "local"; - n := "__main__"; - end else - begin - usr := "system"; - end - if not n then - begin - n := getscriptname(item.OrigScriptPath); - end - end - function getscriptname(nn); - begin - fio := ioFileseparator(); - n := ""; - for i := Length(nn)-1 downto 1 do - begin - if fio=nn[i]then - begin - n := nn[i+1:]; - idx := pos(".",n); - if idx then + delii := ii; + lines := vv.FEditer.Lines; + for idx := 0 to Lines.Length()-1 do begin - n := lowercase(n[1:idx-1]); + if Lines[idx].FMarked then addbreak(vv,idx,i); end break; end end - return n; - end - function setbrks(); //初次添加断点 - begin - its := owner.GetAllPageItems().data; - for i,v in FDebugtsfs do + if delii <> 0 then begin - delii :=-1; - for ii,vv in its do - begin - ifok := vv.ScriptPathIs(v); - if ifok then - begin - delii := ii; - lines := vv.FEditer.Lines; - for idx := 0 to Lines.Length()-1 do - begin - if Lines[idx].FMarked then addbreak(vv,idx,i); - end - break; - end - end - if delii <> 0 then - begin - reindex(its,array(delii:nil)); - end - end - if FRuningItem then - begin - lines := FRuningItem.FEditer.Lines; - for idx := 0 to Lines.Length()-1 do - begin - if Lines[idx].FMarked then addbreak(FRuningItem,idx,"__main__"); - end + reindex(its,array(delii:nil)); end end - function setgdbcallback(); //设置回调 + if FRuningItem then begin - global g_tsldbgcallback_handle; - g_tsldbgcallback_handle := thisfunction(dbgeventcall); - dbgsetcallback(FConnectchannel,"return unit(UtslCodeEditor).tdbgcallback();"); - end - function formatvlist(d); - begin - r := array(); - ncs := array(); - { - ddd := array(); - for i,v in dd do - begin - ddd[i]["id"] := v["n"]; - ddd[i]["data"] := array(v["c"],v["v"],v["t"],v["n"]); - ddd[i]["pid"] := v["p"]; - - end - } - idx := 0; - for i,v in d do + lines := FRuningItem.FEditer.Lines; + for idx := 0 to Lines.Length()-1 do begin - ri := parservname(i,v); - for j,vj in ri do - begin - id := vj["n"]; - if ncs[id]then continue; - ncs[id]:= true; - r[idx]["id"]:= id; - vjt := vj["t"]; - vjv := vj["v"]; - if vjt="*" then - begin - vval := array("value":vjv,"font":("color":0xff0000)); - end else - if ifarray(vjv)then - begin - vval := array("value":vjv,"font":("color":0)); - end else - if ifstring(vjt)and(vjt <> "nil")then - begin - vval := array("value":tostn(vjv),"font":("color":0)); - end else - begin - vval := array("value":"","font":("color":0)); - end - r[idx]["data"]:= array(vj["c"],vval,vj["t"],vj["n"],id); - r[idx]["pid"]:= vj["p"]; - r[idx]["nnp"]:= vj["nnp"]; - idx++; - end + if Lines[idx].FMarked then addbreak(FRuningItem,idx,"__main__"); end - return r; end - function formatsysvlist(d,len); + end + function setgdbcallback(); //设置回调 + begin + global g_tsldbgcallback_handle; + g_tsldbgcallback_handle := thisfunction(dbgeventcall); + dbgsetcallback(FConnectchannel,"return unit(UtslCodeEditor).tdbgcallback();"); + end + function formatvlist(d); + begin + r := array(); + ncs := array(); + { + ddd := array(); + for i,v in dd do + begin + ddd[i]["id"] := v["n"]; + ddd[i]["data"] := array(v["c"],v["v"],v["t"],v["n"]); + ddd[i]["pid"] := v["p"]; + + end + } + idx := 0; + for i,v in d do begin - r := array(); - ncs := array(); - idx := 0; - for i,v in d do + ri := parservname(i,v); + for j,vj in ri do begin - ri := parsersysname(i,v,len); - for j,vj in ri do + id := vj["n"]; + if ncs[id]then continue; + ncs[id]:= true; + r[idx]["id"]:= id; + vjt := vj["t"]; + vjv := vj["v"]; + if vjt="*" then begin - id := vj["n"]; - if ncs[id]then continue; - ncs[id]:= true; - r[idx]["id"]:= id; - vjt := vj["t"]; - vjv := vj["v"]; - if vjt="*" then - begin - vval := array("value":vjv,"font":("color":0xff0000)); - end else - if ifarray(vjv)then - begin - vval := array("value":vjv,"font":("color":0)); - end else - if ifstring(vjt)and(vjt <> "nil")then - begin - vval := array("value":tostn(vjv),"font":("color":0)); - end else - begin - vval := array("value":"","font":("color":0)); - end - r[idx]["data"]:= array(vj["c"],vval,vjt,vj["n"],id,vj["len"]); - r[idx]["pid"]:= vj["p"]; - r[idx]["nnp"]:= vj["nnp"]; - idx++; - end - end - return r; - end - function gettypename(ev); - begin - case datatype(ev)of - 0:t := "int"; //处理长整型的问题 - 20:t := "int64"; - 24:t := "lstr"; - 1:t := "double"; - 2:t := "str"; - 5:t := "array"; - else t := "nil"; - end; - return t; - end - function parsersysname(ostring,ev,nlen); - begin - len := length("*TSL_UNComplete*"); - ucp := false; - if pos("*TSL_UNComplete*",ostring)=1 then - begin - ucp := true; - if Length(ostring)=len then //空串 - begin - nstr := ""; - return array(); + vval := array("value":vjv,"font":("color":0xff0000)); end else - nstr := ostring[len+1:]; - end else - nstr := ostring; - r := array(); - if ucp then t := "*"; - else t := gettypename(ev); - nid := ""; - r[0]:= array("n":"sysparams+", - "c":array("font":("color":0x0000ff,"italic":1),"value":"sysparams") - ); - if nlen >= 0 then - begin - nnl := 0x80000000+_shl(nlen,4)+1; - cn := ""; - if nlen=0 then + if ifarray(vjv)then begin - r[1]:= array("n":"+", - "c":tostn(""), - "len":nnl, - "p":"sysparams+" - ); + vval := array("value":vjv,"font":("color":0)); + end else + if ifstring(vjt)and(vjt <> "nil")then + begin + vval := array("value":tostn(vjv),"font":("color":0)); end else begin - cn := nstr[1:nlen]; - r[1]:= array("n":cn+"+", - "c":cn, - "len":nnl, - "p":"sysparams+" - ); - if nlen "nil")then + begin + vval := array("value":tostn(vjv),"font":("color":0)); + end else + begin + vval := array("value":"","font":("color":0)); + end + r[idx]["data"]:= array(vj["c"],vval,vjt,vj["n"],id,vj["len"]); + r[idx]["pid"]:= vj["p"]; + r[idx]["nnp"]:= vj["nnp"]; + idx++; + end + end + return r; + end + function gettypename(ev); + begin + case datatype(ev)of + 0:t := "int"; //处理长整型的问题 + 20:t := "int64"; + 24:t := "lstr"; + 1:t := "double"; + 2:t := "str"; + 5:t := "array"; + else t := "nil"; + end; + return t; + end + function parsersysname(ostring,ev,nlen); + begin + len := length("*TSL_UNComplete*"); + ucp := false; + if pos("*TSL_UNComplete*",ostring)=1 then + begin + ucp := true; + if Length(ostring)=len then //空串 + begin + nstr := ""; + return array(); + end else + nstr := ostring[len+1:]; + end else + nstr := ostring; + r := array(); + if ucp then t := "*"; + else t := gettypename(ev); + nid := ""; + r[0]:= array("n":"sysparams+", + "c":array("font":("color":0x0000ff,"italic":1),"value":"sysparams") + ); + if nlen >= 0 then + begin + nnl := 0x80000000+_shl(nlen,4)+1; + cn := ""; + if nlen=0 then + begin + r[1]:= array("n":"+", + "c":tostn(""), "len":nnl, "p":"sysparams+" ); - end - return r; - end - function parservname(ostring,ev); - begin - len := length("*TSL_UNComplete*"); - ucp := false; - if pos("*TSL_UNComplete*",ostring)=1 then - begin - ucp := true; - nstr := ostring[len+1:]; end else - nstr := ostring; - len := length(nstr); - r := array(); - if ucp then t := "*"; - else begin - t := gettypename(ev); + cn := nstr[1:nlen]; + r[1]:= array("n":cn+"+", + "c":cn, + "len":nnl, + "p":"sysparams+" + ); + if nlen"; - o := o_; - obk := o; - try - stk := array(); - idx :=0; - while idx<(ct>0?ct:3) do - begin - mus[length(mus)] := o; - d := o.classinfo(); - stk[idx,0] := o; - stk[idx,1] := d; - inh := d["inherited"]; - if not inh then break; - o := findclass(inh[0],o); - idx++; - end - for idx := length(stk)-1 downto 0 do - begin - o:=stk[idx,0]; - for i,v in stk[idx,1,"properties"] do - begin - n := v["name"]; - if v["read"] and (v["access"] in array(0,1)) then - begin - r[n] := 0; - - end else - begin - reindex(r,array(n:nil)); - end - end - for i,v in stk[idx,1,"members"] do - begin - n := v["name"]; - if v["access"] in array(0,1) then - begin - r[n] := 0; - - end else - begin - reindex(r,array(n:nil)); - end - end - - end - rs := mrows(r,1) ; - for i := length(rs)-1 downto 0 do - begin - v := rs[i]; - nv := invoke(obk,v); - if datatype(nv)=7 then r[v] := ""; - else if ifarray(nv) then r[v] := _show_dbg_obj(nv,ct,mus); - else if ifobj(nv) then r[v] := _show_dbg_obj(nv,ct,mus); - else r[v] := _show_dbg_obj(nv,ct,mus); - end - except - return r; - end; + r[i] := _show_dbg_obj(v,ct,mus); + end return r; +end else +if not ifobj(o_) then return o_; +if not ifarray(mus) then mus := array(); +if o_ in mus then return ""; +o := o_; +obk := o; +try + stk := array(); + idx :=0; + while idx<(ct>0?ct:3) do + begin + mus[length(mus)] := o; + d := o.classinfo(); + stk[idx,0] := o; + stk[idx,1] := d; + inh := d["inherited"]; + if not inh then break; + o := findclass(inh[0],o); + idx++; + end + for idx := length(stk)-1 downto 0 do + begin + o:=stk[idx,0]; + for i,v in stk[idx,1,"properties"] do + begin + n := v["name"]; + if v["read"] and (v["access"] in array(0,1)) then + begin + r[n] := 0; + + end else + begin + reindex(r,array(n:nil)); + end + end + for i,v in stk[idx,1,"members"] do + begin + n := v["name"]; + if v["access"] in array(0,1) then + begin + r[n] := 0; + + end else + begin + reindex(r,array(n:nil)); + end + end + + end + rs := mrows(r,1) ; + for i := length(rs)-1 downto 0 do + begin + v := rs[i]; + nv := invoke(obk,v); + if datatype(nv)=7 then r[v] := ""; + else if ifarray(nv) then r[v] := _show_dbg_obj(nv,ct,mus); + else if ifobj(nv) then r[v] := _show_dbg_obj(nv,ct,mus); + else r[v] := _show_dbg_obj(nv,ct,mus); + end +except + return r; +end; +return r; end - %%; - end - FStackList; - FVaraiblesList; - FToolbar; - FCommandtext; - FShowText; - fimgelist; + %%; end - type TFindListWnd=class(TListBox) //查找的地方 - function Create(AOwner); - begin - inherited; - end - function CheckListItem(s);override; - begin - return ifarray(s); - end - function GetItemText(i);override; - begin - it := GetItem(i); - if it then r := it["caption"]; - if not ifstring(r)then return ""; - return r; - end - Published - private + FStackList; + FVaraiblesList; + FToolbar; + FCommandtext; + FShowText; + fimgelist; +end +type TFindListWnd=class(TListBox) //查找的地方 + function Create(AOwner); + begin + inherited; end - type TGoToLineWnd=class(TVCForm) //跳转 - function Create(AOwner);override; + function CheckListItem(s);override; + begin + return ifarray(s); + end + function GetItemText(i);override; + begin + it := GetItem(i); + if it then r := it["caption"]; + if not ifstring(r)then return ""; + return r; + end + Published + private +end +type TGoToLineWnd=class(TVCForm) //跳转 + function Create(AOwner);override; + begin + inherited; + wssizebox := false; + minmaxbox := false; + WsDlgModalFrame := true; + width := 300; + height := 80; + caption := "转到.."; + FLabel := new TLabel(self); + FLabel.SetBoundsRect(array(3,10,70,35)); + FEdit := new TEdit(self); + FEdit.SetBoundsRect(array(75,10,200,35)); + FBtn := new TBtn(self); + FBtn.SetBoundsRect(array(210,10,280,35)); + FLabel.Caption := "目标位置:"; + FBtn.Caption := "定位"; + FLabel.parent := self; + FEdit.parent := self; + FEdit.OnKeyPress := function(o,e) begin - inherited; - wssizebox := false; - minmaxbox := false; - WsDlgModalFrame := true; - width := 300; - height := 80; - caption := "转到.."; - FLabel := new TLabel(self); - FLabel.SetBoundsRect(array(3,10,70,35)); - FEdit := new TEdit(self); - FEdit.SetBoundsRect(array(75,10,200,35)); - FBtn := new TBtn(self); - FBtn.SetBoundsRect(array(210,10,280,35)); - FLabel.Caption := "目标位置:"; - FBtn.Caption := "定位"; - FLabel.parent := self; - FEdit.parent := self; - FEdit.OnKeyPress := function(o,e) + if e.CharCode=13 then begin - if e.CharCode=13 then - begin - e.skip := true; - GotoTextInteger(); - end - end - OnClose := function(o,e) - begin - o.visible := false; e.skip := true; - end - FBtn.parent := self; - FBtn.OnClick := function(o,e) - begin GotoTextInteger(); end end - function DoControlAlign();override; + OnClose := function(o,e) begin + o.visible := false; + e.skip := true; end - function ShowGoto(); + FBtn.parent := self; + FBtn.OnClick := function(o,e) begin - show(); - FEdit.SetFocus(); - FEdit.Text := ""; + GotoTextInteger(); end - private - function GotoTextInteger(); - begin - id := FEdit.Text; - id := StrToIntDef(id,0); - if id>0 then - begin - it := Owner.GetCurrentItem(); - Visible := false; - Owner.OpenAndGotoFileByName(it.ScriptPath,id); - //it.SetFocus(); - //return ; - it := Owner.GetCurrentEditer(); - if not it then return; - //it.ExecuteCommand(it.ecGotoXY,array(id,1)); - //Visible := false; - it.SetFocus(); - end - end - FEdit; - FBtn; end - type TTslCodeMap=class(TTreeView) //tsl代码地图 - function Create(AOwner); + function DoControlAlign();override; + begin + end + function ShowGoto(); + begin + show(); + FEdit.SetFocus(); + FEdit.Text := ""; + end + private + function GotoTextInteger(); + begin + id := FEdit.Text; + id := StrToIntDef(id,0); + if id>0 then begin - inherited; - caption := "代码树:支持[左/右/上/下/enter]键"; - width := 400; - height := 800; - WsPopUp := true; - WsSysMenu := true; - WsSizeBox := true; - OnClose := function(o,e) - begin - o.visible := false; - e.skip := true; - if not FTreeEditer then return; - FTreeEditer.SetFocus(); - end - OnActivate := function(o,e) - begin - if not e.wparam then CodeMapLive(o,e); - {o.Visible := false; - if not FTreeEditer then return; - FTreeEditer.SetFocus();} - end - onKeyPress := thisfunction(CodeMapLive); - //OnDblClick := thisfunction(SynNodeSelected); - OnSelChanged := thisfunction(SynNodeSelected); + it := Owner.GetCurrentItem(); + Visible := false; + Owner.OpenAndGotoFileByName(it.ScriptPath,id); + //it.SetFocus(); + //return ; + it := Owner.GetCurrentEditer(); + if not it then return; + //it.ExecuteCommand(it.ecGotoXY,array(id,1)); + //Visible := false; + it.SetFocus(); end - function CodeMapLive(o,e); + end + FEdit; + FBtn; +end +type TTslCodeMap=class(TTreeView) //tsl代码地图 + function Create(AOwner); + begin + inherited; + caption := "代码树:支持[左/右/上/下/enter]键"; + width := 400; + height := 800; + WsPopUp := true; + WsSysMenu := true; + WsSizeBox := true; + OnClose := function(o,e) begin - o.Visible := false; + o.visible := false; + e.skip := true; if not FTreeEditer then return; FTreeEditer.SetFocus(); end - function SynNodeSelected(o,e); + OnActivate := function(o,e) begin - //双击 + if not e.wparam then CodeMapLive(o,e); + {o.Visible := false; if not FTreeEditer then return; - nd := CurrentNode; - line := nd._tag; - if line>0 then - begin - FTreeEditer.ExecuteCommand(FTreeEditer.ecGoToXY,array(line,1)); - end + FTreeEditer.SetFocus();} end - function hasFocus();override; - begin - return true; - end - function ShowMap(); - begin - FTreeEditer := nil; - it := Owner.GetCurrentItem(); - if not it then return; - //caption := "codemap:"+it.ScriptPath; - FTreeEditer := it.FEditer; - s := FTreeEditer.Text; - if FString <> s then - begin - FString := s; - LoadString(s,FTreeEditer.CaretY); - end else - GoToTheNode(FTreeEditer.CaretY); - end - function Recycling();override; - begin - inherited; - FTempNodes := nil; //节点 - FEditer := nil; - FString := nil; - FTreeEditer := nil; - end - private - function LoadString(s,line); - begin - { 代码块快类型 - #define Block_TypeClass 1 - #define Block_Function 2 - #define Block_Statements 4 - #define Block_If 8 - #define Block_Else 16 - #define Block_SubCase 32 - #define Block_Goto_Label 64 - #define Block_Empty_Begin_End 128 - #define Block_Try 256 - #define Block_NeedSql 512 - #define Block_UnitStruct 1024 - } - if s then r := tsl_tokenizeex_2_(s,1+2+4+8+16+32+256+1024+2048+4096); - else r := array(); - RootNode.RecyclingChildren(); - FTempNodes := array(); - ScriptDelBlocks(r["blcks"],str2array(s,"\r\n"),self.RootNode,0); - GoToTheNode(line); - end - function GoToTheNode(line); - begin - nd := FTempNodes[0]; - for i,v in FTempNodes do - begin - if v._tag <= line then - begin - nd := v; - end else - if v._tag >= Line then - begin - SetSel(nd); - break; - end - end - Show(); - if _wapi.GetFocus()<> Handle then - begin - SetFocus(); - end - end - function ScriptDelBlocks(blcks,strs,Node,ct); - begin - if not blcks then return; - for i,v in blcks do - begin - if v["mtype"]<> 1 then - begin - cnd := CreateTreeNode(); - cnd.Caption := trim(strs[v["mbeg"]-1]); - cnd._tag := v["mbeg"]; - FTempNodes[length(FTempNodes)]:= cnd; - cnd.parent := node; - end - if not cnd then cnd := node; - ScriptDelBlocks(v["msub"],strs,cnd,ct+1); - end - end - FTempNodes; //节点 - FString; //字符串 - FTreeEditer; //编辑框 + onKeyPress := thisfunction(CodeMapLive); + //OnDblClick := thisfunction(SynNodeSelected); + OnSelChanged := thisfunction(SynNodeSelected); end - type TEditer=class(TCustomcontrol) //包括工具栏,状态栏,输出,查找 - function Create(AOwner);override; + function CodeMapLive(o,e); + begin + o.Visible := false; + if not FTreeEditer then return; + FTreeEditer.SetFocus(); + end + function SynNodeSelected(o,e); + begin + //双击 + if not FTreeEditer then return; + nd := CurrentNode; + line := nd._tag; + if line>0 then begin - inherited; - FOpenHistory := new TMyarrayb(); - FFistShows := array(); - FSynHCS := New TMyArrayA(); - //构造部件 - FLastDispathTime := now(); - FTslexe := gettslexe() ;//SysExecName(); - FTabChar := " "; - FTabWidth := 4; - FCurrentItemCode := array(); - FGoBackA := new TMyarrayB(); - FGoBackB := new TMyarrayB(); - FToolbar := new TToolBar(self); //工具栏 - FStatus := new TStatusBar(self); //状态栏 - FInfoShowWnd := new TEditerAuxiliary(self); - FPageEditer := new TPageEditer(self); - //FPageEditer.CloseBtn := true; - FPageEditer.Onbmpbclick := function(o,e) + FTreeEditer.ExecuteCommand(FTreeEditer.ecGoToXY,array(line,1)); + end + end + function hasFocus();override; + begin + return true; + end + function ShowMap(); + begin + FTreeEditer := nil; + it := Owner.GetCurrentItem(); + if not it then return; + //caption := "codemap:"+it.ScriptPath; + FTreeEditer := it.FEditer; + s := FTreeEditer.Text; + if FString <> s then + begin + FString := s; + LoadString(s,FTreeEditer.CaretY); + end else + GoToTheNode(FTreeEditer.CaretY); + end + function Recycling();override; + begin + inherited; + FTempNodes := nil; //节点 + FEditer := nil; + FString := nil; + FTreeEditer := nil; + end + private + function LoadString(s,line); + begin + { 代码块快类型 + #define Block_TypeClass 1 + #define Block_Function 2 + #define Block_Statements 4 + #define Block_If 8 + #define Block_Else 16 + #define Block_SubCase 32 + #define Block_Goto_Label 64 + #define Block_Empty_Begin_End 128 + #define Block_Try 256 + #define Block_NeedSql 512 + #define Block_UnitStruct 1024 + } + if s then r := tsl_tokenizeex_2_(s,1+2+4+8+16+32+256+1024+2048+4096); + else r := array(); + RootNode.RecyclingChildren(); + FTempNodes := array(); + ScriptDelBlocks(r["blcks"],str2array(s,"\r\n"),self.RootNode,0); + GoToTheNode(line); + end + function GoToTheNode(line); + begin + nd := FTempNodes[0]; + for i,v in FTempNodes do + begin + if v._tag <= line then begin - - it := e._Tag; - if not it then return ; - if it.fisnewfile then //单独处理新建关闭 - begin - f := it.OrigScriptPath; - DeletePageItem(it); - if fileexists("",f) then filedelete("",f); + nd := v; + end else + if v._tag >= Line then + begin + SetSel(nd); + break; + end + end + Show(); + if _wapi.GetFocus()<> Handle then + begin + SetFocus(); + end + end + function ScriptDelBlocks(blcks,strs,Node,ct); + begin + if not blcks then return; + for i,v in blcks do + begin + if v["mtype"]<> 1 then + begin + cnd := CreateTreeNode(); + cnd.Caption := trim(strs[v["mbeg"]-1]); + cnd._tag := v["mbeg"]; + FTempNodes[length(FTempNodes)]:= cnd; + cnd.parent := node; + end + if not cnd then cnd := node; + ScriptDelBlocks(v["msub"],strs,cnd,ct+1); + end + end + FTempNodes; //节点 + FString; //字符串 + FTreeEditer; //编辑框 +end +type TEditer=class(TCustomcontrol) //包括工具栏,状态栏,输出,查找 + function Create(AOwner);override; + begin + inherited; + FOpenHistory := new TMyarrayb(); + FFistShows := array(); + FSynHCS := New TMyArrayA(); + //构造部件 + FLastDispathTime := now(); + FTslexe := gettslexe() ;//SysExecName(); + FTabChar := " "; + FTabWidth := 4; + FCurrentItemCode := array(); + FGoBackA := new TMyarrayB(); + FGoBackB := new TMyarrayB(); + FToolbar := new TToolBar(self); //工具栏 + FStatus := new TStatusBar(self); //状态栏 + FInfoShowWnd := new TEditerAuxiliary(self); + FPageEditer := new TPageEditer(self); + //FPageEditer.CloseBtn := true; + FPageEditer.Onbmpbclick := function(o,e) + begin - end else - begin - if JudgeItemState(it)then return; - if it.FEditer.ChangedFlag then - begin - mr := MessageboxA(format("是否保存:%s",it.OrigScriptPath),"提示",3,self); - if mr=IDYES then - begin - SavePageItem(it); - end else - if mr=IDCANCEL then - begin - return; - end - end - DeletePageItem(it); - end - o.CallSelChanged(); - end - FPageEditer.OnCloseClick := function(o,e) - begin - it := GetCurrentItem(); - if not it then return ; + it := e._Tag; + if not it then return ; + if it.fisnewfile then //单独处理新建关闭 + begin + f := it.OrigScriptPath; + DeletePageItem(it); + if fileexists("",f) then filedelete("",f); + + end else + begin if JudgeItemState(it)then return; if it.FEditer.ChangedFlag then begin @@ -4359,1297 +4338,1349 @@ end end end DeletePageItem(it); - ECHO "==222=>>>"; - end; - FFindWnd := new TFindWnd(self); //查找 - FGotoLineWnd := new TGoToLineWnd(self); //共同 - FListPages := new TListPages(self); //tab 跳转页面 - FEchoWnd := new TEditerEchoWnd(self); - FEchoWnd.font := array("height":16,"width":8,"escapement":0,"orientation":0,"weight":400,"italic":0,"underline":0,"strikeout":0, - "charset":0,"outprecision":0,"clipprecision":0,"quality":1,"pitchandfamily":1,"facename":"Courier New","color":0); - FTslDebug := new TTslDebug(self); - FFindListWnd := new TFindListWnd(self); - FCodeMap := new TTslCodeMap(self); - FFileopen := new TOpenFileADlg(self); - FFileSave := new TSavefileADlg(self); - FFileopen.WndOwner := self; - FFileSave.WndOwner := self; - //初始部件 - ////////////////////////////////////// - FEchoWnd.Border := true; - FEchoWnd.WsSysMenu := false; - FEchoWnd.WsSizeBox := false; - FEchoWnd.Caption := "echo..."; - FFindListWnd.Caption := "find...."; - FFindListWnd.OnDblClick := thisfunction(FindListChoosed); - FGotoLineWnd.Visible := false; - ///////////////////////// - FCodeMap.visible := false; - FFindWnd.Visible := false; - FFileSave.Filter := array("any":"*.*","tsl文件":"*.tsl;*.tsf"); - FFileSave.Caption := "另存为"; - FFileopen.Filter := array("any":"*.*","tsl文件":"*.tsl;*.tsf"); - FPageEditer.OnSelChanged := thisfunction(PageItemSelChanged); - //////// - FListPages.Visible := false; - //////////////////////////// - FPageMenu := new TPopUpMenu(self); - for i,v in array("关闭","关闭其他标签","复制文件名","复制文件全名","重新加载","打开目录","另存为") do - begin - mi := new TMenu(self); - mi.Caption := v; - mi.Parent := FPageMenu; - mi.OnClick := thisfunction(PageMenuClick); - end - FExecuteEditer := new TExecuteEditer(self); - FExecuteEditer.visible := false; - //////////// - FPageEditer.PageItemOnRClick := thisfunction(PageItemOnRClick); - FImages := new TControlImageList(self); - FImages.Width := 22; - FImages.Height := 22; - bmp := new TBitmap(); - imgs := GetEditIcons(); - id := 0; - FToolbtns := array(); - dbgbtns := array(); - for i,v in imgs do - begin - bmp.Readvcon(HexFormatStrToTsl(v)); - FImages.addbmp(bmp); - bt := new TToolButton(self); - FToolbtns[i]:= bt; - bt.OnClick := thisfunction(ToolClick); - bt.Caption := i; - bt.imageid := id; - id++; - BT.parent := FToolbar; - if i in array("添加/删除断点F5","暂停","继续","进入","跳出","单步","下一行(F8)","终止","刷新符号表","刷新当前符号")then - begin - dbgbtns[i]:= bt; - end - end - FImages.DrawBimpFirst := true; - FTslDebug.addbtns(dbgbtns); - FToolbar.ImageList := FImages; - FInfoShowWnd.Visible := false; - //FInfoShowWnd.WsSysMenu := true; - FInfoShowWnd.WSsizebox := true; - FInfoShowWnd.height := 200; - //FInfoShowWnd.OnSize := thisfunction(DoControlAlign); - FInfoShowWnd.OnCloseClick := function(o,e) - begin - o.visible := false; - e.skip := true; - DoControlAlign(); - end - ///////////////////// - FStatus.Items := array(("text":"","width":0.85),("text":"","width":0.16)); - ///////////////////////////////////////// - //FInfoShowWnd.Caption := "信息:"; - ////构造节点//////////////////////////////////////////////////// - FToolBar.Parent := self; - FStatus.Parent := self; - FInfoShowWnd.Parent := self; - FPageEditer.Parent := self; - FCodeMap.parent := self; - FGotoLineWnd.Parent := self; - FFindWnd.parent := self; - FFileopen.parent := self; - FFileSave.parent := self; - FListPages.parent := self; - FExecuteEditer.parent := self; - //FEchoWnd - FInfoShowWnd.AddWnd(FEchoWnd); - FInfoShowWnd.AddWnd(FFindListWnd); - FInfoShowWnd.AddWnd(FTslDebug); - FTempPageItem := new TPageEditerItem(FPageEditer); - ///////////// - FSynClasses["txt"]:= array(class(TSynHighLighter),class(TSynCompletion),";txt;"); - FSynClasses["tsl"]:= array(class(TTslSynHighLighter),class(TTslCompletion),";tsl;tsf;pas;stm;"); - FSynClasses["json"]:= array(class(TJsonSynHighLighter),class(TSynCompletion),";json;"); - FSynClasses["ini"]:= array(class(TINISynHigLighter),class(TSynCompletion),";ini;"); - FSynClasses["bat"]:= array(class(TBatSynHigLighter),class(TSynCompletion),";bat;cmd;"); - FSynClasses["None"]:= array(nil,nil,""); - //FSynClasses["tsf"] := FSynClasses["tsl"]; - FTslChmHelp := new TTslChmHelp(); - FCodeFormatInfo := array("wordct":80,"charct":200,"syn":true,"sel":false,"arraytype":0); - FPageEditer.OnDblClick := function(o,e) - begin - CreateAFile(); end - end - function PopUpAuxiliary(); + o.CallSelChanged(); + end + FPageEditer.OnCloseClick := function(o,e) begin - FInfoShowWnd.ShowPopUp(); - end - function ClearPageItemMark(it); - begin - if not it then it := GetCurrentItem(); - if not it then return; - ed := it.FEditer; - ls := ed.Lines; - canval := false; - for i := 0 to ls.length()-1 do - begin - li := ls[i]; - if li.FMarked then - begin - li.FMarked := false; - canval := true; - end - end - if canval then ed.InValidateRect(nil,false); - end - function GetAllPageItems(); - begin - return FPageEditer.PageItems; - end - function SaveFileByName(n); - begin - for i,v in FPageEditer.PageItems.Data do - begin - if v.ScriptPathIs(n)then - begin - return SavePageItem(v); - end - end - end - function GetAllPagesInfo(); - begin - r := array(); - its := FPageEditer.PageItems; - for i := 0 to its.Length()-1 do - begin - it := its[i]; - r["pages"][i]["filename"]:= it.OrigScriptPath; - edt := it.FEditer; - r["pages"][i]["r"]:= edt.TopLine; //edt.CaretY; - ls := edt.Lines; - f2s := array(); - for j := 0 to ls.Length()-1 do - begin - if ls[j].FMarked then f2s[j]:= true; - end - r["pages"][i]["f2"]:= f2s; - r["pages"][i]["isnewfile"]:= it.fisnewfile; - end it := GetCurrentItem(); - if it then + if not it then return ; + if JudgeItemState(it)then return; + if it.FEditer.ChangedFlag then begin - r["currentpage"]:= array(it.OrigScriptPath,it.FEditer.TopLine); - end - //FPageEditer.DoControlAlign(); - return r; - end - function CloseScriptByFileName(n); - begin - for i,v in FPageEditer.PageItems.Data do - begin - if v.ScriptPathIs(n)then + mr := MessageboxA(format("是否保存:%s",it.OrigScriptPath),"提示",3,self); + if mr=IDYES then begin - return DeletePageItem(v); - end - end - end - function CloseAllPageItems(it); - begin - its := FPageEditer.PageItems; - tits := its.Data; - FPageEditer.CloseAllItem(it); - for i,v in tits do - begin - if v=it then - begin - cit := it; - continue; - end - v.Recycling(); - end - if cit then cit.FEditer.ReCreateCaret(); - end - function SaveAllPageItems(); //保存所有 - begin - its := FPageEditer.PageItems; - for i,v in its.Data do - begin - JudgeItemState(v); - end - its := FPageEditer.PageItems; - for i := 0 to its.Length()-1 do - begin - SavePageItem(its[i]); - end - end - function WMUSER(o,e):WM_USER;override; - begin - inherited; - if e.wparam=101 and e.lparam=102 then - begin - self.Enabled := true; - end - end - function EndFind(); - begin - FIsFinding := false; - _send_(WM_USER,101,102,1); - end - function DoFind(d,o); - begin - if FIsFinding then return; - o.SetStatusText("查找....."); - o.SaveCurrentEditer(); - self.Enabled := false; - FIsFinding := true; - if not(d["c_reg"])then - begin - if(d["section"]="查找")and(d["btn"]="全部查找")then - begin - FFindListWnd.Clean(); - ShowFindWnd(); - FindAllInCurrent(d,o,nil,ct); - o.SetStatusText(format("查找到 %d处",ct)); - return EndFind(); + SavePageItem(it); end else - if(d["section"]in array("查找","替换"))and(d["btn"]="查找")then + if mr=IDCANCEL then begin - FindInCurrent(d,o); - return EndFind(); - end else - if(d["section"]in array("替换"))and(d["btn"]="替换")then - begin - if d["replace"]<> d["target"]then FindInCurrent(d,o,nil,1); - return EndFind(); - end else - if(d["section"]in array("替换"))and(d["btn"]="全部替换")then - begin - if d["replace"]<> d["target"]then - begin - FFindListWnd.Clean(); - ShowFindWnd(); - ReplaceAllInCurrent(d,o,nil,idx); - o.SetStatusText(format("替换 %d处",idx)); - end - return EndFind(); - end else - if(d["section"]in array("文件查找"))and(d["btn"]="全部替换")then - begin - FFindListWnd.Clean(); - ShowFindWnd(); - FindInFiles(d,o,true,ct); - o.SetStatusText(format("总共替换 %d处",ct)); - return EndFind(); - end else - if(d["section"]in array("文件查找"))and(d["btn"]="查找")then - begin - FFindListWnd.Clean(); - ShowFindWnd(); - FindInFiles(d,o,false,ct); - o.SetStatusText(format("总共查找 %d处",ct)); - return EndFind(); - end - end - o.SetStatusText("功能开发中...."); - EndFind(); - end - function DebugPageItem(it,h); - begin - if not it then return; - showdbugwnd(); - FTslDebug.Debuglocal(it); - end - function Debugremote(it); - begin - showdbugwnd(); - FTslDebug.Debugremote(it); - end - function DbgNextLine(); - begin - FTslDebug.DbgNextLine(); //FDebuger - end - function ExecutePageItem(it,h); - begin - if not it then return; - ShowEchoWnd(); - //exe :=(FTslExe and ifstring(FTslExe))?FTslExe:SysExecName(); - if FEchoWnd.Exeing()then FEchoWnd.Endexe(); - s := FExecuteEditer.GetCurrentExuteString(it.Scriptpath); - // echo s,"\r\n"; - FEchoWnd.Exec(s,"",h); - //FEchoWnd.Exec(exe,format('"%s" -libpath "%s"',it.ScriptPath,getdirfromfile(it.ScriptPath)),h); - end - {function ExecutePageItemWithCmd(it); - begin - s := FExecuteEditer.GetCurrentExuteString(it.Scriptpath); - hd := "d:\\test\\execmd.cmd"; - //RewriteString(hd,s); - _wapi.WinExec("cmd.exe",1); - //_wapi.WinExec("",1); - //SysExec("","cmd.exe /c " + s,nil,false,c,nil); - //echo "===\r\n"; - end } - function SavePageItem(it,f); - begin - if not it then return -1; - if f or it.PrePareSave()then - begin - it.FEditer.ChangedFlag := false; - s := it.LastText; - case it.EnCode of - "UTF8": - begin - s := AnsiToutf8(it.LastText); - end - "UTF8 BOM": - begin - //0xEF, 0xBB, 0xBF - s := " "; - s[1]:= 0xEF; - s[2]:= 0xBB; - s[3]:= 0xBF; - s += AnsiToutf8(it.LastText); - //ECHO "SAVE UTFB-BOM\r\n"; - end - "UCS2-little": - begin - s := " "; - s[1]:= 0xFF; - s[2]:= 0xFE; - s += multibytetounicode(it.LastText,936); - end - "UCS2-big": - begin - s2 := " "; - s2[1]:= 0xFF; - s2[2]:= 0xFE; - s2 += multibytetounicode(it.LastText,936); - s := ""; - setlength(s,length(s2)); - for i := 1 to length(s2)-1 step 2 do - begin - s[i]:= s2[i+1]; - s[i+1]:= s2[i]; - end - end - end; - fp := it.OrigScriptPath; - if it.FISstm then - begin - try - v := eval(&s); - //s := tostm(v); - r := exportfile(ftstream(),"",fp,v); - it.ReGetLastLoadTime(); - return r; - except - end - end - r := ReWriteString(fp,s); - it.ReGetLastLoadTime(); - return r; - end - return 1; - end - function ShowFindWnd(); - begin - FInfoShowWnd.ShowByTag(FFindListWnd); - ShowLogWnd(true); - end - function showdbugwnd(); - begin - FInfoShowWnd.ShowByTag(FTslDebug); - ShowLogWnd(true); - end - function ShowEchoWnd(); - begin - FInfoShowWnd.ShowByTag(FEchoWnd); - ShowLogWnd(true); - end - function SwitchLogWnd(); - begin - FInfoShowWnd.Visible := not(FInfoShowWnd.Visible); - DoControlAlign(); - end - function SetFindHistroy(d); - begin - FFindWnd.SetHistory(d); - end - function GetFindHistory(); - begin - return FFindWnd.GetHistory(); - end - function ShowLogWnd(flg); - begin - n :=(ifnil(flg)or flg)?true:false; - if n=FInfoShowWnd.Visible then return; - FInfoShowWnd.Visible := n; - DoControlAlign(); - end - function JudgeItemState(it); //状态处理 - begin - lt := it.GetLastLoadTime(); - nlt := it.ReGetLastLoadTime(); - if not lt then return; - if nlt <> lt then - begin - FPageEditer.FCanDraged := false; - FPageEditer.MouseDrageLeave(); //此处不知为什么会报错 - if not nlt then //已经删除 - begin - if Messageboxa("文件已经被删除,依然保存请按确定","提示",1,self)=IDOK then - begin - CreateDirWithFileName(it.OrigScriptPath); //新建 - SavePageItem(it,true); - end else - begin - DeletepageItem(it); //删除 - return true; - end - end else //被其他程序修改 - begin - if Messageboxa(format("%s\r\n被其他程序修改是否重新加载",it.ScriptPath),"提示",1,self)=IDOK then - begin - LoadFromFile(it,true); - end else - begin - it.FEditer.ChangedFlag := true; - end - end - end - end - function PageItemTextChanged(o,flg); - begin - its := FPageEditer.Pageitems; - cit := GetCurrentItem(); - for i := 0 to its.Length()-1 do - begin - it := Its[i]; - if it.FEditer=o then - begin - if cit=it then - begin - if it.fisnewfile then Caption := (flg?"*":"")+" new "; - else - Caption :=(flg?"*":"")+it.OrigScriptPath; - end - callDatafunction(OnPageEditerChanged,it,flg); - it.BitmapA := flg?GetNeedSaveBmp():GetNneedSaveBmp(); return; end end - end - function DeletePageItem(it); + DeletePageItem(it); + ECHO "==222=>>>"; + end; + FFindWnd := new TFindWnd(self); //查找 + FGotoLineWnd := new TGoToLineWnd(self); //共同 + FListPages := new TListPages(self); //tab 跳转页面 + FEchoWnd := new TEditerEchoWnd(self); + FEchoWnd.font := array("height":16,"width":8,"escapement":0,"orientation":0,"weight":400,"italic":0,"underline":0,"strikeout":0, + "charset":0,"outprecision":0,"clipprecision":0,"quality":1,"pitchandfamily":1,"facename":"Courier New","color":0); + FTslDebug := new TTslDebug(self); + FFindListWnd := new TFindListWnd(self); + FCodeMap := new TTslCodeMap(self); + FFileopen := new TOpenFileADlg(self); + FFileSave := new TSavefileADlg(self); + FFileopen.WndOwner := self; + FFileSave.WndOwner := self; + //初始部件 + ////////////////////////////////////// + FEchoWnd.Border := true; + FEchoWnd.WsSysMenu := false; + FEchoWnd.WsSizeBox := false; + FEchoWnd.Caption := "echo..."; + FFindListWnd.Caption := "find...."; + FFindListWnd.OnDblClick := thisfunction(FindListChoosed); + FGotoLineWnd.Visible := false; + ///////////////////////// + FCodeMap.visible := false; + FFindWnd.Visible := false; + FFileSave.Filter := array("any":"*.*","tsl文件":"*.tsl;*.tsf"); + FFileSave.Caption := "另存为"; + FFileopen.Filter := array("any":"*.*","tsl文件":"*.tsl;*.tsf"); + FPageEditer.OnSelChanged := thisfunction(PageItemSelChanged); + //////// + FListPages.Visible := false; + //////////////////////////// + FPageMenu := new TPopUpMenu(self); + for i,v in array("关闭","关闭其他标签","复制文件名","复制文件全名","重新加载","打开目录","另存为") do begin - idx := FPageEditer.GetItemIndex(it); - if idx >= 0 then + mi := new TMenu(self); + mi.Caption := v; + mi.Parent := FPageMenu; + mi.OnClick := thisfunction(PageMenuClick); + end + FExecuteEditer := new TExecuteEditer(self); + FExecuteEditer.visible := false; + //////////// + FPageEditer.PageItemOnRClick := thisfunction(PageItemOnRClick); + FImages := new TControlImageList(self); + FImages.Width := 22; + FImages.Height := 22; + bmp := new TBitmap(); + imgs := GetEditIcons(); + id := 0; + FToolbtns := array(); + dbgbtns := array(); + for i,v in imgs do + begin + bmp.Readvcon(HexFormatStrToTsl(v)); + FImages.addbmp(bmp); + bt := new TToolButton(self); + FToolbtns[i]:= bt; + bt.OnClick := thisfunction(ToolClick); + bt.Caption := i; + bt.imageid := id; + id++; + BT.parent := FToolbar; + if i in array("添加/删除断点F5","暂停","继续","进入","跳出","单步","下一行(F8)","终止","刷新符号表","刷新当前符号")then begin - //f := it.OrigScriptPath; - FPageEditer.DeleteItemByIndex(idx); - it.Recycling(); - it := GetCurrentItem(); - if it then it.FEditer.ReCreateCaret(); - //if it.fisnewfile then filedelete("",f); - + dbgbtns[i]:= bt; end end - function PageItemSelChanged(o,e);virtual; + FImages.DrawBimpFirst := true; + FTslDebug.addbtns(dbgbtns); + FToolbar.ImageList := FImages; + FInfoShowWnd.Visible := false; + //FInfoShowWnd.WsSysMenu := true; + FInfoShowWnd.WSsizebox := true; + FInfoShowWnd.height := 200; + //FInfoShowWnd.OnSize := thisfunction(DoControlAlign); + FInfoShowWnd.OnCloseClick := function(o,e) begin - it := GetCurrentItem(); - if not it then return; - //if JudgeItemState(it) then return ; - FCurrentItemCode[length(FCurrentItemCode)]:= it; - if it.fisnewfile then - begin - Caption :=(it.FEditer.ChangedFlag?"*":"")+" new "; - end - else - begin - Caption :=(it.FEditer.ChangedFlag?"*":"")+it.OrigScriptPath; - end - CallDatafunction(FOnPageItemSelChanged,self(true),it); - cp := it.FEditer.Completion; - if cp and it.FInitCompletion then - begin - it.FInitCompletion := false; - cp.PrePareCompletion(it.Caption); - end - EditerCaretChanged(it.FEditer,nil); + o.visible := false; + e.skip := true; + DoControlAlign(); end - function PageMenuClick(o,e); + ///////////////////// + FStatus.Items := array(("text":"","width":0.85),("text":"","width":0.16)); + ///////////////////////////////////////// + //FInfoShowWnd.Caption := "信息:"; + ////构造节点//////////////////////////////////////////////////// + FToolBar.Parent := self; + FStatus.Parent := self; + FInfoShowWnd.Parent := self; + FPageEditer.Parent := self; + FCodeMap.parent := self; + FGotoLineWnd.Parent := self; + FFindWnd.parent := self; + FFileopen.parent := self; + FFileSave.parent := self; + FListPages.parent := self; + FExecuteEditer.parent := self; + //FEchoWnd + FInfoShowWnd.AddWnd(FEchoWnd); + FInfoShowWnd.AddWnd(FFindListWnd); + FInfoShowWnd.AddWnd(FTslDebug); + FTempPageItem := new TPageEditerItem(FPageEditer); + ///////////// + FSynClasses["txt"]:= array(class(TSynHighLighter),class(TSynCompletion),";txt;"); + FSynClasses["tsl"]:= array(class(TTslSynHighLighter),class(TTslCompletion),";tsl;tsf;pas;stm;"); + FSynClasses["json"]:= array(class(TJsonSynHighLighter),class(TSynCompletion),";json;"); + FSynClasses["ini"]:= array(class(TINISynHigLighter),class(TSynCompletion),";ini;"); + FSynClasses["bat"]:= array(class(TBatSynHigLighter),class(TSynCompletion),";bat;cmd;"); + FSynClasses["None"]:= array(nil,nil,""); + //FSynClasses["tsf"] := FSynClasses["tsl"]; + FTslChmHelp := new TTslChmHelp(); + FCodeFormatInfo := array("wordct":80,"charct":200,"syn":true,"sel":false,"arraytype":0); + FPageEditer.OnDblClick := function(o,e) begin - it := GetCurrentItem(); - if not it then return; - case o.Caption of - "关闭": - begin - if it.fisnewfile then //单独处理新建关闭 - begin - f := it.OrigScriptPath; - DeletePageItem(it); - if fileexists("",f) then filedelete("",f); - - return ; - end - if JudgeItemState(it)then return; - if it.FEditer.ChangedFlag then - begin - mr := MessageboxA(format("是否保存:%s",it.OrigScriptPath),"提示",3,self); - if mr=IDYES then - begin - if SavePageItem(it)=0 then - begin - it.FEditer.ChangedFlag := true; - return 0; - end - end else - if mr=IDCANCEL then - begin - return; - end - end - DeletePageItem(it); - end - "关闭其他标签": - begin - Cit := it; - its := GetAllPageItems(); - for i := 0 to its.Length()-1 do - begin - it := its[i]; - if it.FEditer.ChangedFlag then - begin - r := MessageBoxA("存在未保存的文件,是否保存!","提示",3,self); - if r=IDYES then - begin - SaveAllPageItems(); - break; - end else - if r=IDCANCEL then - begin - return; - end else - begin - end - break; - end - end - CloseAllPageItems(Cit); - end - "另存为": - begin - if JudgeItemState(it)then return; - //FFileopen.OverwritePrompt := true; - if FFileSave.OpenDlg()then - begin - fn := FFileSave.FileName; - dfn := it.ScriptPath; - CreateDirWithFileName(fn); - //echo format('FileCopy("","%s","","%s",false)',dfn,fn); - ret := FileCopy("",dfn,"",fn,false); - if ret then - begin - it.ScriptPath := fn; - if SavePageItem(it)=0 then - begin - it.FEditer.ChangedFlag := true; - end - if it.fisnewfile then - begin - FileDelete("",dfn); - it.fisnewfile := false; - end - end - end - //FFileopen.OverwritePrompt := false; - end - "重新加载": - begin - LoadFromFile(it,true); - end - "复制文件全名": - begin - if not FCliper then FCliper := new TClipBoard(self); - FCliper.text := it.OrigScriptPath; - end - "复制文件名": - begin - if not FCliper then FCliper := new TClipBoard(self); - FCliper.text := it.Caption; - end - "打开目录": - begin - p := it.ScriptPath; - if FileExists("",p)then - begin - for i := length(p)downto 3 do - begin - if p[i]="\\" then - begin - p := p[1:i]; - break; - end - end - //_wapi.WinExec('cmd.exe /C start "" "'+p,1); - _wapi.openresourcemanager(p); - end - end - "采用cmd执行": - begin - //ExecutePageItemWithCmd(it); - end + CreateAFile(); + end + end + function PopUpAuxiliary(); + begin + FInfoShowWnd.ShowPopUp(); + end + function ClearPageItemMark(it); + begin + if not it then it := GetCurrentItem(); + if not it then return; + ed := it.FEditer; + ls := ed.Lines; + canval := false; + for i := 0 to ls.length()-1 do + begin + li := ls[i]; + if li.FMarked then + begin + li.FMarked := false; + canval := true; end end - function PageItemOnRClick(o,e); + if canval then ed.InValidateRect(nil,false); + end + function GetAllPageItems(); + begin + return FPageEditer.PageItems; + end + function SaveFileByName(n); + begin + for i,v in FPageEditer.PageItems.Data do begin - if FPageEditer.GetItemIndexByPos(e.pos)>= 0 then o.PopUpMenu := FPageMenu; - else o.PoPupMenu := nil; + if v.ScriptPathIs(n)then + begin + return SavePageItem(v); + end end - function PageEditerMenuClick(o,e); + end + function GetAllPagesInfo(); + begin + r := array(); + its := FPageEditer.PageItems; + for i := 0 to its.Length()-1 do begin - if pos("复制",o.caption)=1 then + it := its[i]; + r["pages"][i]["filename"]:= it.OrigScriptPath; + edt := it.FEditer; + r["pages"][i]["r"]:= edt.TopLine; //edt.CaretY; + ls := edt.Lines; + f2s := array(); + for j := 0 to ls.Length()-1 do begin - it := GetCurrentItem(); - if it then - begin - ed := it.FEditer; - if ed then - begin - ed.ExecuteCommand(ed.ecCopy); - end - //it.FEditer.ReadOnly := not(o.Checked); - end - return; - end else - if pos("粘贴",o.caption)=1 then - begin - it := GetCurrentItem(); - if it then - begin - ed := it.FEditer; - if ed then - begin - ed.ExecuteCommand(ed.ecPaste); - end - //it.FEditer.ReadOnly := not(o.Checked); - end - return; - end else - if pos("剪切",o.caption)=1 then - begin - it := GetCurrentItem(); - if it then - begin - ed := it.FEditer; - if ed then - begin - ed.ExecuteCommand(ed.ecCut); - end - //it.FEditer.ReadOnly := not(o.Checked); - end - return; - end else - if pos("定位",o.caption)=1 then - begin - InitShowWndPos(FGotoLineWnd,"g",200,200); - FGotoLineWnd.ShowGoto(); - return; - end else - if pos("查看",o.caption)=1 then - begin - cs := o.Caption; - if length(cs)<6 then return; - s :=(o.Caption)[6:]; - GetCurrentEditer().Tryjump(s); - return; - end else - if pos("只读",o.caption)=1 then - begin - it := GetCurrentItem(); - if it then - begin - it.FEditer.ReadOnly := not(o.Checked); - end - return; - end else - if pos("执行",o.Caption)=1 then - begin - it := GetCurrentItem(); - ExecutePageItem(it); - return; - end else - if pos("停止",o.Caption)=1 then - begin - if FEchoWnd.Exeing()then FEchoWnd.EndExe(); - return; - end else - if o.Caption = "转换为大写" then - begin - upperorlowercase(1); - end else - if o.Caption = "转换为小写" then - begin - upperorlowercase(0); - end else - if o.Caption = "删除尾空白" then - begin - seltrimright(); - end + if ls[j].FMarked then f2s[j]:= true; + end + r["pages"][i]["f2"]:= f2s; + r["pages"][i]["isnewfile"]:= it.fisnewfile; end - function PageEditerOnRClick(o,e); - begin - o.popupMenu := nil; - if not FPageEditerMenu then + it := GetCurrentItem(); + if it then + begin + r["currentpage"]:= array(it.OrigScriptPath,it.FEditer.TopLine); + end + //FPageEditer.DoControlAlign(); + return r; + end + function CloseScriptByFileName(n); + begin + for i,v in FPageEditer.PageItems.Data do + begin + if v.ScriptPathIs(n)then begin - FPageEditerMenu := new TPopUpMenu(self); - FPageEditerMenus := array(); - for i,v in array("查看","复制(C)","粘贴(V)","剪切(X)","定位(G)","只读","转换为大写","转换为小写","删除尾空白","执行(F9)","停止执行") do + return DeletePageItem(v); + end + end + end + function CloseAllPageItems(it); + begin + its := FPageEditer.PageItems; + tits := its.Data; + FPageEditer.CloseAllItem(it); + for i,v in tits do + begin + if v=it then + begin + cit := it; + continue; + end + v.Recycling(); + end + if cit then cit.FEditer.ReCreateCaret(); + end + function SaveAllPageItems(); //保存所有 + begin + its := FPageEditer.PageItems; + for i,v in its.Data do + begin + JudgeItemState(v); + end + its := FPageEditer.PageItems; + for i := 0 to its.Length()-1 do + begin + SavePageItem(its[i]); + end + end + function WMUSER(o,e):WM_USER;override; + begin + inherited; + if e.wparam=101 and e.lparam=102 then + begin + self.Enabled := true; + end + end + function EndFind(); + begin + FIsFinding := false; + _send_(WM_USER,101,102,1); + end + function DoFind(d,o); + begin + if FIsFinding then return; + o.SetStatusText("查找....."); + o.SaveCurrentEditer(); + self.Enabled := false; + FIsFinding := true; + if not(d["c_reg"])then + begin + if(d["section"]="查找")and(d["btn"]="全部查找")then + begin + FFindListWnd.Clean(); + ShowFindWnd(); + FindAllInCurrent(d,o,nil,ct); + o.SetStatusText(format("查找到 %d处",ct)); + return EndFind(); + end else + if(d["section"]in array("查找","替换"))and(d["btn"]="查找")then + begin + FindInCurrent(d,o); + return EndFind(); + end else + if(d["section"]in array("替换"))and(d["btn"]="替换")then + begin + if d["replace"]<> d["target"]then FindInCurrent(d,o,nil,1); + return EndFind(); + end else + if(d["section"]in array("替换"))and(d["btn"]="全部替换")then + begin + if d["replace"]<> d["target"]then begin - it := new TMenu(self); - it.Caption := v; - it.parent := FPageEditerMenu; - FPageEditerMenus[v]:= it; - it.OnClick := thisfunction(PageEditerMenuClick); + FFindListWnd.Clean(); + ShowFindWnd(); + ReplaceAllInCurrent(d,o,nil,idx); + o.SetStatusText(format("替换 %d处",idx)); + end + return EndFind(); + end else + if(d["section"]in array("文件查找"))and(d["btn"]="全部替换")then + begin + FFindListWnd.Clean(); + ShowFindWnd(); + FindInFiles(d,o,true,ct); + o.SetStatusText(format("总共替换 %d处",ct)); + return EndFind(); + end else + if(d["section"]in array("文件查找"))and(d["btn"]="查找")then + begin + FFindListWnd.Clean(); + ShowFindWnd(); + FindInFiles(d,o,false,ct); + o.SetStatusText(format("总共查找 %d处",ct)); + return EndFind(); + end + end + o.SetStatusText("功能开发中...."); + EndFind(); + end + function DebugPageItem(it,h); + begin + if not it then return; + showdbugwnd(); + FTslDebug.Debuglocal(it); + end + function Debugremote(it); + begin + showdbugwnd(); + FTslDebug.Debugremote(it); + end + function DbgNextLine(); + begin + FTslDebug.DbgNextLine(); //FDebuger + end + function ExecutePageItem(it,h); + begin + if not it then return; + ShowEchoWnd(); + //exe :=(FTslExe and ifstring(FTslExe))?FTslExe:SysExecName(); + if FEchoWnd.Exeing()then FEchoWnd.Endexe(); + s := FExecuteEditer.GetCurrentExuteString(it.Scriptpath); + // echo s,"\r\n"; + FEchoWnd.Exec(s,"",h); + //FEchoWnd.Exec(exe,format('"%s" -libpath "%s"',it.ScriptPath,getdirfromfile(it.ScriptPath)),h); + end + {function ExecutePageItemWithCmd(it); + begin + s := FExecuteEditer.GetCurrentExuteString(it.Scriptpath); + hd := "d:\\test\\execmd.cmd"; + //RewriteString(hd,s); + _wapi.WinExec("cmd.exe",1); + //_wapi.WinExec("",1); + //SysExec("","cmd.exe /c " + s,nil,false,c,nil); + //echo "===\r\n"; + end } + function SavePageItem(it,f); + begin + if not it then return -1; + if f or it.PrePareSave()then + begin + it.FEditer.ChangedFlag := false; + s := it.LastText; + case it.EnCode of + "UTF8": + begin + s := AnsiToutf8(it.LastText); + end + "UTF8 BOM": + begin + //0xEF, 0xBB, 0xBF + s := " "; + s[1]:= 0xEF; + s[2]:= 0xBB; + s[3]:= 0xBF; + s += AnsiToutf8(it.LastText); + //ECHO "SAVE UTFB-BOM\r\n"; + end + "UCS2-little": + begin + s := " "; + s[1]:= 0xFF; + s[2]:= 0xFE; + s += multibytetounicode(it.LastText,936); + end + "UCS2-big": + begin + s2 := " "; + s2[1]:= 0xFF; + s2[2]:= 0xFE; + s2 += multibytetounicode(it.LastText,936); + s := ""; + setlength(s,length(s2)); + for i := 1 to length(s2)-1 step 2 do + begin + s[i]:= s2[i+1]; + s[i+1]:= s2[i]; + end + end + end; + fp := it.OrigScriptPath; + if it.FISstm then + begin + try + v := eval(&s); + //s := tostm(v); + r := exportfile(ftstream(),"",fp,v); + it.ReGetLastLoadTime(); + return r; + except end end - rd := FPageEditerMenus["只读"]; - if rd then + r := ReWriteString(fp,s); + it.ReGetLastLoadTime(); + return r; + end + return 1; + end + function ShowFindWnd(); + begin + FInfoShowWnd.ShowByTag(FFindListWnd); + ShowLogWnd(true); + end + function showdbugwnd(); + begin + FInfoShowWnd.ShowByTag(FTslDebug); + ShowLogWnd(true); + end + function ShowEchoWnd(); + begin + FInfoShowWnd.ShowByTag(FEchoWnd); + ShowLogWnd(true); + end + function SwitchLogWnd(); + begin + FInfoShowWnd.Visible := not(FInfoShowWnd.Visible); + DoControlAlign(); + end + function SetFindHistroy(d); + begin + FFindWnd.SetHistory(d); + end + function GetFindHistory(); + begin + return FFindWnd.GetHistory(); + end + function ShowLogWnd(flg); + begin + n :=(ifnil(flg)or flg)?true:false; + if n=FInfoShowWnd.Visible then return; + FInfoShowWnd.Visible := n; + DoControlAlign(); + end + function JudgeItemState(it); //状态处理 + begin + lt := it.GetLastLoadTime(); + nlt := it.ReGetLastLoadTime(); + if not lt then return; + if nlt <> lt then + begin + FPageEditer.FCanDraged := false; + FPageEditer.MouseDrageLeave(); //此处不知为什么会报错 + if not nlt then //已经删除 begin - zd := GetCurrentItem().FEditer.Readonly; - rd.Checked := zd; - it := FPageEditerMenus["粘贴(V)"]; - if it then it.Enabled := not zd; - it := FPageEditerMenus["剪切(X)"]; - if it then it.Enabled := not zd; - end - rd := FPageEditerMenus["查看"]; - if rd then - begin - mtic; - it := GetCurrentEditer(); - s := it.CanJump(); - if s then + if Messageboxa("文件已经被删除,依然保存请按确定","提示",1,self)=IDOK then begin - rd.Caption := "查看:"+s; - rd.Enabled := true; + CreateDirWithFileName(it.OrigScriptPath); //新建 + SavePageItem(it,true); end else begin - rd.Caption := "查看"; - rd.Enabled := false; + DeletepageItem(it); //删除 + return true; end - end - ex := FEchoWnd.Exeing()?true:false; - rd := FPageEditerMenus["执行(F9)"]; - if rd then rd.Enabled := not ex; - rd := FPageEditerMenus["停止执行"]; - if rd then rd.Enabled := ex; - rd := FPageEditerMenus["执行"]; - if rd then + end else //被其他程序修改 begin - end - o.popupMenu := FPageEditerMenu; - //MessageBoxA("MESSAGErclick","tis",0); - end - function createparams(p);override; - begin - inherited; - P.ExStyle := P.ExStyle .| WS_EX_ACCEPTFILES; - end - {$ifdef linux} - function DragQueryFileA(); - {$else} - function DragQueryFileA(hDrop:pointer;iFile:integer;lpszFile:string;cch:integer):integer;stdcall;external "Shell32.dll" name "DragQueryFileA"; - {$endif} - function WMDROPFILES(o,e):WM_DROPFILES; - begin - dn := ""; - opends := array(); - for i := 1 to DragQueryFileA(e.wparam,0xFFFFFFFF,"",0) do - begin - len := DragQueryFileA(e.wparam,i-1,nil,0); - if len>0 then + if Messageboxa(format("%s\r\n被其他程序修改是否重新加载",it.ScriptPath),"提示",1,self)=IDOK then begin - setlength(dn,len+10); - if DragQueryFileA(e.wparam,i-1,dn,len+1)>0 then - begin - opends[length(opends)]:= dn[1:len]; - end - end - end - for i,v in opends do - begin - arr := FileList("",v); - if not(pos("D",arr[0,"Attr"]))then OpenAndGotoFileByName(v); - end - end - function GetOpendPageItemByFileName(n); - begin - its := FPageEditer.PageItems; - for i := 0 to its.Length()-1 do - begin - it := its[i]; - if it.ScriptPathIs(n)then return it; - end - end - function EditerCaretChanged(o,e); - begin - if GetCurrentEditer()=o then - begin - FStatus.setitemtext(format("col:%d | %s",o.CaretX,o.PageItem.EnCode),1); - end - end - function OpenScriptByFileName(n); - begin - if not ifstring(n)then return false; - it := GetOpendPageItemByFileName(n); - if it then return it; - fl := FileList("",n); - if not(length(fl)=1)then return false; - nn := fl[0,"FileName"]; - if(POS("d",fl[0,"Attr"]))then return false; - it := new TPageEditerItem(FPageEditer); - it.FDebuger := FTslDebug; - it.FEditer.OnCaretChanged := thisfunction(EditerCaretChanged); - it.FEditer.Parent := FPageEditer; - it.FEditer.TabChar := FTabChar; - it.FEditer.PageItem := it; - it.FEditer.QuckKeys := Thisfunction(EditerQuckKeys); - it.FEditer.OnTextSetFocus := function(o,e) - begin - //echo "\r\n",o.PageItem.Scriptpath; - JudgeItemState(o.PageItem); - end - FPageEditer.PageItems.push(it); - nn1 := n; - nn1[(length(n)-length(nn)+1):]:= nn; - //echo nn1,"==",n,"\r\n"; - it.ScriptPath := nn1; - it.BitmapA := GetNneedSaveBmp(); - it.BitmapB := Closebmp(); - LoadFromFile(it,true); - for i,v in FReadDirs do - begin - if not ifstring(v)then continue; - if pos(v,n)=1 then + LoadFromFile(it,true); + end else begin - it.FEditer.ReadOnly := true; - break; + it.FEditer.ChangedFlag := true; end end - //DoControlAlign(); - if it then - begin - SetHistoryFiles(n); - it.FEditer.OnRclick := thisfunction(PageEditerOnRClick); - it.FEditer.OnTextChanged := thisfunction(PageITEMtextChanged); - end - return it; end - function GetHistoryFiles(); + end + function PageItemTextChanged(o,flg); + begin + its := FPageEditer.Pageitems; + cit := GetCurrentItem(); + for i := 0 to its.Length()-1 do begin - return FOpenHistory.Data; - end - function SetHistoryFiles(v); - begin - if ifarray(v)then + it := Its[i]; + if it.FEditer=o then begin - for i,vi in v do + if cit=it then begin - SetHistoryFiles(vi); + if it.fisnewfile then Caption := (flg?"*":"")+" new "; + else + Caption :=(flg?"*":"")+it.OrigScriptPath; end + callDatafunction(OnPageEditerChanged,it,flg); + it.BitmapA := flg?GetNeedSaveBmp():GetNneedSaveBmp(); return; end - if ifstring(v)and v then + end + end + function DeletePageItem(it); + begin + idx := FPageEditer.GetItemIndex(it); + if idx >= 0 then + begin + //f := it.OrigScriptPath; + FPageEditer.DeleteItemByIndex(idx); + it.Recycling(); + it := GetCurrentItem(); + if it then it.FEditer.ReCreateCaret(); + //if it.fisnewfile then filedelete("",f); + + end + end + function PageItemSelChanged(o,e);virtual; + begin + it := GetCurrentItem(); + if not it then return; + //if JudgeItemState(it) then return ; + FCurrentItemCode[length(FCurrentItemCode)]:= it; + if it.fisnewfile then + begin + Caption :=(it.FEditer.ChangedFlag?"*":"")+" new "; + end + else + begin + Caption :=(it.FEditer.ChangedFlag?"*":"")+it.OrigScriptPath; + end + CallDatafunction(FOnPageItemSelChanged,self(true),it); + cp := it.FEditer.Completion; + if cp and it.FInitCompletion then + begin + it.FInitCompletion := false; + cp.PrePareCompletion(it.Caption); + end + EditerCaretChanged(it.FEditer,nil); + end + function PageMenuClick(o,e); + begin + it := GetCurrentItem(); + if not it then return; + case o.Caption of + "关闭": begin - fcadd := true; - for i,vi in FOpenHistory.Data do + if it.fisnewfile then //单独处理新建关闭 + begin + f := it.OrigScriptPath; + DeletePageItem(it); + if fileexists("",f) then filedelete("",f); + + return ; + end + if JudgeItemState(it)then return; + if it.FEditer.ChangedFlag then begin - if filenameIsTheSame(v,vi)then + mr := MessageboxA(format("是否保存:%s",it.OrigScriptPath),"提示",3,self); + if mr=IDYES then begin - fcadd := false; + if SavePageItem(it)=0 then + begin + it.FEditer.ChangedFlag := true; + return 0; + end + end else + if mr=IDCANCEL then + begin + return; + end + end + DeletePageItem(it); + end + "关闭其他标签": + begin + Cit := it; + its := GetAllPageItems(); + for i := 0 to its.Length()-1 do + begin + it := its[i]; + if it.FEditer.ChangedFlag then + begin + r := MessageBoxA("存在未保存的文件,是否保存!","提示",3,self); + if r=IDYES then + begin + SaveAllPageItems(); + break; + end else + if r=IDCANCEL then + begin + return; + end else + begin + end break; end end - if fcadd then - begin - FOpenHistory.Push(v); - if FOpenHistory.Length()>30 then FOpenHistory.shift(); - end + CloseAllPageItems(Cit); end - end - function ShowHistoryWnd(); - begin - if not FHistoryWnd then - begin - FHistoryWnd := new TMouseMoveList(self); - FHistoryWnd.Visible := false; - FHistoryWnd.WSpOPUp := true; - FHistoryWnd.Parent := self; - FHistoryWnd.Caption := "打开历史...."; - FHistoryWnd.WSsysMenu := true; - FHistoryWnd.WsSizeBox := true; - FHistoryWnd.Width := 400; - FHistoryWnd.Height := 600; - {FHistoryClearMenuPop := new TPopUpMenu(self); - FHistoryClearMenu := new TMenu(self); - FHistoryClearMenu.Caption := "清空历史记录"; - FHistoryClearMenu.Parent := FHistoryClearMenuPop; - FHistoryWnd.PopUpMenu := FHistoryClearMenu; - FHistoryClearMenu.OnClick := function(o,e)begin - FHistoryWnd.SetData(array()); - FOpenHistory.Splices(0,FOpenHistory.Length()); - end } - FHistoryWnd.OnClose := function(o,e) + "另存为": + begin + if JudgeItemState(it)then return; + //FFileopen.OverwritePrompt := true; + if FFileSave.OpenDlg()then begin - o.EndModal(); - o.Visible := false; - e.skip := true; - end - FHistoryWnd.OnClick := function(o,e) - begin - idx := o.getCurrentSelection(); - if idx >= 0 then + fn := FFileSave.FileName; + dfn := it.ScriptPath; + CreateDirWithFileName(fn); + //echo format('FileCopy("","%s","","%s",false)',dfn,fn); + ret := FileCopy("",dfn,"",fn,false); + if ret then begin - n := o.GetItem(idx); - o.EndModal(); - O.Visible := false; - OpenAndGotoFileByName(n); + it.ScriptPath := fn; + if SavePageItem(it)=0 then + begin + it.FEditer.ChangedFlag := true; + end + if it.fisnewfile then + begin + FileDelete("",dfn); + it.fisnewfile := false; + end end end + //FFileopen.OverwritePrompt := false; end - if FOpenHistory.Length()>0 then + "重新加载": begin - FHistoryWnd.SetData(FOpenHistory.Data); - InitShowWndPos(FHistoryWnd,"history",100,100); - FHistoryWnd.ShowModal(); + LoadFromFile(it,true); + end + "复制文件全名": + begin + if not FCliper then FCliper := new TClipBoard(self); + FCliper.text := it.OrigScriptPath; + end + "复制文件名": + begin + if not FCliper then FCliper := new TClipBoard(self); + FCliper.text := it.Caption; + end + "打开目录": + begin + p := it.ScriptPath; + if FileExists("",p)then + begin + for i := length(p)downto 3 do + begin + if p[i]="\\" then + begin + p := p[1:i]; + break; + end + end + //_wapi.WinExec('cmd.exe /C start "" "'+p,1); + _wapi.openresourcemanager(p); + end + end + "采用cmd执行": + begin + //ExecutePageItemWithCmd(it); end end - function OpenAndGoLineByName(n,L); + end + function PageItemOnRClick(o,e); + begin + if FPageEditer.GetItemIndexByPos(e.pos)>= 0 then o.PopUpMenu := FPageMenu; + else o.PoPupMenu := nil; + end + function PageEditerMenuClick(o,e); + begin + if pos("复制",o.caption)=1 then begin - it := OpenScriptByFileName(n); + it := GetCurrentItem(); if it then begin - if l>0 then + ed := it.FEditer; + if ed then begin - ed := it.FEditer; - ed.ExecuteCommand(ed.ecGoToXY,array(L,1)); + ed.ExecuteCommand(ed.ecCopy); end + //it.FEditer.ReadOnly := not(o.Checked); end - return it; - end - function OpenAndGotoFileByName(n,L); + return; + end else + if pos("粘贴",o.caption)=1 then begin - bit := GetCurrentItem(); - if bit then + it := GetCurrentItem(); + if it then begin - if not((ifnil(L)or(L=bit.FEditer.CaretY))and(filenameIsTheSame(n,bit.ScriptPath)))then + ed := it.FEditer; + if ed then begin - bit := array("file":bit.OrigScriptPath,"line":bit.FEditer.CaretY); - if FRebackFlag then FGoBackB.Push(bit); - else FGoBackA.Push(bit); + ed.ExecuteCommand(ed.ecPaste); end + //it.FEditer.ReadOnly := not(o.Checked); end - it := OpenAndGoLineByName(n,L); - if it then FPageEditer.SetSel(it); - return it; - end - function CommetCurrentSel(); //注释选择 + return; + end else + if pos("剪切",o.caption)=1 then begin + it := GetCurrentItem(); + if it then + begin + ed := it.FEditer; + if ed then + begin + ed.ExecuteCommand(ed.ecCut); + end + //it.FEditer.ReadOnly := not(o.Checked); + end + return; + end else + if pos("定位",o.caption)=1 then + begin + InitShowWndPos(FGotoLineWnd,"g",200,200); + FGotoLineWnd.ShowGoto(); + return; + end else + if pos("查看",o.caption)=1 then + begin + cs := o.Caption; + if length(cs)<6 then return; + s :=(o.Caption)[6:]; + GetCurrentEditer().Tryjump(s); + return; + end else + if pos("只读",o.caption)=1 then + begin + it := GetCurrentItem(); + if it then + begin + it.FEditer.ReadOnly := not(o.Checked); + end + return; + end else + if pos("执行",o.Caption)=1 then + begin + it := GetCurrentItem(); + ExecutePageItem(it); + return; + end else + if pos("停止",o.Caption)=1 then + begin + if FEchoWnd.Exeing()then FEchoWnd.EndExe(); + return; + end else + if o.Caption = "转换为大写" then + begin + upperorlowercase(1); + end else + if o.Caption = "转换为小写" then + begin + upperorlowercase(0); + end else + if o.Caption = "删除尾空白" then + begin + seltrimright(); + end + end + function PageEditerOnRClick(o,e); + begin + o.popupMenu := nil; + if not FPageEditerMenu then + begin + FPageEditerMenu := new TPopUpMenu(self); + FPageEditerMenus := array(); + for i,v in array("查看","复制(C)","粘贴(V)","剪切(X)","定位(G)","只读","转换为大写","转换为小写","删除尾空白","执行(F9)","停止执行") do + begin + it := new TMenu(self); + it.Caption := v; + it.parent := FPageEditerMenu; + FPageEditerMenus[v]:= it; + it.OnClick := thisfunction(PageEditerMenuClick); + end + end + rd := FPageEditerMenus["只读"]; + if rd then + begin + zd := GetCurrentItem().FEditer.Readonly; + rd.Checked := zd; + it := FPageEditerMenus["粘贴(V)"]; + if it then it.Enabled := not zd; + it := FPageEditerMenus["剪切(X)"]; + if it then it.Enabled := not zd; + end + rd := FPageEditerMenus["查看"]; + if rd then + begin + mtic; it := GetCurrentEditer(); - if it then + s := it.CanJump(); + if s then begin - if it.ReadOnly then return; - bg := it.BlockBegin; - ed := it.BlockEnd; - if bg and ed and ed[0]<> bg[0]then + rd.Caption := "查看:"+s; + rd.Enabled := true; + end else + begin + rd.Caption := "查看"; + rd.Enabled := false; + end + end + ex := FEchoWnd.Exeing()?true:false; + rd := FPageEditerMenus["执行(F9)"]; + if rd then rd.Enabled := not ex; + rd := FPageEditerMenus["停止执行"]; + if rd then rd.Enabled := ex; + rd := FPageEditerMenus["执行"]; + if rd then + begin + end + o.popupMenu := FPageEditerMenu; + //MessageBoxA("MESSAGErclick","tis",0); + end + function createparams(p);override; + begin + inherited; + P.ExStyle := P.ExStyle .| WS_EX_ACCEPTFILES; + end + {$ifdef linux} + function DragQueryFileA(); + {$else} + function DragQueryFileA(hDrop:pointer;iFile:integer;lpszFile:string;cch:integer):integer;stdcall;external "Shell32.dll" name "DragQueryFileA"; + {$endif} + function WMDROPFILES(o,e):WM_DROPFILES; + begin + dn := ""; + opends := array(); + for i := 1 to DragQueryFileA(e.wparam,0xFFFFFFFF,"",0) do + begin + len := DragQueryFileA(e.wparam,i-1,nil,0); + if len>0 then + begin + setlength(dn,len+10); + if DragQueryFileA(e.wparam,i-1,dn,len+1)>0 then begin - it.ExecuteCommand(it.ecTab,"//"); - end else + opends[length(opends)]:= dn[1:len]; + end + end + end + for i,v in opends do + begin + arr := FileList("",v); + if not(pos("D",arr[0,"Attr"]))then OpenAndGotoFileByName(v); + end + end + function GetOpendPageItemByFileName(n); + begin + its := FPageEditer.PageItems; + for i := 0 to its.Length()-1 do + begin + it := its[i]; + if it.ScriptPathIs(n)then return it; + end + end + function EditerCaretChanged(o,e); + begin + if GetCurrentEditer()=o then + begin + FStatus.setitemtext(format("col:%d | %s",o.CaretX,o.PageItem.EnCode),1); + end + end + function OpenScriptByFileName(n); + begin + if not ifstring(n)then return false; + it := GetOpendPageItemByFileName(n); + if it then return it; + fl := FileList("",n); + if not(length(fl)=1)then return false; + nn := fl[0,"FileName"]; + if(POS("d",fl[0,"Attr"]))then return false; + it := new TPageEditerItem(FPageEditer); + it.FDebuger := FTslDebug; + it.FEditer.OnCaretChanged := thisfunction(EditerCaretChanged); + it.FEditer.Parent := FPageEditer; + it.FEditer.TabChar := FTabChar; + it.FEditer.PageItem := it; + it.FEditer.QuckKeys := Thisfunction(EditerQuckKeys); + it.FEditer.OnTextSetFocus := function(o,e) + begin + //echo "\r\n",o.PageItem.Scriptpath; + JudgeItemState(o.PageItem); + end + FPageEditer.PageItems.push(it); + nn1 := n; + nn1[(length(n)-length(nn)+1):]:= nn; + //echo nn1,"==",n,"\r\n"; + it.ScriptPath := nn1; + it.BitmapA := GetNneedSaveBmp(); + it.BitmapB := Closebmp(); + LoadFromFile(it,true); + for i,v in FReadDirs do + begin + if not ifstring(v)then continue; + if pos(v,n)=1 then + begin + it.FEditer.ReadOnly := true; + break; + end + end + //DoControlAlign(); + if it then + begin + SetHistoryFiles(n); + it.FEditer.OnRclick := thisfunction(PageEditerOnRClick); + it.FEditer.OnTextChanged := thisfunction(PageITEMtextChanged); + end + return it; + end + function GetHistoryFiles(); + begin + return FOpenHistory.Data; + end + function SetHistoryFiles(v); + begin + if ifarray(v)then + begin + for i,vi in v do + begin + SetHistoryFiles(vi); + end + return; + end + if ifstring(v)and v then + begin + fcadd := true; + for i,vi in FOpenHistory.Data do + begin + if filenameIsTheSame(v,vi)then + begin + fcadd := false; + break; + end + end + if fcadd then + begin + FOpenHistory.Push(v); + if FOpenHistory.Length()>30 then FOpenHistory.shift(); + end + end + end + function ShowHistoryWnd(); + begin + if not FHistoryWnd then + begin + FHistoryWnd := new TMouseMoveList(self); + FHistoryWnd.Visible := false; + FHistoryWnd.WSpOPUp := true; + FHistoryWnd.Parent := self; + FHistoryWnd.Caption := "打开历史...."; + FHistoryWnd.WSsysMenu := true; + FHistoryWnd.WsSizeBox := true; + FHistoryWnd.Width := 400; + FHistoryWnd.Height := 600; + {FHistoryClearMenuPop := new TPopUpMenu(self); + FHistoryClearMenu := new TMenu(self); + FHistoryClearMenu.Caption := "清空历史记录"; + FHistoryClearMenu.Parent := FHistoryClearMenuPop; + FHistoryWnd.PopUpMenu := FHistoryClearMenu; + FHistoryClearMenu.OnClick := function(o,e)begin + FHistoryWnd.SetData(array()); + FOpenHistory.Splices(0,FOpenHistory.Length()); + end } + FHistoryWnd.OnClose := function(o,e) + begin + o.EndModal(); + o.Visible := false; + e.skip := true; + end + FHistoryWnd.OnClick := function(o,e) + begin + idx := o.getCurrentSelection(); + if idx >= 0 then + begin + n := o.GetItem(idx); + o.EndModal(); + O.Visible := false; + OpenAndGotoFileByName(n); + end + end + end + if FOpenHistory.Length()>0 then + begin + FHistoryWnd.SetData(FOpenHistory.Data); + InitShowWndPos(FHistoryWnd,"history",100,100); + FHistoryWnd.ShowModal(); + end + end + function OpenAndGoLineByName(n,L); + begin + it := OpenScriptByFileName(n); + if it then + begin + if l>0 then + begin + ed := it.FEditer; + ed.ExecuteCommand(ed.ecGoToXY,array(L,1)); + end + end + return it; + end + function OpenAndGotoFileByName(n,L); + begin + bit := GetCurrentItem(); + if bit then + begin + if not((ifnil(L)or(L=bit.FEditer.CaretY))and(filenameIsTheSame(n,bit.ScriptPath)))then + begin + bit := array("file":bit.OrigScriptPath,"line":bit.FEditer.CaretY); + if FRebackFlag then FGoBackB.Push(bit); + else FGoBackA.Push(bit); + end + end + it := OpenAndGoLineByName(n,L); + if it then FPageEditer.SetSel(it); + return it; + end + function CommetCurrentSel(); //注释选择 + begin + it := GetCurrentEditer(); + if it then + begin + if it.ReadOnly then return; + bg := it.BlockBegin; + ed := it.BlockEnd; + if bg and ed and ed[0]<> bg[0]then + begin + it.ExecuteCommand(it.ecTab,"//"); + end else + begin + it.ExecuteCommand(it.ecLineStart); + it.ExecuteCommand(it.ecString,"//"); + end + end + end + function UnCommentCurrentSel(); //取消注释 + begin + it := GetCurrentEditer(); + if it then + begin + if it.ReadOnly then return; + bg := it.BlockBegin; + ed := it.BlockEnd; + if bg and ed and bg[0]<> ed[0]then + begin + it.ExecuteCommand(it.ecShifttab,array("//")); + end else + begin + s := it.LineText; + if pos("//",s)=1 then begin it.ExecuteCommand(it.ecLineStart); - it.ExecuteCommand(it.ecString,"//"); + it.ExecuteCommand(it.ecSelLineEnd); + if length(s)>= 3 then it.ExecuteCommand(it.ecString,s[3:]); + else it.ExecuteCommand(it.ecString,""); end end end - function UnCommentCurrentSel(); //取消注释 + end + function UnDoCurrentEditer(); + begin + it := GetCurrentEditer(); + if it then begin - it := GetCurrentEditer(); - if it then + if it.ReadOnly then return; + self.Enabled := false; + it.ExecuteCommand(it.ecUndo); + self.Enabled := true; + if it.ChangedFlag then begin - if it.ReadOnly then return; - bg := it.BlockBegin; - ed := it.BlockEnd; - if bg and ed and bg[0]<> ed[0]then + cit := GetCurrentItem(); + if it.Text=cit.LastText then // begin - it.ExecuteCommand(it.ecShifttab,array("//")); - end else - begin - s := it.LineText; - if pos("//",s)=1 then - begin - it.ExecuteCommand(it.ecLineStart); - it.ExecuteCommand(it.ecSelLineEnd); - if length(s)>= 3 then it.ExecuteCommand(it.ecString,s[3:]); - else it.ExecuteCommand(it.ecString,""); - end + it.ChangedFlag := false; end end end - function UnDoCurrentEditer(); - begin - it := GetCurrentEditer(); - if it then + end + function ToolClick(o,e); // + begin + case o.caption of + "打开文件": begin - if it.ReadOnly then return; - self.Enabled := false; - it.ExecuteCommand(it.ecUndo); - self.Enabled := true; - if it.ChangedFlag then + OpenAFile(); + //FPages.OpenAFile(); + end + "新建": + begin + CreateAFile(); + //FPages.CreateAFile(); + end + "保存全部": + begin + return SaveAllPageItems(); + end + "保存": + begin + it := GetCurrentItem(); + if SavePageItem(it)=0 then begin - cit := GetCurrentItem(); - if it.Text=cit.LastText then // - begin - it.ChangedFlag := false; - end + it.FEditer.ChangedFlag := true; end end - end - function ToolClick(o,e); // - begin - case o.caption of - "打开文件": + "取消注释": + begin + UnCommentCurrentSel(); + end + "注释": + begin + CommetCurrentSel(); + end + "快捷键说明": + begin + s := ""; + s += "ctrl+o 打开\r\n"; + s += "ctrl+N 新建\r\n"; + s += "ctrl+s 保存\r\n"; + s += "ctrl+F 查找窗口\r\n"; + s += "ctrl+R 替换窗口\r\n"; + s += "ctrl+a 全选\r\n"; + s += "ctrl+c 拷贝选择\r\n"; + s += "ctrl+D 复制被插入当前行\r\n"; + s += "ctrl+v 粘贴\r\n"; + s += "ctrl+x 剪切选择\r\n"; + s += "ctrl+G 定位到行\r\n"; + s += "ctrl+L|Y 删除当前行\r\n"; + s += "tab | shift+tab 多行选中时缩进\r\n"; + s += "ctrl+/ 注释当前选择\r\n"; + s += "ctrl+\\ 取消当前注释\r\n"; + s += "ctrl+U 反撤销\r\n"; + s += "ctrl+z 撤销\r\n"; + s += "ctrl+tab 切换标签\r\n"; + s += "F2 跳转到下一个断点行\r\n"; + s += "F5 添加删除断点\r\n"; + s += "Alt+F5 将选中字符串转换为大写\r\n"; + s += "ctl+F5 将选中字符串转换为小写\r\n"; + s += "F3 正向搜索先前搜索的字符\r\n"; + s += "ctrl+F3 反向搜索先前搜索的字符\r\n"; + s += "ctrl+tab 切换标签页\r\n"; + s += "F9 执行当前页的代码\r\n"; + s += "ctrl+F9 打开执行代码编辑器\r\n"; + s += "F7 显示隐藏日志窗口\r\n"; + s += "F1 对于tsl语言查找当前光标所在位置的帮助\r\n"; + s += "alt+m 弹出tsl代码地图\r\n"; + messageboxa(s,"快捷键说明",0,self); + end + "撤销": + begin + UnDoCurrentEditer(); + end + "反撤销": + begin + it := GetCurrentEditer(); + if it then begin - OpenAFile(); - //FPages.OpenAFile(); + if it.ReadOnly then return; + self.Enabled := false; + it.ExecuteCommand(it.ecRedo); + self.Enabled := true; end - "新建": + end + "tsl语法检查": + begin + it := GetCurrentEditer(); + if it then begin - CreateAFile(); - //FPages.CreateAFile(); - end - "保存全部": - begin - return SaveAllPageItems(); - end - "保存": - begin - it := GetCurrentItem(); - if SavePageItem(it)=0 then + if not CheckTslCode(it.Text,err)then begin - it.FEditer.ChangedFlag := true; + Messageboxa(err,"提示",0,self); + end else + messageboxa("符合tsl语法","提示",0,self); + end + end + "tsl代码格式化": + begin + it := GetCurrentEditer(); + if it then + begin + if 1 <> MessageboxA("将格式化代码!!","提示",1,self.Handle)then return; + if it.ReadOnly then return; + //sel := FCodeFormatInfo["sel"]; + syn := FCodeFormatInfo["syn"]; + arraytype := FCodeFormatInfo["arraytype"]; + cftype :=(FCodeFormatInfo["cmt"]=1); + arraytype :=(arraytype in array(0,1,3))?arraytype:1; + sel := true; + sel2 := false; + if sel then + begin + s := it.SelText; + if s then sel2 := true; end - end - "取消注释": - begin - UnCommentCurrentSel(); - end - "注释": - begin - CommetCurrentSel(); - end - "快捷键说明": - begin - s := ""; - s += "ctrl+o 打开\r\n"; - s += "ctrl+N 新建\r\n"; - s += "ctrl+s 保存\r\n"; - s += "ctrl+F 查找窗口\r\n"; - s += "ctrl+R 替换窗口\r\n"; - s += "ctrl+a 全选\r\n"; - s += "ctrl+c 拷贝选择\r\n"; - s += "ctrl+D 复制被插入当前行\r\n"; - s += "ctrl+v 粘贴\r\n"; - s += "ctrl+x 剪切选择\r\n"; - s += "ctrl+G 定位到行\r\n"; - s += "ctrl+L|Y 删除当前行\r\n"; - s += "tab | shift+tab 多行选中时缩进\r\n"; - s += "ctrl+/ 注释当前选择\r\n"; - s += "ctrl+\\ 取消当前注释\r\n"; - s += "ctrl+U 反撤销\r\n"; - s += "ctrl+z 撤销\r\n"; - s += "ctrl+tab 切换标签\r\n"; - s += "F2 跳转到下一个断点行\r\n"; - s += "F5 添加删除断点\r\n"; - s += "Alt+F5 将选中字符串转换为大写\r\n"; - s += "ctl+F5 将选中字符串转换为小写\r\n"; - s += "F3 正向搜索先前搜索的字符\r\n"; - s += "ctrl+F3 反向搜索先前搜索的字符\r\n"; - s += "ctrl+tab 切换标签页\r\n"; - s += "F9 执行当前页的代码\r\n"; - s += "ctrl+F9 打开执行代码编辑器\r\n"; - s += "F7 显示隐藏日志窗口\r\n"; - s += "F1 对于tsl语言查找当前光标所在位置的帮助\r\n"; - s += "alt+m 弹出tsl代码地图\r\n"; - messageboxa(s,"快捷键说明",0,self); - end - "撤销": - begin - UnDoCurrentEditer(); - end - "反撤销": - begin - it := GetCurrentEditer(); - if it then + if not s then begin - if it.ReadOnly then return; - self.Enabled := false; - it.ExecuteCommand(it.ecRedo); - self.Enabled := true; + s := it.Text; end - end - "tsl语法检查": - begin - it := GetCurrentEditer(); - if it then + if not s then return; + if syn then begin - if not CheckTslCode(it.Text,err)then + if not CheckTslCode(s,err)then begin - Messageboxa(err,"提示",0,self); - end else - messageboxa("符合tsl语法","提示",0,self); - end - end - "tsl代码格式化": - begin - it := GetCurrentEditer(); - if it then - begin - if 1 <> MessageboxA("将格式化代码!!","提示",1,self.Handle)then return; - if it.ReadOnly then return; - //sel := FCodeFormatInfo["sel"]; - syn := FCodeFormatInfo["syn"]; - arraytype := FCodeFormatInfo["arraytype"]; - cftype :=(FCodeFormatInfo["cmt"]=1); - arraytype :=(arraytype in array(0,1,3))?arraytype:1; - sel := true; - sel2 := false; - if sel then - begin - s := it.SelText; - if s then sel2 := true; + return Messageboxa(err,"提示-tsl语法错误",0,self); end - if not s then + end + try + Enabled := false; + fs := UNIT(UTslCodeFormat).FormatTsl(s,FTabWidth,wordct,charct,arraytype,cftype); + if fs <> s then begin - s := it.Text; - end - if not s then return; - if syn then - begin - if not CheckTslCode(s,err)then + if sel and sel2 then begin - return Messageboxa(err,"提示-tsl语法错误",0,self); + it.SelText := fs; + end else + begin + it.Text := fs; + it.ExecuteCommand(it.ecGotoXY,array(1,1)); end end - try - Enabled := false; - fs := UNIT(UTslCodeFormat).FormatTsl(s,FTabWidth,wordct,charct,arraytype,cftype); - if fs <> s then - begin - if sel and sel2 then - begin - it.SelText := fs; - end else - begin - it.Text := fs; - it.ExecuteCommand(it.ecGotoXY,array(1,1)); - end - end - finally - Enabled := true; - end; - end - end - "查找": - begin - FFindWnd.Show(); - end - "前进": - begin - GoToReBack(); - end - "后退": - begin - GoToBack(); - end - "代码地图(alt+m)": - begin - InitShowWndPos(FCodeMap,"cm",250,100); - FCodeMap.ShowMap(); + finally + Enabled := true; + end; end end - end - function GetCurrentItem(); - begin - return FPageEditer.CurrentItem; - end - function GetCurrentEditer(); - begin - it := GetCurrentItem(); - if it then return it.FEditer; - end - function DoControlAlign();override; // 对齐 - begin - if not(FPageEditer and FPageEditer.parent=self)then return; - rr := ClientRect; - r := rr; - th := FToolbar.CalcHeightFixWidth(rr[2]-rr[0]); - //FToolbar.Height := th; - r[3]:= r[0]+th; - FToolBar.SetBoundsRect(r); - r := rr; - r[1]:= r[3]-FStatus.Height; - FStatus.SetBoundsRect(r); - rr := rr; - rr[1]:= FToolbar.Height+1; - rr[3]:= rr[3]-FStatus.Height-1; - {if ffolderdlg and ffolderdlg.Visible then + "查找": begin - r := rr; - fwd := min(ffolderdlg.Width,integer(r[2] * 0.6)); - r[2] := r[0]+fwd; - rr[0] := r[2]+1; - ffolderdlg.SetBoundsRect(r); - end } - if FInfoShowWnd.Visible and not(FInfoShowWnd.WSpOPUp)then - begin - r := rr; - - r[1]:= r[3]-min(FInfoShowWnd.Height,integer(r[3] * 0.6)); - rr[3]:= r[1]-1; - - {fwd := min(FInfoShowWnd.Width,integer(r[2] * 0.6)); //右侧 - r[0] := r[2]-fwd; - rr[2] := r[0]-1;} - FInfoShowWnd.SetBoundsRect(r); + FFindWnd.Show(); end - FPageEditer.SetBoundsRect(rr); - end - function CreateAFile(); //构造文件 - begin - if FTslCacheDir then + "前进": begin - idx := 0; - while true do + GoToReBack(); + end + "后退": + begin + GoToBack(); + end + "代码地图(alt+m)": + begin + InitShowWndPos(FCodeMap,"cm",250,100); + FCodeMap.ShowMap(); + end + end + end + function GetCurrentItem(); + begin + return FPageEditer.CurrentItem; + end + function GetCurrentEditer(); + begin + it := GetCurrentItem(); + if it then return it.FEditer; + end + function DoControlAlign();override; // 对齐 + begin + if not(FPageEditer and FPageEditer.parent=self)then return; + rr := ClientRect; + r := rr; + th := FToolbar.CalcHeightFixWidth(rr[2]-rr[0]); + //FToolbar.Height := th; + r[3]:= r[0]+th; + FToolBar.SetBoundsRect(r); + r := rr; + r[1]:= r[3]-FStatus.Height; + FStatus.SetBoundsRect(r); + rr := rr; + rr[1]:= FToolbar.Height+1; + rr[3]:= rr[3]-FStatus.Height-1; + {if ffolderdlg and ffolderdlg.Visible then + begin + r := rr; + fwd := min(ffolderdlg.Width,integer(r[2] * 0.6)); + r[2] := r[0]+fwd; + rr[0] := r[2]+1; + ffolderdlg.SetBoundsRect(r); + end } + if FInfoShowWnd.Visible and not(FInfoShowWnd.WSpOPUp)then + begin + r := rr; + + r[1]:= r[3]-min(FInfoShowWnd.Height,integer(r[3] * 0.6)); + rr[3]:= r[1]-1; + + {fwd := min(FInfoShowWnd.Width,integer(r[2] * 0.6)); //右侧 + r[0] := r[2]-fwd; + rr[2] := r[0]-1;} + FInfoShowWnd.SetBoundsRect(r); + end + FPageEditer.SetBoundsRect(rr); + end + function CreateAFile(); //构造文件 + begin + if FTslCacheDir then + begin + idx := 0; + while true do + begin + idx++; + fn := FTslCacheDir+"newfile"+ioFileseparator()+"new"+inttostr(idx); + if fileexists("",fn) then continue; + r := ReWriteString(fn,""); + if r=1 then begin - idx++; - fn := FTslCacheDir+"newfile"+ioFileseparator()+"new"+inttostr(idx); - if fileexists("",fn) then continue; - r := ReWriteString(fn,""); - if r=1 then - begin - it := OpenAndGotoFileByName(fn); - it.fisnewfile := true; - end - return ; + it := OpenAndGotoFileByName(fn); + it.fisnewfile := true; end + return ; end - FFileopen.Caption := "新建文件--输入文件名点击打开"; - FFileopen.Multiselected := false; - it := GetCurrentItem(); - if it then + end + FFileopen.Caption := "新建文件--输入文件名点击打开"; + FFileopen.Multiselected := false; + it := GetCurrentItem(); + if it then + begin + s := it.ScriptPath; + sp := ioFileseparator(); + for i := length(s)downto 2 do begin + if s[i]=sp then + begin + FFileopen.initialDir := s[1:i-1]; + break; + end + end + end + if FFileopen.Opendlg()then + begin + exen := FFileopen.FileName; + if FileExists("",exen)then + begin + r := true; + end else + r := ReWriteString(exen,""); //exportfile(ftstream(),"",exen,"//createBytsl"); + if r=1 then OpenAndGotoFileByName(exen); + end + end + function OpenAFile(); //打开文件 + begin + FFileopen.Caption := "打开文件"; + FFileopen.Multiselected := true; + it := GetCurrentItem(); + if it then + begin + if not it.fisnewfile then + begin s := it.ScriptPath; sp := ioFileseparator(); - for i := length(s)downto 2 do + for i := length(s)downto 3 do begin if s[i]=sp then begin @@ -5657,1040 +5688,1009 @@ end break; end end - end - if FFileopen.Opendlg()then - begin - exen := FFileopen.FileName; - if FileExists("",exen)then - begin - r := true; - end else - r := ReWriteString(exen,""); //exportfile(ftstream(),"",exen,"//createBytsl"); - if r=1 then OpenAndGotoFileByName(exen); - end + end end - function OpenAFile(); //打开文件 + if FFileopen.Opendlg()then begin - FFileopen.Caption := "打开文件"; - FFileopen.Multiselected := true; - it := GetCurrentItem(); - if it then + rs := FFileopen.getResults(); + //echo tostn(rs); + lenrs := length(rs); + for i,v in rs do begin - if not it.fisnewfile then - begin - s := it.ScriptPath; - sp := ioFileseparator(); - for i := length(s)downto 3 do - begin - if s[i]=sp then - begin - FFileopen.initialDir := s[1:i-1]; - break; - end - end - end - end - if FFileopen.Opendlg()then - begin - rs := FFileopen.getResults(); - //echo tostn(rs); - lenrs := length(rs); - for i,v in rs do + if lenrs=1 and not(FileList("",v))then begin - if lenrs=1 and not(FileList("",v))then + if MessageboxA("文件不存在,点击确定新建.点击取消退出","提示",1)=IDOK then begin - if MessageboxA("文件不存在,点击确定新建.点击取消退出","提示",1)=IDOK then - begin - ReWriteString(v,""); - end + ReWriteString(v,""); end - OpenAndGotoFileByName(v,1); end + OpenAndGotoFileByName(v,1); end end - function GoToBack(); + end + function GoToBack(); + begin + FRebackFlag := true; + it := FGoBackA.Pop(); + if it then OpenAndGotoFileByName(it["file"],it["line"]); + FRebackFlag := false; + end + function GoToReBack(); + begin + it := FGoBackB.Pop(); + if it then OpenAndGotoFileByName(it["file"],it["line"]); + end + function seltrimright(); + begin + ed := GetCurrentEditer(); + IF not ed then return; + //ed.Lines.SetValueByIndex + b := ed.BlockBegin; + e1 := ed.BlockEnd; + + + try + if b and e1 then + begin + ed.IncPaintLock(); + for i := b[0] to e1[0] do + begin + s1 := ed.Lines.GetValueByIndex(i-1).FStr; + s := trimright(s1); + if s1=s then continue; + ed.Lines.SetValueByIndex(i-1,s); + end + ed.ExecuteCommand(ed.ecGoToXY,b); + ed.ExecuteCommand(ed.ecSelGotoXY,e1); + ed.DecPaintLock(); + end else begin - FRebackFlag := true; - it := FGoBackA.Pop(); - if it then OpenAndGotoFileByName(it["file"],it["line"]); - FRebackFlag := false; - end - function GoToReBack(); + s1 := ed.LineText; + s := trimright(s1); + if s1<>s then ed.LineText :=s; + end + + except + + end; + + + end + function upperorlowercase(f); + begin + ed := GetCurrentEditer(); + IF not ed then return; + s := ed.SelText; + if s then begin - it := FGoBackB.Pop(); - if it then OpenAndGotoFileByName(it["file"],it["line"]); - end - function seltrimright(); - begin - ed := GetCurrentEditer(); - IF not ed then return; - //ed.Lines.SetValueByIndex b := ed.BlockBegin; e1 := ed.BlockEnd; - - - try - if b and e1 then - begin - ed.IncPaintLock(); - for i := b[0] to e1[0] do + ed.SelText := f?uppercase(s):lowercase(s); + ed.ExecuteCommand(ed.ecGoToXY,b); + ed.ExecuteCommand(ed.ecSelGotoXY,e1); + end + end + function EditerQuckKeys(o,e);virtual; //快捷键 + begin + if e.Result = 0 then + begin + case e.charcode of + VK_F9: begin - s1 := ed.Lines.GetValueByIndex(i-1).FStr; - s := trimright(s1); - if s1=s then continue; - ed.Lines.SetValueByIndex(i-1,s); - end - ed.ExecuteCommand(ed.ecGoToXY,b); - ed.ExecuteCommand(ed.ecSelGotoXY,e1); - ed.DecPaintLock(); - end else - begin - s1 := ed.LineText; - s := trimright(s1); - if s1<>s then ed.LineText :=s; - end - - except - + if ssctrl in e.ShiftState()then + begin + ShowExeEditer(); + e.skip := true; + return true; + end + ExecutePageItem(GetCurrentItem()); + e.skip := true; + return true; + end end; - - end - function upperorlowercase(f); + if e.Result=0 and(ssAlt in e.shiftstate)then begin - ed := GetCurrentEditer(); - IF not ed then return; - s := ed.SelText; - if s then - begin - b := ed.BlockBegin; - e1 := ed.BlockEnd; - ed.SelText := f?uppercase(s):lowercase(s); - ed.ExecuteCommand(ed.ecGoToXY,b); - ed.ExecuteCommand(ed.ecSelGotoXY,e1); - end - end - function EditerQuckKeys(o,e);virtual; //快捷键 - begin - if e.Result = 0 then - begin - case e.charcode of - VK_F9: - begin - if ssctrl in e.ShiftState()then - begin - ShowExeEditer(); - e.skip := true; - return true; - end - ExecutePageItem(GetCurrentItem()); - e.skip := true; - return true; - end - end; - end - if e.Result=0 and(ssAlt in e.shiftstate)then - begin - case e.charcode of - VK_F5: //大写 - begin - upperorlowercase(1); - e.skip := true; - return true; - end - ord("M"): - begin - InitShowWndPos(FCodeMap,"cm",250,100); - FCodeMap.ShowMap(); - e.skip := true; - return true; - end + case e.charcode of + VK_F5: //大写 + begin + upperorlowercase(1); + e.skip := true; + return true; + end + ord("M"): + begin + InitShowWndPos(FCodeMap,"cm",250,100); + FCodeMap.ShowMap(); + e.skip := true; + return true; end end - if ssCtrl in e.ShiftState then - begin - if e.Result=0 then //down - begin - case e.CharCode of - 220,191: - begin - if e.CharCode=220 then UnCommentCurrentSel(); - else CommetCurrentSel(); - e.skip := true; - return true; - end - VK_F5: //小写 - begin - upperorlowercase(0); - return true; - end - ord("D"): - begin - ed := GetCurrentEditer(); - if not ed then return; - if ed.ReadOnly then return; - //xy := ed.CaretY; - ed.ExecuteCommand(ed.ecLineEnd,nil); - S := ed.LineText; - ed.ExecuteCommand(ed.ecString,"\r\n"+s); - return; - end - ord("R"): - begin - InitShowWndPos(FFindWnd,"fr",200,150); - FFindWnd.oPENreplace(); - FFindWnd.Show(); - return true; - end - ord("E"): - begin - ed := GetCurrentEditer(); - IF not ed then return; - s := ed.CaretWords(); - if s then ed.Tryjump(s); - return true; - end - ord("F"): - begin - InitShowWndPos(FFindWnd,"fr",200,150); - FFindWnd.OpenFind(); - FFindWnd.Show(); - return true; - end - ord("G"): - begin - InitShowWndPos(FGotoLineWnd,"g",200,200); - FGotoLineWnd.ShowGoto(); - return true; - end - {ord("O"): - begin - OpenAfile(); - return true; - end - ord("N"): - begin - CreateAfile(); - return true; - end} - ord("Z"): - begin - UnDoCurrentEditer(); - return true; - end - ord("S"): - begin - it := GetCurrentItem(); - if 0=SavePageItem(it)then - begin - it.FEditer.ChangedFlag := true; - end - return true; - end - end - end else //up - begin - case e.CharCode of - VK_TAB: - begin - TabChecking(ssShift in e.ShiftState); - return true; - end - VK_F3: - begin - d := FFindWnd.GetINfo(); - d["section"]:= "查找"; - d["btn"]:= "查找"; - d["c_revers"]:= 1; - DoFind(d,FFindWnd); - return true; - end - end - end - end - if e.Result=1 then + end + if ssCtrl in e.ShiftState then + begin + if e.Result=0 then //down begin case e.CharCode of - 17: + 220,191: begin - if e.Result then + if e.CharCode=220 then UnCommentCurrentSel(); + else CommetCurrentSel(); + e.skip := true; + return true; + end + VK_F5: //小写 + begin + upperorlowercase(0); + return true; + end + ord("D"): + begin + ed := GetCurrentEditer(); + if not ed then return; + if ed.ReadOnly then return; + //xy := ed.CaretY; + ed.ExecuteCommand(ed.ecLineEnd,nil); + S := ed.LineText; + ed.ExecuteCommand(ed.ecString,"\r\n"+s); + return; + end + ord("R"): + begin + InitShowWndPos(FFindWnd,"fr",200,150); + FFindWnd.oPENreplace(); + FFindWnd.Show(); + return true; + end + ord("E"): + begin + ed := GetCurrentEditer(); + IF not ed then return; + s := ed.CaretWords(); + if s then ed.Tryjump(s); + return true; + end + ord("F"): + begin + InitShowWndPos(FFindWnd,"fr",200,150); + FFindWnd.OpenFind(); + FFindWnd.Show(); + return true; + end + ord("G"): + begin + InitShowWndPos(FGotoLineWnd,"g",200,200); + FGotoLineWnd.ShowGoto(); + return true; + end + {ord("O"): + begin + OpenAfile(); + return true; + end + ord("N"): + begin + CreateAfile(); + return true; + end} + ord("Z"): + begin + UnDoCurrentEditer(); + return true; + end + ord("S"): + begin + it := GetCurrentItem(); + if 0=SavePageItem(it)then begin - TabCheckChanged(); + it.FEditer.ChangedFlag := true; end - end - VK_F7: - begin - SwitchLogWnd(); return true; end - VK_F8: + end + end else //up + begin + case e.CharCode of + VK_TAB: begin - DbgNextLine(); + TabChecking(ssShift in e.ShiftState); return true; end - VK_F3: begin d := FFindWnd.GetINfo(); d["section"]:= "查找"; d["btn"]:= "查找"; - d["c_revers"]:= 0; + d["c_revers"]:= 1; DoFind(d,FFindWnd); return true; end - VK_F1: + end + end + end + if e.Result=1 then + begin + case e.CharCode of + 17: + begin + if e.Result then begin - it := GetCurrentItem(); - if it.FSynType="tsl" then - begin - ed := it.FEditer; - IF not ed then return; - s := ed.CaretWords(); - if s then FTslChmHelp.SearchWord(s); - end - return true; + TabCheckChanged(); end - end; - end - end - function ShowTslLangChm(); - begin - FTslChmHelp.ShowTslLangChm(); - end - function InitShowWndPos(wnd,n,ix,iy); //计算初始位置 - begin - if not FFistShows[n]then - begin - FFistShows[n]:= true; - xy := Clienttoscreen(ix,iy); - wnd.left := xy[0]; - wnd.top := xy[1]; - end - end - function SetPageItemSyn(it,n); - begin - if not it then return; - if not ifstring(n)then return; - if it.FSynType=n then return; - hc := GetFreeSynObjectByName(n); - if hc then - begin - cp := hc[1]; - it.FEditer.IncPaintLock(); - it.FEditer.HighLighter := hc[0]; - it.FEditer.Completion := hc[1]; - it.FEditer.DecPaintLock(); - cp.OnJumpChoosed := function(cmp,d); - begin - f := d["file"]; - nf :=(f?(cmp.GetFileFullPath(f)):GetCurrentItem().OrigScriptPath); - //echo "\r\n",nf,"===",d["line"]; - OpenAndGotoFileByName(nf,d["line"]); end - cit := GetCurrentItem(); - if cit=it then + VK_F7: begin - it.FInitCompletion := false; - cp.PrePareCompletion(it.Caption); - end else - begin - it.FInitCompletion := true; + SwitchLogWnd(); + return true; end - it.FSynType := n; + VK_F8: + begin + DbgNextLine(); + return true; + end + + VK_F3: + begin + d := FFindWnd.GetINfo(); + d["section"]:= "查找"; + d["btn"]:= "查找"; + d["c_revers"]:= 0; + DoFind(d,FFindWnd); + return true; + end + VK_F1: + begin + it := GetCurrentItem(); + if it.FSynType="tsl" then + begin + ed := it.FEditer; + IF not ed then return; + s := ed.CaretWords(); + if s then FTslChmHelp.SearchWord(s); + end + return true; + end + end; + end + end + function ShowTslLangChm(); + begin + FTslChmHelp.ShowTslLangChm(); + end + function InitShowWndPos(wnd,n,ix,iy); //计算初始位置 + begin + if not FFistShows[n]then + begin + FFistShows[n]:= true; + xy := Clienttoscreen(ix,iy); + wnd.left := xy[0]; + wnd.top := xy[1]; + end + end + function SetPageItemSyn(it,n); + begin + if not it then return; + if not ifstring(n)then return; + if it.FSynType=n then return; + hc := GetFreeSynObjectByName(n); + if hc then + begin + cp := hc[1]; + it.FEditer.IncPaintLock(); + it.FEditer.HighLighter := hc[0]; + it.FEditer.Completion := hc[1]; + it.FEditer.DecPaintLock(); + cp.OnJumpChoosed := function(cmp,d); + begin + f := d["file"]; + nf :=(f?(cmp.GetFileFullPath(f)):GetCurrentItem().OrigScriptPath); + //echo "\r\n",nf,"===",d["line"]; + OpenAndGotoFileByName(nf,d["line"]); + end + cit := GetCurrentItem(); + if cit=it then + begin + it.FInitCompletion := false; + cp.PrePareCompletion(it.Caption); end else begin - it.FEditer.IncPaintLock(); - it.FEditer.HighLighter := nil; - it.FEditer.Completion := nil; - it.FEditer.DecPaintLock(); - it.FSynType := n; + it.FInitCompletion := true; end - end - function Recycling();override; + it.FSynType := n; + end else begin - inherited; - FSynHCS := nil; - FCurrentItemCode := array(); - FPageEditer := nil; - FToolbar := nil; - FStatus := nil; - FInfoShowWnd := nil; - FPageMenu := nil; - FPageEditerMenu := nil; - FPageEditerMenus := array(); - FOnPageEditerChanged := nil; - fOnPageItemSelChanged := nil; - FListPages := nil; - FCodeMap := nil; - FEchoWnd := nil; - FFindListWnd := nil; - FTempPageItem := nil; - FExecuteEditer := nil; - FTslDebug := nil; + it.FEditer.IncPaintLock(); + it.FEditer.HighLighter := nil; + it.FEditer.Completion := nil; + it.FEditer.DecPaintLock(); + it.FSynType := n; end - function GetSynTypeNames(); + end + function Recycling();override; + begin + inherited; + FSynHCS := nil; + FCurrentItemCode := array(); + FPageEditer := nil; + FToolbar := nil; + FStatus := nil; + FInfoShowWnd := nil; + FPageMenu := nil; + FPageEditerMenu := nil; + FPageEditerMenus := array(); + FOnPageEditerChanged := nil; + fOnPageItemSelChanged := nil; + FListPages := nil; + FCodeMap := nil; + FEchoWnd := nil; + FFindListWnd := nil; + FTempPageItem := nil; + FExecuteEditer := nil; + FTslDebug := nil; + end + function GetSynTypeNames(); + begin + return FSynClasses.IndexNames(); + end + function SetCodeFormatInfo(d); + begin + if ifarray(d)then FCodeFormatInfo := d; + else return FCodeFormatInfo; + end + function getexecuteparams(f); //获得当前的执行参数 + begin + return FExecuteEditer.GetCurrentExuteparams(f); + end + function ShowExeEditer(flg); + begin + if ifnil(flg)or flg then begin - return FSynClasses.IndexNames(); + InitShowWndPos(FExecuteEditer,"exe",200,200); + FExecuteEditer.showexeediter(); + + end else + begin + FExecuteEditer.Visible := false; end - function SetCodeFormatInfo(d); + + end + function getlibpathstr(); + begin + dirs := ""; + fio := ioFileseparator(); + for i,v in FTslSearchDir do begin - if ifarray(d)then FCodeFormatInfo := d; - else return FCodeFormatInfo; - end - function getexecuteparams(f); //获得当前的执行参数 - begin - return FExecuteEditer.GetCurrentExuteparams(f); - end - function ShowExeEditer(flg); - begin - if ifnil(flg)or flg then + if ifstring(v)then begin - InitShowWndPos(FExecuteEditer,"exe",200,200); - FExecuteEditer.showexeediter(); - - end else - begin - FExecuteEditer.Visible := false; - end - - end - function getlibpathstr(); - begin - dirs := ""; - fio := ioFileseparator(); - for i,v in FTslSearchDir do - begin - if ifstring(v)then + if v[length(v)]=fio then begin - if v[length(v)]=fio then - begin - dirs += v; - end else - begin - dirs += v; - dirs += fio; - end - end - dirs += ";"; - end - return dirs; - end - function echoAppendString(s); - begin - FEchoWnd.AppendString(s); - end - published //property 位置 - FHistoryDir; - property OnPageEditerChanged read FOnPageEditerChanged write FOnPageEditerChanged; - property OnPageItemSelChanged read FOnPageItemSelChanged write FOnPageItemSelChanged; - property TslSearchDir read FTslSearchDir write SetTslSearchDir; - property TslCacheDir read FTslCacheDir write SetTslCacheDir; - property TabWidth read FTabWidth write SetTabWidth; - property TabChar read FTabChar; - property Tslexe read FTslExe write FTslExe; - property ReadOnlyDirs read FReadDirs write FReadDirs; - protected - class function Sinit();override; - begin - inherited; - if not FSynClasses then FSynClasses := new TMyArrayA(); - end - class function GetSynTypeByFileType(ft); - begin - if not string(ft)then return "txt"; - nft := lowercase(ft); - for i,v in FSynClasses.IndexNames() do - begin - dv := FSynClasses[v]; - dvf := dv[2]; - if ifstring(dvf)then - begin - if pos(";"+nft+";",dvf)then - begin - return v; - end - end - end - return "None"; - end - class function RegSynType(n,h,c,files); - begin - if ifstring(n)and(h is class(TSynhighLighter))and(c is TSynCompletion)then - begin - FSynClasses[n]:= array(h,c,files); - end - end - class function UnRegSynType(n,h,c); - begin - if ifstring(n)then - begin - FSynClasses.DeleteIndex(n); - end - end - { - r["section"] := CurrentITem.Caption; - r["target"]:= FEdit_target.Editer.Text; - r["replace"]:= FEdit_repace.Editer.Text; - r["filetype"] := FEdit_type.Editer.Text; - r["dir"] := FEdit_dir.Editer.Text; - r["c_revers"]:=FCheck_revers.Checked; - r["c_cycle"]:= FCheck_cycle.Checked; - r["c_wrap"] := FCheck_wrap.Checked; - r["c_case"] := FCheck_case.Checked; - r["c_reg"] := FCheck_reg.Checked; - r["c_dir"] := FCheck_subdir.Checked; - } - function ReplaceAllInCurrent(data,fo,it,idx); - begin - data["c_revers"]:= 0; - data["c_cycle"]:= 0; - if not it then it := GetCurrentItem(); - if not it then return; - ed := it.FEditer; - if not ed then return; - idx := 0; - try - ed.IncPaintLock(); - ed.ExecuteCommand(ed.ecGotoXY,array(1,1)); - cidx := 0; - while FindInCurrent(data,fo,it,1)=0 do - begin - if idx=0 then - begin - FFindListWnd.AppendItem(array("caption":format("replace:%s in file:%s",data["target"],it.OrigScriptPath))); - end - if idx>0 then - begin - ed.MergeLastUndo(); - end - idx++; - L := ed.CaretY; - if cidx=L then continue; - cidx := L; - scap := format(" %d:(第%d行) ",idx,L)+trim(ed.LineText); - FFindListWnd.AppendItem(array("caption":scap,"file":it.OrigScriptPath,"line":L)); - end - finally - ed.DecPaintLock(); - end - //fo.SetStatusText(format("共替换:%d 处",idx)); - end - function FindInFiles(d,o,rep,ct); - begin - fs := GetFilesFormSearchInfo(d); - ct := 0; - for i,v in fs do - begin - if not FIsFinding then break; - o.SetStatusText("查找文件:"+i); - it := GetOpendPageItemByFileName(i); - if not it then - begin - FTempPageItem.ScriptPath := i; - LoadFromFile(FTempPageItem,false); - it := FTempPageItem; - end - if rep then - begin - ReplaceAllInCurrent(d,o,it,idx); - SavePageItem(it); + dirs += v; end else begin - FindAllInCurrent(d,o,it,idx); + dirs += v; + dirs += fio; + end + end + dirs += ";"; + end + return dirs; + end + function echoAppendString(s); + begin + FEchoWnd.AppendString(s); + end + published //property 位置 + FHistoryDir; + property OnPageEditerChanged read FOnPageEditerChanged write FOnPageEditerChanged; + property OnPageItemSelChanged read FOnPageItemSelChanged write FOnPageItemSelChanged; + property TslSearchDir read FTslSearchDir write SetTslSearchDir; + property TslCacheDir read FTslCacheDir write SetTslCacheDir; + property TabWidth read FTabWidth write SetTabWidth; + property TabChar read FTabChar; + property Tslexe read FTslExe write FTslExe; + property ReadOnlyDirs read FReadDirs write FReadDirs; + protected + class function Sinit();override; + begin + inherited; + if not FSynClasses then FSynClasses := new TMyArrayA(); + end + class function GetSynTypeByFileType(ft); + begin + if not string(ft)then return "txt"; + nft := lowercase(ft); + for i,v in FSynClasses.IndexNames() do + begin + dv := FSynClasses[v]; + dvf := dv[2]; + if ifstring(dvf)then + begin + if pos(";"+nft+";",dvf)then + begin + return v; end - ct += idx; end end - function FindInCurrent(data,fo,it,rep); + return "None"; + end + class function RegSynType(n,h,c,files); + begin + if ifstring(n)and(h is class(TSynhighLighter))and(c is TSynCompletion)then begin - if not it then it := GetCurrentItem(); - if not it then return-2; - ed := it.FEditer; - if not ed then return-2; - cy := ed.CaretY; - cx := ed.CaretX; - wordwrap := data["c_wrap"]; - fs := data["target"]; - if not(fs and ifstring(fs))then + FSynClasses[n]:= array(h,c,files); + end + end + class function UnRegSynType(n,h,c); + begin + if ifstring(n)then + begin + FSynClasses.DeleteIndex(n); + end + end + { + r["section"] := CurrentITem.Caption; + r["target"]:= FEdit_target.Editer.Text; + r["replace"]:= FEdit_repace.Editer.Text; + r["filetype"] := FEdit_type.Editer.Text; + r["dir"] := FEdit_dir.Editer.Text; + r["c_revers"]:=FCheck_revers.Checked; + r["c_cycle"]:= FCheck_cycle.Checked; + r["c_wrap"] := FCheck_wrap.Checked; + r["c_case"] := FCheck_case.Checked; + r["c_reg"] := FCheck_reg.Checked; + r["c_dir"] := FCheck_subdir.Checked; + } + function ReplaceAllInCurrent(data,fo,it,idx); + begin + data["c_revers"]:= 0; + data["c_cycle"]:= 0; + if not it then it := GetCurrentItem(); + if not it then return; + ed := it.FEditer; + if not ed then return; + idx := 0; + try + ed.IncPaintLock(); + ed.ExecuteCommand(ed.ecGotoXY,array(1,1)); + cidx := 0; + while FindInCurrent(data,fo,it,1)=0 do begin - fo.SetStatusText("查找内容为空!"); - return-2; - end - stringiswrapword := isCaseWords(fs); - if data["c_case"]then fs := lowercase(fs); - rstring := data["replace"]; - lfs := length(fs); - L := ed.Lines; - ct := L.length(); - if data["c_revers"]then - begin - for i := cy-1 downto cy-ct do + if idx=0 then begin - ridx := i; - if data["c_cycle"]then - begin - ridx :=(ridx<0)?(ridx+ct):ridx; - end - if ridx<0 then - begin - fo.SetStatusText("到达顶部"); - return-2; - end - s := L.GetStringByIndex(ridx); - ls := length(s); - while cx-lfs+1>1 do - begin - if not FIsFinding then return-2; - TryDispatch(); - subs := s[cx-lfs:cx-1]; - if data["c_case"]then subs := lowercase(subs); - if subs=fs and(wordwrap?((stringiswrapword=3)or(((stringiswrapword .& 1)or IsWordsChar(s,cx-1,ls))and((stringiswrapword .& 2)or IsWordsChar(s,cx+lfs,ls)))):true)then //找到了 - begin - ed.ExecuteCommand(ed.ecGotoXY,array(ridx+1,cx)); - ed.ExecuteCommand(ed.ecSelGotoXY,array(ridx+1,cx-lfs)); - if rep then - begin - ed.SelText := rstring; - end - fo.SetStatusText(format("位置: %d %d",ridx+1,cx-lfs)); - return 0; - end - cx--; - end - tidx := ridx-1; - if data["c_cycle"]then - begin - tidx += ct; - tidx := tidx mod ct; - end else - begin - if tidx<0 then - begin - fo.SetStatusText("到达顶部"); - return-2; - end - end - s := L.GetStringByIndex(tidx); - cx := length(s)+1; + FFindListWnd.AppendItem(array("caption":format("replace:%s in file:%s",data["target"],it.OrigScriptPath))); end - fo.SetStatusText("到达顶部"); - return-2; + if idx>0 then + begin + ed.MergeLastUndo(); + end + idx++; + L := ed.CaretY; + if cidx=L then continue; + cidx := L; + scap := format(" %d:(第%d行) ",idx,L)+trim(ed.LineText); + FFindListWnd.AppendItem(array("caption":scap,"file":it.OrigScriptPath,"line":L)); end - for i := 0 to ct do + finally + ed.DecPaintLock(); + end + //fo.SetStatusText(format("共替换:%d 处",idx)); + end + function FindInFiles(d,o,rep,ct); + begin + fs := GetFilesFormSearchInfo(d); + ct := 0; + for i,v in fs do + begin + if not FIsFinding then break; + o.SetStatusText("查找文件:"+i); + it := GetOpendPageItemByFileName(i); + if not it then begin - ridx := i+cy-1; + FTempPageItem.ScriptPath := i; + LoadFromFile(FTempPageItem,false); + it := FTempPageItem; + end + if rep then + begin + ReplaceAllInCurrent(d,o,it,idx); + SavePageItem(it); + end else + begin + FindAllInCurrent(d,o,it,idx); + end + ct += idx; + end + end + function FindInCurrent(data,fo,it,rep); + begin + if not it then it := GetCurrentItem(); + if not it then return-2; + ed := it.FEditer; + if not ed then return-2; + cy := ed.CaretY; + cx := ed.CaretX; + wordwrap := data["c_wrap"]; + fs := data["target"]; + if not(fs and ifstring(fs))then + begin + fo.SetStatusText("查找内容为空!"); + return-2; + end + stringiswrapword := isCaseWords(fs); + if data["c_case"]then fs := lowercase(fs); + rstring := data["replace"]; + lfs := length(fs); + L := ed.Lines; + ct := L.length(); + if data["c_revers"]then + begin + for i := cy-1 downto cy-ct do + begin + ridx := i; if data["c_cycle"]then begin - ridx := ridx mod ct; + ridx :=(ridx<0)?(ridx+ct):ridx; end - if ridx >= ct then + if ridx<0 then begin - fo.SetStatusText("到达底部"); + fo.SetStatusText("到达顶部"); return-2; end s := L.GetStringByIndex(ridx); ls := length(s); - while cx+lfs-1 <= ls do + while cx-lfs+1>1 do begin if not FIsFinding then return-2; - //GetAndDispatchMessageA(); TryDispatch(); - subs := s[cx:cx+lfs-1]; + subs := s[cx-lfs:cx-1]; if data["c_case"]then subs := lowercase(subs); if subs=fs and(wordwrap?((stringiswrapword=3)or(((stringiswrapword .& 1)or IsWordsChar(s,cx-1,ls))and((stringiswrapword .& 2)or IsWordsChar(s,cx+lfs,ls)))):true)then //找到了 begin ed.ExecuteCommand(ed.ecGotoXY,array(ridx+1,cx)); - ed.ExecuteCommand(ed.ecSelGotoXY,array(ridx+1,cx+lfs)); + ed.ExecuteCommand(ed.ecSelGotoXY,array(ridx+1,cx-lfs)); if rep then begin ed.SelText := rstring; end - fo.SetStatusText(format("位置: %d %d",ridx+1,cx)); + fo.SetStatusText(format("位置: %d %d",ridx+1,cx-lfs)); return 0; end - //没找到 - cx++; + cx--; end - cx := 1; + tidx := ridx-1; + if data["c_cycle"]then + begin + tidx += ct; + tidx := tidx mod ct; + end else + begin + if tidx<0 then + begin + fo.SetStatusText("到达顶部"); + return-2; + end + end + s := L.GetStringByIndex(tidx); + cx := length(s)+1; end - fo.SetStatusText("到达底部"); + fo.SetStatusText("到达顶部"); return-2; end - function FindListChoosed(o,e); + for i := 0 to ct do begin - it := o.GetItem(o.GetCurrentSelection()); - if ifarray(it)then + ridx := i+cy-1; + if data["c_cycle"]then begin - f := it["file"]; - l := it["line"]; - if ifstring(f)and l >= 0 then - begin - OpenAndGotoFileByName(f,l); - end + ridx := ridx mod ct; end - end - function TryDispatch(); - begin - {$ifdef linux} - return; - {$endif} - t := now(); - if(t-FLastDispathTime)>0.25e-5 then + if ridx >= ct then begin - FLastDispathTime := t; - GetAndDispatchMessageA(); + fo.SetStatusText("到达底部"); + return-2; end - end - function FindAllInCurrent(data,fo,it,rt); - begin - rt := 0; - if not it then it := GetCurrentItem(); - if not it then return; - ed := it.FEditer; - if not ed then return; - wordwrap := data["c_wrap"]; - fs := data["target"]; - if not(fs and ifstring(fs))then return fo.SetStatusText("找到 0 处"); - if data["c_case"]then fs := lowercase(fs); - stringiswrapword := isCaseWords(fs); - lfs := length(fs); - L := ed.Lines; - ct := L.length(); - cidx := 0; - for i := 0 to ct-1 do + s := L.GetStringByIndex(ridx); + ls := length(s); + while cx+lfs-1 <= ls do begin - s := L.GetStringByIndex(i); - ls := length(s); - cx := 1; - while cx+lfs-1 <= ls do + if not FIsFinding then return-2; + //GetAndDispatchMessageA(); + TryDispatch(); + subs := s[cx:cx+lfs-1]; + if data["c_case"]then subs := lowercase(subs); + if subs=fs and(wordwrap?((stringiswrapword=3)or(((stringiswrapword .& 1)or IsWordsChar(s,cx-1,ls))and((stringiswrapword .& 2)or IsWordsChar(s,cx+lfs,ls)))):true)then //找到了 begin - if not FIsFinding then return rt; - //GetAndDispatchMessageA(); - TryDispatch(); - subs := s[cx:cx+lfs-1]; - if data["c_case"]then subs := lowercase(subs); - //((stringiswrapword .& 2) and (IsWordsChar(s,cx-1,ls)) ( (stringiswrapword .& 1) and IsWordsChar(s,cx+lfs,ls)) ) - if subs=fs and(wordwrap?((stringiswrapword=3)or(((stringiswrapword .& 1)or IsWordsChar(s,cx-1,ls))and((stringiswrapword .& 2)or IsWordsChar(s,cx+lfs,ls)))):true)then //找到了 + ed.ExecuteCommand(ed.ecGotoXY,array(ridx+1,cx)); + ed.ExecuteCommand(ed.ecSelGotoXY,array(ridx+1,cx+lfs)); + if rep then begin - if rt=0 then FFindListWnd.AppendItem(array("caption":format("find:%s in file:%s",fs,it.OrigScriptPath),"file":it.OrigScriptPath,"line":1)); - cx += lfs; - rt++; - if cidx=i+1 then continue; - cidx := i+1; - scap := format(" %d:(第%d行) ",rt,i+1)+trim(s); - FFindListWnd.AppendItem(array("caption":scap,"file":it.OrigScriptPath,"line":i+1)); - continue; + ed.SelText := rstring; end - //没找到 - cx++; + fo.SetStatusText(format("位置: %d %d",ridx+1,cx)); + return 0; end + //没找到 + cx++; end - return rt; + cx := 1; end - function isCaseWords(s); //判断全词匹配 + fo.SetStatusText("到达底部"); + return-2; + end + function FindListChoosed(o,e); + begin + it := o.GetItem(o.GetCurrentSelection()); + if ifarray(it)then begin - if ifstring(s)and s then + f := it["file"]; + l := it["line"]; + if ifstring(f)and l >= 0 then begin - len := length(s); - if len=1 then return IsWordsChar(s,1,1); - return IsWordsChar(s,1,1).|(2 * IsWordsChar(s,len,len)); + OpenAndGotoFileByName(f,l); end end - function IsWordsChar(s,idx,len); + end + function TryDispatch(); + begin + {$ifdef linux} + return; + {$endif} + t := now(); + if(t-FLastDispathTime)>0.25e-5 then begin - if not(len>0)then len := length(s); - if idx>len then return true; - if idx<1 then return true; - ivi := ord(s[idx]); - 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 return true; + FLastDispathTime := t; + GetAndDispatchMessageA(); end - function TabCheckChanged(); + end + function FindAllInCurrent(data,fo,it,rt); + begin + rt := 0; + if not it then it := GetCurrentItem(); + if not it then return; + ed := it.FEditer; + if not ed then return; + wordwrap := data["c_wrap"]; + fs := data["target"]; + if not(fs and ifstring(fs))then return fo.SetStatusText("找到 0 处"); + if data["c_case"]then fs := lowercase(fs); + stringiswrapword := isCaseWords(fs); + lfs := length(fs); + L := ed.Lines; + ct := L.length(); + cidx := 0; + for i := 0 to ct-1 do begin - if not FListPages.Visible then return; - FListPages.Visible := false; - n := FListPages.GetSelFileName; - OpenAndGotoFileByName(n); - end - function TabChecking(f); - begin - its := FPageEditer.PageItems; - if not(its.Length()>1)then return FCurrentItemCode := array(); - if FListPages.Visible then + s := L.GetStringByIndex(i); + ls := length(s); + cx := 1; + while cx+lfs-1 <= ls do begin - FListPages.IncIndex((f>0)?1:(-1)); - end else - begin //初始化 - bit := GetCurrentItem(); - for i := 0 to its.Length()-1 do + if not FIsFinding then return rt; + //GetAndDispatchMessageA(); + TryDispatch(); + subs := s[cx:cx+lfs-1]; + if data["c_case"]then subs := lowercase(subs); + //((stringiswrapword .& 2) and (IsWordsChar(s,cx-1,ls)) ( (stringiswrapword .& 1) and IsWordsChar(s,cx+lfs,ls)) ) + if subs=fs and(wordwrap?((stringiswrapword=3)or(((stringiswrapword .& 1)or IsWordsChar(s,cx-1,ls))and((stringiswrapword .& 2)or IsWordsChar(s,cx+lfs,ls)))):true)then //找到了 begin - it := its[i]; - it.FPageOrderId := 0; + if rt=0 then FFindListWnd.AppendItem(array("caption":format("find:%s in file:%s",fs,it.OrigScriptPath),"file":it.OrigScriptPath,"line":1)); + cx += lfs; + rt++; + if cidx=i+1 then continue; + cidx := i+1; + scap := format(" %d:(第%d行) ",rt,i+1)+trim(s); + FFindListWnd.AppendItem(array("caption":scap,"file":it.OrigScriptPath,"line":i+1)); + continue; end - idx := 1; - for i := length(FCurrentItemCode)-1 downto 0 do + //没找到 + cx++; + end + end + return rt; + end + function isCaseWords(s); //判断全词匹配 + begin + if ifstring(s)and s then + begin + len := length(s); + if len=1 then return IsWordsChar(s,1,1); + return IsWordsChar(s,1,1).|(2 * IsWordsChar(s,len,len)); + end + end + function IsWordsChar(s,idx,len); + begin + if not(len>0)then len := length(s); + if idx>len then return true; + if idx<1 then return true; + ivi := ord(s[idx]); + 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 return true; + end + function TabCheckChanged(); + begin + if not FListPages.Visible then return; + FListPages.Visible := false; + n := FListPages.GetSelFileName; + OpenAndGotoFileByName(n); + end + function TabChecking(f); + begin + its := FPageEditer.PageItems; + if not(its.Length()>1)then return FCurrentItemCode := array(); + if FListPages.Visible then + begin + FListPages.IncIndex((f>0)?1:(-1)); + end else + begin //初始化 + bit := GetCurrentItem(); + for i := 0 to its.Length()-1 do + begin + it := its[i]; + it.FPageOrderId := 0; + end + idx := 1; + for i := length(FCurrentItemCode)-1 downto 0 do + begin + it := FCurrentItemCode[i]; + if it.FPageOrderId<1 then it.FPageOrderId := idx++; + end + sr := array(); + for i := 0 to its.Length()-1 do + begin + it := its[i]; + sv := it.OrigScriptPath; + if it.FEditer.ChangedFlag then sv := "*"+sv; + sr[i,0]:= sv; + sr[i,1]:= it.FPageOrderId; + sr[i,2]:= it; + if it.FPageOrderId=0 then begin - it := FCurrentItemCode[i]; - if it.FPageOrderId<1 then it.FPageOrderId := idx++; + it.FPageOrderId := idx++; end - sr := array(); - for i := 0 to its.Length()-1 do + end + sit := sselect[0]from sr order by[1]asc end; + FCurrentItemCode := sselect[2]from sr order by[1]desc end; + FListPages.SetData(sit); + FListPages.IncIndex(-1); + xy := ClientToScreen(100,100); + FListPages.Top := xy[1]; + FListPages.Left := xy[0]; + //FListPages.SetBoundsRect(array(xy[0],xy[1],xy[0]+600,xy[1]+600)); + //FListPages.Visible := true; + FListPages.Show(SW_SHOWNOACTIVATE); + //bit.FEditer.SetFocus(); + end + end + function GetFreeSynObjectByName(n); + begin + if not ifstring(n)then return; + lns := FSynHCS[n]; + if not lns then + begin + lns := new TMyARRayB(); + FSynHCS[n]:= lns; + end + for i := 0 to lns.length()-1 do + begin + vi := lns[i]; + if not(vi[0].Memo)then return vi; + end + hc := CreateASynObject(n,self); + if hc then + begin + lns.Push(hc); + return hc; + end + end + public + FExecuteEditer; + private + class function CreateASynObject(n,ow); + begin + c := FSynClasses[n]; + //if not c then c := FSynClasses["txt"]; + if c then + begin + if ifobj(c[0])and ifobj(c[1])then return array(CreateObject(c[0],ow),CreateObject(c[1],ow)); + end + end + static FSynClasses; + FCodeFormatInfo; + FTslChmHelp; + FFistShows; + FSynHCS; + FLastDispathTime; + FIsFinding; + FOnPageEditerChanged; + FPageEditerMenu; + FPageEditerMenus; + fOnPageItemSelChanged; + FReadDirs; + FCurrentItemCode; + FGoBackA; // := new TMyarrayB(); + FGoBackB; // := new TMyarrayB(); + FRebackFlag; + FPageEditer; + FToolbar; + FStatus; + FInfoShowWnd; + FCodeMap; + FListPages; + FFindWnd; + FFindListWnd; + FEchoWnd; + FGotoLineWnd; + FFileopen; + FFileSave; + FPageMenu; + //图标 + FNeedSaveBmp; + FNotNeedSaveBmp; + FBmpClose; + FTabWidth; + FTabChar; + FTslexe; + FTslSearchDir; + FTslCacheDir; + FTempPageItem; + FOpenHistory; + FHistoryWnd; + FTslDebug; + private + function GetFilesFormSearchInfo(d); + begin + r := array(); + dir := d["dir"]; + if not dir then return r; + ft := d["filetype"]; + if ft then + begin + ft := str2array(ft,";"); + end + if not ft then ft := array("*"); + FindFiles(dir,ft,d["c_dir"],r); + return r; + end + function FindFiles(dir,ft,sub,ret); + begin + dir_ := dir; + sp := ioFileseparator(); + if not(dir_[length(dir_)]=sp)then dir_ += sp; + if sub then + begin + dirs := FileList("",dir_+"*"); + for i,v in dirs do + begin + TryDispatch(); + if not FIsFinding then return; + fn := v["FileName"]; + if(pos("D",v["Attr"]))and not(fn in array(".",".."))then begin - it := its[i]; - sv := it.OrigScriptPath; - if it.FEditer.ChangedFlag then sv := "*"+sv; - sr[i,0]:= sv; - sr[i,1]:= it.FPageOrderId; - sr[i,2]:= it; - if it.FPageOrderId=0 then + FindFiles(dir_+fn,ft,sub,ret); + end + end + end + for i,v in ft do + begin + vi := trim(v); + if not vi then continue; + fs := FileList("",dir_+vi); + for j,vj in fs do + begin + if(POS("D",vj["Attr"]))then continue; + ret[dir_+vj["FileName"]]:= true; + end + end + end + function SetTslCacheDir(d); + begin + if FTslCacheDir=d then return; + if ifstring(d)then + begin + FTslCacheDir := d; + class(TTSLCompletion).SetCacheDir(d); + end + end + function SetTslSearchDir(d); + begin + if FTslSearchDir=d then return; + if ifarray(d)then + begin + FTslSearchDir := d; + class(TTSLCompletion).SetFindDirs(d); + its := GetAllPageItems(); + for i := 0 to its.Length()-1 do + begin + it := its[i]; + it.RepreComple := true; + end + end + end + function SetTabWidth(n); + begin + if not(n >= 0)then return; + nn := integer(n); + if nn >= 0 and nn <> FTabWidth then + begin + FTabWidth := nn; + if nn=0 then FTabChar := "\t"; + else + begin + FTabChar := ""; + for i := 1 to nn do + begin + FTabChar += " "; + end + end + its := FPageEditer.PageITems; + for i := 0 to its.Length()-1 do its[i].FEditer.TabChar := FTabChar; + end + end + function getdirfromfile(p); + begin + r := ""; + if not ifstring(p)then return r; + sp := ioFileseparator(); + for i := length(p)downto 1 do + begin + if p[i]=sp then return p[1:i]; + end + return r; + end + function LoadFromFile(it,ifinit); + begin + p := it.ScriptPath; + sz := filesize("",p); + if readFile(rwRaw(),"",p,0,sz,s)then + begin + it.ReGetLastLoadTime(); + if lowercase(p[length(p)-3:length(p)])=".stm" then + begin + try + if s then begin - it.FPageOrderId := idx++; - end - end - sit := sselect[0]from sr order by[1]asc end; - FCurrentItemCode := sselect[2]from sr order by[1]desc end; - FListPages.SetData(sit); - FListPages.IncIndex(-1); - xy := ClientToScreen(100,100); - FListPages.Top := xy[1]; - FListPages.Left := xy[0]; - //FListPages.SetBoundsRect(array(xy[0],xy[1],xy[0]+600,xy[1]+600)); - //FListPages.Visible := true; - FListPages.Show(SW_SHOWNOACTIVATE); - //bit.FEditer.SetFocus(); - end - end - function GetFreeSynObjectByName(n); - begin - if not ifstring(n)then return; - lns := FSynHCS[n]; - if not lns then - begin - lns := new TMyARRayB(); - FSynHCS[n]:= lns; - end - for i := 0 to lns.length()-1 do - begin - vi := lns[i]; - if not(vi[0].Memo)then return vi; - end - hc := CreateASynObject(n,self); - if hc then - begin - lns.Push(hc); - return hc; - end - end - public - FExecuteEditer; - private - class function CreateASynObject(n,ow); - begin - c := FSynClasses[n]; - //if not c then c := FSynClasses["txt"]; - if c then - begin - if ifobj(c[0])and ifobj(c[1])then return array(CreateObject(c[0],ow),CreateObject(c[1],ow)); - end - end - static FSynClasses; - FCodeFormatInfo; - FTslChmHelp; - FFistShows; - FSynHCS; - FLastDispathTime; - FIsFinding; - FOnPageEditerChanged; - FPageEditerMenu; - FPageEditerMenus; - fOnPageItemSelChanged; - FReadDirs; - FCurrentItemCode; - FGoBackA; // := new TMyarrayB(); - FGoBackB; // := new TMyarrayB(); - FRebackFlag; - FPageEditer; - FToolbar; - FStatus; - FInfoShowWnd; - FCodeMap; - FListPages; - FFindWnd; - FFindListWnd; - FEchoWnd; - FGotoLineWnd; - FFileopen; - FFileSave; - FPageMenu; - //图标 - FNeedSaveBmp; - FNotNeedSaveBmp; - FBmpClose; - FTabWidth; - FTabChar; - FTslexe; - FTslSearchDir; - FTslCacheDir; - FTempPageItem; - FOpenHistory; - FHistoryWnd; - FTslDebug; - private - function GetFilesFormSearchInfo(d); - begin - r := array(); - dir := d["dir"]; - if not dir then return r; - ft := d["filetype"]; - if ft then - begin - ft := str2array(ft,";"); - end - if not ft then ft := array("*"); - FindFiles(dir,ft,d["c_dir"],r); - return r; - end - function FindFiles(dir,ft,sub,ret); - begin - dir_ := dir; - sp := ioFileseparator(); - if not(dir_[length(dir_)]=sp)then dir_ += sp; - if sub then - begin - dirs := FileList("",dir_+"*"); - for i,v in dirs do - begin - TryDispatch(); - if not FIsFinding then return; - fn := v["FileName"]; - if(pos("D",v["Attr"]))and not(fn in array(".",".."))then - begin - FindFiles(dir_+fn,ft,sub,ret); + v := stm(s); + s := tostn(v); end + it.FEditer.ReadOnly := true; + it.FISstm := true; + except end end - for i,v in ft do + edt := it.FEditer; + tl := edt.TopLine; + cxy := edt.CaretXY; + it.SetLoadScript(s); + if ifinit then begin - vi := trim(v); - if not vi then continue; - fs := FileList("",dir_+vi); - for j,vj in fs do - begin - if(POS("D",vj["Attr"]))then continue; - ret[dir_+vj["FileName"]]:= true; - end + + InitScriptHighLighter(it); + edt.TopLine := tl; + edt.ExecuteCommand(edt.ecGotoXY,cxy); + end + end else + begin + //MessageBoxA(s,"提示",0,self); + it.ReGetLastLoadTime(); + it.SetLoadScript(s); + it.FEditer.ReadOnly := true; //设置为自读 + end + end + function InitScriptHighLighter(it); + begin + p := it.ScriptPath; + for i := length(p)downto 3 do + begin + if p[i]="." then + begin + synt := GetSynTypeByFileType(p[i+1:]); + return SetPageItemSyn(it,synt); end end - function SetTslCacheDir(d); + end + function GetNNeedSaveBmp(); + begin + if not FNOTneedSaveBmp then begin - if FTslCacheDir=d then return; - if ifstring(d)then - begin - FTslCacheDir := d; - class(TTSLCompletion).SetCacheDir(d); - end - end - function SetTslSearchDir(d); - begin - if FTslSearchDir=d then return; - if ifarray(d)then - begin - FTslSearchDir := d; - class(TTSLCompletion).SetFindDirs(d); - its := GetAllPageItems(); - for i := 0 to its.Length()-1 do - begin - it := its[i]; - it.RepreComple := true; - end - end - end - function SetTabWidth(n); - begin - if not(n >= 0)then return; - nn := integer(n); - if nn >= 0 and nn <> FTabWidth then - begin - FTabWidth := nn; - if nn=0 then FTabChar := "\t"; - else - begin - FTabChar := ""; - for i := 1 to nn do - begin - FTabChar += " "; - end - end - its := FPageEditer.PageITems; - for i := 0 to its.Length()-1 do its[i].FEditer.TabChar := FTabChar; - end - end - function getdirfromfile(p); - begin - r := ""; - if not ifstring(p)then return r; - sp := ioFileseparator(); - for i := length(p)downto 1 do - begin - if p[i]=sp then return p[1:i]; - end - return r; - end - function LoadFromFile(it,ifinit); - begin - p := it.ScriptPath; - sz := filesize("",p); - if readFile(rwRaw(),"",p,0,sz,s)then - begin - it.ReGetLastLoadTime(); - if lowercase(p[length(p)-3:length(p)])=".stm" then - begin - try - if s then - begin - v := stm(s); - s := tostn(v); - end - it.FEditer.ReadOnly := true; - it.FISstm := true; - except - end - end - edt := it.FEditer; - tl := edt.TopLine; - cxy := edt.CaretXY; - it.SetLoadScript(s); - if ifinit then - begin - - InitScriptHighLighter(it); - edt.TopLine := tl; - edt.ExecuteCommand(edt.ecGotoXY,cxy); - end - end else - begin - //MessageBoxA(s,"提示",0,self); - it.ReGetLastLoadTime(); - it.SetLoadScript(s); - it.FEditer.ReadOnly := true; //设置为自读 - end - end - function InitScriptHighLighter(it); - begin - p := it.ScriptPath; - for i := length(p)downto 3 do - begin - if p[i]="." then - begin - synt := GetSynTypeByFileType(p[i+1:]); - return SetPageItemSyn(it,synt); - end - end - end - function GetNNeedSaveBmp(); - begin - if not FNOTneedSaveBmp then - begin - s := "0502000000060400000074797065000203000000696D670006040000006461746 + s := "0502000000060400000074797065000203000000696D670006040000006461746 100027701000089504E470D0A1A0A0000000D4948445200000030000000300806 0000005702F987000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000010C49444154 @@ -6703,17 +6703,17 @@ C3309889F6B06F07C8436DD01E360234407BD808D000ED61234003B4878D000DD 1E4A25EE0288B30889CB00A2EF7BF80029711B40FC1521711D40A01F9A25EE038 8711C1F1E9258069465F9F85F89FCFE11DBB6A5799E5F5C96255FE87129C0133F 1E90D21D478EF0B86077F81A0000000049454E44AE42608200"; - FNOTneedSaveBmp := new TBitmap(); - FNOTneedSaveBmp.ReadVcon(HexFormatStrToTsl(s)); - end - return FNOTneedSaveBmp; + FNOTneedSaveBmp := new TBitmap(); + FNOTneedSaveBmp.ReadVcon(HexFormatStrToTsl(s)); end - function Closebmp(); + return FNOTneedSaveBmp; + end + function Closebmp(); + begin + if not FBmpClose then begin - if not FBmpClose then - begin - FBmpClose := new TBitmap(); - s := "0502000000060400000074797065000203000000696D670006040000006461746 + FBmpClose := new TBitmap(); + s := "0502000000060400000074797065000203000000696D670006040000006461746 100025601000089504E470D0A1A0A0000000D494844520000001C000000100806 00000005CF1FEF000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA864000000EB49444154 @@ -6725,15 +6725,15 @@ BFC6105000000097048597300000EC300000EC301C76FA864000000EB49444154 F47AC96526C21CCB26FD326A2180CC21F5CAC302CA5C842B865FD9D7003D1F17B 5B63144B29B2105CB4B537A058800DBF37D7A14ED1460E26DB426CD50EB1183BF 8FF1F00B989BEC710621E4C0000000049454E44AE42608200"; - FBmpClose.ReadVcon(HexformatStrToTsl(s)); - end - return FBmpClose; + FBmpClose.ReadVcon(HexformatStrToTsl(s)); end - function GetNeedSaveBmp(); + return FBmpClose; + end + function GetNeedSaveBmp(); + begin + if not FNeedSaveBmp then begin - if not FNeedSaveBmp then - begin - s := "0502000000060400000074797065000203000000696D670006040000006461746 + s := "0502000000060400000074797065000203000000696D670006040000006461746 10002A701000089504E470D0A1A0A0000000D4948445200000030000000300806 0000005702F987000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000013C49444154 @@ -6748,1222 +6748,1222 @@ B27F0502A7117403C6D9CC26356E2328078DE3A830F4889DB00E265FB1C3E92B8 0E20063B97A54712F701C470F7EACF2389654077793F8D8BCFFC2B1501557C0F4 66974D12EF97ED3C9177AD40AF0C48207A4F40B898CCDD8EC600A800000000049 454E44AE42608200"; - FNeedSaveBmp := new TBitmap(); - FNeedSaveBmp.ReadVcon(HexFormatStrToTsl(s)); - end - return FNeedSaveBmp; + FNeedSaveBmp := new TBitmap(); + FNeedSaveBmp.ReadVcon(HexFormatStrToTsl(s)); end + return FNeedSaveBmp; end - implementation - type tdbgselwnd=class(tdcreateform) - uses tslvcl; - label1:tlabel; - furl:tedit; - label2:tlabel; - fport:tedit; - label3:tlabel; - fusr:tedit; - label4:tlabel; - label5:tlabel; - fpwd:tpassword; - fdir:tedit; - fdiag:tfolderchooseadlg; - flist:tlistview; - fcbtn:tbtn; - flogout:tbtn; - flogin:tbtn; - fdbg:tbtn; - cancel_clk; - save_clk; - dbg_clk; - fhistorydir; - function Create(AOwner);override; //构造 +end +implementation +type tdbgselwnd=class(tdcreateform) + uses tslvcl; + label1:tlabel; + furl:tedit; + label2:tlabel; + fport:tedit; + label3:tlabel; + fusr:tedit; + label4:tlabel; + label5:tlabel; + fpwd:tpassword; + fdir:tedit; + fdiag:tfolderchooseadlg; + flist:tlistview; + fcbtn:tbtn; + flogout:tbtn; + flogin:tbtn; + fdbg:tbtn; + cancel_clk; + save_clk; + dbg_clk; + fhistorydir; + function Create(AOwner);override; //构造 + begin + inherited; + Visible := false; + Loader.LoadFromTfmScript(self,getinfo()); + flist.Columns := array( + ("text":"ID号","width":150), + ("text":"信息","width":300), + ("text":"创建时间","width":100) + ); + flogout.top := 140; + flogout.OnClick := function(o,e) begin - inherited; - Visible := false; - Loader.LoadFromTfmScript(self,getinfo()); - flist.Columns := array( - ("text":"ID号","width":150), - ("text":"信息","width":300), - ("text":"创建时间","width":100) - ); - flogout.top := 140; - flogout.OnClick := function(o,e) - begin - calldatafunction(cancel_clk,self,e); - end - flogin.OnClick := function(o,e) - begin - if fhistorydir and ifstring(fhistorydir)then - begin - Fremotepath := fhistorydir+"remoteinfo.tsm"; - d := getdata(); - Exportfile(ftstream(),"",Fremotepath,d); - end - calldatafunction(save_clk,self,e); - end - fdbg.onclick := function(o,e) - begin - calldatafunction(dbg_clk,self,e); - end - setlist(); + calldatafunction(cancel_clk,self,e); end - function setattachwait(flg); //设置登陆样式 - begin - if flg then - begin - Height := 210; - end else - begin - Height := 550; - end - end - function loaddata(); //导入数据 + flogin.OnClick := function(o,e) begin if fhistorydir and ifstring(fhistorydir)then begin Fremotepath := fhistorydir+"remoteinfo.tsm"; - if fileexists("",Fremotepath)and(1=importfile(ftstream(),"",Fremotepath,d))then + d := getdata(); + Exportfile(ftstream(),"",Fremotepath,d); + end + calldatafunction(save_clk,self,e); + end + fdbg.onclick := function(o,e) + begin + calldatafunction(dbg_clk,self,e); + end + setlist(); + end + function setattachwait(flg); //设置登陆样式 + begin + if flg then + begin + Height := 210; + end else + begin + Height := 550; + end + end + function loaddata(); //导入数据 + begin + if fhistorydir and ifstring(fhistorydir)then + begin + Fremotepath := fhistorydir+"remoteinfo.tsm"; + if fileexists("",Fremotepath)and(1=importfile(ftstream(),"",Fremotepath,d))then + begin + setdata(d); + end + end + end + function getdata(); + begin + r := array(); + r["addr"]:= furl.text; + r["port"]:= fport.text; + r["usr"]:= fusr.text; + r["pwd"]:= fpwd.text; + r["dir"]:= fdir.text; + return r; + end + function tserlogersimplewnd1_close(o;e);virtual; + begin + e.skip := true; + end + function Recycling();override; //回收变量 + begin + inherited; + ci := self.classinfo(); //将成员变量赋值为nil避免循环引用 + for i,v in ci["members"] do + begin + if v["static"]then continue; + invoke(self,v["name"],nil); + end + end + function getdir(); + begin + if fdiag.ChooseDlg()then + begin + fdir.text := fdiag.Folder; + end + end + function setlist(d); + begin + FList.DeleteAllItems(); + fdbg.Enabled := false; + if d and ifarray(d)then + begin + FList.appendItems(d); + FList.SelectedId := 0; + fdbg.Enabled := true; + end + end + function getstartfilename(sv); + begin + dirt := fdir.Text; + if not sv then sv := FList.SelectedValue; + if dirt and sv then + begin + if sv then + begin + fs := sv["info"]; + if fs then begin - setdata(d); - end - end - end - function getdata(); - begin - r := array(); - r["addr"]:= furl.text; - r["port"]:= fport.text; - r["usr"]:= fusr.text; - r["pwd"]:= fpwd.text; - r["dir"]:= fdir.text; - return r; - end - function tserlogersimplewnd1_close(o;e);virtual; - begin - e.skip := true; - end - function Recycling();override; //回收变量 - begin - inherited; - ci := self.classinfo(); //将成员变量赋值为nil避免循环引用 - for i,v in ci["members"] do - begin - if v["static"]then continue; - invoke(self,v["name"],nil); - end - end - function getdir(); - begin - if fdiag.ChooseDlg()then - begin - fdir.text := fdiag.Folder; - end - end - function setlist(d); - begin - FList.DeleteAllItems(); - fdbg.Enabled := false; - if d and ifarray(d)then - begin - FList.appendItems(d); - FList.SelectedId := 0; - fdbg.Enabled := true; - end - end - function getstartfilename(sv); - begin - dirt := fdir.Text; - if not sv then sv := FList.SelectedValue; - if dirt and sv then - begin - if sv then - begin - fs := sv["info"]; - if fs then + for i := length(fs)-1 downto 1 do begin - for i := length(fs)-1 downto 1 do + if fs[i]in array("\\","/")then begin - if fs[i]in array("\\","/")then - begin - fs := fs[i+1:]; - break; - end + fs := fs[i+1:]; + break; end - return gettruefile(dirt,fs,ioFileseparator()); end + return gettruefile(dirt,fs,ioFileseparator()); end end end - private - function getinfo(); - begin - return %% + end + private + function getinfo(); + begin + return %% object tserlogersimplewnd1:tserlogersimplewnd - caption="远程调试" - color=0xFFFFFF - top=100 - height=550 - minmaxbox=false - onclose=tserlogersimplewnd1_close - width=580 - wsdlgmodalframe=true - wssizebox=false - object label1:tlabel - left=4 - top=3 - width=80 - height=25 - caption="服务器地址" - end - object furl:tedit - height=25 - left=88 - tabstop=true - top=3 - width=204 - end - object label2:tlabel - left=296 - top=3 - width=34 - height=25 - caption="端口" - end - object fport:tedit - height=25 - left=333 - tabstop=true - top=3 - width=62 - end - object label3:tlabel - left=2 - top=38 - width=80 - height=25 - caption=" 用户名" - end - object fusr:tedit - height=25 - left=88 - tabstop=true - top=38 - width=300 - end - object label4:tlabel - left=2 - top=72 - width=80 - height=25 - caption=" 密 码" - end - object label5:tlabel - left=2 - top=100 - width=80 - height=25 - caption=" 脚本目录" - end + caption="远程调试" + color=0xFFFFFF + top=100 + height=550 + minmaxbox=false + onclose=tserlogersimplewnd1_close + width=580 + wsdlgmodalframe=true + wssizebox=false + object label1:tlabel + left=4 + top=3 + width=80 + height=25 + caption="服务器地址" + end + object furl:tedit + height=25 + left=88 + tabstop=true + top=3 + width=204 + end + object label2:tlabel + left=296 + top=3 + width=34 + height=25 + caption="端口" + end + object fport:tedit + height=25 + left=333 + tabstop=true + top=3 + width=62 + end + object label3:tlabel + left=2 + top=38 + width=80 + height=25 + caption=" 用户名" + end + object fusr:tedit + height=25 + left=88 + tabstop=true + top=38 + width=300 + end + object label4:tlabel + left=2 + top=72 + width=80 + height=25 + caption=" 密 码" + end + object label5:tlabel + left=2 + top=100 + width=80 + height=25 + caption=" 脚本目录" + end - object fpwd:tpassword - height=25 - left=88 - tabstop=true - top=72 - width=300 - end - object fdir:tedit - height=25 - left=88 - tabstop=true - top=100 - width=300 - end - object fcbtn:tbtn - caption="..." - height=25 - left=390 - tabstop=true - top=100 - width=22 - onclick=getdir - end - object flogout:tbtn - an1chors=[akright akbottom] - caption="取消" - height=23ff - left=375 - tabstop=true - top=480 - width=74 - end - object fdbg:tbtn - an1chors=[akright akbottom] - caption="调试" - height=23 - left=470 - tabstop=true - top=480 - width=74 - end - object flogin:tbtn - caption="连接" - height=23 - left=470 - tabstop=true - top=140 - width=74 - end - object flist:tlistview - anch1ors=[akTop akright akLeft akBottom] - height=290 - left=2 - top=180 - width=560 - end - object fdiag:tfolderchooseadlg - caption="执行目录" - end + object fpwd:tpassword + height=25 + left=88 + tabstop=true + top=72 + width=300 + end + object fdir:tedit + height=25 + left=88 + tabstop=true + top=100 + width=300 + end + object fcbtn:tbtn + caption="..." + height=25 + left=390 + tabstop=true + top=100 + width=22 + onclick=getdir + end + object flogout:tbtn + an1chors=[akright akbottom] + caption="取消" + height=23ff + left=375 + tabstop=true + top=480 + width=74 + end + object fdbg:tbtn + an1chors=[akright akbottom] + caption="调试" + height=23 + left=470 + tabstop=true + top=480 + width=74 + end + object flogin:tbtn + caption="连接" + height=23 + left=470 + tabstop=true + top=140 + width=74 + end + object flist:tlistview + anch1ors=[akTop akright akLeft akBottom] + height=290 + left=2 + top=180 + width=560 + end + object fdiag:tfolderchooseadlg + caption="执行目录" + end end %%; - end - private - function setdata(d); + end + private + function setdata(d); + begin + if not ifarray(d)then return; + furl.text := d["addr"]; + fport.text := d["port"]; + fusr.text := d["usr"]; + fpwd.text := d["pwd"]; + fdir.text := d["dir"]; + end + function gettruefile(dir,n,fio); + begin + if dir and ifstring(dir)then begin - if not ifarray(d)then return; - furl.text := d["addr"]; - fport.text := d["port"]; - fusr.text := d["usr"]; - fpwd.text := d["pwd"]; - fdir.text := d["dir"]; - end - function gettruefile(dir,n,fio); - begin - if dir and ifstring(dir)then + rfile := dir+fio+n; + if fileexists("",rfile)then return rfile; + for i,v in FileList("",dir+fio+"*") do begin - rfile := dir+fio+n; - if fileexists("",rfile)then return rfile; - for i,v in FileList("",dir+fio+"*") do + fn := v["FileName"]; + if pos("D",v["Attr"])and not(fn in array(".",".."))then begin - fn := v["FileName"]; - if pos("D",v["Attr"])and not(fn in array(".",".."))then - begin - rfile := gettruefile(dir+fio+fn,n,fio); - if rfile then return rfile; - end + rfile := gettruefile(dir+fio+fn,n,fio); + if rfile then return rfile; end end end end - function tdbgcallback(); +end +function tdbgcallback(); +begin + global g_tsldbgcallback_handle; + if g_tsldbgcallback_handle then call(g_tsldbgcallback_handle,sysparams); +end +function filenameIsTheSame(p1,p2); +begin + if not(ifstring(p1)and ifstring(p2))then return 0; + if p1=p2 then return 1; + {$ifdef linux} + {$else} + return lowercase(p1)=lowercase(p2); + {$endif} +end +type TMouseMoveList=class(TListBox) + function Create(AOwner);override; begin - global g_tsldbgcallback_handle; - if g_tsldbgcallback_handle then call(g_tsldbgcallback_handle,sysparams); + inherited; + FCurrentIndex :=-1; end - function filenameIsTheSame(p1,p2); + function MouseMove(o,e);override; begin - if not(ifstring(p1)and ifstring(p2))then return 0; - if p1=p2 then return 1; - {$ifdef linux} - {$else} - return lowercase(p1)=lowercase(p2); - {$endif} + inherited; + idx := GetIdxByYpos(e.ypos); + if FCurrentIndex <> idx then + begin + FCurrentIndex := idx; + InValidateRect(nil,false); + end end - type TMouseMoveList=class(TListBox) - function Create(AOwner);override; - begin - inherited; - FCurrentIndex :=-1; - end - function MouseMove(o,e);override; - begin - inherited; - idx := GetIdxByYpos(e.ypos); - if FCurrentIndex <> idx then - begin - FCurrentIndex := idx; - InValidateRect(nil,false); - end - end - function getItemText(i);override; - begin - r := inherited; - return " "+r; - end - function PaintIdx(idx,rc_,cvs);virtual; - begin - {** - @explan(说明)绘制项 %% - @param(item)(TCustomListItem) 项 %% - @param(rc)(array) 绘制区域%% - @param(cvs)(tcanvas) 画布 %% - **} - inherited; - if idx=FCurrentIndex then - begin - rc := rc_; - rc[2:3]-= 1; - cvs.pen.Color := rgb(30,144,255); - cvs.draw("Polyline",array(rc[0:1],(rc[2],rc[1]),(rc[2],rc[3]),(rc[0],rc[3]),rc[0:1])); - end - end - private - FCurrentIndex; + function getItemText(i);override; + begin + r := inherited; + return " "+r; end - type TTSLDataGrid=class(TDrawGrid) + function PaintIdx(idx,rc_,cvs);virtual; + begin {** - @explan(说明)TSL数组和对象展示 %% + @explan(说明)绘制项 %% + @param(item)(TCustomListItem) 项 %% + @param(rc)(array) 绘制区域%% + @param(cvs)(tcanvas) 画布 %% **} - private - static FHGS; - ftext; - FCols; - Fdata; - FMRWD; - FGridControl; - FRows; - FShowTwo; - FCControls; - FColumnWidth; - FRowHeader; - FControlIndex; - FStringAlign; - FNumberAlign; - FDefAlign; - FCanedit; - function showstring(f); + inherited; + if idx=FCurrentIndex then begin - if ifarray(Fdata)then - begin - gettxtobj(); - ftext.text := ""; - if f then - begin - ftext.HighLighter := FHGS[1]; //FHGS[1]; - ftext.Caption := "json"; - ftext.text := ejsonformat(Fdata); - end else - begin - ftext.HighLighter := FHGS[0]; - ftext.Caption := "原串...."; - ftext.text := tostn(Fdata); - end - ftext.show(); - end + rc := rc_; + rc[2:3]-= 1; + cvs.pen.Color := rgb(30,144,255); + cvs.draw("Polyline",array(rc[0:1],(rc[2],rc[1]),(rc[2],rc[3]),(rc[0],rc[3]),rc[0:1])); end - function getdata(i,j,cp,indexs); + end + private + FCurrentIndex; +end +type TTSLDataGrid=class(TDrawGrid) + {** + @explan(说明)TSL数组和对象展示 %% + **} + private + static FHGS; + ftext; + FCols; + Fdata; + FMRWD; + FGridControl; + FRows; + FShowTwo; + FCControls; + FColumnWidth; + FRowHeader; + FControlIndex; + FStringAlign; + FNumberAlign; + FDefAlign; + FCanedit; + function showstring(f); + begin + if ifarray(Fdata)then begin - {** - @explan(说明) 获取数据 - **} - if j=0 and FRowHeader then return FRows[i]; - r := FRows[i]; - if FCols and FShowTwo then + gettxtobj(); + ftext.text := ""; + if f then begin - if FRowHeader then c := FCols[j-1]; - else c := FCols[j]; - d := FData[r][c]; - if cp then cp := "["+tostn(r)+"]"; - if cp then cp += "["+tostn(c)+"]"; - if indexs then indexs := array(r,c); + ftext.HighLighter := FHGS[1]; //FHGS[1]; + ftext.Caption := "json"; + ftext.text := ejsonformat(Fdata); end else begin - d := FData[FRows[i]]; - if cp then + ftext.HighLighter := FHGS[0]; + ftext.Caption := "原串...."; + ftext.text := tostn(Fdata); + end + ftext.show(); + end + end + function getdata(i,j,cp,indexs); + begin + {** + @explan(说明) 获取数据 + **} + if j=0 and FRowHeader then return FRows[i]; + r := FRows[i]; + if FCols and FShowTwo then + begin + if FRowHeader then c := FCols[j-1]; + else c := FCols[j]; + d := FData[r][c]; + if cp then cp := "["+tostn(r)+"]"; + if cp then cp += "["+tostn(c)+"]"; + if indexs then indexs := array(r,c); + end else + begin + d := FData[FRows[i]]; + if cp then + begin + cs := r; + if ifstring(cs)then cs := replacetext(cs,".","\\o"); + cp := "["+tostn(cs)+"]"; + end + if indexs then indexs := array(r); + end + return d; + end + function SetStringAlign(v); + begin + if v <> FStringAlign then + begin + FStringAlign := v; + InvalidateRect(nil,true); + end + end + function SetNumberAlign(v); + begin + if v <> FNumberAlign then + begin + FNumberAlign := v; + InvalidateRect(nil,true); + end + end + function SetdefAlign(v); + begin + if v <> FDefAlign then + begin + FDefAlign := v; + InvalidateRect(nil,true); + end + end + function GetTSLData(); + begin + return FData; + end + function StrToNumber(s); + begin + if pos(".",s)then + begin + return StrToFloatDef(s,0); + end else + begin + return StrToIntDef(s,0); + end + end + function SetRowHeader(v); + begin + nv := v?true:false; + if FRowHeader <> nv then + begin + FRowHeader := nv; + FD := FData; + SetData(array()); + SetData(FD); + end + end + function SetTwoD(v); + begin + //if parent is class(TTSLDataGrid)then exit; + nv := v?true:false; + if nv <> FShowTwo then + begin + if FCanedit and nv then return; //编辑情况 + FD := FData; + SetData(array()); + FShowTwo := nv; + SetData(FD); + end + end + function setdatap(); + begin + if not Fdata then exit; + FCols := nil; + FRows := mrows(Fdata,1); + FCL := mcols(Fdata,1); + allFCL := true; + if FShowTwo then + begin + for i,v in FData do + begin + if not ifarray(v)then begin - cs := r; - if ifstring(cs)then cs := replacetext(cs,".","\\o"); - cp := "["+tostn(cs)+"]"; + allFCL := false; + break; end - if indexs then indexs := array(r); - end - return d; - end - function SetStringAlign(v); - begin - if v <> FStringAlign then - begin - FStringAlign := v; - InvalidateRect(nil,true); end end - function SetNumberAlign(v); + fcs := array(); + wd := 150; + for i,v in FRows do begin - if v <> FNumberAlign then + if ifstring(v)then begin - FNumberAlign := v; - InvalidateRect(nil,true); + wd := max(wd,length(v) * 9); + if wd>200 then break; end end - function SetdefAlign(v); + if RowHeader then begin - if v <> FDefAlign then + fcs[0]:= array("text":" ","width":min(200,wd)); + end + if FCL and allFCL and FShowTwo then + begin + FCols := FCl; + for i,v in FCols do begin - FDefAlign := v; - InvalidateRect(nil,true); + fcs[length(fcs)]:= array("text":ifstring(v)?v:inttostr(v),"width":FMRWD); + end + end else + begin + fcs[length(fcs)]:= array("text":" ","width":ColumnWidth>20?ColumnWidth:150); + end + Columns := fcs; + ItemCount := length(FRows); + end + function gettxtobj(); + begin + if not ftext then + begin + FText := new TFTSLScriptMemo(self); //tmemo(self); + //ftext.HighLighter := FHGS[0]; + ftext.readonly := true; + ftext.left := left+20; + ftext.top := top+20; + ftext.width := 500; + ftext.height := 400; + ftext.wspopup := true; + FText.WsSysMenu := true; + ftext.WsSizeBox := true; + FText.onclose := function(o,e) + begin + e.skip := true; + o.visible := false; + end + FText.parent := self; + end + return ftext; + end + function SetData(data,f); + begin + if Fdata=data then return; + DeleteAllColumns(); + if ftext then ftext.Visible := false; + for i,v in mrows(FCControls,1) do + begin + obj := FCControls[v]; + obj.TSLdata := nil; + obj.Visible := false; + obj.Parent := nil; + end + FCControls := array(); + FData := data; + setdatap(); + end + function itemishow(r,r2); + begin + return r[2]r2[2]; + end + function getdtobject(); + begin + global Fdtobjects; + if not ifarray(Fdtobjects)then Fdtobjects := array(); + for i,v in Fdtobjects do + begin + p := v.Parent; + if not p then + begin + return v; end end - function GetTSLData(); + o := new TTSlDataGrid(initializeapplication()); + o.ControlIndexs(idexs); + o.height := 500; + o.width := 500; + o.Twodimensional := Twodimensional; + o.Visible := false; + o.wspopup := true; + o.WsSysMenu := true; + o.WsSizeBox := true; + o.onclose := thisfunction(ShowDataClose); + Fdtobjects[length(Fdtobjects)]:= o; + return o; + end + function getitemcontrol(d,p,i,j,tp,cp,idexs); + begin + idx := format("%d*%d",i,j); + o := FCControls[idx]; + if tp="grid" then begin - return FData; - end - function StrToNumber(s); - begin - if pos(".",s)then + if not o then begin - return StrToFloatDef(s,0); - end else - begin - return StrToIntDef(s,0); + o := getdtobject(); + o.parent := self; + FCControls[idx]:= o; end + //o.Twodimensional := Twodimensional; + if o.wspopup then p := ClientToScreen(p[0],p[1]); + o.left := p[0]-20; + o.top := p[1]-20; + o.caption := caption+"."+cp; + o.TSLdata := d; + o.show(); end - function SetRowHeader(v); + end + public + function create(AOwner);override; + begin + inherited; + if not fhgs then begin - nv := v?true:false; - if FRowHeader <> nv then - begin - FRowHeader := nv; - FD := FData; - SetData(array()); - SetData(FD); - end + FHGS := array(); + FHGS[0]:= new TTslSynHighLighter(initializeapplication()); + FHGS[1]:= new TJsonSynHighLighter(initializeapplication()); end - function SetTwoD(v); + GridLine := true; + FCControls := array(); + FRowHeader := true; + FixedColumns := 1; + itemheight := 25; + caption := ""; + FMRWD := 150; + FShowTwo := false; + OndblClick := thisfunction(GridCellDblClick); + FNumberAlign := AL9_CENTERRIGHT; + FStringAlign := AL9_CENTERLEFT; + FDefAlign := AL9_CENTER; + mu := new TPopupmenu(self); + for i,v in array("一维","二维","原串","json") do begin - //if parent is class(TTSLDataGrid)then exit; - nv := v?true:false; - if nv <> FShowTwo then + mi := new TMenu(self); + mi.parent := mu; + mi.caption := v; + mi.OnClick := function(o,e) begin - if FCanedit and nv then return; //编辑情况 - FD := FData; - SetData(array()); - FShowTwo := nv; - SetData(FD); - end - end - function setdatap(); - begin - if not Fdata then exit; - FCols := nil; - FRows := mrows(Fdata,1); - FCL := mcols(Fdata,1); - allFCL := true; - if FShowTwo then - begin - for i,v in FData do - begin - if not ifarray(v)then + case o.caption of + "一维": begin - allFCL := false; - break; + Twodimensional := false; + end + "二维": + begin + if FCanedit then return; + Twodimensional := true; + end + "原串": + begin + showstring(); + end + "json": + begin + showstring(1); end end end - fcs := array(); - wd := 150; - for i,v in FRows do + end + PopupMenu := mu; + end + function DoDrawSubItem(o,e);override; + begin + inherited; + if e.skip then exit; + dc := e.canvas; + i := e.itemid; + j := e.subitemid; + d := getdata(i,j); + src := e.SubItemRect; + if j=0 and FRowHeader then + begin + //_wapi.DrawFrameControl(dc.Handle,src,DFC_BUTTON,DFCS_BUTTONPUSH); + dc.Draw("framecontrol",array(src[0:1],src[2:3]),DFC_BUTTON,DFCS_BUTTONPUSH); + end + ds := ""; + dc.font.color := 0; + if ifarray(d)then + begin + ds := format("",length(d)); + //dc.drawtext(ds,src); + class(TLabel).CanvasDrawAlignText(dc,src,ds,FDefAlign); + end else + if ifstring(d)then + begin + ds := d; + //dc.drawtext(ds,src); + class(TLabel).CanvasDrawAlignText(dc,src,ds,FStringAlign); + end else + begin + ds := tostn(d); + if d<0 then dc.font.color := rgb(200,0,0); + if ifnumber(d)and j>0 then begin - if ifstring(v)then - begin - wd := max(wd,length(v) * 9); - if wd>200 then break; - end - end - if RowHeader then - begin - fcs[0]:= array("text":" ","width":min(200,wd)); - end - if FCL and allFCL and FShowTwo then - begin - FCols := FCl; - for i,v in FCols do - begin - fcs[length(fcs)]:= array("text":ifstring(v)?v:inttostr(v),"width":FMRWD); - end + //dc.drawtext(ds,src,DT_RIGHT); + class(TLabel).CanvasDrawAlignText(dc,src,ds,FNumberAlign); end else begin - fcs[length(fcs)]:= array("text":" ","width":ColumnWidth>20?ColumnWidth:150); + //dc.drawtext(ds,src); + if not ifnil(d)then class(TLabel).CanvasDrawAlignText(dc,src,ds,FStringAlign); end - Columns := fcs; - ItemCount := length(FRows); end - function gettxtobj(); + end + function GridCellDblClick(o,e);virtual; + begin + cp := 1; + cl := e.isubitem; + if cl<1 and FRowHeader then exit; + indexs := 1; + d := getdata(e.iitem,cl,cp,indexs); + p := e.ptaction; + if ifarray(d)then begin - if not ftext then - begin - FText := new TFTSLScriptMemo(self); //tmemo(self); - //ftext.HighLighter := FHGS[0]; - ftext.readonly := true; - ftext.left := left+20; - ftext.top := top+20; - ftext.width := 500; - ftext.height := 400; - ftext.wspopup := true; - FText.WsSysMenu := true; - ftext.WsSizeBox := true; - FText.onclose := function(o,e) - begin - e.skip := true; - o.visible := false; - end - FText.parent := self; - end - return ftext; + if d then getitemcontrol(d,p,e.iitem,cl,"grid",cp,indexs); + end else + begin + gettxtobj(); + ftext.caption := Caption+"."+cp; + FText.text := tostn(d); + FText.show(); end - function SetData(data,f); + end + function ShowDataClose(o,e); + begin + o.show(false); + o.TSLdata := array(); + e.skip := true; + end + function Recycling();override; + begin + inherited; + ftext := nil; + FCols := nil; + Fdata := nil; + FControls := array(); + end + function ControlIndexs(dx); + begin + {** + @ignore(忽略) %% + **} + if dx then FControlIndex := dx; + return FControlIndex; + end + property Twodimensional:bool read FShowTwo write SetTwoD; + property TSLdata:variable read GetTSLData write SetData; + property ColumnWidth:integer read FColumnWidth write FColumnWidth; + property RowHeader:bool read FRowHeader write SetRowHeader; + property StringAlign:AlignStyle9 read FStringAlign write SetStringAlign; + property NumberAlign:AlignStyle9 read FNumberAlign write SetNumberAlign; + property DefAlign:AlignStyle9 read FDefAlign write SetdefAlign; + {** + @param(Twodimensional)(BOOL) 是否二维强制二维展示 %% + @param(TSLdata)(array) tsl数据 %% + **} +end +type TGroupGridA=class(TDrawGrid) + {** + @explan(说明)带层级功能的表格 %% + **} + {** + @expample(范例) + FGrid := new TGroupGridA(self); + FGrid.border := true; + FGrid.OddLineBKColor := 0xFF0000; //奇数行背景色 + FGrid.EvenLineBKColor := 0x00FF00;//偶数行背景色 + cls := array(("text":"a","width":300),("text":"b","width":30)); //设置标题 + FGrid.Columns := cls; + d := array( + ("id":1,"data":("福哥",true)), + ("id":2,"data":("a",false)), + ("id":3,"pid":1,"data":(("value":"a","type":"string","font":("color":rgb(200,0,0))),true)), + ("id":4,"pid":1,"data":("a",false)), + ("id":5,"pid":3,"data":("a",false)) + ); + FGrid.SetNodeData(d); //设置数据 + //获得数据使用 FGrid.GetNodeData(); + **} + uses tslvcl; + function Create(AOwner);override; + begin + inherited; + GridLine := true; + FOddLineBKColor := 0xFAF3F1; + FEvenLineBKColor := 0xFFFFFF; + FNodeManger := new TGroupManger(); + GridLine := true; + FNodes := array(); + FCellediter := new tedit(self); + FCellediter.Visible := false; + FCellediter.Parent := self; + FCellediter.onkeyup := thisfunction(doeditcell); + FCellediter.onKillFocus := function(o,e) begin - if Fdata=data then return; - DeleteAllColumns(); - if ftext then ftext.Visible := false; - for i,v in mrows(FCControls,1) do - begin - obj := FCControls[v]; - obj.TSLdata := nil; - obj.Visible := false; - obj.Parent := nil; - end - FCControls := array(); - FData := data; - setdatap(); - end - function itemishow(r,r2); - begin - return r[2]r2[2]; - end - function getdtobject(); - begin - global Fdtobjects; - if not ifarray(Fdtobjects)then Fdtobjects := array(); - for i,v in Fdtobjects do - begin - p := v.Parent; - if not p then - begin - return v; - end - end - o := new TTSlDataGrid(initializeapplication()); - o.ControlIndexs(idexs); - o.height := 500; - o.width := 500; - o.Twodimensional := Twodimensional; o.Visible := false; - o.wspopup := true; - o.WsSysMenu := true; - o.WsSizeBox := true; - o.onclose := thisfunction(ShowDataClose); - Fdtobjects[length(Fdtobjects)]:= o; - return o; end - function getitemcontrol(d,p,i,j,tp,cp,idexs); - begin - idx := format("%d*%d",i,j); - o := FCControls[idx]; - if tp="grid" then - begin - if not o then - begin - o := getdtobject(); - o.parent := self; - FCControls[idx]:= o; - end - //o.Twodimensional := Twodimensional; - if o.wspopup then p := ClientToScreen(p[0],p[1]); - o.left := p[0]-20; - o.top := p[1]-20; - o.caption := caption+"."+cp; - o.TSLdata := d; - o.show(); - end - end - public - function create(AOwner);override; - begin - inherited; - if not fhgs then - begin - FHGS := array(); - FHGS[0]:= new TTslSynHighLighter(initializeapplication()); - FHGS[1]:= new TJsonSynHighLighter(initializeapplication()); - end - GridLine := true; - FCControls := array(); - FRowHeader := true; - FixedColumns := 1; - itemheight := 25; - caption := ""; - FMRWD := 150; - FShowTwo := false; - OndblClick := thisfunction(GridCellDblClick); - FNumberAlign := AL9_CENTERRIGHT; - FStringAlign := AL9_CENTERLEFT; - FDefAlign := AL9_CENTER; - mu := new TPopupmenu(self); - for i,v in array("一维","二维","原串","json") do - begin - mi := new TMenu(self); - mi.parent := mu; - mi.caption := v; - mi.OnClick := function(o,e) - begin - case o.caption of - "一维": - begin - Twodimensional := false; - end - "二维": - begin - if FCanedit then return; - Twodimensional := true; - end - "原串": - begin - showstring(); - end - "json": - begin - showstring(1); - end - end - end - end - PopupMenu := mu; - end - function DoDrawSubItem(o,e);override; - begin - inherited; - if e.skip then exit; - dc := e.canvas; - i := e.itemid; - j := e.subitemid; - d := getdata(i,j); - src := e.SubItemRect; - if j=0 and FRowHeader then - begin - //_wapi.DrawFrameControl(dc.Handle,src,DFC_BUTTON,DFCS_BUTTONPUSH); - dc.Draw("framecontrol",array(src[0:1],src[2:3]),DFC_BUTTON,DFCS_BUTTONPUSH); - end - ds := ""; - dc.font.color := 0; - if ifarray(d)then - begin - ds := format("",length(d)); - //dc.drawtext(ds,src); - class(TLabel).CanvasDrawAlignText(dc,src,ds,FDefAlign); - end else - if ifstring(d)then - begin - ds := d; - //dc.drawtext(ds,src); - class(TLabel).CanvasDrawAlignText(dc,src,ds,FStringAlign); - end else - begin - ds := tostn(d); - if d<0 then dc.font.color := rgb(200,0,0); - if ifnumber(d)and j>0 then - begin - //dc.drawtext(ds,src,DT_RIGHT); - class(TLabel).CanvasDrawAlignText(dc,src,ds,FNumberAlign); - end else - begin - //dc.drawtext(ds,src); - if not ifnil(d)then class(TLabel).CanvasDrawAlignText(dc,src,ds,FStringAlign); - end - end - end - function GridCellDblClick(o,e);virtual; - begin - cp := 1; - cl := e.isubitem; - if cl<1 and FRowHeader then exit; - indexs := 1; - d := getdata(e.iitem,cl,cp,indexs); - p := e.ptaction; - if ifarray(d)then - begin - if d then getitemcontrol(d,p,e.iitem,cl,"grid",cp,indexs); - end else - begin - gettxtobj(); - ftext.caption := Caption+"."+cp; - FText.text := tostn(d); - FText.show(); - end - end - function ShowDataClose(o,e); - begin - o.show(false); - o.TSLdata := array(); - e.skip := true; - end - function Recycling();override; - begin - inherited; - ftext := nil; - FCols := nil; - Fdata := nil; - FControls := array(); - end - function ControlIndexs(dx); - begin - {** - @ignore(忽略) %% - **} - if dx then FControlIndex := dx; - return FControlIndex; - end - property Twodimensional:bool read FShowTwo write SetTwoD; - property TSLdata:variable read GetTSLData write SetData; - property ColumnWidth:integer read FColumnWidth write FColumnWidth; - property RowHeader:bool read FRowHeader write SetRowHeader; - property StringAlign:AlignStyle9 read FStringAlign write SetStringAlign; - property NumberAlign:AlignStyle9 read FNumberAlign write SetNumberAlign; - property DefAlign:AlignStyle9 read FDefAlign write SetdefAlign; - {** - @param(Twodimensional)(BOOL) 是否二维强制二维展示 %% - @param(TSLdata)(array) tsl数据 %% - **} + //inherited SetColumns(array(("text":"","width":25))); end - type TGroupGridA=class(TDrawGrid) - {** - @explan(说明)带层级功能的表格 %% - **} - {** - @expample(范例) - FGrid := new TGroupGridA(self); - FGrid.border := true; - FGrid.OddLineBKColor := 0xFF0000; //奇数行背景色 - FGrid.EvenLineBKColor := 0x00FF00;//偶数行背景色 - cls := array(("text":"a","width":300),("text":"b","width":30)); //设置标题 - FGrid.Columns := cls; - d := array( - ("id":1,"data":("福哥",true)), - ("id":2,"data":("a",false)), - ("id":3,"pid":1,"data":(("value":"a","type":"string","font":("color":rgb(200,0,0))),true)), - ("id":4,"pid":1,"data":("a",false)), - ("id":5,"pid":3,"data":("a",false)) - ); - FGrid.SetNodeData(d); //设置数据 - //获得数据使用 FGrid.GetNodeData(); - **} - uses tslvcl; - function Create(AOwner);override; - begin - inherited; - GridLine := true; - FOddLineBKColor := 0xFAF3F1; - FEvenLineBKColor := 0xFFFFFF; - FNodeManger := new TGroupManger(); - GridLine := true; - FNodes := array(); - FCellediter := new tedit(self); - FCellediter.Visible := false; - FCellediter.Parent := self; - FCellediter.onkeyup := thisfunction(doeditcell); - FCellediter.onKillFocus := function(o,e) + function doeditcell(o,e); + begin + //echo "\r\nkey up:",e.charcode; + case e.charcode of + 13: begin + e.skip := true; o.Visible := false; + callDatafunction(FCelledit,o._Tag,o.text); end - //inherited SetColumns(array(("text":"","width":25))); - end - function doeditcell(o,e); + end; + end + function SetNodeData(d,ncls); //设置数据 + begin + FCellediter.Visible := false; + if not ncls then begin - //echo "\r\nkey up:",e.charcode; - case e.charcode of - 13: - begin - e.skip := true; - o.Visible := false; - callDatafunction(FCelledit,o._Tag,o.text); - end - end; + FCurrentNode_a := nil; + FNodeManger.RootNode.RecyclingChildren(); + FNodeData := array(); + FNodeIds := array(); end - function SetNodeData(d,ncls); //设置数据 + for i,v in d do begin - FCellediter.Visible := false; - if not ncls then + id := v["id"]; + nd := FNodeData[id]; + if nd then begin - FCurrentNode_a := nil; - FNodeManger.RootNode.RecyclingChildren(); - FNodeData := array(); - FNodeIds := array(); - end - for i,v in d do - begin - id := v["id"]; - nd := FNodeData[id]; - if nd then - begin - for j,vj in v["data"] do - begin - nd[j]:= vj; - end - continue; - end - pid := v["pid"]; - nd := CreateNode(); - nd.FNodeid := id; - nd.FNNNODE := V["nnp"]; - nd.Expanded := false; - pnd := FNodeData[pid]; for j,vj in v["data"] do begin nd[j]:= vj; end - if not(pnd)then AppendNode(nd); - else AppendNode(nd,pnd); - FNodeData[id]:= nd; - FNodeIds[id]:= pid; + continue; end - UpdateWindow(); - InValidateRect(nil,false); - end - function GetNodeData(); //获得数据 - begin - r := array(); - ri := 0; - for i,v in FNodeData do + pid := v["pid"]; + nd := CreateNode(); + nd.FNodeid := id; + nd.FNNNODE := V["nnp"]; + nd.Expanded := false; + pnd := FNodeData[pid]; + for j,vj in v["data"] do begin - r[ri,"id"]:= i; - r[ri,"pid"]:= FNodeIds[i]; - r[ri,"data"]:= v.FData; - ri++; + nd[j]:= vj; end - return r; + if not(pnd)then AppendNode(nd); + else AppendNode(nd,pnd); + FNodeData[id]:= nd; + FNodeIds[id]:= pid; end - function getcurrentnodedata(); + UpdateWindow(); + InValidateRect(nil,false); + end + function GetNodeData(); //获得数据 + begin + r := array(); + ri := 0; + for i,v in FNodeData do begin - if FCurrentNode_a then - begin - d := FCurrentNode_a.Fdata; - if d[3]="sysparams+" then return; - d[2]:= "*"; - FNodeManger.getcdnodes(FCurrentNode_a,r); - reindex(FNodeData,r); - reindex(FNodeIds,r); - FCurrentNode_a.RecyclingChildren(); - FCurrentNode_a.Expanded := false; - calldatafunction(FCelldbclk,self,array(1,d,FCurrentNode_a)); - end + r[ri,"id"]:= i; + r[ri,"pid"]:= FNodeIds[i]; + r[ri,"data"]:= v.FData; + ri++; end - function MouseDown(o,e);override; + return r; + end + function getcurrentnodedata(); + begin + if FCurrentNode_a then begin - // - inherited; - if e.shiftdouble()then - begin - r := HitTestItem(e.xpos,e.ypos); - if r[0]>= 0 and r[1]=1 then - begin - nd := FNodes[r[0]]; - d := nd.Fdata; - if d[2]in array("str","int","lstr","double","nil","int64")then - begin - try - rc := o.GetSubItemRect(r[0],r[1]); - FCellediter.SetBoundsRect(rc); - try - FCellediter.Text := d[1]["value"]; - except - FCellediter.Text := ""; - end; - FCellediter._Tag := array(r[1],d,nd); - FCellediter.show(); - FCellediter.SetFocus(); - except - end; - return; - end else - if d[2]="array" then - begin - calldatafunction(FShowarray,d); - return; - end - calldatafunction(FCelldbclk,o,array(r[1],d,nd)); - end - end - FCellediter.Visible := false; + d := FCurrentNode_a.Fdata; + if d[3]="sysparams+" then return; + d[2]:= "*"; + FNodeManger.getcdnodes(FCurrentNode_a,r); + reindex(FNodeData,r); + reindex(FNodeIds,r); + FCurrentNode_a.RecyclingChildren(); + FCurrentNode_a.Expanded := false; + calldatafunction(FCelldbclk,self,array(1,d,FCurrentNode_a)); end - function MouseUp(o,e);override; //展开折叠点击 + end + function MouseDown(o,e);override; + begin + // + inherited; + if e.shiftdouble()then begin - inherited; - r := HitTestItem(e.xpos+5,e.ypos); - if r[0]>= 0 then + r := HitTestItem(e.xpos,e.ypos); + if r[0]>= 0 and r[1]=1 then begin nd := FNodes[r[0]]; - if FCurrentNode_a <> nd then + d := nd.Fdata; + if d[2]in array("str","int","lstr","double","nil","int64")then begin - FCurrentNode_a := nd; - InValidateRect(nil,false); - end - if r[1]=0 then + try + rc := o.GetSubItemRect(r[0],r[1]); + FCellediter.SetBoundsRect(rc); + try + FCellediter.Text := d[1]["value"]; + except + FCellediter.Text := ""; + end; + FCellediter._Tag := array(r[1],d,nd); + FCellediter.show(); + FCellediter.SetFocus(); + except + end; + return; + end else + if d[2]="array" then begin - if nd and nd.NodeCount>0 then - begin - if nd.Expanded then nd.UnExpand(); - else nd.Expand(); - UpDateWindow(); - end + calldatafunction(FShowarray,d); return; end - v := nd[r[1]]; - if ifarray(v)then + calldatafunction(FCelldbclk,o,array(r[1],d,nd)); + end + end + FCellediter.Visible := false; + end + function MouseUp(o,e);override; //展开折叠点击 + begin + inherited; + r := HitTestItem(e.xpos+5,e.ypos); + if r[0]>= 0 then + begin + nd := FNodes[r[0]]; + if FCurrentNode_a <> nd then + begin + FCurrentNode_a := nd; + InValidateRect(nil,false); + end + if r[1]=0 then + begin + if nd and nd.NodeCount>0 then begin - if v["type"]="link" then - begin - return CallMessgeFunction(OnLinkCellClik,o,v); - end + if nd.Expanded then nd.UnExpand(); + else nd.Expand(); + UpDateWindow(); + end + return; + end + v := nd[r[1]]; + if ifarray(v)then + begin + if v["type"]="link" then + begin + //return CallMessgeFunction(OnLinkCellClik,o,v); end end end - function AppendNode(nd,pnd); //在父节点中追加节点 + end + function AppendNode(nd,pnd); //在父节点中追加节点 + begin + if not(pnd is class(TNode))then _pnd := FNodeManger.RootNode; + else _pnd := pnd; + _pnd.AppendNode(nd); + end + function InsertNode(nd,idx,pnd); //插入节点 + begin + if not(pnd is class(TNode))then _pnd := FNodeManger.RootNode; + else _pnd := pnd; + _pnd.InsertNode(nd,idx); + end + function CreateNode(); //构造节点 + begin + return FNodeManger.CreateNode(); + end + function InsertNodes(nds,idx,pnd); //批量添加节点 + begin + if not(pnd is class(TNode))then _pnd := FNodeManger.RootNode; + else _pnd := pnd; + _pnd.InsertNodes(nds,idx); + end + function GetNodeByIndex(idx); //通过序号获得节点,必须update后 + begin + return FNodes[idx]; + end + function UpDateWindow(); //update节点 + begin + //更新窗口 + FNodes := FNodeManger.ListNodes(); + ItemCount := length(FNodes); + end + function DoDrawItem(o,e);override; //绘制单元格 + begin + inherited; + j := e.Subitemid; + i := e.itemid; + DObject := FNodes[i]; + if not DObject then return; + dc := e.canvas; + e.rcitem := rec; + rec := e.SubItemRect; + wd := 4; + if FCurrentNode_a=DObject then begin - if not(pnd is class(TNode))then _pnd := FNodeManger.RootNode; - else _pnd := pnd; - _pnd.AppendNode(nd); - end - function InsertNode(nd,idx,pnd); //插入节点 + dc.Brush.Color := 0xffce87; + end else begin - if not(pnd is class(TNode))then _pnd := FNodeManger.RootNode; - else _pnd := pnd; - _pnd.InsertNode(nd,idx); - end - function CreateNode(); //构造节点 - begin - return FNodeManger.CreateNode(); - end - function InsertNodes(nds,idx,pnd); //批量添加节点 - begin - if not(pnd is class(TNode))then _pnd := FNodeManger.RootNode; - else _pnd := pnd; - _pnd.InsertNodes(nds,idx); - end - function GetNodeByIndex(idx); //通过序号获得节点,必须update后 - begin - return FNodes[idx]; - end - function UpDateWindow(); //update节点 - begin - //更新窗口 - FNodes := FNodeManger.ListNodes(); - ItemCount := length(FNodes); - end - function DoDrawItem(o,e);override; //绘制单元格 - begin - inherited; - j := e.Subitemid; - i := e.itemid; - DObject := FNodes[i]; - if not DObject then return; - dc := e.canvas; - e.rcitem := rec; - rec := e.SubItemRect; - wd := 4; - if FCurrentNode_a=DObject then + if i mod 2 then begin - dc.Brush.Color := 0xffce87; + dc.Brush.Color := FOddLineBKColor; // FOddLineBKColor := 0xFAF3F1; + end else + dc.Brush.Color := FEvenLineBKColor; // FEvenLineBKColor := 0xFFFFFF; + end + dc.FillRect(rec); + dc.pen.color := 0xa8a8a8; + //dc.pen.style := PS_DASHDOT; + dc.pen.width := 2; + dc.moveto(array(rec[2],rec[1])); + dc.LineTo(array(rec[2],rec[3])); + if j=0 then + begin + cj :=-1; + pd := DObject.Parent; + while pd do + begin + if not(pd.FNNNODE)then cj++; + pd := pd.Parent; + end + wd := cj * 20+4; + if DObject.NodeCount>0 then + begin + if DObject.Expanded then bmp := FBmpExpand; + else bmp := FBmpUnexpand; + bmp.Draw(dc,rec[0]+wd+1,rec[1]+10,SRCAND); + //dc.stretchdraw(array(rec[0]+2+wd,rec[1]+2,rec[0]+15+wd,rec[1]+15),bmp); + end + //rec[0]+=wd+4+18; + rec[0]+= wd+16; + end + if j >= 0 and DObject then + begin + rec[0]+= 4; + v := DObject[j]; + if ifstring(v)then + begin + //if j=0 and v="sysparams" then dc.font.color := 0x0000ff; + //else dc.font.color := 0; + dc.DrawText(v,rec,DT_SINGLELINE .| DT_VCENTER); end else begin - if i mod 2 then + if ifarray(v)then begin - dc.Brush.Color := FOddLineBKColor; // FOddLineBKColor := 0xFAF3F1; - end else - dc.Brush.Color := FEvenLineBKColor; // FEvenLineBKColor := 0xFFFFFF; - end - dc.FillRect(rec); - dc.pen.color := 0xa8a8a8; - //dc.pen.style := PS_DASHDOT; - dc.pen.width := 2; - dc.moveto(array(rec[2],rec[1])); - dc.LineTo(array(rec[2],rec[3])); - if j=0 then - begin - cj :=-1; - pd := DObject.Parent; - while pd do - begin - if not(pd.FNNNODE)then cj++; - pd := pd.Parent; - end - wd := cj * 20+4; - if DObject.NodeCount>0 then - begin - if DObject.Expanded then bmp := FBmpExpand; - else bmp := FBmpUnexpand; - bmp.Draw(dc,rec[0]+wd+1,rec[1]+10,SRCAND); - //dc.stretchdraw(array(rec[0]+2+wd,rec[1]+2,rec[0]+15+wd,rec[1]+15),bmp); - end - //rec[0]+=wd+4+18; - rec[0]+= wd+16; - end - if j >= 0 and DObject then - begin - rec[0]+= 4; - v := DObject[j]; - if ifstring(v)then - begin - //if j=0 and v="sysparams" then dc.font.color := 0x0000ff; - //else dc.font.color := 0; - dc.DrawText(v,rec,DT_SINGLELINE .| DT_VCENTER); - end else - begin - if ifarray(v)then + val := v["value"]; + typ := v["type"]; + ft := v["font"]; + rebk := false; + if ifarray(ft)and ft then begin - val := v["value"]; - typ := v["type"]; - ft := v["font"]; - rebk := false; - if ifarray(ft)and ft then - begin - bf := dc.font.fontinfo(); - dc.font.setvalues(ft); - rebk := true; - end - if typ="link" then - begin - udl := dc.font.underline; - fcl := dc.Font.Color; - dc.font.underline := true; - dc.Font.Color := rgb(0,0,254); - end - if ifstring(val)then - begin - dc.drawtext(val,rec,DT_SINGLELINE .| DT_VCENTER .| DT_NOPREFIX); - end else - if ifarray(val)then - begin - dc.drawtext(format("ARRAY<[%d]>",Length(val)),rec,DT_SINGLELINE .| DT_VCENTER .| DT_NOPREFIX); - end - //还原 - if rebk then - begin - dc.font.SetValues(bf); - end else - if typ="link" then - begin - dc.font.underline := udl; - dc.Font.Color := fcl; - end + bf := dc.font.fontinfo(); + dc.font.setvalues(ft); + rebk := true; + end + if typ="link" then + begin + udl := dc.font.underline; + fcl := dc.Font.Color; + dc.font.underline := true; + dc.Font.Color := rgb(0,0,254); + end + if ifstring(val)then + begin + dc.drawtext(val,rec,DT_SINGLELINE .| DT_VCENTER .| DT_NOPREFIX); end else + if ifarray(val)then begin - if not ifnil(v)then dc.drawtext(tostn(v),rec,DT_SINGLELINE .| DT_VCENTER .| DT_NOPREFIX); + dc.drawtext(format("ARRAY<[%d]>",Length(val)),rec,DT_SINGLELINE .| DT_VCENTER .| DT_NOPREFIX); end + //还原 + if rebk then + begin + dc.font.SetValues(bf); + end else + if typ="link" then + begin + dc.font.underline := udl; + dc.Font.Color := fcl; + end + end else + begin + if not ifnil(v)then dc.drawtext(tostn(v),rec,DT_SINGLELINE .| DT_VCENTER .| DT_NOPREFIX); end end end - function Recycling();override; + end + function Recycling();override; + begin + inherited; + FCurrentNode_a := nil; + FCelldbclk := nil; + FShowarray := nil; + FCelledit := nil; + FOnLinkCellClik := nil; + FBoolColumns := nil; + FOddLineBKColor := nil; + FEvenLineBKColor := nil; + FNodeData := nil; + FNodeIds := nil; + FCellediter := nil; + end + published //属性 + property OddLineBKColor read FOddLineBKColor write FOddLineBKColor; + property EvenLineBKColor read FEvenLineBKColor write FEvenLineBKColor; + property BoolColumns read FBoolColumns write FBoolColumns; + property OnLinkCellClik read FOnLinkCellClik write FOnLinkCellClik; + property celldbclk read FCelldbclk write FCelldbclk; + property celledit read FCellEdit write FCelledit; + property Showarray read FShowarray write FShowarray; + private + function GetChildAllChecked(nd,j,ck); + begin + nck := not(ck); + for i := 0 to nd.NodeCount-1 do + begin + cnd := nd.GetNodeByIndex(i); + if ifobj(cnd)then + begin + if cnd.NodeCount=0 then + begin + if cnd[j]=nck then return 0; + end + if 0=GetChildAllChecked(cnd,j,ck)then return 0; + end + end + return 1; + end + function CheckAllChild(nd,j,ck); + begin + for i := 0 to nd.NodeCount-1 do + begin + cnd := nd.GetNodeByIndex(i); + if ifobj(cnd)then + begin + vi := nd[j]; + if vi=0 or vi=1 then cnd[j]:= ck; + CheckAllChild(cnd,j,ck); + end + end + end + FBoolColumns; + FOddLineBKColor; + FEvenLineBKColor; + FNodeData; + FNodeIds; + FOnLinkCellClik; + FCelldbclk; + FCelledit; + FShowarray; + FCellediter; + protected + type TGroupNode=class(TNode) //groupgrid节点 + uses tslvcl; + function Create(); begin inherited; - FCurrentNode_a := nil; - FCelldbclk := nil; - FShowarray := nil; - FCelledit := nil; - FOnLinkCellClik := nil; - FBoolColumns := nil; - FOddLineBKColor := nil; - FEvenLineBKColor := nil; - FNodeData := nil; - FNodeIds := nil; - FCellediter := nil; + FData := array(); end - published //属性 - property OddLineBKColor read FOddLineBKColor write FOddLineBKColor; - property EvenLineBKColor read FEvenLineBKColor write FEvenLineBKColor; - property BoolColumns read FBoolColumns write FBoolColumns; - property OnLinkCellClik read FOnLinkCellClik write FOnLinkCellClik; - property celldbclk read FCelldbclk write FCelldbclk; - property celledit read FCellEdit write FCelledit; - property Showarray read FShowarray write FShowarray; - private - function GetChildAllChecked(nd,j,ck); + function Operator[](idx); begin - nck := not(ck); - for i := 0 to nd.NodeCount-1 do - begin - cnd := nd.GetNodeByIndex(i); - if ifobj(cnd)then - begin - if cnd.NodeCount=0 then - begin - if cnd[j]=nck then return 0; - end - if 0=GetChildAllChecked(cnd,j,ck)then return 0; - end - end - return 1; + return FData[idx]; end - function CheckAllChild(nd,j,ck); + function Operator[1](idx,val); begin - for i := 0 to nd.NodeCount-1 do - begin - cnd := nd.GetNodeByIndex(i); - if ifobj(cnd)then - begin - vi := nd[j]; - if vi=0 or vi=1 then cnd[j]:= ck; - CheckAllChild(cnd,j,ck); - end - end + return FData[idx]:= val; end - FBoolColumns; - FOddLineBKColor; - FEvenLineBKColor; - FNodeData; - FNodeIds; - FOnLinkCellClik; - FCelldbclk; - FCelledit; - FShowarray; - FCellediter; - protected - type TGroupNode=class(TNode) //groupgrid节点 - uses tslvcl; - function Create(); - begin - inherited; - FData := array(); - end - function Operator[](idx); - begin - return FData[idx]; - end - function Operator[1](idx,val); - begin - return FData[idx]:= val; - end - FNodeid; - FNNNODE; - //private - FData; - end - type TGroupManger=class(TNodeManger) //group节点管理 - function Create(); - begin - inherited; - end - function CreateNode();override; - begin - return new TGroupNode(); - end - end - class function Sinit();override; + FNodeid; + FNNNODE; + //private + FData; + end + type TGroupManger=class(TNodeManger) //group节点管理 + function Create(); begin inherited; - GetSJPng(); end - private - FCurrentNode_a; - FNodes; - FNodeManger; - static FBmpExpand; - static FBmpUnexpand; - class function GetSJPng(); + function CreateNode();override; begin - if not FBmpExpand then - begin - FBmpExpand := new TBitmap(); - FBmpExpand.readvcon(HexFormatStrToTsl("0502000000060400000074797065000203000000696D670006040000006461746 + return new TGroupNode(); + end + end + class function Sinit();override; + begin + inherited; + GetSJPng(); + end + private + FCurrentNode_a; + FNodes; + FNodeManger; + static FBmpExpand; + static FBmpUnexpand; + class function GetSJPng(); + begin + if not FBmpExpand then + begin + FBmpExpand := new TBitmap(); + FBmpExpand.readvcon(HexFormatStrToTsl("0502000000060400000074797065000203000000696D670006040000006461746 10002C700000089504E470D0A1A0A0000000D494844520000000A0000000A0806 0000008D32CFBD000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000005C49444154 @@ -7971,11 +7971,11 @@ BFC6105000000097048597300000EC300000EC301C76FA8640000005C49444154 4C41B0FFFFF8F6FC1AEE8D005900A24379EBA86A968D729A82410A07866F76984 A2CD47A1825080E16B9807D00186425C804885FFFF030081696EBEB08C861D000 0000049454E44AE42608200")); - end - if not FBmpUnexpand then - begin - FBmpUnexpand := new TBitmap(); - FBmpUnexpand.readvcon(HexFormatStrToTsl("0502000000060400000074797065000203000000696D670006040000006461746 + end + if not FBmpUnexpand then + begin + FBmpUnexpand := new TBitmap(); + FBmpUnexpand.readvcon(HexFormatStrToTsl("0502000000060400000074797065000203000000696D670006040000006461746 10002BF00000089504E470D0A1A0A0000000D494844520000000A0000000A0806 0000008D32CFBD000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000005449444154 @@ -7983,71 +7983,71 @@ BFC6105000000097048597300000EC300000EC301C76FA8640000005449444154 E40058100AF4210DE7404224E502108AFDE474D852045208057214C1108E05488 AC08043014164DC654F4FFFFFFFF0022DF66E2EA30F3BB0000000049454E44AE4 2608200")); - end end end - type TNodeManger=class //节点树管理 - uses tslvcl; - function Create(); - begin - FRootNode := CreateNode(); - end - function CreateNode();virtual; - begin - return new TNode(); - end - function ListNodes();virtual; - begin - r := array(); - GetExpandedNodes(FRootNode,r,0); - return r; - end - function GetNodeByListIndex(id);virtual; - begin - return GetExpandedNodeById(FRootNode,0,id); - end - function getcdnodes(nd,r); - begin - if not ifarray(r)then r := array(); - for i := 0 to nd.NodeCount-1 do - begin - cnd := nd.GetNodeByIndex(i); - r[cnd.FNodeid]:= nil; - getcdnodes(cnd,r); - end - end - Property RootNode read FRootNode; - Private - function GetExpandedNodes(nd,r,ct); - begin - for i := 0 to nd.NodeCount-1 do - begin - cnd := nd.GetNodeByIndex(i); - r[ct++]:= cnd; - if cnd.NodeCount>0 and cnd.Expanded then GetExpandedNodes(cnd,r,ct); - end - end - function GetExpandedNodeById(nd,ct,id); - begin - for i := 0 to nd.NodeCount-1 do - begin - cnd := nd.GetNodeByIndex(i); - if ct=id then return cnd; - ct++; - if cnd.NodeCount>0 and cnd.Expanded then - begin - r := GetExpandedNodeById(cnd,ct,id); - if r then return r; - end - end - end - private - FRootNode; +end +type TNodeManger=class //节点树管理 + uses tslvcl; + function Create(); + begin + FRootNode := CreateNode(); end - function getdebugicons(); + function CreateNode();virtual; + begin + return new TNode(); + end + function ListNodes();virtual; begin r := array(); - r["调试运行"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + GetExpandedNodes(FRootNode,r,0); + return r; + end + function GetNodeByListIndex(id);virtual; + begin + return GetExpandedNodeById(FRootNode,0,id); + end + function getcdnodes(nd,r); + begin + if not ifarray(r)then r := array(); + for i := 0 to nd.NodeCount-1 do + begin + cnd := nd.GetNodeByIndex(i); + r[cnd.FNodeid]:= nil; + getcdnodes(cnd,r); + end + end + Property RootNode read FRootNode; + Private + function GetExpandedNodes(nd,r,ct); + begin + for i := 0 to nd.NodeCount-1 do + begin + cnd := nd.GetNodeByIndex(i); + r[ct++]:= cnd; + if cnd.NodeCount>0 and cnd.Expanded then GetExpandedNodes(cnd,r,ct); + end + end + function GetExpandedNodeById(nd,ct,id); + begin + for i := 0 to nd.NodeCount-1 do + begin + cnd := nd.GetNodeByIndex(i); + if ct=id then return cnd; + ct++; + if cnd.NodeCount>0 and cnd.Expanded then + begin + r := GetExpandedNodeById(cnd,ct,id); + if r then return r; + end + end + end + private + FRootNode; +end +function getdebugicons(); +begin + r := array(); + r["调试运行"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100021003000089504E470D0A1A0A0000000D4948445200000018000000180806 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA864000002A549444154 @@ -8073,12 +8073,12 @@ D316106E1B2712CF8A1BF723DD499B90609EA1EECD616C05FD910BFB4205232D3 BD4951B5B17F3E04A7676673AB40AAA3EE42AAB480B1E242F267F3D3F47ABA0EA 474E5843E672FAAFD8535441B112445EF0B1ABB702F803D2475555757FB6FA000 0000049454E44AE42608200"; - return r; - end - function GetEditIcons(); - begin - r := array(); - r["打开文件"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + return r; +end +function GetEditIcons(); +begin + r := array(); + r["打开文件"]:= "0502000000060400000074797065000203000000696D670006040000006461746 10002DB02000089504E470D0A1A0A0000000D4948445200000026000000200806 0000007E640AB3000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000027049444154 @@ -8102,7 +8102,7 @@ C5F675AB70008F2127B88142E4E0C613271F16A3B88007B713344F7C853DF73CB 6FE222CB129BCB1CAC68B77FBBA6EF149A3D43F5061371AD7E18AAC5960F2EDA0 1D203F6852E8CFCBEF28AE2F3138E2D2C403FE8DC89312895D9C0B43326D2F230 0C02FA1DC4D3F567030CC0000000049454E44AE42608200"; - r["保存全部"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["保存全部"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100025302000089504E470D0A1A0A0000000D4948445200000020000000200806 000000737A7AF4000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA864000001E849444154 @@ -8122,7 +8122,7 @@ B25E398DD138BF12A29A2B00E9C6F5F31A8EF880976AAD0038670B405D2F512DB BE8D53041C7E29662BD8BE4096F0D8D2226083C6CD034E0369C089C9D1EDB947E F0A6E694BFCD6E063C21D99EA35144AFC6AD9A1381B3E101AFA684F80055B3808 F56B6A2590000000049454E44AE42608200"; - r["保存"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["保存"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100022702000089504E470D0A1A0A0000000D4948445200000020000000200806 000000737A7AF4000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA864000001BC49444154 @@ -8141,7 +8141,7 @@ B72AF2FA26A49FF02345A2E800BE002B8002E800BE00214017E0F264EA838980C 7610C3A00807E3921310682E7FF98CCD65629852312822E0A4DDF9BBF9864BE37 96150C4AC6677733D0D3DB0F3AFA74DF409837977A59FB64D730000000049454E 44AE42608200"; - r["取消注释"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["取消注释"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100022001000089504E470D0A1A0A0000000D4948445200000020000000200806 000000737A7AF4000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA864000000B549444154 @@ -8152,7 +8152,7 @@ BFC6105000000097048597300000EC300000EC301C76FA864000000B549444154 FBD778750DD905B0055AEBFEB3B5766E0B1A6C43F80BEB359CC19A02EC8F11FB7 3CC2EC0DE82996C812DC02C0070005765629339C9EFE60000000049454E44AE42 608200"; - r["注释"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["注释"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100021201000089504E470D0A1A0A0000000D4948445200000020000000200806 000000737A7AF4000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA864000000A749444154 @@ -8162,7 +8162,7 @@ BFC6105000000097048597300000EC300000EC301C76FA864000000A749444154 F81538287A7DEC781F740578170058C52EA32ACFB0A42BCF7D9C3DFF228C0F0A1 437FC39ECC2910F70022F01EA80DBC076AD3DC03A834F7406F96C012182C40B40 319335F36295E4B140000000049454E44AE42608200"; - r["撤销"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["撤销"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100022A03000089504E470D0A1A0A0000000D4948445200000020000000200806 000000737A7AF4000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA864000002BF49444154 @@ -8189,7 +8189,7 @@ DF93E618D36DCDC60B782E9F6302FFDEF6192B101E1E24272D6C2EECDD0689E08 79C9A5C309CC5C6BCD58A0A85056BBF3549D7242BEAD1A752AFC1A50DE7691B15 11047474A0AC9E500391AA1457301F01FDA4F2FDFE8B101E70000000049454E44 AE42608200"; - r["反撤销"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["反撤销"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100028202000089504E470D0A1A0A0000000D4948445200000020000000200806 000000737A7AF4000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000021749444154 @@ -8210,7 +8210,7 @@ D00047F3FBEFFFFC0CF1AEC08503E7E599BFFFFF3EE2DFFBF5F3A4B3206A52B42 00C30120F0EFC7F7FF2F9B4BFFDF54E6053B845C0C2AFDFEFDFE0535153BC0EA0 018F8FDEAC5FFF74B66FD7F5E96F1FF496200B8122105BF6AAB849A841BE07500 3DC0A80306D801FFFF03006C2FCBC409CD25D50000000049454E44AE42608200"; - r["tsl语法检查"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["tsl语法检查"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100020204000089504E470D0A1A0A0000000D4948445200000020000000200806 000000737A7AF4000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000039749444154 @@ -8243,7 +8243,7 @@ A091B5AC338018CE3357AA5477841096BC3652CB16BF6D09216800A79F5DB178F D77AAB0D82BF4CA4E167F65EA8C8BA07CECA7E9A258D6C0308BE01F9B3C16FCAE DC5602BE880BF6A0755CB2325032C38DDAE275FC881840DFF37C6C2E9FD434ECB 40E600F8077525AC9F3D612B2D0000000049454E44AE42608200"; - r["tsl代码格式化"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["tsl代码格式化"]:= "0502000000060400000074797065000203000000696D670006040000006461746 10002E601000089504E470D0A1A0A0000000D4948445200000018000000180806 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000017B49444154 @@ -8260,7 +8260,7 @@ DDAA73C9420879AB1B2A07A5B89430516B804993D2EC4376674530D01997D4177 6FE6818DC8023BFD2B828E1E7E0BFC882D40DE6A8842A21DC4E1EF05DA875A4C2 3300B3F12400AC0F42127D208FC0231443F28BE427F9C549A270000000049454E 44AE42608200"; - r["查找"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["查找"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100021B03000089504E470D0A1A0A0000000D4948445200000020000000200806 000000737A7AF4000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA864000002B049444154 @@ -8286,7 +8286,7 @@ F76DF9044590104F7B07B7B330D84178AFFF03D101A0720F17804928E6F20D85E 87199DCD800BE4305A9C204C98171EEA1060F373D898A02AB91FF98ACF8629C54 061F094AE059B39AAA05CC12BEFAACE44AD44C00C1C951A2989A0A94E27F1700F 805D0F3420D05EDA5310000000049454E44AE42608200"; - r["后退"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["后退"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100027501000089504E470D0A1A0A0000000D4948445200000020000000200806 000000737A7AF4000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000010A49444154 @@ -8299,7 +8299,7 @@ E739344D2397FEB56DDBDEB71080AEEBE0380E39C8AB6F0161189203BC4B02E67 7D0FD775C99FB052679824C96E1FB30B6029CB12BAAE9380D7BB3E9A1F016E59D 715699A4296E56B002CC330C0F3BCEB002C55556D677B19805704400004E06200 F00985F34928814F15230000000049454E44AE42608200"; - r["前进"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["前进"]:= "0502000000060400000074797065000203000000696D670006040000006461746 10002E501000089504E470D0A1A0A0000000D4948445200000020000000200806 000000737A7AF4000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000017A49444154 @@ -8316,7 +8316,7 @@ B85C4055CF250DD2251015779AC1ABF4E121390D3FE5BFF436D9BA680DFE3B533 635460462DF1BD7EC04E388C094CAB45BED577580D8F1101B9D5CE74052BD1302 290D3C15FBE41C416D8A42C8E4681F91F06F7DA0A168403F80000000049454E44 AE42608200"; - r["快捷键说明"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["快捷键说明"]:= "0502000000060400000074797065000203000000696D670006040000006461746 10002C601000089504E470D0A1A0A0000000D4948445200000020000000200806 000000737A7AF4000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000015B49444154 @@ -8332,7 +8332,7 @@ CAC3D17E6E3F1E1FE436FA3907B79101B038D8AB6931A69ECF4E7F070021844FE 52B0006F3162665DEB602BC362EA4B7B2E46D8CE16EB5A2C32105A086DD1BFD46 31FD799FA4D3BE3502300D9500FF1D40E40B036C6466EFBB13F70000000049454 E44AE42608200"; - r["代码地图(alt+m)"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["代码地图(alt+m)"]:= "0502000000060400000074797065000203000000696D670006040000006461746 10002A405000089504E470D0A1A0A0000000D4948445200000020000000200806 000000737A7AF4000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000053949444154 @@ -8378,12 +8378,12 @@ C5AC62B583C1A7151693EFB8A80185CDA0ABC78B8879EBA40C4F02B2E95FCEC67 480BFFD7D4C53956A0D8A8515E34F9205ABC60D86E41C112D78EFE9DB32BC2C42 6DCE4BC2F0BCE9E11F8ED0E507F057DF23119C616B443DD647A2373F6FDA03F81 751AD08E04A61DA310000000049454E44AE42608200"; - return r union dbugicos(); - end - function dbugicos(); - begin - r := array(); - r["添加/删除断点F5"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + return r union dbugicos(); +end +function dbugicos(); +begin + r := array(); + r["添加/删除断点F5"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100022B01000089504E470D0A1A0A0000000D4948445200000018000000180806 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA864000000C049444154 @@ -8394,7 +8394,7 @@ BFC6105000000097048597300000EC300000EC301C76FA864000000C049444154 161D10B4801000F9121FA0AF0520C5DA961D58BD8F0DFB45CEFE7FEFC11BA86EE C00C50210F8F0F13BD608C48689011816501B0C750BFEFF070066B64F1FB7C689 CB0000000049454E44AE42608200"; - r["暂停"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["暂停"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100022401000089504E470D0A1A0A0000000D4948445200000018000000180806 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA864000000B949444154 @@ -8405,7 +8405,7 @@ A38A2A03980C9E3881A8064EDB05E4214EC061D6DC024F067636A3856A062052A 56C0B0821251D01CC098041809F98361571B300982F9841A8E28B87BAE1AC2A4E E8AAE356587C9AE67BA7244C1A7F875014001DF29EF2FFBC3E1B1000000004945 4E44AE42608200"; - r["继续"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["继续"]:= "0502000000060400000074797065000203000000696D670006040000006461746 10002E201000089504E470D0A1A0A0000000D4948445200000018000000180806 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000017749444154 @@ -8422,7 +8422,7 @@ F3441226C636B338BAB6E80E39DC82B82310E16D9BDD2F4AB7CD53C0A3D2B6B60 BB795C946B74871C0D82DEA88EE135135B9755DA51C316F0711BDD3031775042E 1E58356D5B1051CFE2B8205F806770EAF93F6C525FA0000000049454E44AE4260 8200"; - r["进入"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["进入"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100028401000089504E470D0A1A0A0000000D4948445200000018000000180806 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000011949444154 @@ -8436,7 +8436,7 @@ A845FE39846A11DA7F7B1662C8E8CE1B53FE5F300AD0E4B589FEC8D00AD0B6544 6FCCE5D58019ADC1A8438ECD0E4C53E762728023479DEC16F354F805E99B96FAE 4C9270C909FA527427A60976C8BF43880799B976B3940BD8ED0000000049454E4 4AE42608200"; - r["跳出"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["跳出"]:= "0502000000060400000074797065000203000000696D670006040000006461746 10002ED01000089504E470D0A1A0A0000000D4948445200000018000000180806 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000018249444154 @@ -8453,19 +8453,19 @@ E09F48575EB2EA901ADD80B1892D7878FAA6D4414A16F347940A01FEAE75E57C3 67EF1258E5479A34B00595F397D8E58C947424B2705D7DA789108C4F169B2A67A 404BB185B80561CE093340B7E3DB21CF1BDE4BFA6C502801FF275D8DB8771B6A3 0000000049454E44AE42608200"; - {r["单步"] := "0502000000060400000074797065000203000000696D670006040000006461746 - 100025701000089504E470D0A1A0A0000000D4948445200000018000000180806 - 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 - BFC6105000000097048597300000EC300000EC301C76FA864000000EC49444154 - 484BC5D5CD09C240108661EBB003CBB0801460035E723087282A117F886024A0A - 0276F962558893B616565844427BB331B832F783003DF83E46047B7DCFF819BBE - EB0B5CF19B3C2B60C6FB2AD0DD474F0F21C2A7B26A81F2F8FBE383587F41561C2 - B800FE27C079B62DF087102A604B6DE080B304D60E985B0015304733122024C21 - 8C45881830E5707A8D72102FE073FC05A81F01D478A862BC7E2702A8F111CCF04 - AC706A8F1181678AD8F0550E35358E3D59E13A0C61348F1EACE0A50E32BC8F0CA - CB0A046A50194F21C70B3F2B50FE4FD8C1019FCA72BE0383E4C519BFC973024D6 - B19D0FA0973865C3E24DD42ED0000000049454E44AE42608200";} - r["下一行(F8)"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + {r["单步"] := "0502000000060400000074797065000203000000696D670006040000006461746 + 100025701000089504E470D0A1A0A0000000D4948445200000018000000180806 + 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 + BFC6105000000097048597300000EC300000EC301C76FA864000000EC49444154 + 484BC5D5CD09C240108661EBB003CBB0801460035E723087282A117F886024A0A + 0276F962558893B616565844427BB331B832F783003DF83E46047B7DCFF819BBE + EB0B5CF19B3C2B60C6FB2AD0DD474F0F21C2A7B26A81F2F8FBE383587F41561C2 + B800FE27C079B62DF087102A604B6DE080B304D60E985B0015304733122024C21 + 8C45881830E5707A8D72102FE073FC05A81F01D478A862BC7E2702A8F111CCF04 + AC706A8F1181678AD8F0550E35358E3D59E13A0C61348F1EACE0A50E32BC8F0CA + CB0A046A50194F21C70B3F2B50FE4FD8C1019FCA72BE0383E4C519BFC973024D6 + B19D0FA0973865C3E24DD42ED0000000049454E44AE42608200";} + r["下一行(F8)"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100025E01000089504E470D0A1A0A0000000D4948445200000018000000180806 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA864000000F349444154 @@ -8478,7 +8478,7 @@ C67E0230054232A72100B005944550EB801208AF0F698A81C24068048161D9E1C 08034025922407D200D0BD96779402801791C9817200548607CAD517DE0B55910 3AD401AFE0129BF1E207A02B9FA383F9BCBB70F0000000049454E44AE42608200 "; - r["终止"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["终止"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100026602000089504E470D0A1A0A0000000D4948445200000018000000180806 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA864000001FB49444154 @@ -8499,7 +8499,7 @@ E27966323A4FE41FFC06D73EBB1A1C2C6E97110AB0FE6C284B44CE89226961A07 FFBEF4D93BE6132014E0C3C5B785F567435922724E14490B03C5F34B774DE790B F75031142817F89578167F1C202D20F98CF9591BE2EF7850000000049454E44AE 42608200"; - r["刷新符号表"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["刷新符号表"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100027702000089504E470D0A1A0A0000000D4948445200000018000000180806 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000020C49444154 @@ -8520,7 +8520,7 @@ EC0115216F63AD8A10A1E909E1F92C612E2E8FA9D6C807C2ED4799BBF1EA7366B F9697A5599646104306DCFCC89BCE49B76A7AD6C36C759B5F631E60E1CDF55933 DC80970173CBBC31EDBDF84ED7D59D8644A0DE62127806163FE2BA25B6EE90017 13C9EE8D2E4822C60000000049454E44AE42608200"; - r["刷新当前符号"]:= "0502000000060400000074797065000203000000696D670006040000006461746 + r["刷新当前符号"]:= "0502000000060400000074797065000203000000696D670006040000006461746 100027802000089504E470D0A1A0A0000000D4948445200000018000000180806 000000E0773DF8000000017352474200AECE1CE90000000467414D410000B18F0 BFC6105000000097048597300000EC300000EC301C76FA8640000020D49444154 @@ -8541,184 +8541,184 @@ B465B669D12CD1A499A14AF5269EEB7017D499E35101704B7F68CC7CA20AF59AF 2C80370402B8893E285179542751182C80070A0268F02F76827221EED6FD3C319 4F890FD27C2B57AD524A3E1C402000F14DE907133452B765DB24F2321F0FC10DD 0144332BF870524ED00000000049454E44AE42608200"; - return r; - end - function ejsonformat(d,tbw,ct); + return r; +end +function ejsonformat(d,tbw,ct); +begin + //d:天软数据 + //tbw : 字符串,tab 宽度 + //ct 递归深度,忽略 + case datatype(d)of + 0,20:return inttostr(d); + 1:return floattostr(d); + 2:return tostn(d); + 8,10,11,12:return "null"; + end; + if not(ct>0)then ct := 0; + if not ifstring(tbw)then tbw := " "; + tbstr := ""; + tbstra := ""; + for i := 0 to ct do begin - //d:天软数据 - //tbw : 字符串,tab 宽度 - //ct 递归深度,忽略 - case datatype(d)of - 0,20:return inttostr(d); - 1:return floattostr(d); - 2:return tostn(d); - 8,10,11,12:return "null"; - end; - if not(ct>0)then ct := 0; - if not ifstring(tbw)then tbw := " "; - tbstr := ""; - tbstra := ""; - for i := 0 to ct do + tbstr += tbw; + if i>0 then tbstra += tbw + end + if ifarray(d)then + begin + if not d then return "[]"; + idx := 0; + for i,v in d do begin - tbstr += tbw; - if i>0 then tbstra += tbw + if idx <> i then + begin + fobj := true; + break; + end + idx++; end - if ifarray(d)then + if fobj then begin - if not d then return "[]"; - idx := 0; + r := "{"; for i,v in d do begin - if idx <> i then + if ifstring(i)then ii := tostn(i); + else ii := tostn(tostn(i)); + r += "\r\n"+tbstr+ii+":"; + if ifarray(v)and v then begin - fobj := true; - break; + r += "\r\n"+tbstr; end - idx++; + r += ejsonformat(v,tbw,ct+1)+","; end - if fobj then - begin - r := "{"; - for i,v in d do - begin - if ifstring(i)then ii := tostn(i); - else ii := tostn(tostn(i)); - r += "\r\n"+tbstr+ii+":"; - if ifarray(v)and v then - begin - r += "\r\n"+tbstr; - end - r += ejsonformat(v,tbw,ct+1)+","; - end - lr := length(r); - r[lr:]:= "\r\n"+tbstra+"}"; - end else - begin - r := "["; - for i,v in d do - begin - r += "\r\n"+(tbstr)+ejsonformat(v,tbw,ct+1)+","; - end - lr := length(r); - r[lr:]:= "\r\n"+tbstra+"]"; - end - return r; + lr := length(r); + r[lr:]:= "\r\n"+tbstra+"}"; end else - if ifobj(d)then begin - try - //return "{}"; - //此处可以遍历对象信息 - objtoarray(d,dinfo); - for i,v in mrows(dinfo,1) do - begin - nv := invoke(d,v); - if ifobj(nv)then nv := nil; //避免死循环 - dinfo[v]:= nv; - end - return ejsonformat(dinfo,tbw,ct); - except - return "{}"; + r := "["; + for i,v in d do + begin + r += "\r\n"+(tbstr)+ejsonformat(v,tbw,ct+1)+","; end - end else - return "null"; - end - function objtoarray(o,r); + lr := length(r); + r[lr:]:= "\r\n"+tbstra+"]"; + end + return r; + end else + if ifobj(d)then begin - d := o.classinfo(); - if not ifarray(r)then r := array(); - for i,v in d["inherited"] do - begin - objtoarray(findclass(v,o),r); - end - for i,v in d["members"] do - begin - n := v["name"]; - if v["access"]in array(0,1)then + try + //return "{}"; + //此处可以遍历对象信息 + objtoarray(d,dinfo); + for i,v in mrows(dinfo,1) do begin - r[n]:= 0; - end else - begin - reindex(r,array(n:nil)); + nv := invoke(d,v); + if ifobj(nv)then nv := nil; //避免死循环 + dinfo[v]:= nv; end + return ejsonformat(dinfo,tbw,ct); + except + return "{}"; end - for i,v in d["properties"] do + end else + return "null"; +end +function objtoarray(o,r); +begin + d := o.classinfo(); + if not ifarray(r)then r := array(); + for i,v in d["inherited"] do + begin + objtoarray(findclass(v,o),r); + end + for i,v in d["members"] do + begin + n := v["name"]; + if v["access"]in array(0,1)then begin - n := v["name"]; - if v["read"]and(v["access"]in array(0,1))then - begin - r[n]:= 0; - end else - begin - reindex(r,array(n:nil)); - end + r[n]:= 0; + end else + begin + reindex(r,array(n:nil)); end end - function ReWriteString(fn,d); + for i,v in d["properties"] do begin - if not ifstring(d)then return 0; - als := ""; - len := length(d); - if FileExists(als,fn)and(filesize(als,fn)>len)then + n := v["name"]; + if v["read"]and(v["access"]in array(0,1))then begin - lfn := FileList(als,fn); //修正文件名变小写的问题 - if lfn then + r[n]:= 0; + end else + begin + reindex(r,array(n:nil)); + end + end +end +function ReWriteString(fn,d); +begin + if not ifstring(d)then return 0; + als := ""; + len := length(d); + if FileExists(als,fn)and(filesize(als,fn)>len)then + begin + lfn := FileList(als,fn); //修正文件名变小写的问题 + if lfn then + begin + nfn := lfn[0,"FileName"]; + if nfn then begin - nfn := lfn[0,"FileName"]; - if nfn then + for i := length(fn)downto 1 do begin - for i := length(fn)downto 1 do + if fn[i]="\\" then begin - if fn[i]="\\" then - begin - fn := fn[1:i]+nfn; - break; - end + fn := fn[1:i]+nfn; + break; end end end - FileDelete(als,fn); - end else - begin - CreateDirWithFileName(fn); end - spos := 0; - return writefile(rwraw(),als,fn,spos,len,d); + FileDelete(als,fn); + end else + begin + CreateDirWithFileName(fn); end - function gettslexe(); + spos := 0; + return writefile(rwraw(),als,fn,spos,len,d); +end +function gettslexe(); +begin + return static gettslexefullpath(); +end +function gettslexefullpath(); +begin + plg := pluginpath(); + sp := ioFileseparator(); + for i:= length(plg)-1 downto 1 do begin - return static gettslexefullpath(); - end - function gettslexefullpath(); - begin - plg := pluginpath(); - sp := ioFileseparator(); - for i:= length(plg)-1 downto 1 do + if plg[i]=sp then begin - if plg[i]=sp then + if sp="/" then + begin + return plg[1:i]+"TSL"; + end else begin - if sp="/" then - begin - return plg[1:i]+"TSL"; - end else - begin - return plg[1:i]+"tsl.exe"; - end + return plg[1:i]+"tsl.exe"; end end - return ""; - end - {$ifdef linux} - function HtmlHelpA() - begin - return 0; - end - function GetDesktopWindow() - begin - return 0; - end - {$else} - function HtmlHelpA(hwndCaller:pointer;pszFile:string;uCommand:integer;dwData:pointer):pointer;stdcall;external "HHCTRL.OCX" name "HtmlHelpA"; - function GetDesktopWindow():pointer;stdcall;external "User32.dll" name "GetDesktopWindow"; - {$endif} + end + return ""; +end +{$ifdef linux} +function HtmlHelpA() +begin + return 0; +end +function GetDesktopWindow() +begin + return 0; +end +{$else} +function HtmlHelpA(hwndCaller:pointer;pszFile:string;uCommand:integer;dwData:pointer):pointer;stdcall;external "HHCTRL.OCX" name "HtmlHelpA"; +function GetDesktopWindow():pointer;stdcall;external "User32.dll" name "GetDesktopWindow"; +{$endif} end. diff --git a/designer/utslsynmemo.tsf b/designer/utslsynmemo.tsf index 0ad79fe..338dcd3 100644 --- a/designer/utslsynmemo.tsf +++ b/designer/utslsynmemo.tsf @@ -3,7 +3,7 @@ interface {** @explan(说明) tsl语法编辑器库 **} -uses TslVcl,UTslMemo; +uses utslvclauxiliary,UTslMemo,TslVcl; function FileSaveThreader(o,d); type TTSLCompletion= class(TSynCompletion) {** @@ -1555,6 +1555,7 @@ type TTsfFileParser = class // //FFileWorker := new TThreadWorker("this.OnMessage :=findfunction('UTslSynMemo.FileSaveThreader') ;"); FFindDirs := array(); end + function DispatchMethod(o,d);//分发消息 begin if not ifarray(d) then return ; @@ -1608,7 +1609,8 @@ type TTsfFileParser = class // end if r then begin - //echo "\r\nlodad"; + //echo "\r\nlodad"; + vmsg := r["msg"]; end else begin s := d["value"]; @@ -1618,32 +1620,53 @@ type TTsfFileParser = class // cls := array(); ScriptDelBlocks(r["blcks"],str2array(s,"\n"),cls); - r["blcks"] := cls; - + r["blcks"] := cls; vmsg := getmsgd_Crc32(s);//GetMsgdigest(s,0); end ext := array(); FormatFunction(rti,r["functions"],rt,"",r["lines"],ext,1); FormatBlocks(rti,r["blcks"],rt,"",nil,ext,1); FormatWords(rti,r["words"],rt,"",ext,1); - - + dounits := array(vmsg); + uout := array(); for i,v in r["units"] do //单元 - begin - + begin vfn := checknamespacename(v); if m=(lowercase(vfn)+".tsf") then continue; vi := LoadByName(vfn); if vi then begin - if vmsg=vi["msg"] then continue; + if vi["msg"] =vmsg then + begin + continue; + end ext := array(); FormatFunction(rti,vi["functions"],rt,vfn,vi["lines"],ext,4); FormatBlocks(rti,vi["blcks"],rt,vfn,nil,ext,4); FormatWords(rti,vi["words"],rt,vfn,ext,4); - - end + dounits[length(dounits)] := vi["msg"]; + loadunits(vi["units"],dounits,uout); + end end + //mtic; + for i,v in uout do + begin + vfn := checknamespacename(v); + if m=(lowercase(vfn)+".tsf") then continue; + vi := LoadByName(vfn); + if vi then + begin + if vi["msg"] =vmsg then + begin + continue; + end + ext := array(); + FormatFunction(rti,vi["functions"],rt,vfn,vi["lines"],ext,4); + end + end + uout := array(); + //echo "\r\n other time:",mtoc; + dounits := array(vmsg); for i,v in r["class"] do //类 begin vfn := checknamespacename(v); @@ -1651,13 +1674,27 @@ type TTsfFileParser = class // vi := LoadByName(vfn); if vi then begin - if vmsg=vi["msg"] then continue; + if vi["msg"] in dounits then continue; ext:= array(); FormatFunction(rti,vi["functions"],rt,vfn,vi["lines"],ext,4); FormatWords(rti,vi["words"],rt,vfn,ext,4); //ident 文件名 + loadclasses(vi["class"],dounits,uout); end end + for i,v in uout do + begin + vfn := checknamespacename(v); + if m=(lowercase(vfn)+".tsf") then continue; + vi := LoadByName(vfn); + if vi then + begin + if vi["msg"]=vmsg then continue; + ext:= array(); + FormatFunction(rti,vi["functions"],rt,vfn,vi["lines"],ext,4); + FormatWords(rti,vi["words"],rt,vfn,ext,4); + end + end //FormatFile(rti,FCacheS,rt,3,m); return rt; //return o.postmessage(r); @@ -1665,6 +1702,74 @@ type TTsfFileParser = class // end end private + function loadunitcalss(us,cs,dounits,uout,cout); + begin + if not ifarray(uout) then uout := array(); + if not ifarray(cout) then cout := array(); + for i,v in us do + begin + vfn := checknamespacename(v); + vi := LoadByName(vfn); + if vi then + begin + if vi["msg"] in dounits then continue; + dounits[length(dounits)] := vi["msg"]; + uout[length(uout)] := vfn; + loadunitcalss(vi["units"],vi["class"],dounits,uout,cout); + end + + end + for i,v in cs do + begin + vfn := checknamespacename(v); + if m=(lowercase(vfn)+".tsf") then continue; + vi := LoadByName(vfn); + if vi then + begin + if vi["msg"] in dounits then continue; + dounits[length(dounits)] := vi["msg"]; + //ident 文件名 + cout[length(cout)] := vfn; + loadunitcalss(vi["units"],vi["class"],dounits,uout,cout); + end + end + end + function loadunits(us,dounits,uout); + begin + if not ifarray(uout) then uout := array(); + for i,v in us do + begin + vfn := checknamespacename(v); + vi := LoadByName(vfn); + if vi then + begin + if vi["msg"] in dounits then continue; + dounits[length(dounits)] := vi["msg"]; + uout[length(uout)] := vfn; + loadunits(vi["units"],dounits,uout); + end + + end + end + function loadclasses(cs,dounits,uout); + begin + if not ifarray(uout) then uout := array(); + for i,v in cs do + begin + vfn := checknamespacename(v); + if m=(lowercase(vfn)+".tsf") then continue; + vi := LoadByName(vfn); + if vi then + begin + if vi["msg"] in dounits then continue; + dounits[length(dounits)] := vi["msg"]; + //ident 文件名 + uout[length(uout)] := vfn; + loadclasses(cs,dounits,uout); + end + end + end + function checknamespacename(v); begin for ii in FCacheS do @@ -1782,7 +1887,7 @@ type TTsfFileParser = class // end ScriptDelBlocks(v["msub"],strs,r); end - end + end function FormatBlocks(idx,r,d,f,rr,ext,od); begin if not ifarray(ext) then ext := array(); @@ -1997,7 +2102,7 @@ type TTsfFileParser = class // fn := FCacheDir+ioFileseparator()+ModifyFname(n)+".p"; if importfile(ftstream(),"",fn,d)=1 and ifarray(d) then begin - FCacheS[lowercase(n)] := d; + FCacheS[lowercase(n)] := new tparserdobject(d); FFilePaths[lowercase(n)] := d["fullpath"]; return d; end @@ -2049,4 +2154,23 @@ begin end end +type tparserdobject = class + function create(d); + begin + if ifarray(d) then + FData := d; + end + function operator[](idx); + begin + if FData then + return FData[idx]; + end + function operator[1](idx,v); + begin + if FData then + FData[idx] := v; + end + private + FData ; +end end. \ No newline at end of file diff --git a/funcext/tvclib/getmsgd_crc32.tsf b/funcext/tvclib/getmsgd_crc32.tsf new file mode 100644 index 0000000..f867ac3 --- /dev/null +++ b/funcext/tvclib/getmsgd_crc32.tsf @@ -0,0 +1,89 @@ +Function getmsgd_Crc32(s); +Begin + {** + @explan(说明) 获得字符串的信息指纹%% + @param(s)(string) 字符串 %% + @return(string) 8位长度的信息指纹%% + **} + {$ifdef linux} + G_CRC32TABLE:=array( + 0x00000000, 0x77073096, 0xEE0E612C, 0x990951BA, + 0x076DC419, 0x706AF48F, 0xE963A535, 0x9E6495A3, + 0x0EDB8832, 0x79DCB8A4, 0xE0D5E91E, 0x97D2D988, + 0x09B64C2B, 0x7EB17CBD, 0xE7B82D07, 0x90BF1D91, + 0x1DB71064, 0x6AB020F2, 0xF3B97148, 0x84BE41DE, + 0x1ADAD47D, 0x6DDDE4EB, 0xF4D4B551, 0x83D385C7, + 0x136C9856, 0x646BA8C0, 0xFD62F97A, 0x8A65C9EC, + 0x14015C4F, 0x63066CD9, 0xFA0F3D63, 0x8D080DF5, + 0x3B6E20C8, 0x4C69105E, 0xD56041E4, 0xA2677172, + 0x3C03E4D1, 0x4B04D447, 0xD20D85FD, 0xA50AB56B, + 0x35B5A8FA, 0x42B2986C, 0xDBBBC9D6, 0xACBCF940, + 0x32D86CE3, 0x45DF5C75, 0xDCD60DCF, 0xABD13D59, + 0x26D930AC, 0x51DE003A, 0xC8D75180, 0xBFD06116, + 0x21B4F4B5, 0x56B3C423, 0xCFBA9599, 0xB8BDA50F, + 0x2802B89E, 0x5F058808, 0xC60CD9B2, 0xB10BE924, + 0x2F6F7C87, 0x58684C11, 0xC1611DAB, 0xB6662D3D, + + 0x76DC4190, 0x01DB7106, 0x98D220BC, 0xEFD5102A, + 0x71B18589, 0x06B6B51F, 0x9FBFE4A5, 0xE8B8D433, + 0x7807C9A2, 0x0F00F934, 0x9609A88E, 0xE10E9818, + 0x7F6A0DBB, 0x086D3D2D, 0x91646C97, 0xE6635C01, + 0x6B6B51F4, 0x1C6C6162, 0x856530D8, 0xF262004E, + 0x6C0695ED, 0x1B01A57B, 0x8208F4C1, 0xF50FC457, + 0x65B0D9C6, 0x12B7E950, 0x8BBEB8EA, 0xFCB9887C, + 0x62DD1DDF, 0x15DA2D49, 0x8CD37CF3, 0xFBD44C65, + 0x4DB26158, 0x3AB551CE, 0xA3BC0074, 0xD4BB30E2, + 0x4ADFA541, 0x3DD895D7, 0xA4D1C46D, 0xD3D6F4FB, + 0x4369E96A, 0x346ED9FC, 0xAD678846, 0xDA60B8D0, + 0x44042D73, 0x33031DE5, 0xAA0A4C5F, 0xDD0D7CC9, + 0x5005713C, 0x270241AA, 0xBE0B1010, 0xC90C2086, + 0x5768B525, 0x206F85B3, 0xB966D409, 0xCE61E49F, + 0x5EDEF90E, 0x29D9C998, 0xB0D09822, 0xC7D7A8B4, + 0x59B33D17, 0x2EB40D81, 0xB7BD5C3B, 0xC0BA6CAD, + + 0xEDB88320, 0x9ABFB3B6, 0x03B6E20C, 0x74B1D29A, + 0xEAD54739, 0x9DD277AF, 0x04DB2615, 0x73DC1683, + 0xE3630B12, 0x94643B84, 0x0D6D6A3E, 0x7A6A5AA8, + 0xE40ECF0B, 0x9309FF9D, 0x0A00AE27, 0x7D079EB1, + 0xF00F9344, 0x8708A3D2, 0x1E01F268, 0x6906C2FE, + 0xF762575D, 0x806567CB, 0x196C3671, 0x6E6B06E7, + 0xFED41B76, 0x89D32BE0, 0x10DA7A5A, 0x67DD4ACC, + 0xF9B9DF6F, 0x8EBEEFF9, 0x17B7BE43, 0x60B08ED5, + 0xD6D6A3E8, 0xA1D1937E, 0x38D8C2C4, 0x4FDFF252, + 0xD1BB67F1, 0xA6BC5767, 0x3FB506DD, 0x48B2364B, + 0xD80D2BDA, 0xAF0A1B4C, 0x36034AF6, 0x41047A60, + 0xDF60EFC3, 0xA867DF55, 0x316E8EEF, 0x4669BE79, + 0xCB61B38C, 0xBC66831A, 0x256FD2A0, 0x5268E236, + 0xCC0C7795, 0xBB0B4703, 0x220216B9, 0x5505262F, + 0xC5BA3BBE, 0xB2BD0B28, 0x2BB45A92, 0x5CB36A04, + 0xC2D7FFA7, 0xB5D0CF31, 0x2CD99E8B, 0x5BDEAE1D, + + 0x9B64C2B0, 0xEC63F226, 0x756AA39C, 0x026D930A, + 0x9C0906A9, 0xEB0E363F, 0x72076785, 0x05005713, + 0x95BF4A82, 0xE2B87A14, 0x7BB12BAE, 0x0CB61B38, + 0x92D28E9B, 0xE5D5BE0D, 0x7CDCEFB7, 0x0BDBDF21, + 0x86D3D2D4, 0xF1D4E242, 0x68DDB3F8, 0x1FDA836E, + 0x81BE16CD, 0xF6B9265B, 0x6FB077E1, 0x18B74777, + 0x88085AE6, 0xFF0F6A70, 0x66063BCA, 0x11010B5C, + 0x8F659EFF, 0xF862AE69, 0x616BFFD3, 0x166CCF45, + 0xA00AE278, 0xD70DD2EE, 0x4E048354, 0x3903B3C2, + 0xA7672661, 0xD06016F7, 0x4969474D, 0x3E6E77DB, + 0xAED16A4A, 0xD9D65ADC, 0x40DF0B66, 0x37D83BF0, + 0xA9BCAE53, 0xDEBB9EC5, 0x47B2CF7F, 0x30B5FFE9, + 0xBDBDF21C, 0xCABAC28A, 0x53B39330, 0x24B4A3A6, + 0xBAD03605, 0xCDD70693, 0x54DE5729, 0x23D967BF, + 0xB3667A2E, 0xC4614AB8, 0x5D681B02, 0x2A6F2B94, + 0xB40BBE37, 0xC30C8EA1, 0x5A05DF1B, 0x2D02EF8D); + result :=0xFFFFFFFF; + bs := binary(s); + for i:=0 to length(bs)-1 do + begin + ebx:=G_CRC32TABLE[(result .& 0xff) .^ord(bs[i]) ]; + result shr=8; + result .^= ebx; + end; + result:=_not(result); + return inttohex(result,8); + {$endif} + return GetMsgDigest(s,0); +End; \ No newline at end of file diff --git a/funcext/tvclib/iofileseparator.tsf b/funcext/tvclib/iofileseparator.tsf new file mode 100644 index 0000000..71394c5 --- /dev/null +++ b/funcext/tvclib/iofileseparator.tsf @@ -0,0 +1,11 @@ +function iofileseparator(); +begin + {** + @explan(说明) 返回文件系统的目录分割符 %% + @return(string) linux 下/ windows下\ + **} + {$ifdef linux} + return '/'; + {$endif} + return '\\'; +end \ No newline at end of file diff --git a/funcext/tvclib/tcomponent.tsf b/funcext/tvclib/tcomponent.tsf new file mode 100644 index 0000000..938eb3a --- /dev/null +++ b/funcext/tvclib/tcomponent.tsf @@ -0,0 +1,626 @@ +type tcomponent = class(TSLUIBASE) +uses utslvclauxiliary,utslvclbase; + {** + @explan(说明) 可视化组件基类 %% + @date(20220505) 分离tcomponent基类 + **} + private + {** + @param(FOwner)(tcomponent) 所有者 %% + @param(FComponents)( TFpList ) 子项 %% + @param(FComponentState)( array of integer) 节点状态 %% + @param(FComponentStyle)( array of integer) 节点样式 %% + @param(FFreeNotifies)( TFpList) 销毁通知节点 %% + **} + FOwner; + FName; + FComponents; + FFreeNotifies: TFpList; + FComponentState; + FComponentStyle; + FComponentCreated; + FLoader; + function ComponentGetParent();virtual; + begin + + end + function ComponentSetParent();virtual; + begin + + end +#!begin //private methods + function GetLoader(); + begin + global G_T_TTFM2COMPONET_; + if not G_T_TTFM2COMPONET_ then return 0; + if not FLoader then FLoader := createobject(G_T_TTFM2COMPONET_); + return FLoader; + end + function GetPropInfo(); + begin + o := self(true); + r := getPropInfo2(o); + ret := array(); + ii := 0; + for i,v in r do + begin + ret[ii++]:= v; + end + return select * from ret order by["name"] end; + end + static FClassDigestB; + class function GetClassDigestB(idx,d); + begin + if not ifarray(FClassDigestB)then FClassDigestB := array(); + if ifnil(d)then return FClassDigestB[idx]; + else FClassDigestB[idx]:= d; + end + function getPropInfo2(o); + begin + if not(o is class(tcomponent))then return array(); + t := o.classinfo; + idx := getmsgd_Crc32(tostm(t))+"&&"; + r := GetClassDigestB(idx); + if ifarray(r)then return r; + r := array(); + hs := t["inherited"]; + for i,v in hs do + begin + r union=static call(thisfunction,findclass(v,o))name v+"&&_&&"; + end + for i,v in t["properties"] do + begin + n := v["name"]; + if((v["access"]in array(2,3))or(not(v["read"])))or not(v["type"])then + begin + deleteindex(r,n); + continue; + end + if v["read"]and v["type"]then + begin + r union=array(n:v[array("name","type","write","parser")]); + end + end + for i,v in t["members"] do + begin + n := v["name"]; + if(v["access"]in array(2,3))or not(v["type"])then + begin + deleteindex(r,n); + continue; + end + tr := v[array("name","type","write","parser")]; + tr["write"]:= true; + r union=array(n:tr); + end + GetClassDigestB(idx,r); + return r; + end + function GetComponent(AIndex); + begin + {** + @explan(说明) 获取子节点 %% + @param(AIndex)( integer ) 子项序号 %% + **} + return FComponents.geti(AIndex); + end + function SetComponentState(v); + begin + if ifarray(v)then FComponentState := v; + end + function GetComponentCount(); + begin + {** + @explan(说明) 获取子节数量%% + @return(AIndex)( integer ) 数量 %% + **} + return FComponents.count(); + end + function GetComponentIndex(); + begin + {** + @explan(说明) 获取子节序号%% + @return(AIndex)( integer ) 子项序号 %% + **} + if FOwner is class(tcomponent)then + begin + return FOwner.Components.findvid(self); + end + return-1; + end + procedure Insert(AComponent:TComponent); //此处需要修改 + begin + {** + @explan(说明)添加子节点 %% + **} + FComponents.Add(AComponent); + AComponent.FOwner := Self(true); + end + procedure Remove(AComponent:TComponent); + begin + {** + @explan(说明)移除子节点 %% + **} + if FComponents.Remove(AComponent)>0 then + begin + AComponent.FOwner := Nil; + return true; + end + return false; + end; + procedure RemoveNotification(AComponent:TComponent); + begin + FFreeNotifies.Remove(AComponent); + if FFreeNotifies.count()<1 then includestate(FComponentState,csFreeNotification); + end +#!end + protected +#!begin //protected methods + function SetName(v);virtual; + begin + if ifstring(v)and length(v)>1 and v <> FName then + begin + if isKeyWords(v)then return; + nv := lowercase(v); + if new TCharDiscrimi().IsVariableName(v)then + begin + r := RootOwner().FindComponentByName(nv); + if not r then + begin + FName := nv; + end + end + end + end + Procedure SetAncestor(Value:Boolean); + begin + If Value then includestate(FComponentState,csAncestor)else excludestate(FCOmponentState,csAncestor); + For Runner := 0 To FComponents.Count-1 do + begin + FComponents.geti(Runner).SetAncestor(Value); + end + end; + function ValidateContainer(AComponent:TComponent);virtual; + begin + if AComponent is class(tcomponent)then return AComponent.ValidateInsert(Self); + end + function ValidateInsert(AComponent:TComponent);virtual; + begin + return true; + end +public + function ExecuteCommand(cmd,p);virtual; + begin + + end + Procedure Notification(AComponent,Operation);virtual; + begin + {** + @explan(说明) 通知处理 %% + @param(AComponent)(tcomponent) 改变的对象 %% + @param(Operation)(member of TOperation) 通知码 %% + **} + If(Operation=opRemove)then + begin + RemoveFreeNotification(AComponent); + end + data := FComponents.data(); + C := length(data)-1; + While(C >= 0) do + begin + data[c].Notification(AComponent,Operation); + c--; + end; + end; +private + Procedure SetDesignInstance(Value); + begin + If Value then + includestate(FComponentState,csDesignInstance) + else + excludestate(FComponentState,csDesignInstance); + end; +public + procedure RemoveFreeNotification(AComponent:TComponent); + begin + RemoveNotification(AComponent); + AComponent.RemoveNotification(self); + end; + Procedure SetDesigning(Value,SetChildren);virtual; + begin + {** + @explan(说明) 设计器使用方法,设置为设计状态,或者解除设置状态 %% + @param(Value)(bool) 状态值 %% + @param(SetChildren)(bool) 是否修改子控件状态 %% + **} + if ifnil(SetChildren)then SetChildren := true; + If Value then + includestate(FComponentState,csDesigning); + else + excludestate(FComponentState,csDesigning); + if SetChildren then + begin + items := FComponents.data; + For Runner := 0 To length(items)-1 do + begin + items[Runner].SetDesigning(Value); + end + end + end; +protected + function SetParentComponent(Value);virtual; + begin + end + function GetChildren();virtual; + begin + end + procedure Updating;virtual; + begin + includestate(FComponentState,csUpdating); + end + procedure Updated;virtual; + begin + excludestate(FComponentState,csUpdating); + end + +#!end +public +#!begin //public methods + function create(AOwner);virtual; + begin + class(TSLUIBASE).create(); + FComponents := NEW TFpList(); + FFreeNotifies := NEW TFpList(); + FComponentStyle := array(csInheritable); + FComponentstate := array(); + SetOwner(AOwner); + FEventsProperties := array(); + FVariableProperties := array(); + FComponentCreated := true; + return; + If AOwner is class(tcomponent)then + begin + FOwner := AOwner; + AOwner.InsertComponent(Self); + end + end + function RootOwner(); + begin + if not(FOwner is class(TComponent))then return self(true); + return FOwner.RootOwner(); + end + function FindComponentByName(n); + begin + if n and n=FName then return self(true); + cps := Components; + for i := 0 to cps.Count-1 do + begin + r := cps[i].FindComponentByName(n); + if r then return r; + end + return false; + end + function isDescendant(cd); + begin + {** + @explan(说明) 判断节点是否为其子节点 %% + @param(cd)(tcomponent) 等判断节点 %% + @return(bool) true 为子节点 false 非子节点 %% + **} + if cd=self then return true; + for i := 0 to FComponents.count()-1 do + begin + if FComponents[i].isDescendant(cd)then return true; + end + return false; + end + function SetOwner(AOwner); + begin + {** + @explan(说明) 设置所有者,注意只能成功设置一次,之后设置无效 %% + @param(AOwner)(tcomponent) 所有者 %% + **} + if ifnil(FOwner)and(AOwner is class(tcomponent))then + begin + if isDescendant(AOwner)then exit; + FOwner := AOwner; + AOwner.InsertComponent(self(true)); + end + end + function Recycling();override; + begin + if not FComponentCreated then exit; + Destroying(); + DestroyComponents(); + If FOwner is class(tcomponent)Then FOwner.RemoveComponent(Self); + inherited; + end + function Destroy();virtual; + begin + inherited; + end; + function Destroying(); + begin + If csDestroying in FComponentstate Then Exit; + includestate(FComponentState,csDestroying); + if not FCOmponents then exit; + data := FCOmponents.data(); + for i,v in data do v.Destroying(); + end; + function ExecuteAction(act:TBasicAction):Boolean;virtual; + begin + {** + @explan(说明)执行action %% + **} + if act.HandlesTarget(Self)then + begin + act.ExecuteTarget(Self); + return True; + end else + return False; + end + function UpdateAction(act:TBasicAction):Boolean;virtual; + begin + {** + @explan(说明) 更新action %% + **} + if act.HandlesTarget(Self)then + begin + act.UpdateTarget(Self); + return True; + end else + return False; + end + function DestroyComponents(); + begin + {** + @explan(说明)删除子项 %% + **} + if not FComponents then exit; + FName := nil; + data := FComponents.data(); + FComponents.clean(); + for i,Acomponent in data do + begin + Acomponent.Recycling(); + end + end; + Procedure FreeNotification(AComponent:TComponent); + begin + {** + @explan(说明) 关联对象,在释放的时候相互通知 %% + @param(AComponent)(TComponent) 对象 %% + **} + if not(AComponent is class(tcomponent))then exit; + If(Owner <> Nil)and(AComponent=Owner)then exit; + If FFreeNotifies.IndexOf(AComponent)=-1 then + begin + FFreeNotifies.Add(AComponent); + AComponent.FreeNotification(self(true)); //添加当前的 + end; + end; + //function GetParentComponent(); virtual;begin end + //function HasParent(); virtual;begin end + function InsertComponent(AComponent);virtual; + begin + {** + @explan(说明)插入节点 %% + **} + if AComponent.ValidateContainer(Self)then + begin + self.Insert(AComponent); + If csDesigning in FComponentState then AComponent.SetDesigning(true); + Notification(AComponent,opInsert); + end + end; + Procedure RemoveComponent(AComponent); + begin + {** + @explan(说明)移除子节点 %% + **} + Notification(AComponent,opRemove); + if Remove(AComponent)then Acomponent.Setdesigning(False); + end; + function Assigned(o);virtual; + begin + return ifobj(o); + end +#!end + private + FEventsProperties; + FChangedProperties; + FVariableProperties; + function GetPublishInfo(); + begin + r := publishs(); + rr := array(); + ri := 0; + for i,v in r do + begin + if ifstring(v) then rr[ri++] := lowercase(v); + end + return rr; + end + function OrderPublish(r,od); //排序发布的东西 + begin + if od then + begin + r1 := array(); + for i,v in od do + begin + vi := r[v]; + if vi then r1[v]:= vi; + end + r := r1; + end + end +public + function publishs();virtual; + begin + //return array("currentcolor","lazyitems","range","firstdayofweek","align","mbbtnstyle","textalign","text","imagelist","canvs","images","items","bkbitmap","icon","popupmenu","mainmenu","cursor","height","width","left","top","enabled","visible","caption","color","font","onclick","rootfolder","initialdir"); + end + function GetPublishproperties();virtual; + begin + {** + @explan(说明) 获得properties,设计器使用%% + **} + ps := GetPropInfo(); + r := array(); + pps := GetPublishInfo(); + for i,v in ps do + begin + typ := v["type"]; + if typ="eventhandler" then continue; + otype := GetPropertyType(typ); + if otype then + begin + n := v["name"]; + if pps and not(n in pps)then continue; + if typ in array("variable","popupmenu","syscursor","tmainmenu")then + begin + r[n]:= otype.FormatEdit(FVariableProperties[n],v["write"]?true:false); + end else + r[n]:= otype.FormatEdit(invoke(self(true),n),v["write"]?true:false); + end + end + //次序处理 + //////////////////// + OrderPublish(r,pps); + //////////////////// + return r; + end + function GetPublishEvents();virtual; + begin + {** + @explan(说明) 获得event值,设计器使用 %% + @return(array) + **} + ps := GetPropInfo(); + r := array(); + pps := GetPublishInfo(); + for i,v in ps do + begin + typ := v["type"]; + if typ <> "eventhandler" then continue; + otype := GetPropertyType(typ); + if otype then + begin + n := v["name"]; + if pps and not(n in pps)then continue; + ne := FEventsProperties[n]; + r[n]:= otype.FormatEdit(ne,v["write"]?true:false); + end + end + OrderPublish(r,pps); + return r; + end + function GetChangedPropertiesn(n);virtual; + begin + return FChangedProperties[n]; + end + function GetChangedPublish();virtual; + begin + {** + @explan(说明)获取修改过的publish,设计器使用 %% + **} + r := array(); + if not FChangedProperties then return r; + ps := GetPropInfo(); + for i,vi in ps do + begin + n := vi["name"]; + vv := FChangedProperties[n]; + if ifnil(vv)then continue; + vit := vi["type"]; + otype := GetPropertyType(vit); + if vi["write"]and otype then + begin + r[n]:= otype.FormatTMF(vv); + end + end + return r; + end + function SetChangedPublish(n,v);virtual; + begin + {** + @explan(说明) 设计器相关函数 %% + **} + if not ifarray(FChangedProperties)then FChangedProperties := array(); + //reindex(FChangedProperties,array(n:nil)); + FChangedProperties[n]:= v; + end + function DeleteChangedPublish(n);virtual; + begin + if n and ifstring(n)then + begin + if not ifarray(FChangedProperties)then FChangedProperties := array(); + reindex(FChangedProperties,array(n:nil)); + end + end + function SetPublish(n,v);virtual; + begin + {** + @explan(说明) 修改单个值,设计器使用 %% + @param(n)(string) 名称 %% + @param(v)(any) 值 %% + **} + ps := GetPropInfo(); + for i,vi in ps do //获取信息 + begin + if n=vi["name"]then + begin + vit := vi["type"]; + otype := GetPropertyType(vit); //获得转换对象 + if ifobj(otype)then + begin + iv := otype.UnformatEdit(v); //反转换 + SetChangedPublish(n,iv); //保存 + if vit="eventhandler" then //分类保存 + begin + FEventsProperties[n]:= iv; + end else + begin + if vit in array("variable","popupmenu","syscursor","tmainmenu")then //分类保存 + begin + FVariableProperties[n]:= iv; + if vit="tmainmenu" then + begin + try + invoke(self(true),n,1,iv); + except + return false; + end; + end + end else + //if not ifnil(iv) then //设置到设计控件 + begin + try + //if n="visible" and (not((self(true) is class(tform)) and (self(true) is class(tpanelform)))) then + //else + invoke(self(true),n,1,iv); + except + return false; + end; + end + end + end + return true; + end + end + end + property Owner:tcomponent read FOwner; + {** + @param(Owner)(tcomponent) 所有者 %% + @param(ComponentState)() 状态集合 %% + @param(ComponentStyle)() 样式结合 %% + @param(ComponentCreated)(bool) 样式结合 %% + **} + //property DesignInfo read FDesignInfo write FDesignInfo; + property ComponentCreated read FComponentCreated; + property Components read FComponents; + property ComponentState read FComponentState write SetComponentState; + property ComponentStyle read FComponentStyle; + property Name:string read FName write SetName; + property Parent read ComponentGetParent write ComponentSetParent; + property Loader read GetLoader; +end \ No newline at end of file diff --git a/funcext/tvclib/tcontrol.tsf b/funcext/tvclib/tcontrol.tsf new file mode 100644 index 0000000..7fd3d26 --- /dev/null +++ b/funcext/tvclib/tcontrol.tsf @@ -0,0 +1,1540 @@ +type tcontrol = class(tcomponent) +{** + @explan(说明) 界面控件基类 %% + @date(20220509) %% +**} + uses utslvclauxiliary,utslvclmemstruct,utslvclevent,utslvclgdi,utslvclaction,utslvclmenu; + private //计量处数据 + #!begin //members + STATIC FSIDC; + FActionLink: TControlActionLink; + FCanvas: TCanvas; + FMessagehandle;//消息表 + FtagPAINTSTRUCT; + + //;数据 + //private + FAnchors; + FAnchorBounds; + + FCaption;//标题 + FCaptureMouseButtons;//鼠标样式 + FColor;//颜色 + FBKBitmap; + FControlFlags;//控件标记 + FControlStyle;//控件样式 + FDesktopFont; + FDockOrientation; + FDragCursor; + FFont; //字体 + FHostDockSite: TWinControl; + FLastDoChangeBounds: TRect; + FLastDoChangeClientSize: TPoint; + FLastResizeClientHeight: integer; + FLastResizeClientWidth: integer; + FLastResizeHeight: integer; + FLastResizeWidth: integer; + FOnClick; //点击 + Fonrclick; + FOnContextPopup; + FOnDblClick; //双击 + FOnDragDrop; + FOnDragOver; + FOnSize; + FOnMove; + FOnEditingDone; + FOnEndDock; + FOnEndDrag; + FOnMouseDown; //按下 + FOnMouseEnter; //进入 + FMouseEntereded; + FOnMouseLeave; //离开 + FOnMouseMove; //移动 + FOnPopupMenu; + FOnMouseUp; //弹起 + FOnMouseWheel; //滚动 + FOnMouseWheelDown; //滚动按下 + FOnMouseWheelUp; //滚动弹起 + //FOnQuadClick; + //FOnResize; // + FOnShowHint; + FOnStartDock; + FOnStartDrag; + //FOnTripleClick; + FBorder; + protected + //对齐 + FAlign;//对齐方式 + FUnAlignBounds; + + FParent;// TWinControl; //父节点 + //public + //FParentBiDiMode;//: Boolean; + FPopupMenu;//: TPopupMenu; + //FIsControl;//: Boolean; + FShowHint;//: Boolean; + //FParentColor;//: Boolean; + FParentFont;//: Boolean; + //FParentShowHint;//: Boolean; + //FAutoSizingAll;//: boolean; + //FAutoSizingSelf;//: Boolean; + FEnabled;//: Boolean; //有效 + //FMouseEntered;//: boolean; + FVisible;//: Boolean; //可见 + FID; + + FOnMeasureItem; + FOnDrawItem; + #!end + + //位置信息 + //protected + FLeft:integer; //左边 + FTop:integer;//: Integer; //上 + FWidth:integer; + FHeight:integer; //高度 + FControls; + FControlState; + FCursor; + {** + @param(FLeft)(integer) 左边 %% + @param(FTop)(integer) 上边 %% + @param(FWidth)(integer) 宽度 %% + @param(FHeight)(integer) 高度 %% + **} + function SetAction(Value);virtual; + begin + if csDesigning in ComponentState then + begin + FActionLink := Value; + return; + end + if ifnil(Value)then + begin + if FActionLink then + begin + FActionLink.SetAction(nil); + end + excludestate(FControlStyle,csActionClient); + end else + if Value is class(TBasicAction)then + begin + includestate(FControlStyle,csActionClient); + if ifnil(FActionLink)then FActionLink := createobject(GetActionLinkClass(),self); + FActionLink.Action := Value; + FActionLink.Onchange := thisfunction(DoActionChange); + ActionChange(Value,csLoading in Value.ComponentState); + Value.FreeNotification(Self); + end + end + function getparenttype(); + begin + return class(TWinControl); + end + procedure DoActionChange(Sender:TObject); + begin + if Sender=Action then ActionChange(Sender,False); + end + function GetAction();virtual; + begin + if csDesigning in ComponentState then + begin + return FActionLink; + end + if FActionLink then + begin + return FActionLink.Action; + end + end + function SetEnabled(v);virtual; + begin + nv := v?true:false; + if FEnabled <> nv then + begin + FEnabled := nv; + end + end + //protected + procedure SetAlign(Value:TAlign);virtual; + begin + if not(Value in array(alLeft,alRight,alBottom,alTop,alNone,alClient))then exit; + if FAlign=Value then exit; + bds := UnAlignBounds; + FAlign := Value; + //调其兄弟节点的位置 %% + if FParent is getparenttype() and FParent.HandleAllocated()then + begin + if FAlign=alNone then + begin + //bds := UnAlignBounds; + SetBounds(bds[0],bds[1],bds[2],bds[3]); + end + FParent.DoControlAlign(); + end + end + procedure SetAnchors(Value);virtual; + begin + if not ifarray(Value)then exit; + if FAnchors=Value then exit; + FAnchorBounds := 0; + val := Value union2 array(); + aks := array(akLeft,akRight,akTop,akBottom); + for i,v in val do + begin + if not(v in aks)then exit; + end + FAnchors := val; + end + + private + function SetUnAlignBounds(Value); + begin + {** + @explan(说明) 设置非对齐的范围 %% + **} + if(align in array(alTop,alLeft,alRight,alBottom,alClient))then exit; + if CheckArrayIsControlBounds(Value)and FUnAlignBounds <> Value then + begin + FUnAlignBounds := Value; + if parent and(Align <> alNone)and Parent.HandleAllocated()then Parent.DoControlAlign(); + end + end + Function GetUnAlignBounds();virtual; //type_tcontrol + begin + if alNone=FAlign then + begin + FUnAlignBounds := GetBoundsRect(); + end + if not ifarray(FUnAlignBounds)then FUnAlignBounds := GetBoundsRect(); + return FUnAlignBounds; + end + function GetEnabled();virtual; + begin + return FEnabled; + end + + procedure SetLeft(Value:Integer); //type_tcontrol + begin + if Value>-5000000 and Value<5000000 and Value <> FLeft then SetBounds(Value,FTop,FWidth,FHeight); + end + procedure SetTop(Value:Integer); //type_tcontrol + begin + if Value>-5000000 and Value<5000000 and Value <> FTop then SetBounds(FLeft,Value,FWidth,FHeight); + end + procedure SetWidth(Value:Integer); //type_tcontrol + begin + if Value>-5000000 and Value<5000000 and Value <> FWidth then SetBounds(FLeft,FTop,Max(0,Value),FHeight); + end + procedure SetHeight(Value:Integer); //type_tcontrol + begin + if Value>-5000000 and Value<5000000 and Value <> FHeight then SetBounds(FLeft,FTop,FWidth,Max(0,Value)); + end + function GetText(); //type_tcontrol + begin + return RealGetText(); + end + procedure SetText(Value:string); //type_tcontrol + begin + return RealSetText(Value); + end + function SetParentFont(v:bool); + begin + nv := v?true:false; + if FParentFont <> nv then + begin + FParentFont := nv; + if nv then + begin + hd := GetParentFontHandle(); + if Parent then Parent.Perform(New tuieventbase(CMFONTCHANGED,hd,1)); + end + end + end + public + function PaintStruct(); + begin + {** + @explan(说明) 获取绘制消息结对象 %% + @return(TPAINTSTRUCT) 包含绘制 + **} + if not FtagPAINTSTRUCT then + begin + FtagPAINTSTRUCT := new TPAINTSTRUCT(); + end + return FtagPAINTSTRUCT; + end + function bindmessage(id,func); //type_tcontrol + begin + {** + @ignore 忽略 %% + @explan(说明) 绑定处理函数到消息id %% + **} + if not ifarray(FMessagehandle)then FMessagehandle := array(); + if ifnumber(id)and (datatype(func)=7)then FMessagehandle[id]:= func; + end + private + static FClassDigestA; + class function CtlInfoAndDigest(idx,d); //通过类的指纹保存或者获取控件信息 + begin + if not ifarray(FClassDigestA)then FClassDigestA := array(); + if ifnil(d)then return FClassDigestA[idx]; + else FClassDigestA[idx]:= d; + end + function FindMessageFunctionstr(o);virtual; //type_tcontrol + begin + { + @explan(说明) 自动绑定消息函数到消息id %% + } + if not(o is class(tcontrol))then return array(); + t := o.classinfo; + idx := getmsgd_Crc32(tostm(t))+"%%"; + r := CtlInfoAndDigest(idx); + if ifarray(r)then return r; + r := array(); + hs := t["inherited"]; + for i,v in hs do + begin + //sbf := static call(thisfunction,findclass(v,o)) name v+"%%_%%"; + sbf := call(thisfunction,findclass(v,o)); + for ii,vv in sbf do + begin + r[ii]:= vv; + end + end + for i,v in t["subs"] do + begin + if v["access"]in array(2,3)then continue; + fstring := v["functionname"]; + if not ifstring(fstring)then continue; + //f := findfunction(fstring,o); + returntype := v["returntype"]; + try + if returntype then + begin + mid := invoke(o,returntype); + r[mid]:= fstring; + //bindmessage(mid,f); + end + except + end + end + CtlInfoAndDigest(idx,r); + return r; + end + function bindmessages(o);virtual; //type_tcontrol + begin + { + @explan(说明) 自动绑定消息函数到消息id %% + } + s := FindMessageFunctionstr(o); + for i,v in s do + begin + bindmessage(i,findfunction(v,o)); + end + return; + if not(o is class(tcontrol))then return; + t := o.classinfo; + hs := t["inherited"]; + for i,v in hs do + begin + call(thisfunction,findclass(v,o)); + end + for i,v in t["subs"] do + begin + if v["access"]in array(2,3)then continue; + fstring := v["functionname"]; + if not ifstring(fstring)then continue; + f := findfunction(fstring,o); + returntype := v["returntype"]; + try + if returntype then + begin + mid := invoke(o,returntype); + bindmessage(mid,f); + end + except + end; + end + end + protected + function GetControlFont();virtual; + begin + return FFont; + end + function SetControlFont(v);virtual; + begin + if ifarray(v)then + begin + FFont.SetValues(v); + end else + if v is class(tfont)then + begin + FFont.copyfont(v); + end + end + function CurrentFont(); + begin + if ParentFont and Parent then return Parent.CurrentFont(); + return Font; + end + function GetParentFontHandle();virtual; + begin + if ParentFont and Parent then return Parent.GetParentFontHandle(); + return Font.Handle; + end + function SetBorder(v);virtual; + begin + FBorder := v?true:false; + end + function SetZorder(n); + begin + f := Parent; + if f is getparenttype() then + begin + return f.MoveControlOrder(self,n); + end + end + function GetZorder(); + begin + f := Parent; + if f is getparenttype()then + begin + return f.Controls.indexof(self); + end + end + function RealGetText: + TCaption; + virtual; //type_tcontrol + begin + return FCaption; + end + procedure RealSetText(Value:TCaption);virtual; //type_tcontrol + begin + FCaption := Value; + end + +#!begin //资源处理 + function GetCursor();virtual; + begin + return FCursor; + end + procedure SetCursor(Value);virtual; + begin + if(FCursor is class(tcustomcursor))and ifnumber(Value)and FCursor.id <> Value then + begin + FCursor.id := Value; + Perform(new tuieventbase(CM_CURSORCHANGED,0,0)); + end; + end + procedure SetVisible(Value);virtual; + begin + FVisible := Value?true:false; + end + procedure DoOnParentHandleDestruction;virtual; + begin + end + +#!end + protected + function messagecreater(hwnd,message,wparam,lparam);virtual; ////type_tcontrol + begin + {** + @explan(说明)根据消息参数构造消息对象; + **} + if message in array(WM_MOUSEMOVE,WM_LBUTTONDOWN, + WM_RBUTTONDOWN,WM_LBUTTONUP, + WM_RBUTTONUP,WM_LBUTTONDBLCLK, + WM_RBUTTONDBLCLK,WM_MBUTTONDOWN,WM_MBUTTONUP,WM_MBUTTONDBLCLK)then + begin + r := new TMMouse(message,wparam,lparam,hwnd); + end else + if message=WM_MENUSELECT then + begin + r := new TMMENUSELECT(message,wparam,lparam,hwnd); + end else + if message=WM_MEASUREITEM then + begin + r := new TMMEASUREITEM(message,wparam,lparam,hwnd); + end else + if message in array(WM_KEYDOWN,WM_KEYUP,WM_CHAR,WM_SYSKEYDOWN,WM_SYSKEYUP)THEN + begin + r := new TMKEY(message,wparam,lparam,hwnd); + end else + if message=WM_DRAWITEM then + begin + r := new TMDRAWITEM(message,wparam,lparam,hwnd); + end else + if message=WM_NOTIFY then + begin + r := new TMNOTIFY(message,wparam,lparam,hwnd); + end else + if message=WM_MOUSEWHEEL then + begin + r := new TMMOUSEWHEEL(message,wparam,lparam,hwnd); + end else + if message=WM_STYLECHANGED or message=WM_STYLECHANGING then + begin + r := new TMSTYLECHANG(message,wparam,lparam,hwnd); + end else + r := new tuieventbase(message,wparam,lparam,hwnd); + return r; + //return new tuieventbase(message,wparam,lparam,hwnd); + end + function GetClientOrigin();virtual; ////type_tcontrol + begin + if FParent then base := FParent.ClientOrigin(); + return array(base[0]+FLeft,base[1]+FTop); + end + function GetLogicalClientRect();virtual; //type_tcontrol + begin + return GetClientRect(); + end; + function GetClientScrollOffset();virtual; //type_tcontrol + begin + return array(0,0); + end + function GetScrolledClientRect();virtual; //type_tcontrol + begin + Result := GetClientRect(); + ScrolledOffset := GetClientScrollOffset(); + Result[0]+= ScrolledOffset[0]; + Result[1]+= ScrolledOffset[1]; + Result[2]+= ScrolledOffset[0]; + Result[3]+= ScrolledOffset[1]; + return Result; + end; + function GetControlOrigin();virtual; //type_tcontrol + begin + Result := array(FLeft,FTop); + if FParent <> nil then + begin + ParentsClientOrigin := FParent.ClientOrigin(); + Result[0]+= ParentsClientOrigin[0]; + Result[1]+= ParentsClientOrigin[1]; + end; + return Result; + end + function OnControlAppend(AControl);virtual; + begin + {** + @explan(说明) 子控件添加 %% + **} + end + function OnControlDelete(AControl);virtual; + begin + {** + @explan(说明) 子控件删除 %% + **} + end + function operatectrl(actrl,op);virtual; //type_tcontrol + begin + idx := FControls.indexof(actrl); + if op=opRemove then + begin + if(idx >= 0)then + begin + FControls.deli(idx); + aparent := actrl.FParent; + actrl.FParent := nil; + OnControlDelete(actrl); + //if (actrl.Align<>alNone) and (aparent is class(TWincontrol)) then aparent.DoControlAlign(); + ifop := true; + end + end else + if op=opInsert then + begin + if idx=-1 then + begin + FControls.append(actrl); + actrl.FParent := self(true); + OnControlAppend(actrl); + ifop := true; + end + end + return ifop; + end + function SetParent(NewParent);virtual; //type_tcontrol + begin + //1.为窗口类 + //2.可以作为父窗口 + //3.调用api 可以成功 + if NewParent=self then return; + if NewParent=FParent then return; + if NewParent is getparenttype() then + begin + if FParent then + begin + FParent.operatectrl(self(true),opRemove); + end + np := NewParent.Parent; + while np is getparenttype() do + begin + if np=self then return; + np := np.Parent; + end + NewParent.operatectrl(self(true),opInsert); + end else + begin + if Parent then FParent.operatectrl(self(true),opRemove); + end + end + procedure SetParentComponent(NewParentComponent);override; //type_tcontrol + begin + SetParent(NewParentComponent); + end + public + procedure Notification(AComponent:TComponent;Operation:TOperation);override; //type_tcontrol + begin + {** + @explan(说明) 通知消息处理 %% + **} + if Operation=opRemove then + begin + if AComponent=PopupMenu then + PopupMenu := nil ; + else + if AComponent=Action then Action := nil; + idx := FControls.indexof(AComponent); //删除子控件 + if idx >= 0 then + begin + FControls.deli(idx); + end + end; + inherited; + end; + protected + procedure UpdateMouseCursor(X, Y: integer); + begin + end + procedure ChangeBounds(ALeft,ATop,AWidth,AHeight:integer;KeepBase:boolean);virtual; //type_tcontrol + begin + SizeChanged :=(FWidth <> AWidth)or(FHeight <> AHeight); + PosChanged :=(FLeft <> ALeft)or(FTop <> ATop); + if(not SizeChanged)and(not PosChanged)then Exit; + // d := new ttagWINDOWPOS(); + d := new tvclwindowpos_class(0); + if SizeChanged then + begin + d.cx := AWidth; + d.cy := AHeight; + D.flags := SWP_NOMOVE; + e := new tuieventbase(WM_WINDOWPOSCHANGED,0,d._getptr_); + //e := new tuieventbase(WM_SIZE,0,makeposition(AWidth,AHeight)); + class(tcontrol).wndproc(e); + end + if PosChanged then + begin + d.x := ALeft; + d.y := ATop; + d.flags := SWP_NOSIZE; + e := new tuieventbase(WM_WINDOWPOSCHANGED,0,d._getptr_); + //e := new tuieventbase(WM_MOVE,6,makeposition( ALeft,ATop)); + class(tcontrol).wndproc(e); + end + {if SizeChanged or PosChanged then + begin + if (Parent is class(TWinControl)) and Parent.HandleAllocated then + begin + Parent.DoControlAlign(); + end + end } + end + function MouseHover(o,e);virtual; + begin + if not FMouseEntereded then + begin + DoMouseEnter(o,e); + FMouseEntereded := true; + end + end + function MouseLeave(o,e);virtual; + begin + if FMouseEntereded then + begin + DoMouseLeave(o,e); + FMouseEntereded := false; + end + end + function defaulthandler(e);virtual; + begin + return 0; + end + public + function MouseMove(o,e);virtual; + begin + end + function MouseDown(o,e);virtual; + begin + {** + @explan(说明) 鼠标按下消息 %% + @param(o)(TWinControl) 控件自身 %% + @param(e)(TMMouse) 消息 %% + **} + end + function MouseUp(o,e);virtual; + begin + {** + @explan(说明) 鼠标松开消息 %% + @param(o)(TWinControl) 控件自身 %% + @param(e)(TMMouse) 消息 %% + **} + end + function ContextMenu(o,e);virtual; + begin + {** + @explan(说明) 右键菜单 %% + @param(o)(TWinControl) 控件自身 %% + @param(e)(tuieventbase) 消息 %% + **} + if e.Result then exit; + if FPopupMenu is class(TcustomPopupmenu) then + begin + uf := TPM_LEFTALIGN .| TPM_TOPALIGN .| TPM_RIGHTBUTTON; + _wapi.TrackPopupMenu(FPopupMenu.Handle,uf,e.lolparamsigned,e.hilparamsigned,0,e.wparam,nil); + e.skip := true; + end + end + public + procedure FontChanged(Sender:TObject);virtual; + begin + if parent then parent.FontChanged(Sender); + end + function GetClientRect();virtual; // //type_tcontrol visual size of client area + begin + {** + @explan(说明) 获取客户区%% + @return( array of integer) 左上右下 %% + **} + return array(0,0,FWidth,Height); + end + +#!begin //消息处理 + function DoCNCOMMAND(o,e);virtual; + begin + {** + @explan(说明) 通知消息 %% + @param(o)(tcontrol) 控件自身 %% + @param(e)(tuieventbase) 消息 %% + **} + end + function CNCOMMAND(o,e):CN_COMMAND;virtual; + begin + DoCNCOMMAND(o,e); + end + function CNMEASUREITEM(o,e):CN_MEASUREITEM;virtual; + begin + CallMessgeFunction(FOnMeasureItem,o,e); + DoMeasureItem(o,e); + end + function DoMeasureItem(o,e);virtual; + begin + {** + @explan(说明) 控件测量通知消息 %% + @param(o)(TWinControl) 控件自身 %% + @param(e)(TMMEASUREITEM) 消息 %% + **} + end + function CNDRAWITEM(o,e):CN_DRAWITEM;virtual; + begin + //tb := new tbrush(); + //tbh := tb.handle; + //odh := _wapi.SelectObject(canvas.Handle,tbh); + DoDrawItem(o,e); + //_wapi.SelectObject(canvas.Handle,odh); + end + function DoDrawItem(o,e);virtual; + begin + { + @explan(说明) 控件绘制通知消息 %% + @param(o)(TWinControl) 控件自身 %% + @param(e)(TMDRAWITEM) 消息 %% + } + CallMessgeFunction(FOnDrawItem,o,e); + end + function DoMouseEnter(o,e);virtual; + begin + { + @explan(说明) 鼠标进入控件回调 %% + } + CallMessgeFunction(FOnMouseEnter,o,e); + end + function DoMouseLeave(o,e);virtual; + begin + { + @explan(说明) 鼠标离开控件回调 %% + } + CallMessgeFunction(FOnMouseLeave,o,e); + end + function DoCnNotify(o,e);virtual; + begin + {** + @expaln(说明) 父窗口通知回调 %% + **} + end + function CNNOTIFY(o,e):CN_NOTIFY;virtual; + begin + DoCnNotify(o,e); + end + function WMERASEBKGND(o,e):WM_ERASEBKGND;virtual; + begin + end + function WMCancelMode(o,e):LM_CANCELMODE;virtual; + begin + end + function WMContextMenu(o,e):LM_CONTEXTMENU;virtual; + begin + CallMessgeFunction(FOnPopupMenu,o,e); + ContextMenu(o,e); + end + function WMLButtonDown(o,e):LM_LBUTTONDOWN;virtual; + begin + e.SetButton(mbLeft); + CallMessgeFunction(FOnMouseDown,o,e); + MouseDown(o,e); + end + function WMRButtonDown(o,e):LM_RBUTTONDOWN;virtual; + begin + e.SetButton(mbRight); + CallMessgeFunction(FOnMouseDown,o,e); + MouseDown(o,e); + end + function WMMButtonDown(o,e):LM_MBUTTONDOWN;virtual; + begin + e.SetButton(mbMiddle); + CallMessgeFunction(FOnMouseDown,o,e); + MouseDown(o,e); + end + function WMLButtonDBLCLK(o,e):LM_LBUTTONDBLCLK;virtual; + begin + e.SetButton(mbLeft); + e.setshiftdouble(ssDouble); + CallMessgeFunction(FOnMouseDown,o,e); + MouseDown(o,e); + return; + if not(e.skip)then + begin + CallMessgeFunction(FOnDblClick,o,e); + end + end + function WMRButtonDBLCLK(o,e):LM_RBUTTONDBLCLK;virtual; + begin + { + @explan(说明) 鼠标右双击击消息 %% + @param(o)(TWinControl) 控件自身 %% + @param(e)(TMMouse) 消息 %% + } + e.SetButton(mbRight); + e.setshiftdouble(ssDouble); + CallMessgeFunction(FOnMouseDown,o,e); + MouseDown(o,e); + end + function WMMOUSEHOVER(o,e):WM_MOUSEHOVER;virtual; + begin + MouseHover(o,e); + end + function WMMOUSELEAVE(o,e):WM_MOUSELEAVE;virtual; + begin + MouseLeave(o,e); + end + function WMMouseMove(o,e):LM_MOUSEMOVE;virtual; + begin + CallMessgeFunction(FOnMouseMove,o,e); + MouseMove(o,e); + end + function WMLButtonUp(o,e):LM_LBUTTONUP;virtual; + begin + e.SetButton(mbLeft); + CallMessgeFunction(FOnMouseUp,o,e); + MouseUp(o,e); + end + function WMRButtonUp(o,e):LM_RBUTTONUP;virtual; + begin + e.SetButton(mbRight); + CallMessgeFunction(FOnMouseUp,o,e); + MouseUp(o,e); + if not e.skip then + begin + CallMessgeFunction(FOnrbuttonup,o,e); //右键点击 + end + end + function WMMButtonUp(o,e):LM_MBUTTONUP;virtual; + begin + e.SetButton(mbMiddle); + CallMessgeFunction(FOnMouseUp,o,e); + MouseUp(o,e); + end + function DoMouseWheel(o,e);virtual; + begin + {** + @explan(说明) 鼠标滚动消息 %% + @param(o)(TWinControl) 控件自身 %% + @param(e)(TMMOUSEWHEEL) 滚动消息 %% + **} + end + function WMMouseWheel(o,e):LM_MOUSEWHEEL;virtual; + begin + CallMessgeFunction(FOnMouseWheel,o,e); + if not e.Result then + begin + if e.delta<0 then CallMessgeFunction(FOnMouseWheelDown,o,e); + else CallMessgeFunction(FOnMouseWheelUp,o,e); + end + DoMouseWheel(o,e); + end + function DoCNALIGN(o,e);virtual; + begin + if FAlign=alNone then exit; + if not(Visible)then exit; + if(o is getparenttype())and not(o.HandleAllocated())then + begin + exit; + end + if e.width<1 then exit; + if e.height<1 then exit; + bds := UnAlignBounds; + case Align of + alTop: + begin + ht := min(e.height,bds[3]-bds[1]); + if ht then + begin + SetBounds(e.left,e.top,e.width,ht); + //SetBoundsRect(array(e.left,e.top,e.width+e.left,e.top+ht)); + e.top += ht; + e.height -= ht; + end + end + alRight: + begin + wd := min(e.width,bds[2]-bds[0]); + SetBounds(e.left+e.width-wd,e.top,wd,e.height); + e.width := e.width-wd; + end + alLeft: + begin + wd := min(e.width,bds[2]-bds[0]); + SetBounds(e.left,e.top,wd,e.height); + e.left := e.left+wd; + e.width := e.width-wd; + end + alBottom: + begin + ht := min(e.height,bds[3]-bds[1]); + SetBounds(e.left,e.top+e.height-ht,e.width,ht); + e.height -= ht; + end + alClient: + begin + SetBounds(e.left,e.top,e.width,e.height); + e.height := 0; + e.width := 0; + end + end + {if self is class(TWinControl) then + begin + //InvalidateRect(nil,true); updateWindow(); + end } + end + function CNALIGN(o,e):CN_ALIGN;virtual; + begin + DoCNALIGN(o,e); + end + public + function CNANCHOR(o,e):CN_ANCHOR;virtual; + begin + if Align <> alNone then exit; + if not ifarray(FAnchors)then exit; + if not(Visible)then exit; + if(o is getparenttype())and not(o.HandleAllocated())then + begin + exit; + end + if akLeft+akTop=sum(FAnchors)then exit; //左上 + c := e.Prec; + bds := GetBoundsRect(); + if not FAnchorBounds then + begin + FAnchorBounds := array(bds[0],bds[1],c[2]-bds[2],c[3]-bds[3]); + return; + end + w := width; + h := height; + dx := c[2]-c[0]-(FAnchorBounds[0]+w+FAnchorBounds[2]); + dy := c[3]-c[1]-(FAnchorBounds[1]+h+FAnchorBounds[3]); + dx1 := integer(dx/2); + dx2 := dx-dx1; + dy1 := integer(dy/2); + dy2 := dy-dy1; + L := bds[0]; + r := bds[2]; + t := bds[1]; + b := bds[3]; + if(akLeft in FAnchors)and(akRight in FAnchors)then + begin + R := c[2]-FAnchorBounds[2]; + end + if not(akLeft in FAnchors)and(akRight in FAnchors)then + begin + R := c[2]-FAnchorBounds[2]; + L := r-w; + end + if not(akLeft in FAnchors)and not(akRight in FAnchors)then + begin + L := FAnchorBounds[0]+dx1; + R := l+w; + end + //********************************** + if(akTop in FAnchors)and(akBottom in FAnchors)then + begin + T := FAnchorBounds[1]; + B := c[3]-FAnchorBounds[3]; + end + if not(akTop in FAnchors)and(akBottom in FAnchors)then + begin + B := c[3]-FAnchorBounds[3]; + T := b-h; + //T := bds[1]+dy; + // + end + if not(akTop in FAnchors)and not(akBottom in FAnchors)then + begin + b := c[3]-FAnchorBounds[3]+dy1; + t := B-h; + end + SetBoundsRect(array(L,T,R,B)); + return; + + end + function WMMove(o,e):LM_MOVE;virtual; + begin + CallMessgeFunction(OnMove,o,e); + end + function DoWMSIZE(o,e);virtual; + begin + end + function WMSize(o,e):LM_SIZE;virtual; + begin + CallMessgeFunction(OnSize,o,e); + DoWMSIZE(o,e); + end + + + function CMCursorChanged(o,e):CM_CURSORCHANGED;virtual; + begin + //if SetTempCursor(o.Cursor) then e.skip := true; + //return ; + if not(csDesigning in ComponentState)then + begin + if SetTempCursor(o.Cursor)then e.skip := true; + end else + begin + cr := new tcustomcursor(); + cr.id := IDC_ARROW; + if SetTempCursor(cr)then e.skip := true; + end + end + public //暂时不用的消息 + { + function WMWindowPosChanged(o,e):LM_WINDOWPOSCHANGED;virtual; + begin + end + function CMChanged(o,e):CM_CHANGED;virtual; + begin + end + function LMCaptureChanged(o,e):LM_CaptureChanged;virtual; + begin + end + function CMBiDiModeChanged(o,e):CM_BIDIMODECHANGED;virtual; + begin + end + function CMSysFontChanged(o,e):CM_SYSFONTCHANGED;virtual; + begin + end + function CMEnabledChanged(o,e):CM_ENABLEDCHANGED;virtual; + begin + end + function CMHitTest(o,e):CM_HITTEST;virtual; + begin + end + function CMMouseEnter(o,e):CM_MOUSEENTER;virtual; + begin + end + function CMMouseLeave(o,e):CM_MOUSELEAVE;virtual; + begin + end + function CMHintShow(o,e):CM_HINTSHOW;virtual; + begin + end + function CMParentBiDiModeChanged(o,e):CM_PARENTBIDIMODECHANGED;virtual; + begin + end + function CMParentColorChanged(o,e):CM_PARENTCOLORCHANGED;virtual; + begin + end + function CMParentFontChanged(o,e):CM_PARENTFONTCHANGED;virtual; + begin + end + function CMParentShowHintChanged(o,e):CM_PARENTSHOWHINTCHANGED;virtual; + begin + end + function CMVisibleChanged(o,e):CM_VISIBLECHANGED;virtual; + begin + end + function CMTextChanged(o,e):CM_TEXTCHANGED;virtual; + begin + end } + +#!end //消息处理 + protected //key and mouse + function SetColor(v);virtual; + begin + if v <> FColor and ifnumber(v)then + begin + FColor := v; + end + end + function SetBitmap(v);virtual; + begin + if v <> FBKBitmap then + begin + FBKBitmap := v; + end + end + function GetActionLinkClass();virtual; + begin + {** + @explan(说明) 返回actionlinkclass %% + @return(TControlActionLink class) + **} + return class(TControlActionLink); + end + procedure ActionChange(Sender:TObject;CheckDefaults:Boolean);virtual; + begin + if Sender is class(TCustomAction)then + begin + NewAction := Sender; + if (not CheckDefaults) or (Caption='') or (Caption=Name)then Caption := NewAction.Caption; + if (not CheckDefaults) or Enabled then Enabled := NewAction.Enabled; + if (not CheckDefaults) or Visible then Visible := NewAction.Visible; + { + if not CheckDefaults or (Hint = '') then + Hint := NewAction.Hint; + if not CheckDefaults or (Self.HelpContext = 0) then + Self.HelpContext := HelpContext; + if not CheckDefaults or (Self.HelpKeyword = '') then + Self.HelpKeyword := HelpKeyword; + } + // HelpType is set implicitly when assigning HelpContext or HelpKeyword + end; + end + function click(o,e);virtual; //type_tcontrol + begin + end + function DblClick(o,e);virtual; //type_tcontrol + begin + end + public + function ScreenToClient(X,Y);virtual; + begin + if Parent then + begin + ps := Parent.ScreenToClient(x,y); + return array(ps[0]-Left,ps[1]-Top); + end + return array(x,y); + end + function ClientToScreen(x,y);virtual; + begin + if Parent then + begin + ps := array(x+Left,y+Top); + return Parent.ClientToScreen(x+Left,y+Top); + end + return array(x,y); + end + function IsContainer(cd);virtual; + begin + { + @explan(说明)判断当前是否可以作为容器 %% + @param(cd)(tcontrol 及其子类) cd 是否可以为子项 %% + } + return false; + end + function getid(); + begin + return Fid; + end + function create(Owner);override; //type_tcontrol + begin + inherited; + if ifnil(FSIDC)then FSIDC := new tidcreater(100); + FId := FSIDC.createid(); + //init(); + bindmessages(self(true)); + FControlStyle := array(csCaptureMouse,csClickEvents,csSetCaption,csDoubleClicks); + FAlign := alNone; + FAnchors := array(akLeft,akTop); + FControls := new TFpList(); + FVisible := True; + FParentBidiMode := True; + FParentColor := True; + FParentFont := false; + FDesktopFont := True; + FParentShowHint := True; + FIsControl := False; + FEnabled := True; + FDragCursor := crDrag; + FCaption := "title"; + FLeft := 10; + FTop := 10; + FFont := new TFontControl(); + FFont.Control := self(true); + FWidth := 120; + FHeight := 40; + FBorder := false; + FColor := 0xffffff; //_wapi.GetSysColor(COLOR_WINDOW);//0xffffff; + FCanvas := new TControlCanvs(); + FCursor := new tcustomcursor(); + FCursor.id := IDC_ARROW; + end + procedure CheckNewParent(AParent:TWinControl);virtual; //type_tcontrol + begin + { + @ignore(忽略) + @explan(说明) 判断是否可以作为父节点 + } + return(AParent is getparenttype())and AParent.IsContainer(self(true)); + return false; + end + function Recycling();override; //type_tcontrol + begin + {** + @explan(说明) 资源回收,子类请override该方法然后在destroy中调用 %% + **} + FFont := nil; + FMessagehandle := array(); + {while true do + begin + ci := FControls.Count; + if ci<1 then break; + cvi := FControls[ci-1]; + cvi.SetParent(nil); + end } + FSIDC.deleteid(FID); + SetParent(nil); + FOnClick := nil; //点击 + FOnContextPopup := nil; + FOnDblClick := nil; //双击 + FOnDragDrop := nil; + FOnDragOver := nil; + FOnSize := nil; + FOnMove := nil; + FOnEditingDone := nil; + FOnEndDock := nil; + FOnEndDrag := nil; + FOnMouseDown := nil; //按下 + FOnMouseEnter := nil; //进入 + FMouseEntereded := nil; + FOnMouseLeave := nil; //离开 + FOnMouseMove := nil; //移动 + FOnPopupMenu := nil; + FOnMouseUp := nil; //弹起 + FOnMouseWheel := nil; //滚动 + FOnMouseWheelDown := nil; //滚动按下 + FOnMouseWheelUp := nil; //滚动弹起 + //FOnQuadClick := nil; + //FOnResize := nil; // + FOnShowHint := nil; + FOnStartDock := nil; + FOnStartDrag := nil; + FOnTripleClick := nil; + FBKBitmap := nil; + if FActionLink is class(TControlActionLink)then + begin + FActionLink.Recycling(); + FActionLink := nil; + end + inherited; + end + function destroy();override; + begin + inherited; + end + function GetBoundsRect(); //type_tcontrol + begin + {** + @explan(说明)获取矩形范围 %% + **} + return array(FLeft,FTop,FLeft+FWidth,FTop+FHeight); + end; + function SetBoundsRect(rect); + begin + {** + @explan(说明) 设置矩形范围 %% + **} + nt := 100000; + if ifarray(rect)and rect[0]0 and aHeight>0 then + begin + ChangeBounds(integer(ALeft),integer(ATop),integer(AWidth),integer(AHeight),false); + end + end + function GetBounds();virtual; //type_tcontrol + begin + //aLeft, aTop, aWidth, aHeight: integer + {** + @explan(说明) 获取控件范围 %% + @return( array of integer) array(aLeft, aTop, aWidth, aHeight: integer) %% + + **} + return array(Left,top,Width,height); + //ChangeBounds(ALeft, ATop, AWidth, AHeight, false); + end + procedure SetTempCursor(Value);virtual; + begin + if Parent then return Parent.SetTempCursor(Value); + end + // drag and dock + function Dragging(); + begin + //return DragManager.Dragging(Self); + end; + procedure BeginDrag(Immediate:Boolean;Threshold); + begin + if not ifnumber(Threshold)then Threshold :=-1; + //DragManager.DragStart(Self, Immediate, Threshold); + end + procedure EndDrag(Drop:Boolean); + begin + //if Dragging() then DragManager.DragStop(Drop); + end + function getmessagehandle(id);virtual; + begin + if ifnumber(id)and FMessagehandle then return FMessagehandle[id]; + end + function dispatch(o,e);virtual; //type_tcontrol + begin + {** + @explan(说明)消息分发函数 %% + @param(o)()控件自身 %% + @param(e)(tuieventbase) 消息类及其子类 %% + **} + func := getmessagehandle(e.Msg); + if func then call(func,o,e); + end + procedure DoControlAlign();virtual; + begin + end + procedure DoControlAnchor();virtual; + begin + end + procedure WndProc(TheMessage);virtual; //type_tcontrol + begin + {** + @explan(说明) 消息循环 %% + @param(e)(tuieventbase) 消息对象 %% + **} + TheMessage.Sender := self(true); + tmsg := TheMessage.msg; + case tmsg of + WM_WINDOWPOSCHANGED: + begin + d := new tvclwindowpos_class(TheMessage.lparam); + flags := d.flags; + if not((flags .& SWP_NOMOVE)=SWP_NOMOVE)then + begin + x := d.x; + y := d.y; + if x <> FLeft then FLeft := x; + if y <> FTop then FTop := y; + end + if not((flags .& SWP_NOSIZE)=SWP_NOSIZE)then + begin + cx := d.cx; + cy := d.cy; + if cx <> FWidth then FWidth := cx; + if cy <> FHeight then FHeight := cy; + end + end + {WM_SIZE: + begin + x := TheMessage.lolparamsigned(); + dxsize := x-FClientWdith; + if FClientWdith<> x then FClientWdith := x; + y := TheMessage.hilparamsigned(); + dysize := y-FClientHeight; + if FClientHeight <> y then FClientHeight := y; + DoControlAnchor(array(dxsize,dysize)); + DoControlAlign(array(FClientLeft,FClientTop,x,y)); + end + WM_MOVE: + begin + x := TheMessage.lolparamsigned(); + if FClientLeft<> x then FClientLeft := x; + y := TheMessage.hilparamsigned(); + if FClientTop <> y then FClientTop := y; + end } + end; + if(csDesigning in ComponentState)then + begin + //CallMessgeFunction(,self(true),TheMessage); + end else + if(tmsg >= LM_KEYFIRST)and(tmsg <= LM_KEYLAST)then + begin + // keyboard messages + //Form := GetParentForm(Self); + //if (Form <> nil) and (Form.WantChildKey(Self,TheMessage)) then exit; + end else + if((tmsg >= LM_MOUSEFIRST)and(tmsg <= LM_MOUSELAST))or((tmsg >= LM_MOUSEFIRST2)and(tmsg <= LM_MOUSELAST2))then + begin + // mouse messages + case tmsg of + LM_MOUSEMOVE: + begin + //Application.HintMouseMessage(Self, TheMessage); + end; + LM_LBUTTONDOWN,LM_LBUTTONDBLCLK: + begin + includestate(FControlState,csLButtonDown); + if FDragMode=dmAutomatic then + begin + end; + //BeginAutoDrag(); + end; + LM_LBUTTONUP: + begin + excludestate(FControlState,csLButtonDown); + end; + end; + end; + if tmsg=LM_PAINT then + begin + includestate(FControlFlags,cfProcessingWMPaint); + try + Dispatch(self(true),TheMessage); + finally + excludestate(FControlFlags,cfProcessingWMPaint); + end; + end else + begin + Dispatch(self(true),TheMessage); + end + end; + function Perform(e); + begin + {** + @explan(说明) 消息通知执行 %% + @param(e)(tuieventbase) + **} + WndProc(e); + return e.Result; + end + property ActionLink read FActionLink; //write FActionLink; + {public + procedure AdjustSize;virtual; // smart calling DoAutoSize + begin + includestate(FControlFlags,cfAutoSizeNeeded); + if Parent then + begin + Parent.AdjustSize(); // + end + end } + public + // standard properties, which should be supported by all descendants + property Action:taction read GetAction write SetAction; + property Anchors:anchors read FAnchors write SetAnchors; + property Align:align read FAlign write SetAlign; + protected + property UnAlignBounds read GetUnAlignBounds write SetUnAlignBounds; + {** + @param(Action)(taction) action对象 %% + @param(UnAlignBounds)(array of integer) 去除自动对齐时的范围 %% + @param(Align)(member of TAlign ) 默认 alNone 对齐方式 %% + @param(Anchors)( array of TAnchorKind member) 锚定位置 ,默认 array(akTop,akLeft) %% + **} + public + property ParentFont:bool read FParentFont write SetParentFont; + property Caption:string read GetText write SetText ; + property Enabled:bool read GetEnabled write SetEnabled; + property Cursor:syscursor read GetCursor write SetCursor; + {** + @param(Cursor)(tcursor 通过 member of TSystemCursor 设置) 系统鼠标 %% + **} + property Font:font read GetControlFont write SetControlFont;//write SetFont; + property OnMouseWheel read FOnMouseWheel write FOnMouseWheel; + {** + @param(Caption)(string) 控件标题 %% + @param(Enabled)(bool) 控件是否有效 %% + @param(OnMouseWheel)(function[TControl,TMMOUSEWHEEL]) 滚动回调函数 %% + **} + //property MouseEntered read FMouseEntered; + property OnSize:eventhandler read FOnSize write FOnSize; + property OnMove:eventhandler read FOnMove write FOnMove; + property OnMouseMove:eventhandler read FOnMouseMove Write FOnMouseMove; + property OnPopupMenu read FOnPopupMenu write FOnPopupMenu; + property OnMouseDown:eventhandler read FOnMouseDown write FOnMouseDown; + {** + @param(OnMouseMove)(function[TControl,TMMouse]) 鼠标移动回调函数 %% + @param(OnPopupMenu)(function[TControl,TMMouse]) 弹出菜单回调函数 %% + @param(OnMouseDown)(function[TControl,TMMouse]) 鼠标按下回调函数 %% + @param(OnMouseUp)(function[TControl,TMMouse]) 鼠标松开回调函数 %% + @param(OnClick)(function[TControl,TMMouse]) 鼠标点击回调函数 %% + @param(OnDblClick)(function[TControl,TMMouse]) 鼠标双击回调函数 %% + @param(PopupMenu)(tpopupmenu) 弹出菜单%% + @param(Parent)(tcontrol) 父控件 %% + @param(Visible)(bool) 是否可见 %% + **} + property OnMouseUp:eventhandler read FOnMouseUp write FOnMouseUp; + property OnClick:eventhandler read FOnClick write FOnClick; + property onrclick:eventhandler read Fonrclick write Fonrclick; + property OnDblClick:eventhandler read FOnDblClick write FOnDblClick; + //property OnResize read FOnResize write FOnResize; + property OnShowHint read FOnShowHint write FOnShowHint; + property Parent read FParent write SetParent; + property PopupMenu:tpopupmenu read FPopupMenu write FPopupMenu{read GetPopupmenu write SetPopupMenu}; + //property ShowHint read FShowHint write SetShowHint ; + property Visible:bool read FVisible write SetVisible ; + property ClientRect read GetClientRect; + property Height: Integer read FHeight write SetHeight; + property Width :integer read FWidth write SetWidth; + property Left :integer read FLeft write SetLeft; + property Top :integer read FTop write SetTop; + property Border:bool read FBorder write SetBorder; + {** + @param(ClientRect)(array of integer) 客户区矩形array(left,top,right,bottom) %% + @param(BoundsRect)(array of integer) 控件区矩形array(left,top,right,bottom) %% + @param(Height)(integer) 高度 %% + @param(Width)(integer) 宽度 %% + @param(Zorder)(integer) 设置控件在父窗口的次序,最底层为 0 %% + @param(Top)() 上方位置 %% + @param(Left)() 左边 %% + **} + property BoundsRect read GetBoundsRect write SetBoundsRect; + property Zorder read GetZorder write SetZorder; + property ControlState: TControlState read FControlState write FControlState; + property Color:color read FColor write SetColor;//FColor; + property BKBitmap:tbitmap read FBKBitmap write SetBitmap; + property OnMeasureItem read FOnMeasureItem write FOnMeasureItem; + property OnDrawItem read FOnDrawItem write FOnDrawItem; + //property OnMouseEnter:eventhandler read FOnMouseEnter write FOnMouseEnter; + //property OnMouseLeave:eventhandler read FOnMouseLeave write FOnMouseLeave; + property Controls read FControls; + property Canvas: TCanvas read FCanvas; + {** + @param(Canvas)(TCanvas) 画布对象 %% + @param(Controls)(TFpList of tcontrol) 子组件 %% + @param(OnMouseLeave)(function[TControl,tuieventbase]) 鼠标离开回调 %% + @param(OnMouseEnter)(function[TControl,tuieventbase]) 鼠标进入回调 %% + @param(OnMeasureItem)(function[TControl,TMMEASUREITEM]) 控件测量回调 %% + @param(OnDrawItem)(function[TControl,TMDRAWITEM]) 控件绘制回调 %% + @param(Color)(integer) 背景色 %% + **} + function isCustomPaint(); + begin + return csCustomPaint in FControlState ; + end +end diff --git a/funcext/tvclib/tcustomcontrol.tsf b/funcext/tvclib/tcustomcontrol.tsf new file mode 100644 index 0000000..2b44cd2 --- /dev/null +++ b/funcext/tvclib/tcustomcontrol.tsf @@ -0,0 +1,61 @@ +type tcustomcontrol=class(TWinControl) + uses utslvclauxiliary; + {** + @explan(说明) 自绘制窗口控件 %% + **} + private + FOnPaint:TNotifyEvent; + protected + procedure PaintWindow(DC:HDC);override; + begin + //odh := canvas.Handle; + Canvas.Handle := dc; + Canvas.ClipRect := PAINTSTRUCT().rcpaint(); + try + Paint(); + finally + Canvas.Handle := odh; + end; + end + procedure Paint();override; + begin + inherited; + if datatype(FOnPaint)=7 then call(FOnPaint,self(true)); + end + public + function Create(AOwner:TComponent);override; + begin + inherited; + includestate(FControlState,csCustomPaint); + //FCanvas := new tcanvas(); + end + function CreateParams(p);override; + begin + inherited; + //p.style .|= WS_CLIPSIBLINGS .| WS_CLIPCHILDREN; + end + function Recycling();override; + begin + FOnPaint := nil; + inherited; + end + function DoVScroll(o,e);virtual; + begin + end + function DoHScroll(o,e);virtual; + begin + end + public + function WMVScroll(o,e):LM_VScroll;virtual; + begin + return DoVScroll(o,e); + end + function WMHScroll(o,e):LM_HSCROLL;virtual; + begin + return DoHScroll(o,e); + end + property OnPaint:eventhandler read FOnPaint write FOnPaint; + {** + @param(OnPaint)(function[TCustomControl,tuieventbase]) 窗口关闭消息回调 %% + **} +end; \ No newline at end of file diff --git a/funcext/tvclib/tcustomscrollcontrol.tsf b/funcext/tvclib/tcustomscrollcontrol.tsf new file mode 100644 index 0000000..7a300bf --- /dev/null +++ b/funcext/tvclib/tcustomscrollcontrol.tsf @@ -0,0 +1,375 @@ +type tcustomscrollcontrol = class(TCustomControl) + uses utslvclmemstruct; + {** + @explan(说明) 带滚动条的自绘制窗口 %% + **} + private + FLocalX;//水平基准 + FLocalXold; + FLocalY;//垂直基准 + FLocalYold; + FSI; //滚动条结构 + FAutoScroll; //自动滚动条 + FThumbTrack; //thunmtrack + FWhileStep ;//滚动步长 + function SetAutoScroll(v); + begin + if(v in array(0,1,2,3))and v <> FAutoScroll then + begin + FAutoScroll := v; + InitialScroll(); + end + end + + function SetWhileStep(v); + begin + if not v>=1 then return ; + nv := integer(v); + if FWhileStep=nv then return ; + FWhileStep := nv; + end + protected + function GetXScrollDelta();virtual; //x间隔 + begin + {** + @explan(说明) 获得x间隔 %% + **} + return 10; + end + function GetYScrollDelta();virtual; //y 间隔 + begin + {** + @explan(说明) 获得y间隔 %% + **} + return 10; + end + function GetClientXCapacity();virtual; //宽度容量 + begin + {** + @explan(说明) 客户区x容量 %% + **} + return 0; + end + function GetClientYCapacity();virtual; //高度容量 + begin + {** + @explan(说明) 客户区y容量 %% + **} + return 0; //integer((yClient) / FDeltaY); + end + function GetClientXCount();virtual; //宽度间隔 + begin + {** + @explan(说明) 客户区x数量 %% + **} + return 0; + end + function GetClientYCount();virtual; //高度项 + begin + {** + @explan(说明) 客户区y数量 %% + **} + return 0; + end + function PositionChanged();virtual; //基准点改变 + begin + {** + @explan(说明) 基准点改变回调 %% + **} + end + function GetDeltaXpos();virtual; //水平变化 + begin + r := FLocalX-FLocalXold; + FLocalXold := FLocalX; + return r; + end + function GetDeltaYpos();virtual; //垂直变化 + begin + r := FLocalY-FLocalYold; + FLocalYold := FLocalY; + return r; + end + function GetXPos();virtual; + begin + return FLocalX; + end + function GetYPos();virtual; + begin + return FLocalY; + end + function SetXpos(x);virtual; + begin + nx := integer(x); + if not HandleAllocated()then return FLocalX := nx; + if nx <> FLocalX then + begin + hwnd := Handle; + FSI.fMask := SIF_POS; //SIF_ALL; + _wapi.GetScrollInfo(hwnd,SB_HORZ,FSI._getptr_); + ypos := FSI.nPos; + hwnd := Handle; + FSI.fMask := SIF_POS; + FSI.nPos := nx; + _wapi.SetScrollInfo(hwnd,SB_HORZ,FSI._getptr_,TRUE); + // 获得滚动条滑块的位置，由于窗口调整，它可能不是同一个值 + _wapi.GetScrollInfo(hwnd,SB_HORZ,FSI._getptr_); + if FSI.nPos <> ypos then + begin + FLocalXold := FLocalX; + FLocalX := FSI.nPos; + PositionChanged(); + end + end + end + function SetYpos(y);virtual; + begin + nx := integer(y); + if not HandleAllocated()then return FLocalY := nx; + if nx <> FLocalY then + begin + hwnd := Handle; + FSI.fMask := SIF_POS; //SIF_ALL; + _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); + ypos := FSI.nPos; + FSI.nPos := nx; + FSI.fMask := SIF_POS; + _wapi.SetScrollInfo(hwnd,SB_VERT,FSI._getptr_,TRUE); + // 获得滚动条滑块的位置，由于窗口调整，它可能不是同一个值 + _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); + if FSI.nPos <> ypos then + begin + FLocalYold := FLocalY; + FLocalY := FSI.nPos; + PositionChanged(); + end + end + end + function InitialScroll();virtual; + begin + if not HandleAllocated()then return; + hwnd := Handle; + // 设置垂直滚动条范围和页面大小（设置页面大小将决定滑块的粗细） + FSI.fMask := SIF_POS .| SIF_RANGE .| SIF_PAGE; + FSI.nMin := 0; + FSI.nPos := FLocalY; //20200709 + FSI.nMax :=(FAutoScroll .& 1)?(GetClientYCount()):0; + FSI.nPage := GetClientYCapacity(); + _wapi.SetScrollInfo(hwnd,SB_VERT,FSI._getptr_,true); + {if FSI.nMax>FSI.nPage then + begin + FLocalYold := FLocalY; + FLocalY := 0; + end else + begin } + FSI.fMask := SIF_POS; + _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); + FLocalYold := FLocalY; + FLocalY := FSI.nPos; + //end + // 设置水平滚动条范围和页面大小（设置页面大小将决定滑块的粗细） + FSI.cbSize := FSI._size_; + FSI.fMask := SIF_RANGE .| SIF_PAGE .| SIF_POS; + FSI.nMin := 0; + FSI.nPos := FLocalX; + FSI.nMax :=(FAutoScroll .& 2)?(GetClientXCount()):0; + FSI.nPage := GetClientXCapacity(); + _wapi.SetScrollInfo(hwnd,SB_HORZ,FSI._getptr_,TRUE); + {if FSI.nMax>FSI.nPage then + begin + FLocalXold := FLocalX; + FLocalX := 0; + end else + begin } + FSI.fMask := SIF_POS; + _wapi.GetScrollInfo(hwnd,SB_HORZ,FSI._getptr_); + FLocalXold := FLocalX; + FLocalX := FSI.nPos; + //end + PositionChanged(); + end + function DoVScroll(o,e);override; + begin + // 获得垂直滚动条的所有信息 + if csDesigning in ComponentState then return; + FSI.fMask := SIF_ALL; + hwnd := e.hwnd; + _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); + // 保存当前滑块位置，迟些进行比较 + yPos := FSI.nPos; + case e.lowparam of + // 用户点击键盘 Home 按键 + SB_TOP: + begin + FSI.nPos := FSI.nMin; + end + // 用户点击键盘 End 按键 + SB_BOTTOM: + begin + FSI.nPos := FSI.nMax; + end + // 用户点击滚动条上边的三角形 + SB_LINEUP: + begin + FSI.nPos -= 1; + end + // 用户点击滚动条下边的三角形 + SB_LINEDOWN: + begin + FSI.nPos += 1; + end + // 用户点击滑块上边的滚动条轴 + SB_PAGEUP: + begin + //return ; + FSI.nPos -= FSI.nPage; + end + // 用户点击滑块下边的滚动条轴 + SB_PAGEDOWN: + begin + //return ; + FSI.nPos += FSI.nPage; + end + // 用户拖动滚动条 + SB_THUMBTRACK: + begin + if ThumbTrack then + begin + FSI.nPos := FSI.nTrackPos; + end + end + SB_THUMBPOSITION: + begin + FSI.nPos := FSI.nTrackPos; + end + end + // 设置滚动条滑块的新位置 + if FSI.nPos=yPos then return; + return SetYpos(FSI.nPos); + FSI.fMask := SIF_POS; + _wapi.SetScrollInfo(hwnd,SB_VERT,FSI._getptr_,TRUE); + // 获得滚动条滑块的位置，由于窗口调整，它可能不是同一个值 + _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); + // 与此前的保存的值进行比较，如果不同则滚动窗口 + FLocalY := FSI.nPos; + if(FSI.nPos <> yPos)then + begin + PositionChanged(); + end + return 0; + end + function DoHScroll(o,e);override; + begin + if csDesigning in ComponentState then return; + FSI.fMask := SIF_ALL; + _wapi.GetScrollInfo(e.hwnd,SB_HORZ,FSI._getptr_); + // 保存当前滑块位置，迟些进行比较 + xPos := FSI.nPos; + case e.lowparam of + // 用户点击滚动条左边的三角形 + SB_LEFT: + begin + FSI.nPos := FSI.nMin; + end + SB_RIGHT: + begin + FSI.nPos := FSI.nMax; + end + SB_LINELEFT: + begin + FSI.nPos -= 1; + end + // 用户点击滚动条右边的三角形 + SB_LINERIGHT: + begin + FSI.nPos += 1; + end + // 用户点击滑块左边的滚动条轴 + SB_PAGELEFT: + begin + FSI.nPos -= FSI.nPage; + end + // 用户点击滑块右边的滚动条轴 + SB_PAGERIGHT: + begin + FSI.nPos += FSI.nPage; + end + // 用户拖动滚动条 + SB_THUMBTRACK: + begin + if ThumbTrack then + begin + FSI.nPos := FSI.nTrackPos; + end + end + SB_THUMBPOSITION: + begin + //return ; + FSI.nPos := FSI.nTrackPos; + end + end; + if FSI.nPos=xPos then return; + return SetXpos(FSI.nPos); + // 设置滚动条滑块的新位置 + FSI.fMask := SIF_POS; + _wapi.SetScrollInfo(e.hwnd,SB_HORZ,FSI._getptr_,TRUE); + // 获得滚动条滑块的位置，由于窗口调整，它可能不是同一个值 + _wapi.GetScrollInfo(e.hwnd,SB_HORZ,FSI._getptr_); + // 与此前的保存的值进行比较，如果不同则滚动窗口 + FLocalX := FLocalX; + FLocalX := FSI.nPos; + if(FSI.nPos <> xPos)then + begin + PositionChanged(); + end + end + function DoMouseWheel(o,e);override; + begin + if csDesigning in ComponentState then return; + hwnd := self.Handle; + FSI.fMask := SIF_ALL; + _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); + // 保存当前滑块位置，迟些进行比较 + yPos := FSI.nPos; + dd := 0; + if e.delta<0 and FSI.nMax>yPos then + begin + //dd++; + dd += FWhileStep; + end + if e.delta>0 and FSI.nMin rect2 then + begin + if Parent then + begin + //Parent.InvalidateRect(nil,false); + Parent.InvalidateRect(rect1,false); + Parent.InvalidateRect(rect2,false); + //Parent.updateWindow(); + end + end + end + function RealSetText(s);override; + begin + {** + @explan(说明) 修改标题 %% + **} + if ifstring(s)and caption <> s then + begin + inherited; + InvalidateRect(rec,true); + end + end + procedure Paint();virtual; + begin + {** + @explan(说明)控件绘制调用 ,使用Canvas属性和PAINTSTRUCT结构体 绘制控件 %% + **} + if(datatype(FOnPaint)<> 7)or(not call(FOnPaint,self(true)))then + begin + canvas.Font := font; + Canvas.DrawText(self.caption,self.ClientRect,DT_VCENTER .| DT_SINGLELINE .| DT_CENTER .| DT_NOPREFIX); + end + //_wapi.DrawFrameControl(Canvas.handle,const ClientRect,DFC_BUTTON,DFCS_BUTTONCHECK); + //_wapi.DrawEdge(Canvas.handle,const ClientRect,EDGE_ETCHED,BF_RECT); + //_wapi.DrawFocusRect(Canvas.Handle,const ClientRect); + end + procedure DoOnChangeBounds();override; + begin + end + procedure DoOnParentHandleDestruction;override; + begin + end + function InvalidateRectForce(); + begin + if Parent then + begin + nrec := array(FLeft,FTop,FLeft+FWidth,FTop+FHeight); + //return Parent.InvalidateRect(nrec,true); + return Parent.InvalidateRect(nrec,false); + end + end + public + procedure SetVisible(Value);virtual; + begin + nv := Value?true:false; + if nv <> Visible then + begin + inherited; + InvalidateRectForce(); + end + end + function InvalidateRect(rec,f); + begin + {** + @explan(说明)设置窗口区域无效 %% + @param(rec)(array) 无效区域,nil表示窗口整体无效,array(左上右下) %% + @param(f)(bool) 是否重画 %% + **} + if Visible {and Parent}then + begin + if not ifarray(rec)then return InvalidateRectForce(); + nrec := array(FLeft+rec[0],FTop+rec[1],FLeft+rec[2],FTop+rec[3]); + return Parent.InvalidateRect(nrec,false); + end + end + function WMPaint(o,Message:TLMPaint):LM_PAINT;override; + begin + //if csCustomPaint in ControlState then if Message.lparam<>2 then return ; + dc := Message.wparam; + if dc then + begin + //_wapi.ReleaseDC(Canvas.Handle); + //odh := canvas.Handle; + Canvas.Handle := dc; + try + _wapi.SetViewportOrgEx(dc,FLeft,FTop,nil); + //_send_(WM_ERASEBKGND,dc,1,1); + //Perform(new tuieventbase(WM_ERASEBKGND,dc,1)); + //Perform(messagecreater(nil,WM_ERASEBKGND,dc,1)); + WMERASEBKGND(self(true),messagecreater(nil,WM_ERASEBKGND,dc,2)); + Canvas.SaveDC(); + Paint(); + Canvas.RestoreDC(); + //Canvas. + finally + Canvas.Handle := odh; + end; + //Canvas.Handle := _wapi.GetDC(self.Handle); + end + end + function WMERASEBKGND(o,e):WM_ERASEBKGND;override; + begin + if e.wparam and e.lparam then + begin + if(BKBitmap is class(tcustombitmap))and BKBitmap.HandleAllocated()then + begin + //Canvas.StretchDraw(GetClientRect(),self.BKBitmap);//20210812 修正默认的背景绘图 + Canvas.DrawBitmap(self.BKBitmap,GetClientRect()); + end else + begin + cl := Color; + if ifnumber(cl)then + begin + Canvas.Brush.Color := cl; + Canvas.FillRect(GetClientRect()); + end + end + e.skip := true; + return 1; + end + end + function CMCursorChanged(var Message:TLMessage):CM_CURSORCHANGED;override; + begin + inherited; + end + procedure FontChanged(Sender:TObject);override; + begin + inherited; + end + function IsContainer(cd);override; + begin + return false; + end + function Create(AOwner:TComponent);override; + begin + inherited; + //inherited Create(AOwner); + FLeft := 10; + FTop := 10; + FWidth := 80; + FHeight := 25; + includestate(FControlState,csCustomPaint); + end + function Recycling();override; + begin + FOnPaint := nil; + inherited; + end + function SetParent(NewParent);override; //type_tcontrol + begin + op := parent; + if op=NewParent then return; + inherited; + if NewParent is class(TWinControl)then + begin + InvalidateRect(); + end + end + property OnPaint:eventhandler read FOnPaint write FOnPaint; + {** + @param(OnPaint)(function[TGraphicControl]:bool) 绘制回调,返回true不执行默认绘制 %% + **} +end; \ No newline at end of file diff --git a/funcext/tvclib/tslvcl.tsf b/funcext/tvclib/tslvcl.tsf index fa7b1aa..8e25619 100644 --- a/funcext/tvclib/tslvcl.tsf +++ b/funcext/tvclib/tslvcl.tsf @@ -21,57 +21,35 @@ unit tslvcl; {$define gdipaint} {$endif} interface -uses utslvclconstant,utslvclauxiliary,utslvclmemstruct,cstructurelib,UVCPropertyTypesPersistence,ugtkinterface; +uses utslvclconstant,utslvclbase,utslvclauxiliary,cstructurelib,utslvclmemstruct,utslvclevent,UVCPropertyTypesPersistence,utslvclgdi,utslvclaction,utslvclmenu,utslvclstdctl,utslvclgrid,utslvcltree; function initializeapplication(); //获得app对象 function RegisterComponentType(n,typ); //设计器中注册控件 function GetAndDispatchMessageA(hwnd,minm,maxm); //win32 分发消息 function ExitMessageLoop(); //退出主循环 -function ShowErrorMessage(msg); -function gettswin32api(); //win32 api +//function gettswin32api(); //win32 api function NotifyComponent(Sender,Act,ToComponent); //notfiy -//////////////////////为操作///////////////////// -function getbitsfrominteger(n,b,e); -function lowuperdword(value_,lvalue,uvalue,ptrl); -function unsignedtosigned(v,n); -function signedtounsigned(v,n); -function intasposition(xy); -function makeposition(x,y); -function makelong(low,high,ptrl);//低位高位合并 +//////////////////////操作///////////////////// Function tslcstructure(data,dsize,pack,ptr); -////////////////////点区域操作////////////////// -function pointinrect(p,rec); -function intersectrect(rec1,rec2,irec); -function CompareRect(orect,nrect); -function pointtovector(pts);//点转换为数组 + +//function CompareRect(orect,nrect); function calldatafunction(); -function CallMessgeFunction(f,o,e); +//function CallMessgeFunction(f,o,e); //////////////////////执行tsl脚本代码//////////////////// -function tslScriptGo(script); //function TSL_Check(func,funclen,oResult); function CheckTslCode(code,err); //检查tsl语法 -function SysExecWait(handle,exe,cmd,dir,fui); //执行 win32 程序 -function gettemppath(); //临时目录 +//function SysExecWait(handle,exe,cmd,dir,fui); //执行 win32 程序 function TS_ModulePath(); function TS_ExecPath(); function TS_GetAppPath(); function TS_GetUserProfileHome(); -function TSL_ReservedKeys2(); //保留关键字 function TS_GetIniPath(hometype,IniName); function CopyUsedTslDllToNewDir(p); ///////////////////////////////////////////// function DeleteAllFiles(path); function CreateDirWithFileName(fname); function GetPathFromFullName(fullname,fname,ftype); -function GetTextWidthAndHeightWidthFont(s,f,mul); -//**************************** -function FormatTslData(d,sj,tn); -function HexStrToTsl(hex); -function TslToHexStr(d); -function TslToHexFormatStr(tsl); -function HexFormatStrToTsl(D); + //************************ -function GetGdipStatus(v); -function LoginTslServer(usr,pwd,addr,port); //******************************* function MessageBoxA(txt,title,flag,hd); function _timeproc_(hwnd,message,wparam,lparam);//win32消息分发 @@ -79,5929 +57,24 @@ function _twinproc_(hwnd,message,wparam,lparam);//win32 function _MessgeHook_a(hwnd,message,wparam,lparam); function remotetslcallback(data); //********其他辅助函数******* -Function getmsgd_Crc32(s); //信息指纹函数 //**********操作系统相关函数********************* -function ioFileseparator(); //文件目录分割符号 function initlib(); //////////////////////////////////// -function controlisCustomPaint(id); -/////////////////// -function ParserCommandLine(s); //解析命令行参数 -type tidcreater=class - {** - @ignore(忽略) - **} - private - __sid; - cid; - Reuseids; - usedids; - //protected - {** - @explan(说明) 不重复整数id 生成类 %% - @param(cid)(integer) 当前id值 %% - @param(Reuseids) (array) 已经回收的id %% - - **} - public - function clean(); - begin - Reuseids := array(); - cid := __sid; - end - function create(sid); - begin - {** - @explan(说明) 构造函数 %% - @param(sid)(integer) 初始化的id值 - **} - if ifnumber(sid)then cid := sid; - else cid := 0; - __sid := cid; - usedids := Reuseids := array(); - end - function createid(); - begin - {** - @explan(说明) 构造id %% - @return(integer) id值 %% - - **} - ret := nil; - for i in Reuseids do - begin - if ifnumber(i)then - begin - ret := i; - break; - end - end - if ifnumber(ret)then - begin - reindex(Reuseids,array(ret:nil)); - usedids[ret]:= ret; - return ret; - end - cid += 1; - usedids[cid]:= cid; - return cid; - end - function deleteid(id); - begin - {** - @explan(说明) 不重复整数id 生成类 %% - @param(id)(integer) 需要回收的id值 %% - @return(bool) 是否成功 - **} - if ifnumber(id)then - begin - Reuseids[integer(id)]:= id; - reindex(usedids,array(integer(id):nil)); - return 1; - end - return 0; - end - function addid(id); - begin - if ifnumber(id)and id>0 then - begin - cid := max(cid,id); - usedids[id]:= id; - end - end -end - - - type tswin32api = class({$ifdef linuxgtk}tgtkapis{$endif}) //windows接口 - {** - @explan(说明) win32api接口函数类 - 1. 导出了部分win32的api - 2. winuser头文件的宏定义 - 3. 添加了部分结构体定义到成员变量 - 4. 下面的external函数的win32api可以在msdn中查找具体用法 - **} - private - - - _DLLID; - public - function destroy(); - begin - {for i,v in _DLLID do - begin - FreeLibrary(v); - end} - end - - function create(); - begin - {DLLID := array("Kernel32.dll","User32.dll","Gdi32.dll","Comctl32.dll","Comdlg32.dll","Shell32.dll"); - _DLLID := array(); - for i,v in DLLID do - begin - _DLLID[v]:= LoadLibraryA(v); - end} - end - - function getpathbyprocid(id); - begin - {** - @explan(说明) 获取所有进程路径 %% - @param(id)(integer) 进程id - **} - strFilePath := ""; - len := 1024; - setlength(strFilePath,len); - hd := OpenProcess(0x000F0000L .| 0x00100000L .| 0xFFFF,0,id); - GetModuleFileNameExA(hd,0,strFilePath,len); - //QueryFullProcessImageNameA(hd, 1, strFilePath, len); - r := ""; - for i := 1 to length(strFilePath) do - begin - vi := strFilePath[i]; - if vi="\0" then break; - r += vi; - end - if hd then CloseHandle(hd); - return r; - end - function EnumProcesses(); - begin - {** - @explan(说明) 获取所有进程id - **} - {** - @example(获取所有进程id,并获得路径) - t := EnumProcesses(); - for i,v in t do echo getpathbyprocid(v),"\r\n"; - **} - ret := zeros(2048); - EnumProcesses_(ret,length(ret)* 4,t); - r := ""; - if t>0 then r := ret[0:t/4]; - return r; - end - - function Toolhelp32Snapshot(); - begin - {** - @explan(说明) 获取所有进程信息 %% - @param() - @return(array) 进程信息 %% - **} - currentProcess := new Ttagprocessentry32(); - hProcess := CreateToolhelp32Snapshot(2,0); //给系统内的所有进程拍一个快照 - r := array(); - if hProcess=-1 then return r; - bMore := Process32First(hProcess,currentProcess._getptr_); //获取第一个进程信息 - countProcess := 0; - while(bMore) do - begin - r[countProcess]:= currentProcess._getdata_; - bMore := Process32Next(hProcess,currentProcess._getptr_); //遍历下一个 - countProcess++; - end - CloseHandle(hProcess); //清除hProcess句柄 - return r; - end - - function Toolhelp32Snapshotmodule(id); - begin - {** - @explan(说明) 获取所有module信息 - **} - if not(id >= 0)then id := 0; - currentProcess := new TtagMODULEENTRY32(); - hProcess := CreateToolhelp32Snapshot(8,id); //给系统内的所有进程拍一个快照 - r := array(); - if hProcess=-1 then return r; - bMore := Module32First(hProcess,currentProcess._getptr_); //获取第一个进程信息 - countProcess := 0; - while(bMore) do - begin - r[countProcess]:= currentProcess._getdata_; - bMore := Module32Next(hProcess,currentProcess._getptr_); //遍历下一个 - countProcess++; - end - CloseHandle(hProcess); //清除hProcess句柄 - return r; - end - function Comctl32version(); //获取comctl32.dll版本 - begin - o := tslcstructure(array( - ("cbsize","int",0), - ("dwmajorversion","int",0), - ("dwminorversion","int",0), - ("dwbuildnumber","int",0), - ("dwplatformid","int",0))); - o._setvalue_("cbsize",o._size_); - Comctl32DllGetVersion(o._getptr_); - return o._getdata_(); - end - function shell32Version(); //获取shell32.dll版本 - begin - o := tslcstructure(array( - ("cbsize","int",0), - ("dwmajorversion","int",0), - ("dwminorversion","int",0), - ("dwbuildnumber","int",0), - ("dwplatformid","int",0))); - o._setvalue_("cbsize",o._size_); - shell32DllGetVersion(o._getptr_); - return o._getdata_(); - end - function GetCursorInfo(); - begin - { - @explan(说明) 获取cursor 信息 %% - @param(array) 字段: - flags 为0 表示 The cursor is hidden. - 为1 表示 The cursor is showing. - 为2 表示 The cursor is suppressed - hcursor 光标句柄 - ptscreenpos 光标位置 - } - o := new ctslctrans(array( - ("cbsize","int",0,0,4,"int",1), - ("flags","int",0,4,4,"int",1), - ("hcursor","intptr",0,8,4,"intptr",1), - ("ptscreenpos","int[2]", - (0,0),12,8,"intarray",2)),nil,nil); - o._setvalue_("cbsize",o._size_()); - if(GetCursorInfo_(o._getptr_()))then - begin - return o._getdata_(); - end - end - function GetScreenRect(); - begin - {** - @explan(说明) 获取屏幕大小%% - @return(array) 左上右下 %% - **} - rc := new tcrect(); - SystemParametersInfoA(0x30,0,rc._getptr_(),0); - return rc._getdata_(); - end - function GetMonitor(mhandle,r); //获得显示器信息%% - begin - r := new TMONITORINFO(); - return GetMonitorInfoA(mhandle,r._getptr_()); - end - - {$ifdef linuxgtk} - - class function AnsiToWidChar(c); - begin - if not ifstring(c) then return ""; - return c; - end - function ShowWindow(hwd :pointer;f:integer); - begin - {SW_HIDE := 0x0;SW_SHOWNORMAL := 0x1;SW_NORMAL := 0x1; - SW_SHOWMINIMIZED := 0x2;SW_SHOWMAXIMIZED := 0x3;SW_MAXIMIZE := 0x3; - SW_SHOWNOACTIVATE := 0x4;SW_SHOW := 0x5;SW_MINIMIZE := 0x6; - SW_SHOWMINNOACTIVE := 0x7;SW_SHOWNA := 0x8;SW_RESTORE := 0x9; - SW_SHOWDEFAULT := 0xA;SW_FORCEMINIMIZE := 0xB;SW_MAX := 0xB;} - global G_GTK_WINDOW_ACTIVATE; - if not hwd then return ; - if not GTK_WIDGET(hwd) then return ; - if f =0 then - begin - - if gtk_widget_is_toplevel(hwd) then - begin - p := GetParent(hwd); - if p then gtk_window_set_transient_for(hwd,0); - end - gtk_widget_hide(hwd); - end else - if f=0xc then - begin - if gtk_widget_is_toplevel(hwd) then - begin - p := GetParent(hwd); - if p and GTK_WIDGET(p) then - begin - if gtk_widget_is_toplevel(p) then pp := p; - else - pp := gtk_widget_get_toplevel(p); - if pp then gtk_window_set_transient_for(hwd,pp); - end - end - gtk_widget_show_all(hwd); - end else - begin - if gtk_widget_is_toplevel(hwd) then - begin - global g_current_get_focus_widget; - cf := g_current_get_focus_widget; - p := GetParent(hwd); - if p and GTK_WIDGET(p) then - begin - if gtk_widget_is_toplevel(p) then pp := p; - else - pp := gtk_widget_get_toplevel(p); - if pp then gtk_window_set_transient_for(hwd,pp); - end - if 2 =g_object_get_data(hwd,"gtk_popwp") then - begin - x := g_object_get_data(hwd,"gtk_layout_x"); - y := g_object_get_data(hwd,"gtk_layout_y"); - w := g_object_get_data(hwd,"gtk_layout_width"); - h := g_object_get_data(hwd,"gtk_layout_height"); - gtk_window_move(hwd,x,y); - if w>=0 and h>=0 then - gtk_widget_set_size_request(hwd,w,h); - end - if f=0x4 then - begin - if not gtk_window_get_decorated(hwd) then - gtk_window_set_type_hint((hwd),3); - if cf and cf<>g_current_get_focus_widget then //设置一下focus - begin - tplev := gtk_widget_get_toplevel(cf); - if tplev then gtk_window_set_focus(tplev,cf); - end - end - end - gtk_widget_show(hwd); - if f<>0x4 and G_GTK_WINDOW_ACTIVATE<>hwd then - begin - if G_GTK_WINDOW_ACTIVATE then - AddMessageToGtkMessageQueue(G_GTK_WINDOW_ACTIVATE,0x6,0,0,0); - G_GTK_WINDOW_ACTIVATE := hwd; - AddMessageToGtkMessageQueue(hwd,0x6,1,0,0); - end - end - return true; - end - function MessageBoxA(hwnd :pointer;txt:string;cap:string;flag:integer); - begin - return gtk_MessageBoxA(hwnd,txt,cap,flag); - end - function IsWindow(h); - begin - wt := static gtk_widget_get_type(); - r := g_type_check_instance_is_a(h,wt); - return r; - end - function GetWindowTextA(h,s,l); - begin - if not(h>0 or h<0) then return ; - if not ifstring(s) then return ; - wt := static gtk_window_get_type(); - if g_type_check_instance_is_a(h,wt) then - begin - rs := GtkStringToTsl(gtk_window_get_title(h)); - end else - begin - lbl := g_object_get_data(h,"gtk_layout_label"); - if lbl then - begin - rs := GtkStringToTsl(gtk_label_get_text(lbl)); - end else - begin - et := g_object_get_Data(h,"gtk_layout_editer"); - if et then - begin - rs := GtkStringToTsl( gtk_entry_get_text(h)); - end else - begin - et := g_object_get_Data(h,"gtk_layout_memo"); - if et then - begin - rs := gtk_executeMessageA(h,0xd,0,0); - end - end - end - end - if rs then - begin - for i:= 1 to min(length(s),min(length(rs),l)) do - begin - s[i] := rs[i]; - end - return i; - end - end - function SetWindowTextA(h,s); - begin - if not(h>0 or h<0) then return ; - if not ifstring(s) then return ; - wt := static gtk_window_get_type(); - us := TslStringToGtk(s); - if g_type_check_instance_is_a(h,wt) then - begin - gtk_window_set_title(h,us); - end else - begin - return ; - lbl := g_object_get_data(h,"gtk_layout_label"); - if lbl then - begin - return gtk_label_set_text(lbl,us); - end - et := g_object_get_Data(h,"gtk_layout_editer"); - if et then - begin - return gtk_entry_set_text(h,us); - end - et := g_object_get_Data(h,"gtk_layout_memo"); - if et then - begin - gtk_executeMessageA(h,0xc,0,us); - end - - //et := g_object_get_Data(h,"gtk_layout_memo"); - //if et then return gtk_entry_set_text(et,us); - end - end - function GetScrollInfo(hWnd:pointer;x:integer;info:pointer) - begin - return gtk_GetScrollInfo(hwnd,x,info); - end - function SetScrollInfo(hwnd:pointer; nBar:integer; lpsi:pointer;redraw:integer) - begin - return gtk_SetScrollInfo(hwnd,nBar,lpsi,redraw); - end - function SystemParametersInfoA(uiAction:integer;uiParam:integer; pvParam:pointer; fWinIni:integer); - begin - if (uiAction = 0x30) and (pvParam>0 or pvParam<0) then - begin - w := static gdk_screen_width(); - h := static gdk_screen_height(); - rc := new tcrect(pvParam); - rc._setvalue_(0,0); - rc._setvalue_(1,0); - rc._setvalue_(2,w); - rc._setvalue_(3,h); - end - end - function GetClientRect(h :pointer;var rec:array of integer); - begin - if h then - begin - x0 := g_object_get_data(h,"gtk_layout_width"); - y0 := g_object_get_data(h,"gtk_layout_height"); - end - rec := array(0,0,x0, y0); - return true; - end - function GetWindowRect(hwnd :pointer;var rec:array of integer):integer; - begin - xy := array(0,0); - ClientToScreen(hwnd,xy); - h := g_object_get_data(hwnd,"gtk_layout_height"); - w := g_object_get_data(hwnd,"gtk_layout_width"); - rec := array(xy[0],xy[1],xy[0]+w,xy[1]+h); - end - function GetWindowInfo(hwnd :pointer;f:pointer):integer; - begin - if not(f>0 or f<0 ) then return 0; - //info := new TWINDOWINFO(f); - end - function SetWindowPos(h:pointer;hWndInsertAfter:pointer; X:integer; Y:integer; cx:integer;cy:integer; uFlags:integer); - begin - - if 0x400 .& uFlags then - begin - //echo "border set \r\n"; - InvalidateRect(h,nil,false); - return ; - end - if not(h>0 or h<0) then return ; - flg := 0; - wt := static gtk_window_get_type(); - if g_type_check_instance_is_a(h,wt) then //主窗口 - begin - x0 := g_object_get_data(h,"gtk_layout_x"); - y0 := g_object_get_data(h,"gtk_layout_y"); - if (x>=0 and y>=0) and (x<>x0 or y<>y0) then //窗口位置 - begin - gtk_window_move(h,x,y); - g_object_set_data(h,"gtk_layout_x",x); - g_object_set_data(h,"gtk_layout_y",y); - flg .|=2; - end - w0 := g_object_get_data(h,"gtk_layout_width"); - h0 := g_object_get_data(h,"gtk_layout_height"); - if (cx>=0 and cy>=0) and ( cx<>w0 or cy<>h0) then - begin - if gtk_window_get_resizable(h) then - begin - gtk_widget_get_size_request(h,cx0,cy0); //改小一点 - if cx0>cx or cy0>cy then - begin - gtk_widget_set_size_request(h,cx,cy); - end - gtk_window_resize(h,cx,cy); - end - else - begin - //gtk_widget_get_size_request(h,cx0,cy0); - //echo "\r\noldsize:",cx0,"====",cy0; - //gtk_window_resize(wh,cx,cy); - gtk_widget_set_size_request(h,cx,cy); - //gtk_window_set_decorated(h,true); - //gtk_window_set_resizable(h,true); - - //gtk_window_resize(h,cx,cy); - //gtk_window_set_decorated(h,false); - //gtk_window_resize_to_geometry(h,cx,cy); - end - g_object_set_data(h,"gtk_layout_width",cx); - g_object_set_data(h,"gtk_layout_height",cy); - flg .|=1; - end - if flg then //多发送一次消息 - begin - Gtk_TrigMoveSizeEvent(h,x,y,cx,cy,flg); - end - end else - if isGtkWidget(h) then - begin - lot := gtk_widget_get_parent(h); - //flg := 0; - if lot then - begin - x0 := g_object_get_data(h,"gtk_layout_x"); - y0 := g_object_get_data(h,"gtk_layout_y"); - if x<>x0 or y<>y0 then - begin - gtk_layout_move(lot,h,x,y); - g_object_set_data(h,"gtk_layout_x",x); - g_object_set_data(h,"gtk_layout_y",y); - flg .|=2; - end - end - w0 := g_object_get_data(h,"gtk_layout_width"); - h0 := g_object_get_data(h,"gtk_layout_height"); - if (cx>=0 and cy>=0) and ( cx<>w0 or cy<>h0) then - begin - gtk_widget_set_size_request(h,cx,cy); - g_object_set_data(h,"gtk_layout_width",cx); - g_object_set_data(h,"gtk_layout_height",cy); - //lbl := g_object_get_data(h,"gtk_layout_lable"); - //if lbl then gtk_widget_set_size_request(lbl,cx-5,cy-5); - flg .|=1; - end - if flg then - begin - Gtk_TrigMoveSizeEvent(h,x,y,cx,cy,flg); - end - - end - end - function IsGtkWidget(h); - begin - wt := static gtk_widget_get_type(); - return g_type_check_instance_is_a(h,wt); - end - function gtk_window_showmodal(w); //shomodal - begin - dialog := w.handle; - pt := GetParent(dialog); - if (pt) and GTK_WIDGET(pt) then - begin - if (not gtk_widget_is_toplevel(pt)) then - begin - pt := gtk_widget_get_toplevel(pt); - end - w.Visible := true; - gtk_window_set_type_hint((dialog),0); - //gtk_window_set_modal(GTK_WINDOW( dialog),TRUE); //屏蔽掉showmodal - gtk_window_set_transient_for( GTK_WINDOW(dialog),GTK_WINDOW(pt)); - - return true; - end - end - function gtk_window_endmodal(w); //shomodal - begin - dialog := w.handle; - pt := GetParent(dialog); - if (pt) then - begin - if (not gtk_widget_is_toplevel(pt)) then - begin - pt := gtk_widget_get_toplevel(pt); - end - //gtk_window_set_modal(GTK_WINDOW( dialog),false); //屏蔽掉showmodal - gtk_window_set_transient_for( GTK_WINDOW(dialog),0); - w.Visible := false; - end - end - function GetParent(h); //获得父窗口 - begin - if not IsGtkWidget(h) then return 0; - if gtk_widget_is_toplevel(h) then return g_object_get_data(h,"gtk_layout_parent"); - p := gtk_widget_get_parent(h); - if p then - return g_object_get_data(p,"gtk_layout_owner"); - return 0; - end - function SetParent(h :pointer;phwnd:pointer); //设置gtk父窗口 - begin - if h=phwnd then return 0; - if not IsGtkWidget(h) then return 0; - if gtk_widget_is_toplevel(h) then - begin - r := g_object_get_data(h,"gtk_layout_parent"); - if r=phwnd then return ; - g_object_set_data(h,"gtk_layout_parent",IsGtkWidget(phwnd)?phwnd:0); - - if gtk_widget_is_visible(h) then //显示的子窗口处理 - begin - if GTK_WIDGET(phwnd) then - begin - if gtk_widget_is_toplevel(phwnd) then pp := phwnd; - else - pp := gtk_widget_get_toplevel(phwnd); - gtk_window_set_transient_for(h,pp); - end - end else - begin - gtk_window_set_transient_for(h,0); //处理20211020 - end - return r; - end - lot :=gtk_widget_get_parent(h); ;//g_object_get_data(h,"gtk_layout_parent");// //原有layout - if lot then - begin - r := g_object_get_data(lot,"gtk_layout_owner"); - if r=phwnd then return 0; - gtk_container_remove(lot,h); - end - if not phwnd then return r; - lot := g_object_get_data(phwnd,"gtk_layout"); - if lot then - begin - x := g_object_get_data(h,"gtk_layout_x"); - y := g_object_get_data(h,"gtk_layout_y"); - gtk_layout_put(lot,h,x,y); - - end - return r; - end - function hittestwidget(h,x,y); - begin - wd := class(TGlobalComponentcache).getwndbyhwnd(h); - if wd then return wd.gethitstyle(x,y); - return 0; - end - function GetTopWidgetList(h,x,y,r); - begin - wd := class(TGlobalComponentcache).getwndbyhwnd(h); - if wd and wd.Visible and wd.Enabled then - begin - xy := wd.ScreenToClient(x,y); - if xy[0]>0 and xy[1]>0 and wd.width>xy[0] and wd.height>xy[1] then - begin - r[length(r)] := array(h,xy); - ctls := wd.Controls; - for i:= 0 to ctls.count-1 do - begin - ci := ctls[i]; - if (ci is class(TWinControl)) and ci.HandleAllocated() and (not ci.WsPopUp) then - begin - GetTopWidgetList(ci.Handle,x,y,r); - end - end - end - end - end - // class(TGlobalComponentcache).getwndbyhwnd(hwnd); - function Gtk_TrigMoveSizeEvent(h,aleft,atop,AWidth,AHeight,flg); - begin - SWP_NOMOVE := 2; - SWP_NOSIZE := 1; - WM_WINDOWPOSCHANGED := 0x47; - d := new tvclwindowpos_class(0); - SizeChanged := flg .& 1; - PosChanged := flg .& 2; - - if SizeChanged then - begin - vb := g_object_get_data(h,"gtk_window_vscroll_bar"); - hb := g_object_get_data(h,"gtk_window_hscroll_bar"); - if vb and gtk_widget_is_visible(vb) then - begin - d.cx := max(AWidth-10,0); - end - else d.cx := AWidth; - if hb and gtk_widget_is_visible(hb) then - begin - d.cy := max(AHeight-10,0); - end - else - d.cy := AHeight; - D.flags := SWP_NOMOVE; - _twinproc_(h,WM_WINDOWPOSCHANGED,0,d._getptr_); - end - if PosChanged then - begin - d.x := ALeft; - d.y := ATop; - d.flags := SWP_NOSIZE; - _twinproc_(h,WM_WINDOWPOSCHANGED,0,d._getptr_); - end - if SizeChanged then //这个是不是应该放前面 - begin - gtk_widgetsizechanged(h,AHeight,AWidth); - end - {if SizeChanged then - begin - _twinproc_(h,0x5,0,makeposition(AWidth,AHeight)); - end} - if PosChanged then - begin - _twinproc_(h,0x3,0,makeposition(ALeft,ATop)); - end - - end - function GetCursorPos(var p:array of integer); - begin - gdk_display_get_pointer(gdk_display_get_default(), nil, x, y, nil) ; - p := array(x,y); - return true; - end - function PostQuitMessage(c); - begin - gtk_main_quit(); - return c; - end - ///////////////////////////////////////// - - ///////////////////////////////////////// - - Function LoadCursorA2(hd:pointer;n:pointer) - begin - rn := array(0x7F01:152,0x7F8A:126,0x7F89:24,0x7F88:0,0x7F87:0, - 0x7F86:58,0x7F85:138,0x7F84:70,0x7F83:12,0x7F82:14,0x7F80:58,0x7F04:6, - 0x7F03:30,0x7F02:150)[n]; - if ifnil(rn) then rn := 2; - return gdk_cursor_new(rn); - end - function RegisterClassExA(wc:pointer); - begin - return gtk_RegisterClassExA(wc); - end - function GetClassInfoExA(HH:pointer;lpszClass:string;lpwcx:pointer); - begin - return gtk_GetClassInfoExtA(hh,lpszClass,lpwcx); - end - function CreateWindowExA(dwExStyle:integer; lpClassName:string; lpWindowName:string; - dwStyle:integer;x:integer;y:integer;nWidth:integer;nHeight:integer; - hWndParent:pointer;hMenu:pointer; hInstance:pointer;lpParam:pointer); - begin - return gtk_createwindowexa(dwExStyle,lpClassName,lpWindowName,dwStyle,x,y,nwidth,nheight,hwndparent,hmenu,hinstance,lpParam); - end - ///////////////////////空接口 - class function LoadLibraryA(txt:string)begin end; - class function FreeLibrary(hd:pointer)begin end; - class function GetModuleHandleA(name:pointer)begin return 1; end; - - function SetClassLongPtrA(HH:pointer;idx:integer;dwNewLong:pointer)begin end; - function GetClassLongPtrA(HH:pointer;idx:integer)begin end; - //////////////////////////////////////// - function CallWindowProcA(lpPrevWndFunc:pointer;hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer) - begin - //默认处理程序 - //echo "call defalt handler\r\n"; - end - function GetKeyState(key); - begin - return gtk_GetKeyState(key); - end - function GetAsyncKeyState(key); - begin - return gtk_GetAsyncKeyState(key); - end - function GetSysColor(idx:integer):integer; - begin - if idx = 0x5 then - begin - return 0xffffff; - end - return 0xf0f0f0; - end - function SendMessageA(h,msg,w,l); - begin - return gtk_sendmessagea(h,msg,w,l); - end - function PostMessageA(h,msg,w,l,d); - begin - return gtk_postmessagea(h,msg,w,l,d); - end - function SetWindowLongPtrA(h,n,v); - begin - if not(h>0 or h<0) then return 0; - return gtk_SetWindowLongPtrA(h,n,v); - end - function GetWindowLongPtrA(h,idx); - begin - if not(h>0 or h<0) then return 0; - return gtk_GetWindowLongPtrA(h,idx); - end - function DestroyWindow(h:pointer); - begin - if h>0 or h<0 then - begin - SetParent(h,0); - if IsGtkWidget(h) then - begin - gtk_widget_destroy(h); - end - end - end - class function MultiByteToWideChar_a(CodePage:integer;dwFlags:integer;lpMultiByteStr:string;cbMultiByte:integer;var lpWideCharStr:string;cchWideChar:integer):integer; - class function GetEncoderClsid(n:String;ed:pointer):integer; - begin - WriteStringToPtr(ed,n); //保存 - return -1; - end - function EnableWindow(w,c); - begin - //可能还有其他处理 - if not(w>0 or w<0) then return false; - r := gtk_widget_get_sensitive(w); - nc := c?true:false; - issetfc := false; - if r<>nc then - begin - if not nc then //似乎还是有点问题 - begin - cf := GetFocus(); - pcf := cf; - while pcf do //查找上层窗口 - begin - if pcf = w then - begin - g_object_set_data(w,"gtk_focus_widget_handle",cf); - issetfc := true; - break; - end - pcf := gtk_widget_get_parent(pcf); - end - if not issetfc then //保存当前消失的窗口 - begin - g_object_set_data(w,"gtk_focus_widget_handle",0); - end - end - gtk_widget_set_sensitive(w,nc); - global g_current_get_focus_widget; - if nc and 0=g_current_get_focus_widget then - begin - fh := g_object_get_data(w,"gtk_focus_widget_handle") ; - if fh and GTK_WIDGET(fh) then - begin - SetFocus(fh); - end - end - end - return r; - end - function CreateStreamOnHGlobal(hGlobal:pointer;fDeleteOnRelease:integer; var ppstm:pointer):pointer; - begin - ppstm := ""; - return true; - end - function GetHGlobalFromStream(pstm:string; var phglobal:string):pointer; - begin - // - phglobal := pstm; - end - function memcpy2(var dst:string;src:string;size_t:integer):pointer; - begin - //字符串 - dst := src; - return ;// - end - function GlobalUnlock(mem :string):integer; - begin - return mem; - end - function GlobalSize(menm:pointer):integer; - begin - return 0;// - end - function InvalidateRect(hwnd :pointer;rec:array of integer;f:integer):integer; - begin - h := g_object_get_data(hwnd,"gtk_clientwideget"); - if h then - begin - //return gtk_widget_queue_draw(h); - if ifarray(rec) and ifnumber(rec[0]) and ifnumber(rec[1]) and ifnumber(rec[2]) and ifnumber(rec[3]) then - begin - - gtk_widget_queue_draw_area(h,rec[0],rec[1],rec[2]-rec[0],rec[3]-rec[1]); - end - else - begin - gtk_widget_queue_draw(h); - - end - end - end - function InvalidateRect2(hwnd :pointer;rec:pointer;f:integer):integer; - begin - InvalidateRect(hwnd,0,f); - end - - //////////////////////////////gdi/////////////////////////////////////////// - function SelectObject(hdc :pointer;gdiobj:pointer); - begin - // - if not hdc then return 0; - if not(gdiobj>0 or gdiobj<0) then return 0; - global gtk_gdi_object_globals; - if not ifarray(gtk_gdi_object_globals) then return 0; - obj := gtk_gdi_object_globals[inttostr(gdiobj)]; - if not obj then return 0; - t := obj[1]; - o := obj[0]; - case obj[1] of - "pen": - begin - r := gtk_object_get_data(hdc,"pen"); - gtk_object_set_data(hdc,"pen",gdiobj); - gtk_object_set_data(hdc,"pen.color",o.color); - gtk_object_set_data(hdc,"pen.width",o.width); - gtk_object_set_data(hdc,"pen.style",o.style); - end - "brush": - begin - r := gtk_object_get_data(hdc,"brush"); - gtk_object_set_data(hdc,"brush",gdiobj); - gtk_object_set_data(hdc,"brush.color",o.color); - end - "font": - begin - r := gtk_object_get_data(hdc,"font"); - gtk_object_set_data(hdc,"font",gdiobj); - end - "rgn": - begin - r := gtk_object_get_data(hdc,"rgn"); - gtk_object_set_data(hdc,"rgn",gdiobj); - end - end ; - return r; - end - Function TextOutA(hdc :pointer;X:integer;y:integer;txt:string;len:integer):integer; - begin - cl := gtk_object_get_data(hdc,"text.color"); -// gtk_rgb_color_rgb(cl,r,g,b); -// cairo_set_source_rgb(hdc, r, g, b); - xb := gtk_object_get_data(hdc,"viewport.x"); - yb := gtk_object_get_data(hdc,"viewport.y"); - ft := gtk_object_get_data(hdc,"font"); - global gtk_gdi_object_globals; - if ft and ifarray(gtk_gdi_object_globals) then - begin - fto := gtk_gdi_object_globals[inttostr(ft)]; - if fto then fto := fto[0]; - if fto then //文字处理 - begin - fc := fto._getvalue_("facename"); - ht := fto._getvalue_("height"); - wd := fto._getvalue_("width"); - it := fto._getvalue_("italic"); - wt := fto._getvalue_("weight")=700; - udl := fto._getvalue_("underline"); - fnotset := false; - {fns := static pango_font_family_get_names(); - for i,v in fns do - begin - if v=fc then - begin - fnotset := true; - break; - end - end } - cft := (fnotset?fc:"AR PL UKai CN"); - global g_gtk_font_get_size ; - if not ifarray(g_gtk_font_get_size) then g_gtk_font_get_size := array(); - cfinfo := g_gtk_font_get_size[cft,ht,wd,it,wt]; - if cfinfo then - begin - wd := cfinfo["width"]; - dkzt := cfinfo["zczw"]; - iwd2 := cfinfo["iwd2"]; - cairo_select_font_face(hdc,cft,it,wt); - cairo_set_font_size(hdc,cfinfo["iwd2"]); - end else - begin - cairo_select_font_face(hdc,cft,it,wt); - ext := new _cairo_text_extents_t(nil); - brk := 0; - wd2 := wd*2-2-wt; //稍微缩小一点 - iwd2 := wd2; - brk_Ct := 0; - dkzt := false; - while not brk do - begin - brk_Ct++; - cairo_set_font_size(hdc,iwd2); - cairo_text_extents(hdc, U"国", ext._getptr_()); - nwd := ext.width; - if brk_Ct = 1 then - begin - cairo_text_extents(hdc, U"i", ext._getptr_()); - nwd2 := ext.width; - dkzt := (nwd2/nwd)>0.6; - //echo "\r\n*********************",(nwd2/nwd); - if dkzt then //不支持中文,稍微放大一点 - begin - wd2 := wd+1+it-wt; - iwd2 := wd+1+it-wt; - end - end - if nwd>(wd2+0.4) then - begin - iwd2-=0.25; - end else - if nwd<(wd2) then - begin - iwd2+=0.25; - end else - begin - brk := true; - end - if brk_Ct>50 then break; - end - g_gtk_font_get_size[cft,ht,wd,it,wt] := array("width":wd,"zczw":dkzt,"iwd2":iwd2); - end - end - - end - - wid := wd; - idx := 1 ; - tlen := (len<0)?length(txt):(min(len,length(txt))); - xp := x+xb; - yp := y+yb+ht; - ///////////////////背景///////////////////////////////////////// - if gtk_object_get_data(hdc,"font.bkmode") = 2 then - begin - gtk_rgb_color_rgb(gtk_object_get_data(hdc,"font.bkcolor"),r,g,b); - //cairo_fill - cairo_move_to(hdc,xp,yp); - cairo_line_to(hdc,xp+wid*tlen,yp); - cairo_line_to(hdc,xp+wid*tlen,yp-ht); - cairo_line_to(hdc,xp,yp-ht); - cairo_line_to(hdc,xp,yp); - cairo_set_source_rgb(hdc, r, g, b); - cairo_fill(hdc); - end - gtk_rgb_color_rgb(cl,r,g,b); - cairo_set_source_rgb(hdc, r, g, b); - //////////////////////////////////////////////////////// - if udl then - begin - cairo_set_line_width(hdc,0.5); - end - while idx<=tlen do - begin - if udl then bxp := xp; - ci := GetChar(txt,idx); - {if ci=13 then // \n - begin - idx++; - yp+=ht; - continue; - end else // \r - if ci = 10 then - begin - idx++; - xp := x+xb; - continue; - end } - cairo_move_to(hdc,xp,yp); - if (ci .& 0x80) then - begin - if idx14 then - cairo_show_text(hdc,TslStringToGtk2( txt[idx])); - end - xp+=wid; - idx++; - if udl then - begin - cairo_move_to(hdc,bxp,yp); - cairo_line_to(hdc,xp,yp); - end - //cairo_move_to(hdc,xp,yp); - end - cairo_stroke(hdc); - return 1; - end - Function DrawTextA(hdc :pointer;txt:string;len:integer;rec:array of integer;fmt:integer):integer; - begin - //输出字符数 - //方位 - return DrawTextExA(hdc,txt,len,rec,fmt,0); - end - Function DrawTextExA(hdc :pointer;txt:string;len:integer;rec:array of integer;fmt:integer;lpdtp:pointer):integer; - begin - slen := length( txt); - if slen<1 then return ; - ft := gtk_object_get_data(hdc,"font"); - global gtk_gdi_object_globals; - if ft and ifarray(gtk_gdi_object_globals) then - begin - fto := gtk_gdi_object_globals[inttostr(ft)]; - if fto then fto := fto[0]; - wd := fto._getvalue_("width"); - ht := fto._getvalue_("height"); - end - //DT_LEFT := 0; - DT_RIGHT := 0x2; - //DT_TOP := 0; - DT_BOTTOM:= 0x8; - DT_CENTER := 0x1; - DT_VCENTER:= 0x4; - //DT_SINGLELINE:= 0x20; - //DT_TABSTOP:= 0x80; - rw := rec[2]-rec[0]; - nlen := min(len, min(integer(rw/wd),slen)); - sx := rec[0]; - rh := rec[3]-rec[1]; - sy := rec[1]; - if fmt=0 or not(fmt>0 or fmt<0 ) then - begin - - end - if (fmt .& DT_CENTER)=DT_CENTER then //处理 - begin - if nlen = slen then - begin - sx +=(rw-(nlen*wd))/2; - end - - end - if (fmt .& DT_VCENTER)=DT_VCENTER then //处理 - begin - if rh>ht then - begin - sy+=(rh-ht)/2; - end - end - if (fmt .& DT_RIGHT)=DT_RIGHT then //不处理 - begin - if rw>(nlen*wd) then - begin - sx := rec[2]-((nlen*wd)); - end - end - if (fmt .& DT_BOTTOM)=DT_BOTTOM then //不处理 - begin - sy := rec[3]-3-ht; - end - r := TextOutA(hdc,sx,sy,txt,nlen); - return r; - rr := gtk_object_get_data(hdc,"rgn"); - if rr then - begin - p := new TCRect(gdiobj); - rc := p._getdata_(); - cairo_reset_clip(hdc); - cairo_rectangle(hdc,rc[0],rc[1],rc[2]-rc[0],rc[3]-rc[1]); - cairo_clip(hdc); - end else - begin - cairo_reset_clip(hdc); - end - return r; - end - Function SetTextColor(hdc :pointer;col:integer):integer; - begin - gtk_object_set_data(hdc,"text.color",col); - return true; - end - Function FillRect(dc:pointer;rec:array of integer;br:pointer):integer; - begin - if not dc then return ; - if ifarray(rec) then - begin - global gtk_gdi_object_globals; - if not ifarray(gtk_gdi_object_globals) then gtk_gdi_object_globals := array(); - brs := gtk_gdi_object_globals[inttostr(br)]; - if not brs then return 0; - cl := brs[0].Color; - x := gtk_object_get_data(dc,"viewport.x"); - y := gtk_object_get_data(dc,"viewport.y"); - cairo_rectangle(dc, x+rec[0], y+rec[1], rec[2]-rec[0], rec[3]-rec[1]); - gtk_rgb_color_rgb(cl,r,g,b); - cairo_set_source_rgb(dc,r,g,b); - cairo_fill(dc); - end - end - Function InvertRect(dc:pointer;rec:array of integer;br:pointer):integer; - begin - if not dc then return ; - if ifarray(rec) then - begin - global gtk_gdi_object_globals; - if not ifarray(gtk_gdi_object_globals) then gtk_gdi_object_globals := array(); - brs := gtk_gdi_object_globals[inttostr(br)]; - if not brs then return 0; - cl := brs[0].Color; - x := gtk_object_get_data(dc,"viewport.x"); - y := gtk_object_get_data(dc,"viewport.y"); - cairo_rectangle(dc, x+rec[0], y+rec[1], rec[2]-rec[0], rec[3]-rec[1]); - gtk_rgb_color_rgb(cl,r,g,b); - cairo_set_source_rgb(dc,1-r,1-g,1-b); - cairo_fill(dc); - end - end - function ReleaseDC(hwd :pointer;hdc:pointer):integer; - begin - - end - function SelectClipRgn(hdc :pointer;gdiobj:pointer); - begin - - r := SelectObject(hdc,gdiobj); - if not(gdiobj) then - begin - gtk_object_set_data(hdc,"rgn",nil); - cairo_reset_clip(hdc); - end - else - begin - rr := gtk_object_get_data(hdc,"rgn"); - if rr <> gdiobj then return ; - p := new TCRect(gdiobj); - rc := p._getdata_(); - cairo_reset_clip(hdc); - x := gtk_object_get_data(dc,"viewport.x"); //控制基准位置 - y := gtk_object_get_data(dc,"viewport.y"); - cairo_rectangle(hdc,rc[0]+x,rc[1]+y,rc[2]-rc[0],rc[3]-rc[1]); - cairo_clip(hdc); - //gtk_object_set_data(hdc,"rgn",gdiobj); - end - return r; - end - function CreateRectRgn(nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer):pointer; - begin - global gtk_gdi_object_globals; - if not ifarray(gtk_gdi_object_globals) then gtk_gdi_object_globals := array(); - p := new TCRect(); - p.left := nLeftRect; - p.top := nTopRect; - p.right := nRightRect; - p.bottom := nBottomRect; - ptr := p._getptr_(); - gtk_gdi_object_globals[inttostr(ptr)] := array(p,"rgn"); - return ptr; - end - function CombineRgn(hrgnDest:pointer;hrgnSrc1:pointer;hrgnSrc2:pointer; fnCombineMode:integer):integer; - begin - //RGN_ERROR := 0x0;RGN_AND := 0x1;RGN_OR := 0x2;RGN_XOR := 0x3;RGN_DIFF := 0x4;RGN_COPY := 0x5; - rd := new TCRect(hrgnDest); - rs1 := new TCRect(hrgnSrc1); - if fnCombineMode=0x1 then - begin - rs2 := new TCRect(hrgnSrc2); - rd.left := max(rs1.left,rs2.left); - rd.top := max(rs1.top,rs2.top); - rd.right := min(rs1.right,rs2.right); - rd.bottom := min(rs1.bottom,rs2.bottom); - end else - if fnCombineMode=0x5 then - begin - rd.left := rs1.left ; - rd.top := rs1.top ; - rd.right := rs1.right ; - rd.bottom := rs1.bottom ; - end - return ret; - end - - function SetViewportOrgEx(dc:pointer;x:integer;y:integer;var pt:array of integer):integer; - begin - if not dc then return 0; - gtk_object_set_data(dc,"viewport.x",x); - gtk_object_set_data(dc,"viewport.y",y); - return 1; - end - - function DeleteObject(gdiobj :pointer);//删除gdi对象 - begin - global gtk_gdi_object_globals; - if not ifarray(gtk_gdi_object_globals) then return 0; - r := gtk_gdi_object_globals[inttostr( gdiobj)]; - if r then - begin - reindex(gtk_gdi_object_globals,array(inttostr(gdiobj):nil)); - return true; - end - class(TGdiplusflat).GdipDisposeImage(gdiobj); - return 0; - end - function DestroyIcon(icon:pointer):integer; - begin - return DeleteObject(icon); - end - function DestroyCursor(cursor:pointer):integer; - begin - return DeleteObject(cursor); - end - function CreatePen(FS,w,FC); //gtk 模拟 pen - begin - global gtk_gdi_object_globals; - if not ifarray(gtk_gdi_object_globals) then gtk_gdi_object_globals := array(); - p := new ttgtk_pen(); - p.width := w; - p.color := FC; - p.style := fs; - ptr := p._getptr_(); - gtk_gdi_object_globals[inttostr(ptr)] := array(p,"pen"); - return ptr; - //构造画笔 - end - function CreateSolidBrush(crColor:integer); - begin - global gtk_gdi_object_globals; - if not ifarray(gtk_gdi_object_globals) then gtk_gdi_object_globals := array(); - p := new ttgtk_brush(); - p.color := crColor; - ptr := p._getptr_(); - gtk_gdi_object_globals[inttostr(ptr)] := array(p,"brush"); - return ptr; - end - function CreateFontIndirectA(lplf:pointer); - begin - - global gtk_gdi_object_globals; - if not ifarray(gtk_gdi_object_globals) then gtk_gdi_object_globals := array(); - p := new ttgtk_font(); - p2 := new ttgtk_font(lplf); - for i,v in array("height","width","escapement","orientation","weight","italic","underline","strikeout","charset","outprecision","clipprecision","quality","pitchandfamily","facename") do - p._setvalue_(v,p2._getvalue_(v)); - ptr := p._getptr_(); - gtk_gdi_object_globals[inttostr(ptr)] := array(p,"font"); - return ptr; - end - Function GetTextMetricsA(hdc :pointer;TM:pointer):integer; - begin - - end - Function MoveToEx(hdc :pointer;x:integer;y:integer;var point:array of integer):integer; - begin - xb := gtk_object_get_data(hdc,"viewport.x"); - yb := gtk_object_get_data(hdc,"viewport.y"); - //cairo_move_to(hdc,x+xb,y+yb); - xy := gtk_object_get_data(hdc,"movepointto"); - if xy then - begin - point := xy; - end else point := array(0,0); - gtk_object_set_data(hdc,"movepointto",array(x,y)); - end - Function LineTo(dc :pointer;x:integer;y:integer):integer; - begin - xb := gtk_object_get_data(dc,"viewport.x"); - yb := gtk_object_get_data(dc,"viewport.y"); - pc := gtk_object_get_data(dc,"pen.color"); - pw := gtk_object_get_data(dc,"pen.width"); - pt := gtk_object_get_data(dc,"pen.style"); - if pw>0 then cairo_set_line_width(dc,pw); - else cairo_set_line_width(dc,1); - if pc=0 then - begin - cairo_set_source_rgb(dc,0,0,0); - end else - begin - gtk_rgb_color_rgb(pc,rc,gc,bc); - cairo_set_source_rgb(dc,rc,gc,bc); - end - cairo_applay_pen_style(dc); - xy := gtk_object_get_data(dc,"movepointto"); - if xy then - begin - cairo_move_to(dc,xy[0]+xb,xy[1]+yb); - end - gtk_object_set_data(dc,"movepointto",array(x,y)); - cairo_line_to(dc,x+xb,y+yb); - cairo_stroke(dc); - - end - - //////////////////////////gtk 菜单////////////////// - Function CreateMenu():pointer; - begin - r := gtk_menu_bar_new(); - gtk_widget_show(r); - return r; - end - Function CreatePopupMenu():pointer; - begin - //弹出菜单 - r := gtk_menu_new(); - gtk_widget_show(r); - g_object_set_data(r,"popmenubar",true); - return r; - end - Function DestroyMenu(hMenu:pointer):integer; - begin - return gtk_widget_destroy(hMenu); - end - Function DrawMenuBar(hwd:pointer):integer; //处理菜单栏 - begin - h :=g_object_get_data(hwd,"gtk_layout_height"); - w :=g_object_get_data(hwd,"gtk_layout_width"); - gtk_widgetsizechanged(hwd,h,w); - end - Function SetMenu(hwd:pointer;hmenu:pointer):integer; //设置菜单栏 - begin - vb := g_object_get_data(hwd,"gtk_vbox"); - if not vb then return ; - mb := g_object_get_data(hwd,"menubar"); - if mb = hmenu then return ; - if mb then - begin - gist := gtk_container_get_children(mb); - ridx := 0; - while gist do - begin - og := new _gslist(gist); - dt := og.data; - if dt then - gtk_container_remove(mb,dt); - ridx++; - gist := og.next; - end - gtk_widget_destroy(mb); - end - if hmenu then - begin - g_object_set_data(hwd,"menubar",hmenu); - g_object_set_data(hmenu,"menubarwindow",hwd); - gtk_box_pack_start(vb,hmenu,0,0,0); - gtk_widget_realize(hmenu); - //gtk_widget_show_all(hmenu); - end - else - begin - g_object_set_data(hwd,"menubar",0); - end - h :=g_object_get_data(hwd,"gtk_layout_height"); - w :=g_object_get_data(hwd,"gtk_layout_width"); - gtk_widgetsizechanged(hwd,h,w); - //移除原有窗口 - //menubar 添加到窗口 - end - Function RemoveMenu( hMenu:pointer; uPosition:integer;uFlags:integer):integer; - begin - mi := gtk_menu_shell_get_by_positon(hmenu,uPosition); - if mi then - begin - g_object_ref(mi); - gtk_container_remove(hMenu,mi); - return true; - end - - //移除菜单项目 - end - Function SetMenuItemInfoA( hMenu:pointer; uItem:integer;fByPosition:integer;lpmii:pointer):integer; - begin - return gtk_SetMenuItemInfoA(hMenu,uitem,fbyposition,lpmii); - //添加菜单 - end - Function InsertMenuItemA( hMenu:pointer;uItem:integer;fByPosition:integer;lpmii:pointer):integer; - begin - return gtk_insertmenuitema(hMenu,uitem,fbyposition,lpmii); - //添加菜单 - end - Function TrackPopupMenu( hMenu:pointer;uFlags:integer; x:integer; y:integer; nReserved:integer;hWnd:pointer; prcRect: array of integer):integer; - begin - //echo "\r\n===trackmenu:",hmenu,"===",x,"===",y,"===",nReserved,"===hwnd:",hwnd,"===rect:",tostn(prcRect); - if g_object_get_data(hMenu,"popmenubar") then - begin - g_object_set_data(hMenu,"popmenubarwindow",hWnd); - gtk_menu_popup(hmenu,0,0,0,0,3,0);//弹出 - return 1; - end else - begin - - end - //弹出菜单 - end - - function ClientToScreen(hwnd :pointer;var p:array of integer):integer; // 继续努力 - begin - if not hwnd then return ; - if not GTK_WIDGET(hwnd) then return ; - x := g_object_get_data(hwnd,"gtk_layout_x"); - y := g_object_get_data(hwnd,"gtk_layout_y"); - p[0]+=x; - p[1]+=y; - if not gtk_widget_is_toplevel(hwnd) then - begin - phwnd := GetParent(hwnd); - return ClientToScreen(phwnd,p); - end else - begin - mb := g_object_get_data(hwnd,"menubar"); - if mb and gtk_widget_is_visible(mb) then - begin - rec := zeros(4); - gtk_widget_get_allocation(mb,rec); - if rec[3]>1 then - begin - p[1]+= rec[3] ;//max(rec[3],25); - end - - end - end - return true; - end - function ScreenToClient(hwnd :pointer;var p:array of integer):integer;// 继续努力 - begin - p1 := array(0,0); - ClientToScreen(hwnd,p1); - p[0]-=p1[0]; - p[1]-=p1[1]; - return true; - end - function BeginPaint(hwd :pointer;strc:pointer):pointer; - begin - psc := new TPAINTSTRUCT(strc); - dc := g_object_get_data(hwd,"paint_dc"); - h := g_object_get_data(hwd,"paint_height"); - w := g_object_get_data(hwd,"paint_width"); - psc._setvalue_("hdc",dc); - psc._setvalue_("rcpaint",array(0,0,w,h)); - return dc; - end - function EndPaint(hwd :pointer;strc:pointer):integer; - begin - return 0; - end - function SaveDC(hdc :pointer):integer; - begin - if not(hdc>0 or hdc<0) then return ; - cairo_save(hdc); //需要处理 - end - function RestoreDC(hdc :pointer;nSavedDC:integer):integer; - begin - if not(hdc>0 or hdc<0) then return ; - cairo_restore(hdc); //需要处理 - end - function DeleteDC(hdc :pointer):integer; - begin - if not(hdc>0 or hdc<0) then return ; - gtk_object_set_data(hdc); //清空 - cairo_destroy(hdc); //需要处理 - end - function GetTextExtentPoint32A(hdc:pointer;lpString:string;c:integer; psizl:pointer):integer; - begin - end - function GetTextExtentPoint32A2(hdc:pointer;lpString:string;c:integer; var psizl:array of integer):integer; - begin - psizl := array(0,0); - if not(hdc>0 or hdc<0) then return 0; - if not( ifstring(lpString) and c>0 and c>=length(lpString)) then return 0; - ft := gtk_object_get_data(hdc,"font"); - global gtk_gdi_object_globals; - wd := 8; - ht := 16; - if ft and ifarray(gtk_gdi_object_globals) then - begin - fto := gtk_gdi_object_globals[inttostr(ft)]; - if fto then fto := fto[0]; - if fto then //文字处理 - begin - fc := fto._getvalue_("facename"); - ht := fto._getvalue_("height"); - wd := fto._getvalue_("width"); - end - end - psizl[0] := wd*length(lpString); - psizl[1] := ht; - return 1; - - end - function GetCharWidthA(hdc:pointer;iFirst:integer;iLast:integer;var lpBuffer:array of integer):integer; - begin - - - end - Function Rectangle(dc :pointer;l:integer;t:integer;r:integer;b:integer):integer; - begin - x := gtk_object_get_data(dc,"viewport.x"); - y := gtk_object_get_data(dc,"viewport.y"); - pc := gtk_object_get_data(dc,"pen.color"); - pw := gtk_object_get_data(dc,"pen.width"); - if pw>0 then cairo_set_line_width(dc,pw); - else cairo_set_line_width(dc,1); - if pc=0 then - begin - cairo_set_source_rgb(dc,0,0,0); - end else - begin - gtk_rgb_color_rgb(pc,rc,gc,bc); - cairo_set_source_rgb(dc,rc,gc,bc); - end - cairo_applay_pen_style(dc); - cairo_move_to(dc,l+x,t+y); - cairo_line_to(dc,r+x,t+y); - cairo_line_to(dc,r+x,b+y); - cairo_line_to(dc,l+x,b+y); - cairo_line_to(dc,l+x,t+y); - cairo_stroke(dc); - //return - cairo_stroke_preserve(dc); - bsh := gtk_object_get_data(dc,"brush.color"); - gtk_rgb_color_rgb(bsh,rc,gc,bc); - cairo_set_source_rgb(dc,rc,gc,bc); - cairo_fill(dc); - end - Function Ellipse(dc :pointer;l:integer;t:integer;r:integer;b:integer):integer; - begin - //圆心 - //长度 - x := gtk_object_get_data(dc,"viewport.x"); - y := gtk_object_get_data(dc,"viewport.y"); - pc := gtk_object_get_data(dc,"pen.color"); - pw := gtk_object_get_data(dc,"pen.width"); - brc := gtk_object_get_data(dc,"brush.color"); - if pw>0 then cairo_set_line_width(dc,pw); - else cairo_set_line_width(dc,1); - - mx := (l+r)/2+x; - my := (b+t)/2+y; - cairo_translate(dc,mx,my); - rx := (r-l)/2; - ry := (b-t)/2; - cairo_scale(dc,1,ry/rx); - cairo_applay_pen_style(dc); - cairo_arc(dc, 0, 0, rx, 0, 2 * 3.14); - if brc=0 then - begin - cairo_set_source_rgb(dc,0,0,0); - end else - begin - gtk_rgb_color_rgb(brc,rc,gc,bc); - cairo_set_source_rgb(dc,rc,gc,bc); - end - cairo_fill_preserve(dc); - if pc=0 then - begin - cairo_set_source_rgb(dc,0,0,0); - end else - begin - gtk_rgb_color_rgb(pc,rc,gc,bc); - cairo_set_source_rgb(dc,rc,gc,bc); - end - cairo_stroke(dc); - cairo_scale(dc,1,rx/ry); - cairo_translate(dc,0-mx,0-my); - end - Function RoundRect(dc :pointer;l:integer;t:integer;r:integer;b:integer;wid:integer;ht:integer):integer; - begin - xb := gtk_object_get_data(dc,"viewport.x"); - yb := gtk_object_get_data(dc,"viewport.y"); - pc := gtk_object_get_data(dc,"pen.color"); - pw := gtk_object_get_data(dc,"pen.width"); - - if pw>0 then cairo_set_line_width(dc,pw); - else cairo_set_line_width(dc,1); - cairo_applay_pen_style(dc); - cairo_draw_round_rectangle(dc,l,t,r-l,b-t,wid); - - bsh := gtk_object_get_data(dc,"brush.color"); - gtk_rgb_color_rgb(bsh,rc,gc,bc); - cairo_set_source_rgb(dc,rc,gc,bc); - cairo_fill_preserve(dc); //绘制底色 - if pc=0 then - begin - cairo_set_source_rgb(dc,0,0,0); - end else - begin - gtk_rgb_color_rgb(pc,rc,gc,bc); - cairo_set_source_rgb(dc,rc,gc,bc); - end - cairo_stroke(dc);//绘制边框 - return ; - end - Function Chord(hdc :pointer;l:integer;t:integer;r:integer;b:integer;wid:integer;ht:integer):integer; - begin - - end - Function Pie(hdc :pointer;nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer;nXRadial1:integer;nYRadial1:integer;nXRadial2:integer;nYRadial2:integer):integer; - begin - - end - Function SetArcDirection(hdc :pointer;direct:integer):integer; - begin - - end - Function Arc(hdc :pointer;nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer;nXRadial1:integer;nYRadial1:integer;nXRadial2:integer;nYRadial2:integer):integer; - begin - - end - Function Polygon(hdc :pointer;points:array of integer;n:integer):integer; - begin - - end - Function PolyBezier(hdc :pointer;points:array of integer;n:integer):integer; - begin - - end - Function SetPolyFillMode(hdc :pointer;md:integer):integer; - begin - - end - Function Polyline(dc :pointer;points:array of integer;n:integer):integer; - begin - if n<2 then return ; - x := gtk_object_get_data(dc,"viewport.x"); - y := gtk_object_get_data(dc,"viewport.y"); - pc := gtk_object_get_data(dc,"pen.color"); - pw := gtk_object_get_data(dc,"pen.width"); - if pw>0 then cairo_set_line_width(dc,pw); - else cairo_set_line_width(dc,1); - if pc=0 then - begin - cairo_set_source_rgb(dc,0,0,0); - end else - begin - gtk_rgb_color_rgb(pc,rc,gc,bc); - cairo_set_source_rgb(dc,rc,gc,bc); - end - cairo_move_to(dc,points[0]+x,Points[1]+y); - cairo_applay_pen_style(dc); - for i := 1 to n-1 do - begin - cairo_line_to(dc,Points[i*2]+x,Points[i*2+1]+y); - end - cairo_stroke(dc); - end - Function PolyPolyline(hdc :pointer;points:array of integer;pc:array of integer;n:integer):integer; - begin - - end - Function DrawFrameControl(DC:pointer; var LPRECT: array of integer ; dr1 :integer;dr2:integer):integer; - begin - { - DFC_SCROLL := 0x3;DFC_BUTTON := 0x4;DFC_POPUPMENU := 0x5; - DFCS_CAPTIONCLOSE := 0x0;DFCS_CAPTIONMIN := 0x1;DFCS_CAPTIONMAX := 0x2; - DFCS_CAPTIONRESTORE := 0x3;DFCS_CAPTIONHELP := 0x4;DFCS_MENUARROW := 0x0; - DFCS_MENUCHECK := 0x1;DFCS_MENUBULLET := 0x2;DFCS_MENUARROWRIGHT := 0x4; - DFCS_SCROLLUP := 0x0;DFCS_SCROLLDOWN := 0x1;DFCS_SCROLLLEFT := 0x2; - DFCS_SCROLLRIGHT := 0x3;DFCS_SCROLLCOMBOBOX := 0x5;DFCS_SCROLLSIZEGRIP := 0x8; - DFCS_SCROLLSIZEGRIPRIGHT := 0x10;DFCS_BUTTONCHECK := 0x0;DFCS_BUTTONRADIOIMAGE := 0x1; - DFCS_BUTTONRADIOMASK := 0x2;DFCS_BUTTONRADIO := 0x4;DFCS_BUTTON3STATE := 0x8; - DFCS_BUTTONPUSH := 0x10;DFCS_INACTIVE := 0x100;DFCS_PUSHED := 0x200; - DFCS_CHECKED := 0x400;DFCS_TRANSPARENT := 0x800;DFCS_HOT := 0x1000; - DFCS_ADJUSTRECT := 0x2000;DFCS_FLAT := 0x4000;DFCS_MONO := 0x8000; - - } - x := gtk_object_get_data(dc,"viewport.x"); - y := gtk_object_get_data(dc,"viewport.y"); - case dr1 of - 0x4 : //DFC_BUTTON - begin - //if dr2 = 0x10 then // DFCS_BUTTONPUSH - //begin - - //end else - cairo_applay_pen_style(dc); - if dr2 = 0 then // DFCS_BUTTONCHECK - begin - cairo_set_source_rgb(dc,135/255,135/255,135/255); - cairo_set_line_width(dc,5); - - cairo_rectangle (dc, LPRECT[0]+x, LPRECT[1]+y, LPRECT[2]-LPRECT[0], LPRECT[3]-LPRECT[1]); - cairo_stroke_preserve(dc); - cairo_set_source_rgb(dc,1,1,1); - cairo_fill(dc); - end else - if dr2 = 0x400 then // DFCS_CHECKED - begin - cairo_set_source_rgb(dc,135/255,135/255,135/255); - cairo_set_line_width(dc,5); - - cairo_rectangle (dc, LPRECT[0]+x, LPRECT[1]+y, LPRECT[2]-LPRECT[0], LPRECT[3]-LPRECT[1]); - cairo_stroke_preserve(dc); - cairo_set_source_rgb(dc,1,1,1); - cairo_fill(dc); - - cairo_move_to(dc,LPRECT[0]+x+2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/3); - cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])/3,LPRECT[3]-2); - cairo_line_to(dc,LPRECT[2]-2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/4); - cairo_set_source_rgb(dc,100/255,100/255,100/255); - cairo_set_line_width(dc,4); - cairo_stroke(dc); - end else - if dr2 = 0x1 then // DFCS_BUTTONRADIOIMAGE - begin - cairo_set_source_rgb(dc,135/255,135/255,135/255); - cairo_set_line_width(dc,5); - l := LPRECT[0]; - r := LPRECT[2]; - t := LPRECT[1]; - b := LPRECT[3]; - mx := (l+r)/2+x; - my := (b+t)/2+y; - cairo_translate(dc,mx,my); - rx := (r-l)/2; - ry := (b-t)/2; - cairo_scale(dc,1,ry/rx); - - cairo_arc(dc, 0, 0, rx, 0, 2 * 3.14); - cairo_stroke_preserve(dc); - cairo_set_source_rgb(dc,1,1,1); - cairo_fill(dc); - cairo_set_line_width(dc,1); - cairo_arc(dc, 0, 0, max(rx-5,3), 0, 2 * 3.14); - cairo_set_source_rgb(dc,100/255,100/255,100/255); - cairo_fill(dc); - cairo_scale(dc,1,rx/ry); - cairo_translate(dc,0-mx,0-my); - end else - if dr2 = 0x4 then // DFCS_BUTTONRADIO - begin - cairo_set_source_rgb(dc,135/255,135/255,135/255); - cairo_set_line_width(dc,5); - l := LPRECT[0]; - r := LPRECT[2]; - t := LPRECT[1]; - b := LPRECT[3]; - mx := (l+r)/2+x; - my := (b+t)/2+y; - cairo_translate(dc,mx,my); - rx := (r-l)/2; - ry := (b-t)/2; - cairo_scale(dc,1,ry/rx); - - cairo_arc(dc, 0, 0, rx, 0, 2 * 3.14); - cairo_stroke_preserve(dc); - cairo_set_source_rgb(dc,1,1,1); - cairo_fill(dc); - cairo_scale(dc,1,rx/ry); - cairo_translate(dc,0-mx,0-my); - end else - begin - cairo_set_line_width(dc,4); - - cairo_rectangle(dc, LPRECT[0]+x, LPRECT[1]+y, LPRECT[2]-LPRECT[0], LPRECT[3]-LPRECT[1]); - {cairo_move_to(dc,LPRECT[0]+x,LPRECT[1]+y); - cairo_line_to(dc,LPRECT[2]+x,LPRECT[1]+y); - cairo_line_to(dc,LPRECT[2]+x,LPRECT[3]+y); - cairo_line_to(dc,LPRECT[0]+x,LPRECT[3]+y); - cairo_line_to(dc,LPRECT[0]+x,LPRECT[1]+y); - cairo_set_source_rgb(dc,200/255,200/255,200/255); - cairo_stroke_preserve(dc); - cairo_set_source_rgb(dc,221/255,221/255,221/255); - cairo_fill(dc);} - - cairo_set_source_rgb(dc,221/255,221/255,221/255); - cairo_fill_preserve(dc); - cairo_set_source_rgb(dc,210/255,207/255,205/255); - cairo_stroke(dc); - end - end - 0x3 : // DFC_SCROLL - begin - cairo_set_source_rgb(dc,221/255,221/255,221/255); - cairo_set_line_width(dc,0.1); - cairo_applay_pen_style(dc); - cairo_rectangle(dc, LPRECT[0]+x, LPRECT[1]+y, LPRECT[2]-LPRECT[0], LPRECT[3]-LPRECT[1]); - cairo_fill(dc); - - if dr2 = 0 then // DFCS_SCROLLUP - begin - cairo_move_to(dc,LPRECT[0]+x+2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/1.5); - cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])/2,LPRECT[1]+3); - cairo_line_to(dc,LPRECT[2]-2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/1.5); - cairo_line_to(dc,LPRECT[0]+x+2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/1.5); - cairo_set_source_rgb(dc,10/255,10/255,10/255); - cairo_fill(dc); - end else - if dr2 = 1 then // DFCS_SCROLLDOWN - begin - cairo_move_to(dc,LPRECT[0]+x+2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/3); - cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])/2,LPRECT[3]-3); - cairo_line_to(dc,LPRECT[2]-2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/3); - cairo_line_to(dc,LPRECT[0]+x+2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/3); - cairo_set_source_rgb(dc,10/255,10/255,10/255); - cairo_fill(dc); - end - if dr2 = 2 then //DFCS_SCROLLLEFT; - begin - cairo_move_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])*2/3,LPRECT[1]+y+2); - cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])*2/3,LPRECT[3]+y-2); - cairo_line_to(dc,LPRECT[0]+x+2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/2); - cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])*2/3,LPRECT[1]+y+2); - - cairo_set_source_rgb(dc,10/255,10/255,10/255); - cairo_fill(dc); - end else - if dr2 = 3 then //DFCS_SCROLLRIGHT; - begin - cairo_move_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])/3,LPRECT[1]+y+2); - cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])/3,LPRECT[3]+y-2); - cairo_line_to(dc,LPRECT[2]+x-2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/2); - cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])/3,LPRECT[1]+y+2); - - cairo_set_source_rgb(dc,10/255,10/255,10/255); - cairo_fill(dc); - end - end - end - - end - Function SetBkColor(dc:pointer;clrref:integer):integer; - begin - //font背景色 - gtk_object_set_data(dc,"font.bkcolor",clrref); - end - Function GetBkColor(dc:pointer):integer; - begin - return gtk_object_get_data(dc,"font.bkcolor"); - end - Function SetBkMode(dc:pointer;clrref:integer):integer; - begin - gtk_object_set_data(dc,"font.bkmode",clrref); - end - Function GetBkMode(dc:pointer):integer; - begin - return gtk_object_get_data(dc,"font.bkmode"); - end - Function FillRgn(dc:pointer;rgn:pointer;br:pointer):integer; - begin - - end - Function SetTextAlign(dc:pointer;fMode:integer):integer; - begin - - end - Function SetWorldTransform(dc:pointer;lpXform:pointer):integer; - begin - - end - - function UpdateWindow(hwnd :pointer):integer; - begin - w :=g_object_get_data(hwnd,"gtk_layout_width"); - h := g_object_get_data(hwnd,"gtk_layout_height"); - gtk_widgetsizechanged(hwnd,h,w); - return true; - end - function ClipCursor(rec:array of integer):integer; - begin - - end - function SetFocus(hwnd :pointer):pointer; - begin - cfcs := GetFocus(); - if cfcs = hwnd then return 0; - if not(hwnd>0 or hwnd<0) then return 0; - ph := hwnd; - if not GTK_WIDGET(hwnd) then return 0; - if not gtk_widget_is_toplevel(hwnd) then - begin - ph := gtk_widget_get_toplevel(hwnd); - end - //if not lot then - //lot := hwnd; - //gtk_widget_grab_focus(lot); - //echo "\r\n+++setfocus>>>",ph,">>>",hwnd; - gtk_window_set_focus(ph,hwnd); - return 0; - - end - function GetFocus():pointer; - begin - global g_current_get_focus_widget; - if g_current_get_focus_widget then return g_current_get_focus_widget; - return 0; - end - Function LoadImageA(hinst:pointer;lpszName:string; uType:integer; cxDesired:integer;cyDesired:integer;fuLoad:integer):pointer; - begin - - end - function LoadBitmapA(hin:pointer;lpsz:string):pointer; - begin - - end - function LoadBitmapA2(hin:pointer;lpsz:pointer):pointer; - begin - - end - Function GetObjectA(hgdiobj:pointer;cbBuffer:integer;lpvObject:pointer):integer; - begin - bmpobj := new TSHBMP(lpvObject); - bmpobj.bmwidth := gdk_pixbuf_get_width(hgdiobj); - bmpobj.bmheight := gdk_pixbuf_get_height(hgdiobj); - return ; - end - function GetIconInfo(hIcon:pointer; piconinfo:pointer):integer; - begin - //icoobj := new TSHICON(lpvObject); - //icoobj.bmwidth := gdk_pixbuf_get_width(hgdiobj); - //icoobj.bmheight := gdk_pixbuf_get_height(hgdiobj); - return ; - end - function CreateCompatibleDC(hdc :pointer):pointer; - begin - sf := cairo_image_surface_create(0,100,100); - r := cairo_create(sf); - return r; - return 0; - end - Function SetCursor(hd:pointer):pointer; - begin - global g_show_cursor_window; - if g_show_cursor_window and hd<>0 then - gdk_window_set_cursor(g_show_cursor_window,hd); - end - function drawbitmaptodc(bm,hdc,x,y,rc,flag,thdc); - begin - if not hdc then return ; - xb := gtk_object_get_data(hdc,"viewport.x"); - yb := gtk_object_get_data(hdc,"viewport.y"); - img := class(TGdiplusflat).GdipGetbmpSurface(bm); - //cairo_set_source(hdc, img); - //cairo_pattern_set_extend(cairo_get_source(hdc),1); - cairo_set_source_surface(hdc, img, x-rc[0], y-rc[1]); - cairo_rectangle(hdc,xb+x,yb+y,rc[2]-rc[0],rc[3]-rc[1]); - if flag = 0x8800c6 or flag = 0x4 then - begin - //echo "\r\nset alopha***********"; - //cairo_paint_with_alpha(hdc,0.5); - //cairo_set_source_rgba(hdc, 0.6, 0.6, 0.6, 0.5); - end else - begin - //cairo_paint_with_alpha(hdc,0); - //cairo_paint_with_alpha(hdc,1); - //cairo_set_source_rgba(hdc, 1.0, 1.0, 1.0, 0); - //cairo_fill(hdc); - end - cairo_fill(hdc); - //cairo_set_source_surface(hdc, img, x-rc[0], y-rc[1]); - end - function drawbitmapstretchtodc(bm,hdc,drect,rc,flag,thdc); - begin - if not hdc then return ; - xb := gtk_object_get_data(hdc,"viewport.x"); - yb := gtk_object_get_data(hdc,"viewport.y"); - img := class(TGdiplusflat).GdipGetbmpSurface(bm); - if not img then return ; - x := drect[0]; - y := drect[1]; - p1 := (drect[2]-drect[0])/(rc[2]-rc[0]); - p2 := (drect[3]-drect[1])/(rc[3]-rc[1]); - if p1<0 or p2<0 then return 0; - cairo_translate(hdc,xb+x,yb+y); - cairo_scale(hdc,p1,p2); - cairo_set_source_surface(hdc, img, 0, 0); - cairo_rectangle(hdc,0,0,rc[2]-rc[0],rc[3]-rc[1]); - if flag = 0x8800c6 or flag = 0x4 then - begin - //echo "\r\nset alopha*******+++****************"; - //cairo_paint_with_alpha(hdc,0.5); - //cairo_set_source_rgba(hdc, 0.6, 0.6, 0.6, 0.5); - end else - begin - //cairo_paint_with_alpha(hdc,0); - //cairo_paint_with_alpha(hdc,1); - //cairo_set_source_rgba(hdc, 1.0, 1.0, 1.0, 0); - - end - cairo_fill(hdc); - cairo_scale(hdc,1/p1,1/p2); - cairo_translate(hdc,0-xb-x,0-yb-y); - end - function DrawIcon(hDC:pointer;X:integer;Y:integer;hIcon:pointer):integer; - begin - if not hdc then return ; - xb := gtk_object_get_data(hdc,"viewport.x"); - yb := gtk_object_get_data(hdc,"viewport.y"); - img := class(TGdiplusflat).GdipGetbmpSurface(hIcon); - if not img then return 0; - cairo_set_source_surface(hdc, img, x+xb, y+yb); - cairo_paint(hdc); - return true; - end - //////////////////////imagelist///////////////////////////////////////////////////////////////////////// - function ImageList_Add(himl:pointer;hbmImage:pointer; hbmMask:pointer):integer; - begin - if not(himl>0 or himl<0) then return 0; - if not(hbmImage>0 or hbmImage<0) then return 0; - global g_image_list_caches ; - if not ifarray(g_image_list_caches) then g_image_list_caches := array(); - sptr := inttostr(himl); - obj := g_image_list_caches[sptr,"imglist"] ; - if not obj then return ; - class(TGdiplusflat).GdipCreateBitmapFromHBITMAP(hbmImage,r1,0); - bmp := new TBitmap(); - bmp.Handle := r1; - obj.Push(bmp); - end - function ImageList_AddMasked(himl:pointer;hbmImage:pointer; crMask:integer):integer; - begin - return ImageList_Add(himl,hbmImage,crMask); - end - function ImageList_BeginDrag(himlTrack:pointer; iTrack:integer;x:integer;y:integer):integer; - begin - global g_gtk_drag_window,g_image_list_caches,g_gtk_dragxy ; - if not ifarray(g_image_list_caches) then return ; - if not(himlTrack>0 or himlTrack<0) then return ; - sptr := inttostr(himlTrack); - if not g_gtk_drag_window then - begin - g_gtk_drag_window := new TCustomControl(getapplication()); - g_gtk_drag_window.color := rgb(180,180,180); - g_gtk_drag_window.Border := false; - g_gtk_drag_window.WsPopUp := true; - g_gtk_drag_window.Enabled := false; - g_gtk_drag_window.Visible := false; - end - cx := g_image_list_caches[sptr,"width"] ; - cy := g_image_list_caches[sptr,"height"] ; - obj := g_image_list_caches[sptr,"imglist"] ; - if not(cx>0 and cy>0) then return ; - if obj then - begin - g_gtk_drag_window.BKBitmap := obj[i]; - cx+=2; - cy+=2; - end - g_gtk_drag_window.SetBounds(0,0,cx,cy); - g_gtk_dragxy := array(x,y); - end - function ImageList_DragMove(x:integer;y:integer):integer; - begin - global g_gtk_drag_window,g_gtk_drag_lock_window,g_gtk_dragxy; - if not g_gtk_drag_window then return ; - xy := g_gtk_drag_lock_window.ClientToScreen(x,y); - SetWindowPos(g_gtk_drag_window.Handle,0,xy[0]-g_gtk_dragxy[0],xy[1]-g_gtk_dragxy[1],-1,-1,0); - end - function ImageList_DragEnter(hwndLock:pointer;x:integer;y:integer):integer; - begin - global g_gtk_drag_window,g_gtk_drag_lock_window; - if not g_gtk_drag_window then return ; - g_gtk_drag_lock_window := class(TGlobalComponentcache).getwndbyhwnd(hwndLock); - if not g_gtk_drag_lock_window then return ; - g_gtk_drag_window.Parent := g_gtk_drag_lock_window; - g_gtk_drag_window.Enabled := false; - ImageList_DragMove(x,y); - g_gtk_drag_window.show( 0x4); - end - function ImageList_DragLeave(hwndLock:pointer):integer; - begin - global g_gtk_drag_window,g_gtk_drag_lock_window; - g_gtk_drag_lock_window := nil; - if not g_gtk_drag_window then return ; - g_gtk_drag_window.show(0); - end - procedure ImageList_EndDrag(); - begin - //global g_gtk_drag_window; - //g_gtk_drag_window.show(0); - end - function ImageList_Create(cx:integer; cy:integer; flags:integer; cInitial:integer;cGrow:integer):pointer; - begin - global g_image_list_caches ; - if not ifarray(g_image_list_caches) then g_image_list_caches := array(); - ptr := new tcstring(8)._getptr_(); - sptr := inttostr(ptr); - g_image_list_caches[sptr,"width"] := cx; - g_image_list_caches[sptr,"height"] := cy; - g_image_list_caches[sptr,"flags"] := flags; - g_image_list_caches[sptr,"initial"] := cInitial; - g_image_list_caches[sptr,"grow"] := cGrow; - g_image_list_caches[sptr,"imglist"] := new TMyArrayB(); - return ptr; - end - function ImageList_Draw(himl:pointer;i:integer;hdcDst:pointer;x:integer;y:integer;fStyle:integer):integer; - begin - if not(himl>0 or himl<0) then return 0; - global g_image_list_caches ; - if not ifarray(g_image_list_caches) then return 0; - sptr := inttostr(himl); - obj := g_image_list_caches[sptr,"imglist"]; - if not obj then return ; - bmp := obj[i]; - if not bmp then return ; - cx := g_image_list_caches[sptr,"width"]; - cy := g_image_list_caches[sptr,"height"]; - drawbitmapstretchtodc(bmp.Handle,hdcDst,array(x,y,x+cx,y+cy),array(0,0,bmp.bmwidth,bmp.bmheight),fStyle,0); - end - function ImageList_Destroy(himl:pointer):integer; - begin - if not(himl>0 or himl<0) then return 0; - global g_image_list_caches ; - if not ifarray(g_image_list_caches) then return 0; - reindex(g_image_list_caches,array(inttostr(himl):nil)); - end - function ImageList_Replace(himl:pointer;id:integer;hbmImage:pointer; hbmMask:pointer):integer; - begin - if not(himl>0 or himl<0) then return 0; - if not(hbmImage>0 or hbmImage<0) then return 0; - global g_image_list_caches ; - if not ifarray(g_image_list_caches) then return 0; - obj := g_image_list_caches[inttostr(himl),"imglist"]; - if not obj then return ; - class(TGdiplusflat).GdipCreateBitmapFromHBITMAP(hbmImage,0,r1); - bmp := new TBitmap(); - bmp.Handle := r1; - if id=-1 then obj.Push(bmp); - else - obj.splice(id,1,bmp); - end - function ImageList_Remove(himl:pointer;id:integer):integer; - begin - if not(himl>0 or himl<0) then return 0; - global g_image_list_caches ; - if not ifarray(g_image_list_caches) then return 0; - obj := g_image_list_caches[inttostr(himl),"imglist"]; - if not obj then return ; - if id=-1 then obj.pop(); - else - obj.splice(id,1); - end - function ImageList_SetBkColor(himl:pointer;clrBk:integer):integer; - begin - - end - function ImageList_LoadImageA2(hi:pointer;lpbmp:pointer;cx:integer;cGrow:integer; crMask:integer;uType:integer;uFlags:integer):pointer; - begin - - end - function ImageList_GetBkColor(himl:pointer):integer; - begin - - end - function ImageList_GetDragImage(ppt:pointer;pptHotspot:pointer):pointer; - function ImageList_GetImageCount(himl:pointer):integer; - begin - if not(himl>0 or himl<0) then return 0; - global g_image_list_caches ; - if not ifarray(g_image_list_caches) then return 0; - obj := g_image_list_caches[inttostr(himl),"imglist"]; - if not obj then return 0; - return obj.length(); - end - function ImageList_SetImageCount(himl:pointer;clrBk:integer):integer; - function ImageList_Copy(himlDst:pointer;iDst:integer; himlSrc:pointer;iSrc:integer;uFlags:integer):integer; - function ImageList_Duplicate(himl:pointer):pointer; - function ImageList_Merge(himl1:pointer;i1:integer;himl2:pointer;i2:integer;dx:integer;dy:integer):pointer; - function ImageList_SetDragCursorImage(himlDrag:pointer;iDrag:integer;dxHotspot:integer;dyHotspot:integer):integer; - function ImageList_GetImageInfo(himl:pointer; i:integer;pImageInfo:pointer):integer; - begin - - end - function ImageList_ReplaceIcon(himl:pointer;i:integer;hicon:pointer):integer; - begin - return ImageList_Replace(himl,i,hicon,0); - end - function ImageList_SetIconSize(himl:pointer;cx:integer;cy:integer):integer; - function ImageList_GetIconSize(himl:pointer;var cx:integer;var cy:integer):integer; - begin - global g_image_list_caches ; - if not ifarray(g_image_list_caches) then return 0; - sptr := inttostr(himl); - cx := g_image_list_caches[sptr,"width"]; - cy := g_image_list_caches[sptr,"height"]; - return 1; - end - function ImageList_GetIcon(himl:pointer;i:integer;flags:integer):pointer; - begin - if not(himl>0 or himl<0) then return 0; - global g_image_list_caches ; - if not ifarray(g_image_list_caches) then return 0; - obj := g_image_list_caches[inttostr(himl),"imglist"]; - if not obj then return ; - r := obj[i]; - if r then return r.Handle; - return 1; - end - function ImageList_DrawIndirect(pimldp:pointer):pointer; - function ImageList_DragShowNolock(fShow:integer):integer; - ////////////////////////////////////////////////////// - ////////////////////////clipboard//////////////////////////////////////// -function OpenClipboard(h); -begin - return true; -end -function EmptyClipboard(); -begin - -end -function CloseClipboard(); -begin - return true; -end -function IsClipboardFormatAvailable(fmt); -begin - return true; -end -function getclipboardtext(clpd); -begin - c := gtk_clipboard_get(69); - r := gtk_clipboard_wait_for_text(c); - if r then r := GtkStringToTsl(r); - //echo "\r\ncop wire:",writefile(rwraw(),"","/tmp/test12.txt",0,length(r),r); - - return r; -end -function setclipboardtext(clbd,s); -begin - c := gtk_clipboard_get(69); - if ifstring(s) and s then - begin - gs := TslStringToGtk(s); - return gtk_clipboard_set_text(c,gs,length(gs)); - end else - if ifnil(s) then gtk_clipboard_set_text(c,"",0); - return 1; -end -function getclipboardbmp(); -begin - return 0; -end -function setclipboardbmp(); -begin - return false; -end -//////////////////////////////////////end clip board ////////////////////////////////// - -//////////////////////////////timmer////////////////// - class function SetTimer(hWnd:pointer; nIDEvent:pointer; uElapse:integer;lpTimerFunc:pointer):integer; - begin - global g_gtk_ttimer_cache; - if not ifarray(g_gtk_ttimer_cache) then g_gtk_ttimer_cache := array(); - sc := array( - (0,"int",0), - (1,"int",0)); - obj := tslcstructure(sc); - - rt := g_timeout_add(uElapse,lpTimerFunc,obj._getptr_() ); - g_gtk_ttimer_cache[rt] := obj; - obj._setvalue_(0,rt); - return rt; - - end - class function KillTimer(hWnd:pointer; nIDEvent:pointer):integer; - begin - global g_gtk_ttimer_cache; - if not ifarray(g_gtk_ttimer_cache) then return 0; - obj := g_gtk_ttimer_cache[nIDEvent] ; - g_source_remove(obj._getvalue_(0)); - reindex(g_gtk_ttimer_cache,array(nIDEvent:nil)); - return true; - end - //////////////////////////////////////////////////////////////////// - type TtagOFNA_ = class(tslcstructureobj) - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate( - array( - ("lstructsize","int",152), - ("hwndowner","intptr",0), - ("hinstance","intptr",0), - ("lpstrfilter","intptr",0), - ("lpstrcustomfilter","intptr",0), - ("nmaxcustfilter","int",0), - ("nfilterindex","int",1), - ("lpstrfile","intptr",2049), - ("nmaxfile","int",2048), - ("lpstrfiletitle","intptr",512), - ("nmaxfiletitle","int",511), - ("lpstrinitialdir","intptr",0), - ("lpstrtitle","intptr",0), - ("flags","int",0), //6148 - ("nfileoffset","byte[2]",(0,0)), - ("nfileextension","byte[2]",(0,0)), - ("lpstrdefext","intptr",0), - ("lcustdata","intptr",0), - ("lpfnhook","intptr",0), - ("lptemplatename","intptr",0), - ("pvreserved","intptr",0), - ("dwreserved","int",0), - ("flagsex","int",0))); - //lpstrdefext - return SSTRUCT; - end - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - end - function GetOpenFileNameA(LPOPENFILENAMEA:pointer):integer; - begin - - r := GetSaveFileNameA(LPOPENFILENAMEA); - - return r; - end - function GetSaveFileNameA(LPOPENFILENAMEA:pointer):integer; - begin - global g_open_file_flag; - r := false; - obj := new TtagOFNA_(LPOPENFILENAMEA); - wd := obj._getvalue_("hwndowner"); - wd := wd?:nil; - if wd then wd := gtk_widget_get_toplevel(wd); - mulsel := false; - if obj._getvalue_("flags") .& 0x200 then mulsel := true; - //echo "\r\n>>>", obj._getvalue_("nmaxfiletitle"); - if mulsel then - begin - cdlg := gtk_file_chooser_dialog_new("file selector",wd,0,"open",100,"cancel",50,nil); - gtk_file_chooser_set_select_multiple(cdlg,true); - end else - begin - cdlg := gtk_file_chooser_dialog_new("file selector",wd,1,"open",100,"cancel",50,nil); - end - dfdir := obj._getvalue_("lpstrinitialdir"); - if dfdir then //默认位置 - begin - df := ReadStringFromPtr(dfdir); - if df then - begin - gtk_file_chooser_set_filename(cdlg,TslStringToGtk( df)); - end - end - if 100=gtk_dialog_run(cdlg)then - begin - mf := obj._getvalue_("nmaxfile"); - if mulsel then - begin - gfs := gtk_file_chooser_get_filenames(cdlg); - gf := ""; - ff1 := true; - fodpos := 0; - ffd := "/"; - while gfs do - begin - if mf1 then - ffd := dts[1:fodpos-1]; - else ffd := "/"; - gf :=ffd; - gf+="\0"; - end - if fodpos 1 then - begin - bts := ReadBytesFromPtr(obj._getvalue_("lpstrfilter"),obj._getvalue_("nmaxfiletitle")); - fndx := ""; - for i ,v in bts do - begin - if bts[i]=0 and bts[i+1]=0 then break; - fndx+=chr(bts[i]); - end - stp := str2array(fndx,"\0")[fidx*2-1]; - for i := length(stp) downto 1 do - begin - if stp[i] = "." then - begin - stype := stp[i:]; - end - end - for i := length(gf) downto 1 do - begin - gfi := gf[i]; - if gfi="/" then - begin - gf+=stype; - break; - end else - if gfi = "." then - begin - break; - end - end - end - end - if gf then - begin - gf := GtkStringToTsl( gf); - fptr := obj._getvalue_("lpstrfile"); - bts := zeros(length(gf)+1); - for i := 1 to length(gf) do - begin - bts[i-1] := ord(gf[i]); - end - WriteBytesToPtr(fptr,bts); - r := true; - end - end - gtk_widget_destroy(cdlg); - return r; - end - function ChooseFontA(LOGFONTA:pointer):integer; - begin - - obj := new ttagCHOOSEFONTA(LOGFONTA); - lgobj := obj._getvalue_("lplogfont"); - ht := lgobj._getvalue_("height"); - hts := ""; - if ht>5 then hts := inttostr(ht); - ss := lgobj._getvalue_("facename")+" "+(lgobj._getvalue_("italic")?"Italic":"")+" "+((lgobj._getvalue_("weight")=700)?"Bold":"") + " "+ hts;; - cdlg := gtk_font_selection_dialog_new("font select"); - gtk_font_selection_dialog_set_preview_text(cdlg,"test fonttext"); - gtk_font_selection_dialog_set_font_name(cdlg,TslStringToGtk(ss)); - if gtk_dialog_run(cdlg)=-5 then //确定 - begin - s := GtkStringToTsl( gtk_font_selection_dialog_get_font_name(cdlg)); - fns := static pango_font_family_get_names(); - for i,v in fns do - begin - if pos(v,s)=1 then - begin - lgobj._setvalue_("facename",GtkStringToTsl(v)); - if pos("Italic",s) then - begin - lgobj._setvalue_("italic",1); - end else - begin - lgobj._setvalue_("italic",0); - end - if pos("Bold",s) then - begin - lgobj._setvalue_("weight",700); - end else - begin - lgobj._setvalue_("weight",400); - end - nms := inttostr(0->9); - for j := 1 to length(s) do - begin - if s[j] in nms then - begin - nm := s[j]; - for jj:= j+1 to length(s) do - begin - if s[jj] in nms then - begin - nm+=s[jj]; - end else break; - end - break; - end - end - if nm then - begin - ht := strtoint(nm); - lgobj._setvalue_("height",ht); - lgobj._setvalue_("width",integer(ht/2)); - end - break; - end - end - r := true; - end - gtk_widget_destroy(cdlg); - return r; - end - function ChooseColorA(LOGFONTA:pointer):integer;//颜色选择 - begin - obj := new ttagCHOOSECOLORA(LOGFONTA); - cdlg := gtk_color_selection_dialog_new("color select dialog"); - btnptr := tsl_gtk_color_selection_property(cdlg); //获得位置 - cpbtns := tslcstructure(array((0,"intptr",0)),nil,nil,btnptr); - cbtnobj := cpbtns._getvalue_(0); - color := new _GdkColor(); - rc := obj.rgbresult ; - rcs := array(getrvalue(rc),getgvalue(rc),getbvalue(rc)); - color.setrgb((_shl( rcs[0],8)),(_shl(rcs[1],8)),(_shl( rcs[2],8))); - gtk_color_selection_set_current_color(cbtnobj,color._getptr_()); - r := gtk_dialog_run(cdlg); - //rt := Gtk_dlg_get_response_name_by_id(r); - gtk_color_selection_get_current_color(cbtnobj,color._getptr_()); - obj.rgbresult := rgb( _shr(color.r,8),_shr(color.g,8),_shr(color.b,8)); - gtk_widget_destroy(cdlg); - return r=-5; - end - - type TBrowseinfoA_ = class(tslcstructureobj) - {** - @explan(说明)文件夹选择结构 %% - **} - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate( - array( - ("hwndowner","intptr",0), - ("pidlroot","intptr",0), - ("pszdisplayname","intptr",0), - ("lpsztitle","intptr",0), - ("ulflags","int",0), - ("lpfn","intptr",0), - ("lparam","intptr",0), - ("iimage","int",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - - end - end - function SHBrowseForFolderA(LPITEMIDLIST:pointer):pointer; - begin - obj := new TBrowseinfoA_(LPITEMIDLIST); - wd := obj._getvalue_("hwndowner"); - wd := wd?:nil; - if wd and not(gtk_widget_is_toplevel(wd)) then wd := gtk_widget_get_toplevel(wd); //top level - r := 0; - cdlg := gtk_file_chooser_dialog_new("folder selector",wd,3,"open",100,"cancel",50,nil); - dir := obj._getvalue_("pidlroot"); - if dir then //默认位置 - begin - df := ReadStringFromPtr(dir); - if df then - begin - gtk_file_chooser_set_filename(cdlg,TslStringToGtk( df)); - end - end - if 100=gtk_dialog_run(cdlg) then - begin - r := GtkStringToTsl( gtk_file_chooser_get_filename(cdlg)); - end - gtk_widget_destroy(cdlg); - return r; - - end - function SHGetPathFromIDListA(LPBROWSEINFOA:pointer;var buf:string ):integer; - begin - for i := 1 to length(LPBROWSEINFOA) do - begin - buf[i] := LPBROWSEINFOA[i]; - end - buf[i+1] := 0; - return true; - end - function ILCreateFromPathA(pszPath:string):pointer; - begin - mt := static new aefclassobj_(); - len := length(pszPath)+1; - bts := zeros(n); - for i:= 1 to len-1 do bts[i-1] :=ord(pszPath[i]); - r := mt.tmalloc(len); - WriteBytesToPtr(r,bts); - return r; - end - procedure ILFree(pidl:pointer); - begin - mt := static new aefclassobj_(); - mt.tfree(pidl); - end - //caret 插入符号 处理 - function CreateCaret(hWnd :pointer;hBitmap:pointer;nWidth:integer;nHeight:integer):integer; - begin - if not(hwnd>0 or hwnd<0) then return 0; - global g_gtk_caret_cache_timer; //缓存 - if not g_gtk_caret_cache_timer then - begin - g_gtk_caret_cache_timer := new TTimer(); - g_gtk_caret_cache_timer.Interval := 680; - g_gtk_caret_cache_timer.Ontimer := function(o,e)begin - global g_current_get_focus_widget; - h := g_current_get_focus_widget; - if not h then return ; - if not g_object_get_data(h,"caretshow") then return ; - ct := g_object_get_data(h,"gtk_window_caret"); - //if not gtk_widget_is_visible(ct) then gtk_widget_show(ct); - //return ; - if gtk_widget_is_visible(ct) then gtk_widget_hide(ct); - else - gtk_widget_show(ct); - end - g_gtk_caret_cache_timer.start(); - end - h := g_object_get_data(hwnd,"gtk_window_caret"); //获得caret - if not h then - begin - h := gtk_event_box_new(); - c := new _GdkColor(nil); - c.SetRgb(0,0,0); - gtk_widget_modify_bg(h,0,c._getptr_()); - gtk_widget_hide(h); - lot := g_object_get_data(hWnd,"gtk_layout"); - g_object_set_data(hwnd,"gtk_window_caret",h); - //g_object_set_data(h,"gtk_caret_window",hwnd); //所属窗口 - gtk_layout_put(lot,h,0,0); //位置 - end - if nWidth>=0 and nHeight>=0 then - gtk_widget_set_size_request(h,nWidth,nHeight); - //g_gtk_caret_cache_caret := h; - return h; - end - function DestroyCaret():integer; - begin - global g_current_get_focus_widget; - hwnd := g_current_get_focus_widget; - if not(hwnd>0 or hwnd<0) then return ; - if not IsGtkWidget(hwnd) then return ; - g_object_set_data(hwnd,"caretshow",0); - ct := g_object_get_data(hwnd,"gtk_window_caret"); - if IsGtkWidget(ct) then - begin - gtk_widget_hide(ct); - end - return ; - // 获得focus - end - function SetCaretPos(x:integer;y:integer):integer; - begin - global g_current_get_focus_widget; - hwnd := g_current_get_focus_widget; - if IsGtkWidget(hwnd) then - begin - lot := g_object_get_data(hwnd,"gtk_layout"); - crt := g_object_get_data( hwnd,"gtk_window_caret"); - if lot and crt then - begin - gtk_layout_move(lot,crt,x,y); - gtk_object_set_data(hwnd,"caret_x_pos",x); - gtk_object_set_data(hwnd,"caret_y_pos",y); - end - - end - return ; - end - function GetCaretPos(lp:array of integer):integer; - begin - global g_current_get_focus_widget; - hwnd := g_current_get_focus_widget; - if IsGtkWidget(hwnd) then - begin - x := gtk_object_get_data(hwnd,"caret_x_pos"); - y := gtk_object_get_data(hwnd,"caret_y_pos"); - lp := array(x,y); - end - lp := array(0,0); - return ; - end - function HideCaret(hwnd :pointer):integer; - begin - // 获得focus widget - if not(hwnd>0 or hwnd<0) then return ; - if not IsGtkWidget(hwnd) then return ; - ct := g_object_get_data(hwnd,"gtk_window_caret"); - g_object_set_data(hwnd,"caretshow",0); - if IsGtkWidget(ct) then - begin - gtk_widget_hide(ct); - end - return ; - end - - - function ShowCaret(hwnd :pointer):integer; - begin - if not(hwnd>0 or hwnd<0) then return ; - if not IsGtkWidget(hwnd) then return ; - g_object_set_data(hwnd,"caretshow",1); - return 1; - end - function GetCaretBlinkTime():integer; - begin - - end - function SetCaretBlinkTime(uMSeconds :integer):integer; - begin - - end - Function WinExec(lpCmdLine:string;nCmdShow:integer):integer; - begin - - end; - function SetForegroundWindow(hwd :pointer):integer; - begin - end - function Shell_NotifyIconA(dwMessage:integer; lpData:pointer):integer; - begin - end - function BringWindowToTop(hwd :pointer); - begin - end - //socket - function socket(af:integer;tp:integer;protocol:integer):pointer;begin end - function WSAStartup(af:SHORT;DA:pointer):integer;begin end - function WSACleanup():integer;begin end - function htonl(hostlong:integer):integer;begin end - function htons(hostshort:short):short;begin end - function ntohs(hostshort:short):short;begin end - function bind(s:pointer;name:pointer;len:integer):integer;begin end - function accept(s:pointer;name:pointer;var len:integer):pointer;begin end - function send(s:pointer;bufer:string;len:integer;flag:integer):integer;begin end - function recv(s:pointer;var bufer:string;len:integer;flag:integer):integer;begin end - function listen(s:pointer;port:integer):integer;begin end - function closesocket(s:pointer):integer;begin end - function connect(s:pointer;name:pointer;len:integer):integer;begin end - function inet_addr(s:string):integer;begin end - function WSAGetLastError():integer;begin end - function inet_ntoa(ad:integer):string;begin end - function shutdown(s:pointer;how:integer):integer;begin end - function WSAAsyncSelect(s:pointer;hWnd:pointer;wMsg:integer;lEvent:integer):integer;begin end - function ioctlsocket(s:pointer;cmd:integer;var argp:integer):integer;begin end - function setsockopt(s:pointer;level:integer;optname:integer;optval:string;optlen:integer):integer;begin end - function getsockopt(s:pointer;level:integer;optname:integer;var optval:string;var optlen:integer):integer;begin end - - - {$else} - function openresourcemanager(p); //打开资源管理器 - begin - if ifstring(p) then - return WinExec('cmd.exe /C start "" "'+p,1); - end - ////////////////////////clipboar////////////////////// - function OpenClipboard(hwd :pointer):integer;stdcall;external "User32.dll" name "OpenClipboard"; - function EmptyClipboard():integer;stdcall;external "User32.dll" name "EmptyClipboard"; - function CloseClipboard():integer;stdcall;external "User32.dll" name "CloseClipboard"; - function SetClipboardData(uflags:integer;mem:pointer):pointer;stdcall;external "User32.dll" name "SetClipboardData"; - function GetClipboardData(uflags:integer):pointer;stdcall;external "User32.dll" name "GetClipboardData"; - function IsClipboardFormatAvailable(format:integer):integer;stdcall;external "User32.dll" name "IsClipboardFormatAvailable"; -function getclipboardtext(clpd); -begin - sid := GetClipboardData(0x7); - r := ReadStringFromPtr(sid); - return r; -end -function setclipboardtext(clbd,s); -begin - len := length(s); - hm := GlobalAlloc(2,len+1);//分配内容 - if hm <>0 then - begin - lm := GlobalLock(hm);//枷锁 - if lm <> 0 then - begin - memcpy(lm,s,len);//内存拷贝 - GlobalUnlock(hm);//解锁 - r := SetClipboardData(1,hm); - if r<>0 then - begin - ret := 1; - end - end - end - return ret; -end -function getclipboardbmp(); -begin - return GetClipboardData(0x2); - -end -function setclipboardbmp(bmp); -begin - r := SetClipboardData(0x2,bmp); - if r<>0 then - begin - ret := 1; - end - return ret; -end - -////////////////////////////////////////////////////////////////////////////////////////////////////// - class function AnsiToWidChar(c); - begin - if not ifstring(c) then return ""; - iSize := MultiByteToWideChar_a(0, 0, C , -1, "", 0); - if not(iSize>0) then return ""; - pwszUnicode := ""; - setlength(pwszUnicode,isize*2); //少减去2 - MultiByteToWideChar_a(0, 0, c , -1, pwszUnicode , iSize-1); - return pwszUnicode; - end - class function GetEncoderClsid(n:String;ed:pointer); - begin - r := tslvclgetencoderclsid(n,ed); - return r; - end; - //*********** - function GetDpiForMonitor(hmonitor:pointer; dpiType:integer;var dpiX:integer;var dpiY:integer):pointer;stdcall;external "Shcore.dll" name "GetDpiForMonitor"; - //Kernel32.dll - //进程和内存相关 - class function SetTimer(hWnd:pointer; nIDEvent:pointer; uElapse:integer;lpTimerFunc:pointer):integer;stdcall;external "User32.dll" name "SetTimer"; - class function KillTimer(hWnd:pointer; nIDEvent:pointer):integer;stdcall;external "User32.dll" name "KillTimer"; - - class function MultiByteToWideChar_a(CodePage:integer;dwFlags:integer;lpMultiByteStr:string;cbMultiByte:integer;var lpWideCharStr:string;cchWideChar:integer):integer;stdcall;external "Kernel32.dll" name "MultiByteToWideChar"; - class function GetModuleHandleA(name:pointer):pointer;stdcall;external "Kernel32.dll" name "GetModuleHandleA"; - class function GetComputerNameA(var lpBuffer:string;var nSize:integer):integer;stdcall;external "Kernel32.dll" name "GetComputerNameA"; - class function LoadLibraryA(txt:string):POINTER;stdcall;external "Kernel32.dll" name "LoadLibraryA"; - class function FreeLibrary(hd:pointer):integer;stdcall;external "Kernel32.dll" name "FreeLibrary"; - class function GetLastError():integer;stdcall;external "Kernel32.dll" name "GetLastError"; - class function GetEnvironmentVariableA(lpName:string;lpBuffer:string;nSize:integer):integer;stdcall;external "Kernel32.dll" name "GetEnvironmentVariableA"; - class function SetEnvironmentVariableA(lpName:string; lpValue:string):integer;stdcall;external "Kernel32.dll" name "SetEnvironmentVariableA"; - class function GetLogicalDriveStringsA(BUFSIZE:integer; szLogicDriveStrings:string):integer;stdcall;external "Kernel32.dll" name "GetLogicalDriveStringsA"; - class function GetDiskFreeSpaceExA(lpDirectoryName:string;var lpFreeBytesAvailableToCaller:int64;var lpTotalNumberOfBytes:int64;var lpTotalNumberOfFreeBytes:int64):integer;stdcall ;external "Kernel32.dll" name "GetDiskFreeSpaceExA"; - function GlobalAlloc(uFlags :integer;dwBytes:integer):pointer;stdcall;external "Kernel32.dll" name "GlobalAlloc"; - function CreateStreamOnHGlobal(hGlobal:pointer;fDeleteOnRelease:integer; var ppstm:pointer):pointer;stdcall;external "Ole32.dll" name "CreateStreamOnHGlobal"; - function GetHGlobalFromStream(pstm:pointer; var phglobal:pointer):pointer;stdcall;external "Ole32.dll" name "GetHGlobalFromStream"; - function GlobalLock(mem :pointer):pointer;stdcall;external "Kernel32.dll" name "GlobalLock"; - function GlobalUnlock(mem :pointer):integer;stdcall;external "Kernel32.dll" name "GlobalUnlock"; - function GlobalSize(menm:pointer):integer;stdcall;external "Kernel32.dll" name "GlobalSize"; - function GetStartupInfoA(lpStartupInfo:pointer):integer;stdcall ;external "Kernel32.dll" name "GetStartupInfoA" ; - function GetExitCodeProcess(hProcess:pointer;var lpExitCode:integer):integer;stdcall ;external "Kernel32.dll" name "GetExitCodeProcess" ; - function CreateProcessA(lpApplicationName:string;lpCommandLine:string;lpProcessAttributes:pointer; - lpThreadAttributes:pointer;bInheritHandles:integer;dwCreationFlags:integer;lpEnvironment:pointer; - lpCurrentDirectory:string;lpStartupInfo:pointer; - lpProcessInformation:pointer):integer;stdcall ;external "Kernel32.dll" name "CreateProcessA" ; - function CreatePipe(var hReadPipe:pointer;var hWritePipe : pointer; - lpPipeAttributes:pointer;nSize:integer):integer;stdcall;external "Kernel32.dll" name "CreatePipe"; - function PeekNamedPipe(hNamedPipe:pointer;var lpBuffer:string; nBufferSize:integer; var lpBytesRead:integer; - varlpTotalBytesAvail:integer;var lpBytesLeftThisMessage:integer):integer;stdcall;external "Kernel32.dll" name "PeekNamedPipe"; - function GetStdHandle(nStdHandle:integer):pointer;stdcall;external "Kernel32.dll" name "GetStdHandle"; - function SetStdHandle(nStdHandle:integer;hHandle:pointer):integer;stdcall;external "Kernel32.dll" name "SetStdHandle"; - function CreateFileA(var lpFileName:string;dwDesiredAccess:integer; - dwShareMode:integer;lpSecurityAttributes:pointer;dwCreationDisposition:integer; - dwFlagsAndAttributes:integer;hTemplateFile:pointer):pointer;stdcall;external "Kernel32.dll" name "CreateFileA"; - function WriteFile(hFile:pointer; lpBuffer:pointer;nNumberOfBytesToWrite:integer;var lpNumberOfBytesWritten:integer; lpOverlapped:pointer):integer;stdcall;external "Kernel32.dll" name "WriteFile"; - function WriteFile2(hFile:pointer; var lpBuffer:string;nNumberOfBytesToWrite:integer;var lpNumberOfBytesWritten:integer; lpOverlapped:pointer):integer;stdcall;external "Kernel32.dll" name "WriteFile"; - function ReadFile__(hFile:pointer;var lpBuffer:string;nNumberOfBytesToRead:integer;var lpNumberOfBytesRead:integer;pOverlapped:pointer):integer;stdcall;external "Kernel32.dll" name "ReadFile"; - function OpenProcess(dwDesiredAccess:integer;bInheritHandle:integer;dwProcessId:integer):pointer;stdcall;external "Kernel32.dll" name "OpenProcess"; - function GetHandleInformation(hObject:pointer;var lpdwFlags:integer):integer;stdcall;external "Kernel32.dll" name "GetHandleInformation"; - function CloseHandle(hObject:pointer):integer;stdcall ;external "Kernel32.dll" name "CloseHandle" ; - function _lclose(hObject:pointer):pointer;stdcall ;external "Kernel32.dll" name "_lclose" ; - function CreateToolhelp32Snapshot(dwFlags:integer;th32ProcessID:integer):pointer;stdcall;external "Kernel32.dll" name "CreateToolhelp32Snapshot"; - function Process32First(hSnapshot:pointer;lppe:pointer):integer;stdcall;external "Kernel32.dll" name "Process32First"; - function Process32Next(hSnapshot:pointer; lppe:pointer):integer;stdcall;external "Kernel32.dll" name "Process32Next"; - function Module32First(hSnapshot:pointer;lpme:pointer):integer;stdcall;external "Kernel32.dll" name "Module32First"; - function Module32Next(hSnapshot:pointer; lppe:pointer):integer;stdcall;external "Kernel32.dll" name "Module32Next"; - function GetCurrentDirectoryA(nBufferLength:integer; var lpBuffer:string):integer;stdcall;external "Kernel32.dll" name "GetCurrentDirectoryA"; - function SetCurrentDirectoryA(lpPathName:string):integer;stdcall;external "Kernel32.dll" name "SetCurrentDirectoryA"; - Function WinExec(lpCmdLine:string;nCmdShow:integer):integer;stdcall; external "kernel32.dll" name "WinExec" ; - function GetDriveTypeA(lpRootPathName:string):integer;stdcall; external "kernel32.dll" name "GetDriveTypeA" ; - (* - DRIVE_UNKNOWN = 0; {未知} - DRIVE_NO_ROOT_DIR = 1; {可移动磁盘} - DRIVE_REMOVABLE = 2; {软盘} - DRIVE_FIXED = 3; {本地硬盘} - DRIVE_REMOTE = 4; {网络磁盘} - DRIVE_CDROM = 5; {CD-ROM} - DRIVE_RAMDISK = 6; {RAM 磁盘} - *) - function EnumProcesses_(var lpidProcess:array of integer;cb:integer; var lpcbNeeded:integer):integer;stdcall;external "Kernel32.dll" name "K32EnumProcesses"; - function GetModuleFileNameExA(hProcess:pointer; hModule:pointer;var lpFilename:string;nSize:integer):integer;stdcall;external "Kernel32.dll" name "K32GetModuleFileNameExA"; - function QueryFullProcessImageNameA(hProcess:pointer; dwFlags:integer;var lpFilename:string;var nSize:integer):integer;stdcall;external "Kernel32.dll" name "QueryFullProcessImageNameA"; - function GetCurrentProcess():pointer;stdcall;external "Kernel32.dll" name "GetCurrentProcess"; - function OpenProcessToken(ProcessHandle:pointer;DesiredAccess:integer; var TokenHandle:pointer):integer;stdcall;external "Advapi32.dll" name "OpenProcessToken"; - //SeDebugPrivilege - function LookupPrivilegeValueA(var PolicyHandle:string;var Name:string; lpLuid:pointer):integer;stdcall;external "Advapi32.dll" name "LookupPrivilegeValueA"; - function AdjustTokenPrivileges(TokenHandle:pointer; DisableAllPrivileges:integer; NewState:pointer ; BufferLength:integer; - PreviousState:pointer; ReturnLength:pointer):integer;stdcall;external "Advapi32.dll" name "AdjustTokenPrivileges"; - //Snapshot from Psapi.lib – WinSDK V7.0* - (* #if (PSAPI_VERSION > 1) - #define EnumProcesses K32EnumProcesses - #define EnumProcessModules K32EnumProcessModules - #define EnumProcessModulesEx K32EnumProcessModulesEx - #define GetModuleBaseNameA K32GetModuleBaseNameA - #define GetModuleBaseNameW K32GetModuleBaseNameW - #define GetModuleFileNameExA K32GetModuleFileNameExA - #define GetModuleFileNameExW K32GetModuleFileNameExW - #define GetModuleInformation K32GetModuleInformation - #define EmptyWorkingSet K32EmptyWorkingSet - #define QueryWorkingSet K32QueryWorkingSet - #define QueryWorkingSetEx K32QueryWorkingSetEx - #define InitializeProcessForWsWatch K32InitializeProcessForWsWatch - #define GetWsChanges K32GetWsChanges - #define GetWsChangesEx K32GetWsChangesEx - #define GetMappedFileNameW K32GetMappedFileNameW - #define GetMappedFileNameA K32GetMappedFileNameA - #define EnumDeviceDrivers K32EnumDeviceDrivers - #define GetDeviceDriverBaseNameA K32GetDeviceDriverBaseNameA - #define GetDeviceDriverBaseNameW K32GetDeviceDriverBaseNameW - #define GetDeviceDriverFileNameA K32GetDeviceDriverFileNameA - #define GetDeviceDriverFileNameW K32GetDeviceDriverFileNameW - #define GetProcessMemoryInfo K32GetProcessMemoryInfo - #define GetPerformanceInfo K32GetPerformanceInfo - #define EnumPageFilesW K32EnumPageFilesW - #define EnumPageFilesA K32EnumPageFilesA - #define GetProcessImageFileNameA K32GetProcessImageFileNameA - #define GetProcessImageFileNameW K32GetProcessImageFileNameW - #endif *) - - - - //定时器 - //function SetClassLongA(hWnd:pointer; nIDEvent:pointer):integer;stdcall;external "User32.dll" name " SetClassLongA"; - function GetDpiFromDpiAwarenessContext(v:pointer):integer;stdcall;external "User32.dll" name "GetDpiFromDpiAwarenessContext"; - function GetDpiForWindow(hwnd:pointer):integer;stdcall;external "User32.dll" name "GetDpiForWindow"; - function GetMonitorInfoA(hMonitor:pointer;lpmi:pointer):integer;stdcall;external "User32.dll" name "GetMonitorInfoA"; - function MonitorFromWindow(hwnd:pointer;dwFlags:integer):pointer;stdcall;external "User32.dll" name "MonitorFromWindow"; - function GetSysColor(idx:integer):integer;;stdcall;external "User32.dll" name "GetSysColor"; - function SystemParametersInfoA(uiAction:integer;uiParam:integer; pvParam:pointer; fWinIni:integer):integer;stdcall;external "User32.dll" name "SystemParametersInfoA"; - - //双击间隔 - function SetDoubleClickTime(it:integer):integer;stdcall;external "User32.dll" name "SetDoubleClickTime"; - function GetDoubleClickTime():integer;stdcall;external "User32.dll" name "GetDoubleClickTime"; - //热键 - function RegisterHotKey(hWnd:pointer;id:integer; fsModifiers:integer; vk:integer):integer;stdcall;external "User32.dll" name "RegisterHotKey"; - function UnregisterHotKey(hWnd:pointer;id:integer):integer;stdcall;external "User32.dll" name "UnregisterHotKey"; - function MapVirtualKeyA(uCode:integer; uMapType:integer):integer;stdcall;external "User32.dll" name "MapVirtualKeyA"; - function GetKeyNameTextA(lParam:integer;var lpString:string;cchSize:integer):integer;stdcall;external "User32.dll" name "GetKeyNameTextA"; - - //窗口相关 - class function FindWindowA(lpClassName:string;lpWindowName:string):pointer;stdcall;external "User32.dll" name "FindWindowA"; - class function GetForegroundWindow():pointer;stdcall;external "User32.dll" name "GetForegroundWindow"; - class function GetActiveWindow():pointer;stdcall;external "User32.dll" name "GetActiveWindow"; - class function SetActiveWindow(h:pointer):pointer;stdcall;external "user32.dll" name "SetActiveWindow"; - function UpdateLayeredWindow(hWnd:pointer;hdcDst:pointer;pptDst:pointer;psize:pointer;hdcSrc:pointer;pptSrc:pointer; crKey:integer;pblend:pointer; dwFlags:pointer):integer;stdcall;external "User32.dll" name "UpdateLayeredWindow"; - function GetFocus():pointer;stdcall;external "User32.dll" name "GetFocus"; - function SetLayeredWindowAttributes(hwnd:pointer;crKey:integer;bAlpha:byte;dwFlags:integer):integer;stdcall;external "User32.dll" name "SetLayeredWindowAttributes"; - class function IsWindow(hd:pointer):integer;stdcall;external "User32.dll" name "IsWindow"; - class function IsWindowVisible(hd:pointer):integer;stdcall;external "User32.dll" name "IsWindowVisible"; - function GetWindow(hd:pointer;cd:integer):pointer;stdcall;external "User32.dll" name "GetWindow"; - function GetNextWindow(hd:pointer;cd:integer):pointer;stdcall;external "User32.dll" name "GetNextWindow"; - function GetTopWindow(hd:pointer):pointer;stdcall;external "User32.dll" name "GetTopWindow"; - function IsChild(hd:pointer;cd:pointer):integer;stdcall;external "User32.dll" name "IsChild"; - function RegisterClassExA(wc:pointer):short;stdcall;external "User32.dll" name "RegisterClassExA"; - function EnableWindow(wc:pointer;b:integer):integer;stdcall;external "User32.dll" name "EnableWindow"; - //窗口操作 - function ShowWindow(hwd :pointer;f:integer):integer;stdcall;external "User32.dll" name "ShowWindow"; - function BringWindowToTop(hwd :pointer):integer;stdcall;external "User32.dll" name "BringWindowToTop"; - function SetForegroundWindow(hwd :pointer):integer;stdcall;external "User32.dll" name "SetForegroundWindow"; - function SetWindowPos(wd:pointer;hWndInsertAfter:pointer; - X:integer; Y:integer; cx:integer;cy:integer; uFlags:integer):pointer;stdcall;external "User32.dll" name "SetWindowPos"; - function MoveWindow(wd:pointer; X:integer; Y:integer; cx:integer;cy:integer; bRepaint:integer):pointer;stdcall;external "User32.dll" name "MoveWindow"; - //窗口大小 - function GetClientRect(hwnd :pointer;var rec:array of integer):integer;stdcall;external "User32.dll" name "GetClientRect"; - function GetWindowRect(hwnd :pointer;var rec:array of integer):integer;stdcall;external "User32.dll" name "GetWindowRect"; - function GetWindowInfo(hwnd :pointer;f:pointer):integer;stdcall;external "User32.dll" name "GetWindowInfo"; - - function GetSystemMetrics(ndx :integer):integer;stdcall;external "User32.dll" name "GetSystemMetrics"; - function ClientToScreen(hwnd :pointer;var p:array of integer):integer;stdcall;external "User32.dll" name "ClientToScreen"; - function ScreenToClient(hwnd :pointer;var p:array of integer):integer;stdcall;external "User32.dll" name "ScreenToClient"; - - function GetParent(hwnd :pointer):pointer;stdcall;external "User32.dll" name "GetParent"; - function SetParent(hwnd :pointer;phwnd:pointer):pointer;stdcall;external "User32.dll" name "SetParent"; - function UpdateWindow(hwnd :pointer):integer;stdcall;external "User32.dll" name "UpdateWindow"; - function GetUpdateRect(hWnd:pointer; var lpRect:array of integer;bErase:integer):integer;stdcall;external "User32.dll" name "GetUpdateRect"; - function InvalidateRect(hwnd :pointer;rec:array of integer;f:integer):integer;stdcall;external "User32.dll" name "InvalidateRect"; - function InvalidateRect2(hwnd :pointer;rec:pointer;f:integer):integer;stdcall;external "User32.dll" name "InvalidateRect"; - function ValidateRect(hwnd :pointer;rec:array of integer):integer;stdcall;external "User32.dll" name "ValidateRect"; - function SetFocus(hwnd :pointer):pointer;stdcall;external "User32.dll" name "SetFocus"; - function GetWindowTextLengthA(hwnd :pointer):integer;stdcall;external "User32.dll" name "GetWindowTextLengthA"; - function GetWindowTextA(hwnd :pointer;var s:string;l:integer):integer;stdcall;external "User32.dll" name "GetWindowTextA"; - function SetWindowTextA(hwnd :pointer;s:string):integer;stdcall;external "User32.dll" name "SetWindowTextA"; - function GetClassInfoExA(HH:pointer;lpszClass:string;lpwcx:pointer):integer;stdcall;external "User32.dll" name "GetClassInfoExA"; - function DefWindowProc(hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):integer;stdcall;external "User32.dll" name "DefWindowProc"; - {$IFDEF win64} - function SetWindowLongPtrA(HH:pointer;idx:integer;dwNewLong:pointer):pointer;stdcall;external "User32.dll" name "SetWindowLongPtrA"; - function GetWindowLongPtrA(HH:pointer;idx:integer):pointer;stdcall;external "User32.dll" name "GetWindowLongPtrA"; - function SetClassLongPtrA(HH:pointer;idx:integer;dwNewLong:pointer):pointer;stdcall;external "User32.dll" name "SetClassLongPtrA"; - function GetClassLongPtrA(HH:pointer;idx:integer):pointer;stdcall;external "User32.dll" name "GetClassLongPtrA"; - - {$ELSE} - function SetWindowLongPtrA(HH:pointer;idx:integer;dwNewLong:pointer):pointer;stdcall;external "User32.dll" name "SetWindowLongA"; - function GetWindowLongPtrA(HH:pointer;idx:integer):pointer;stdcall;external "User32.dll" name "GetWindowLongA"; - function SetClassLongPtrA(HH:pointer;idx:integer;dwNewLong:pointer):pointer;stdcall;external "User32.dll" name "SetClassLongA"; - function GetClassLongPtrA(HH:pointer;idx:integer):pointer;stdcall;external "User32.dll" name "GetClassLongA"; - {$ENDIF} - //function SetWindowLongA(HH:pointer;idx:integer;dwNewLong:pointer):pointer;stdcall;external "User32.dll" name "SetWindowLongA"; - //function GetWindowLongA(HH:pointer;idx:integer):pointer;stdcall;external "User32.dll" name "GetWindowLongA"; - function GetClassNameA(HH:pointer;var name:string;len:integer):pointer;stdcall;external "User32.dll" name "GetClassNameA"; - function CreateWindowExA(dwExStyle:integer; lpClassName:string; lpWindowName:string; - dwStyle:integer;x:integer;y:integer;nWidth:integer;nHeight:integer; - hWndParent:pointer;hMenu:pointer; hInstance:pointer;lpParam:pointer):pointer;stdcall;external "User32.dll" name "CreateWindowExA"; - function DestroyWindow(hWnd:pointer):integer;stdcall;external "User32.dll" name "DestroyWindow"; - //消息相关 - function CallWindowProcA(lpPrevWndFunc:pointer;hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):pointer;stdcall;external "User32.dll" name "CallWindowProcA"; - function DefWindowProcA(hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):pointer;stdcall;external "User32.dll" name "DefWindowProcA"; - function SendMessageA(hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):pointer;stdcall;external "User32.dll" name "SendMessageA"; - function PostMessageA(hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):integer;stdcall;external "User32.dll" name "PostMessageA"; - function GetMessageA(lpMsg:pointer;hWnd:pointer;wMsgFilterMin:integer;wMsgFilterMax:integer):integer;stdcall;external "User32.dll" name "GetMessageA"; - function PeekMessageA(lpMsg:pointer; hWnd:pointer; wMsgFilterMin:integer; wMsgFilterMax:integer;wRemoveMsg:integer):integer ;stdcall;external "User32.dll" name "PeekMessageA"; - function PostQuitMessage(code:integer);stdcall;external "User32.dll" name "PostQuitMessage"; - function PostThreadMessageA(idThread:integer ;Msg:integer;wParam:pointer;lParam:pointer):integer;stdcall;external "User32.dll" name "PostThreadMessageA"; - function TranslateMessage(msg:pointer):integer;stdcall;external "User32.dll" name "TranslateMessage"; - function DispatchMessageA(msg:pointer):integer;stdcall;external "User32.dll" name "DispatchMessageA"; - function TranslateAcceleratorA(hWnd:pointer; hAccTable:pointer;lpMsg:pointer):integer;stdcall;external "User32.dll" name "TranslateAcceleratorA"; - function CreateAcceleratorTableA(paccel:pointer;cAccel:integer):pointer;stdcall;external "User32.dll" name "CreateAcceleratorTableA"; - function DestroyAcceleratorTable(hAccel:pointer):integer;stdcall;external "User32.dll" name "DestroyAcceleratorTable"; - //按键状态 - Function GetKeyState(key:integer):short;stdcall;external "User32.dll" name "GetKeyState"; - Function GetAsyncKeyState(key:integer):short;stdcall;external "User32.dll" name "GetAsyncKeyState"; - - //光标 - function WindowFromPoint(X:integer; Y:integer):pointer;stdcall;external "User32.dll" name "WindowFromPoint"; - function ClipCursor(rec:array of integer):integer;stdcall;external "User32.dll" name "ClipCursor"; - - function GetCursorPos(var point: array of integer):integer;stdcall;external "User32.dll" name "GetCursorPos"; - function GetCursorInfo_( pci:pointer):integer;stdcall;external "User32.dll" name "GetCursorInfo"; - function ShowCursor(bshow:integer):integer;stdcall;external "User32.dll" name "ShowCursor"; - function SetCursorPos(x:integer;y:integer):integer;stdcall;external "User32.dll" name "SetCursorPos" ; - Function LoadCursorA(hd:pointer;n:string):pointer;stdcall;external "User32.dll" name "LoadCursorA"; - Function LoadCursorA2(hd:pointer;n:pointer):pointer;stdcall;external "User32.dll" name "LoadCursorA"; - Function SetCursor(hd:pointer):pointer;stdcall;external "User32.dll" name "SetCursor"; - function CreateCursor(hInst:pointer; xHotSpot:integer;yHotSpot:integer; nWidth:integer; nHeight:integer; pvANDPlane:pointer; pvXORPlane:pointer):pointer;stdcall;external "User32.dll" name "CreateCursor"; - //caret 插入符号 - function CreateCaret(hWnd :pointer;hBitmap:pointer;nWidth:integer;nHeight:integer):integer;stdcall;external "User32.dll" name "CreateCaret"; - function SetCaretPos(x:integer;y:integer):integer;stdcall;external "User32.dll" name "SetCaretPos"; - function HideCaret(hwnd :pointer):integer;stdcall;external "User32.dll" name "HideCaret"; - function DestroyCaret():integer;stdcall;external "User32.dll" name "DestroyCaret"; - function SetCaretBlinkTime(uMSeconds :integer):integer;stdcall;external "User32.dll" name "SetCaretBlinkTime"; - function ShowCaret(hwnd :pointer):integer;stdcall;external "User32.dll" name "ShowCaret"; - function GetCaretBlinkTime():integer;stdcall;external "User32.dll" name "GetCaretBlinkTime"; - function GetCaretPos(lp:array of integer):integer;stdcall;external "User32.dll" name "GetCaretPos"; - - function memcpy(dst:pointer;src:string;size_t:integer):pointer;cdecl;external "msvcrt.dll" name "memcpy"; - function memcpy2(var dst:string;src:pointer;size_t:integer):pointer;cdecl;external "msvcrt.dll" name "memcpy"; - function fopen(filename:string; mode:string):pointer;cdecl;external "msvcrt.dll" name "fopen"; - function fclose(f:pointer):integer;cdecl;external "msvcrt.dll" name "fclose"; - function LockFile(hFile:pointer; dwFileOffsetLow:integer; dwFileOffsetHigh:integer;nNumberOfBytesToLockLow:integer;nNumberOfBytesToLockHigh:integer):integer;stdcall;external "Kernel32.dll" name "LockFile"; - function UnlockFile(hFile:pointer; dwFileOffsetLow:integer; dwFileOffsetHigh:integer;nNumberOfBytesToLockLow:integer;nNumberOfBytesToLockHigh:integer):integer;stdcall;external "Kernel32.dll" name "UnlockFile"; - //icon - function DrawIcon(hDC:pointer;X:integer;Y:integer;hIcon:pointer):integer;stdcall;external "User32.dll" name "DrawIcon"; - function CreateIcon(hInstance:pointer;nWidth:integer;nHeight:integer;cPlanes:byte;cBitsPixel:byte ;lpbANDbits:pointer;lpbXORbits:pointer):pointer;stdcall;external "User32.dll" name "CreateIcon"; - function CreateIconIndirect(info:pointer):pointer;stdcall;external "User32.dll" name "CreateIconIndirect"; - function CreateIcon2(hInstance:pointer;nWidth:integer;nHeight:integer;cPlanes:byte;cBitsPixel:byte ;var lpbANDbits:string;var lpbXORbits:string):pointer;stdcall;external "User32.dll" name "CreateIcon"; - function DestroyIcon(icon:pointer):integer;stdcall;external "User32.dll" name "DestroyIcon"; - function GetIconInfo(hIcon:pointer; piconinfo:pointer):integer;stdcall;external "User32.dll" name "GetIconInfo"; - function DestroyCursor(cursor:pointer):integer;stdcall;external "User32.dll" name "DestroyCursor"; - //scroll - function SetScrollRange(hWnd:pointer;nBar:integer;nMinPos:integer; nMaxPos:integer;bRedraw:integer):integer;stdcall;external "User32.dll" name "SetScrollRange"; - function GetScrollRange(hWnd:pointer;nBar:integer;var nMinPos:integer; var nMaxPos:integer):integer;stdcall;external "User32.dll" name "GetScrollRange"; - function SetScrollPos(hWnd:pointer;nBar:integer;Pos:integer;bRedraw:integer):integer;stdcall;external "User32.dll" name "SetScrollPos"; - function GetScrollPos(hWnd:pointer;nBar:integer):integer;stdcall;external "User32.dll" name "GetScrollPos"; - function ScrollWindow(hWnd:pointer;x:integer;y:integer; var lpRect:array of integer;var lpClipRect:array of integer):integer;stdcall;external "User32.dll" name "ScrollWindow"; - function ScrollDC(hDC:pointer;dx:integer;dy:integer;var lprcScroll:array of integer; var lprcClip:array of integer;hrgnUpdate:pointer;lprcUpdate:pointer):integer;stdcall;external "User32.dll" name "ScrollDC"; - function GetScrollInfo(hWnd:pointer;x:integer;info:pointer):integer;stdcall;external "User32.dll" name "GetScrollInfo"; - function SetScrollInfo(hwnd:pointer; nBar:integer; lpsi:pointer;redraw:integer):integer;stdcall;external "User32.dll" name "SetScrollInfo"; - //menu菜单类***************************************************** - Function CreateMenu():pointer;stdcall;external "User32.dll" name "CreateMenu"; - Function CreatePopupMenu():pointer;stdcall;external "User32.dll" name "CreatePopupMenu"; - Function DestroyMenu(hMenu:pointer):integer;stdcall;external "User32.dll" name "DestroyMenu"; - Function IsMenu(hMenu:pointer):integer;stdcall;external "User32.dll" name "IsMenu"; - function DeleteMenu(hMenu:pointer;uPosition:integer;uFlags:integer):integer;stdcall;external "User32.dll" name "DeleteMenu"; //会销毁 - Function GetMenuInfo(hMenu:pointer;lpcmi:pointer):integer;stdcall;external "User32.dll" name "GetMenuInfo"; - Function SetMenuInfo(hMenu:pointer;lpcmi:pointer):integer;stdcall;external "User32.dll" name "SetMenuInfo"; - Function GetSubMenu(hMenu:pointer;nPos:integer):pointer;stdcall;external "User32.dll" name "GetSubMenu"; - Function GetSystemMenu(hWnd:pointer;bRevert:integer):pointer;stdcall;external "User32.dll" name "GetSystemMenu"; - - Function RemoveMenu( hMenu:pointer; uPosition:integer;uFlags:integer):integer;stdcall;external "User32.dll" name "RemoveMenu"; - Function SetMenuItemInfoA( hMenu:pointer; uItem:integer;fByPosition:integer;lpmii:pointer):integer;stdcall;external "User32.dll" name "SetMenuItemInfoA"; - Function InsertMenuItemA( hMenu:pointer;uItem:integer;fByPosition:integer;lpmii:pointer):integer;stdcall;external "User32.dll" name "InsertMenuItemA"; - function AppendMenuA(hMenu:pointer;uFlags:integer;uIDNewItem:pointer; var lpNewItem:string):integer;stdcall ;external "User32.dll" name "AppendMenuA"; - function HiliteMenuItem(hWnd:pointer; hMenu:pointer; uIDHiliteItem:integer; uHilite:integer):integer;stdcall;external "User32.dll" name "HiliteMenuItem"; - Function GetMenuItemInfoA( hMenu:pointer; uItem:integer;fByPosition:integer;lpmii:pointer):integer;stdcall;external "User32.dll" name "GetMenuItemInfoA"; - Function TrackPopupMenu( hMenu:pointer;uFlags:integer; x:integer; y:integer; nReserved:integer;hWnd:pointer; prcRect: array of integer):integer;stdcall;external "User32.dll" name "TrackPopupMenu"; - function TrackPopupMenuEx(hMenu:pointer;uFlags:integer;x:integer;y:integer;hwnd:pointer;lptpm:pointer):integer;stdcall;external "User32.dll" name "TrackPopupMenuEx"; - Function ModifyMenuA( hMenu:pointer; uItem:integer;fByPosition:integer;lpmii:pointer;lpNewItem:string):integer;stdcall;external "User32.dll" name "ModifyMenuA"; - Function GetMenuStringA(hMenu:pointer; uIDItem:integer; var lpString:string; nMaxCount:integer;uFlag:integer):integer;stdcall;external "User32.dll" name "GetMenuStringA"; - Function RedrawWindow(hWnd:pointer;lprcUpdate:array of integer; hrgnUpdate:pointer;flags:integer):integer;stdcall;external "User32.dll" name "RedrawWindow"; - - //***************window menu************************* - Function DrawMenuBar(hwd:pointer):integer;stdcall;external "User32.dll" name "DrawMenuBar"; - Function SetMenu(hwd:pointer;hmenu:pointer):integer;stdcall;external "User32.dll" name "SetMenu"; - Function GetMenu(hwd:pointer):pointer;stdcall;external "User32.dll" name "GetMenu"; - //********************************************** - function GetDesktopWindow():pointer;stdcall;external "User32.dll" name "GetDesktopWindow"; - Function GetDC(hwd :pointer):pointer;stdcall;external "User32.dll" name "GetDC"; - function GetWindowDC(hWnd:pointer):pointer;stdcall;external "User32.dll" name "GetWindowDC"; - Function GetDCEx(hwd :pointer;hrgnClip:pointer;flags:integer):pointer;stdcall;external "User32.dll" name "GetDCEx"; - Function LoadImageA(hinst:pointer;lpszName:string; uType:integer; cxDesired:integer;cyDesired:integer;fuLoad:integer):pointer;stdcall;external "User32.dll" name "LoadImageA"; - function LoadBitmapA(hin:pointer;lpsz:string):pointer;stdcall;external "User32.dll" name "LoadBitmapA"; - function LoadBitmapA2(hin:pointer;lpsz:pointer):pointer;stdcall;external "User32.dll" name "LoadBitmapA"; - Function LoadIconA(hd:pointer;n:string):pointer;stdcall;external "User32.dll" name "LoadIconA"; - Function LoadIconA2(hd:pointer;n:pointer):pointer;stdcall;external "User32.dll" name "LoadIconA"; - Function DrawTextA(hdc :pointer;txt:string;len:integer;rec:array of integer;fmt:integer):integer;stdcall;external "User32.dll" name "DrawTextA"; - Function DrawTextExA(hdc :pointer;txt:string;len:integer;rec:array of integer;fmt:integer;lpdtp:pointer):integer;stdcall;external "User32.dll" name "DrawTextExA"; - Function DrawFrameControl(DC:pointer; var LPRECT: array of integer ; dr1 :integer;dr2:integer):integer;stdcall;external "User32.dll" name "DrawFrameControl"; - function DrawEdge(hdc:pointer;var qrc:array of integer;edge:integer;grfFlags:integer):integer;;stdcall;external "User32.dll" name "DrawEdge"; - function DrawFocusRect(hDC:pointer; var rect:array of integer):integer;stdcall;external "User32.dll" name "DrawFocusRect"; - Function FillRect(dc:pointer;rec:array of integer;br:pointer):integer;stdcall;external "User32.dll" name "FillRect"; - Function InvertRect(dc:pointer;rec:array of integer;br:pointer):integer;stdcall;external "User32.dll" name "InvertRect"; - function ReleaseDC(hwd :pointer;hdc:pointer):integer;stdcall;external "User32.dll" name "ReleaseDC"; - function BeginPaint(hwd :pointer;strc:pointer):pointer;stdcall;external "User32.dll" name "BeginPaint"; - function EndPaint(hwd :pointer;strc:pointer):integer;stdcall;external "User32.dll" name "EndPaint"; - function WindowFromDC(dc:pointer):pointer;stdcall;external "User32.dll" name "WindowFromDC"; - function MessageBoxA(hwnd :pointer;txt:string;cap:string;flag:integer):integer;stdcall;external "User32.dll" name "MessageBoxA"; - function TrackMouseEvent(lpEventTrack:pointer):integer;stdcall;external "User32.dll" name "TrackMouseEvent"; - //Gdi32.dll - function SaveDC(hdc :pointer):integer;stdcall;external "Gdi32.dll" name "SaveDC"; - function RestoreDC(hdc :pointer;nSavedDC:integer):integer;stdcall;external "Gdi32.dll" name "RestoreDC"; - function DeleteDC(hdc :pointer):integer;stdcall;external "Gdi32.dll" name "DeleteDC"; - { - https://msdn.microsoft.com/query/dev14.query?appId=Dev14IDEF1&l=ZH-CN&k=k(WINGDI%2FCreateCompatibleDC);k(CreateCompatibleDC);k(DevLang-C%2B%2B);k(TargetOS-Windows)&rd=true - If the function succeeds, the return value is the handle to a memory DC. - If the function fails, the return value is NULL. - } - function CreateCompatibleDC(hdc :pointer):pointer;stdcall;external "Gdi32.dll" name "CreateCompatibleDC"; - { - https://msdn.microsoft.com/query/dev14.query?appId=Dev14IDEF1&l=ZH-CN&k=k(WINGDI%2FGetTextColor);k(GetTextColor);k(DevLang-C%2B%2B);k(TargetOS-Windows)&rd=true - } - Function GetTextColor(hdc :pointer):integer;stdcall;external "Gdi32.dll" name "GetTextColor"; - Function SetTextColor(hdc :pointer;col:integer):integer;stdcall;external "Gdi32.dll" name "SetTextColor"; - function GetTextExtentPoint32A(hdc:pointer;lpString:string;c:integer; psizl:pointer):integer;stdcall;external "Gdi32.dll" name "GetTextExtentPoint32A"; - function GetTextExtentPoint32A2(hdc:pointer;lpString:string;c:integer; var psizl:array of integer):integer;stdcall;external "Gdi32.dll" name "GetTextExtentPoint32A"; - function GetCharWidthA(hdc:pointer;iFirst:integer;iLast:integer;var lpBuffer:array of integer):integer;stdcall;external "Gdi32.dll" name "GetCharWidthA"; - function GetCharABCWidthsA(hdc:pointer;wFirst:integer;wLast:integer; lpABC:pointer):integer;stdcall;external "Gdi32.dll" name "GetCharABCWidthsA"; - function GetFontLanguageInfo(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "GetFontLanguageInfo"; - Function SetDCPenColor(hdc :pointer;col:integer):integer;stdcall;external "Gdi32.dll" name "SetDCPenColor"; - Function GetDCPenColor(hdc :pointer):integer;stdcall;external "Gdi32.dll" name "GetDCPenColor"; - Function GetDCBrushColor(hdc :pointer):integer;stdcall;external "Gdi32.dll" name "GetDCBrushColor"; - Function SetDCBrushColor(hdc :pointer;col:integer):integer;stdcall;external "Gdi32.dll" name "SetDCBrushColor"; - { - https://msdn.microsoft.com/query/dev14.query?appId=Dev14IDEF1&l=ZH-CN&k=k(WINGDI%2FRectangle);k(Rectangle);k(DevLang-C%2B%2B);k(TargetOS-Windows)&rd=true - } - Function Rectangle(hdc :pointer;l:integer;t:integer;r:integer;b:integer):integer;stdcall;external "Gdi32.dll" name "Rectangle"; - Function Ellipse(hdc :pointer;l:integer;t:integer;r:integer;b:integer):integer;stdcall;external "Gdi32.dll" name "Ellipse"; - Function RoundRect(hdc :pointer;l:integer;t:integer;r:integer;b:integer;wid:integer;ht:integer):integer;stdcall;external "Gdi32.dll" name "RoundRect"; - Function Chord(hdc :pointer;l:integer;t:integer;r:integer;b:integer;wid:integer;ht:integer):integer;stdcall;external "Gdi32.dll" name "Chord"; - Function Pie(hdc :pointer;nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer;nXRadial1:integer;nYRadial1:integer;nXRadial2:integer;nYRadial2:integer):integer;stdcall;external "Gdi32.dll" name "Pie"; - Function SetArcDirection(hdc :pointer;direct:integer):integer;stdcall;external "Gdi32.dll" name "SetArcDirection"; - Function Arc(hdc :pointer;nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer;nXRadial1:integer;nYRadial1:integer;nXRadial2:integer;nYRadial2:integer):integer;stdcall;external "Gdi32.dll" name "Arc"; - Function Polygon(hdc :pointer;points:array of integer;n:integer):integer;stdcall;external "Gdi32.dll" name "Polygon"; - Function PolyBezier(hdc :pointer;points:array of integer;n:integer):integer;stdcall;external "Gdi32.dll" name "PolyBezier"; - Function SetPolyFillMode(hdc :pointer;md:integer):integer;stdcall;external "Gdi32.dll" name "SetPolyFillMode"; - Function Polyline(hdc :pointer;points:array of integer;n:integer):integer;stdcall;external "Gdi32.dll" name "Polyline"; - Function PolyPolyline(hdc :pointer;points:array of integer;pc:array of integer;n:integer):integer;stdcall;external "Gdi32.dll" name "PolyPolyline"; - function ExtFloodFill(hdc:pointer;nXStart:integer; nYStart:integer;crColor:integer;fuFillType:integer):integer;stdcall;external "Gdi32.dll" name "ExtFloodFill"; - function SetTextJustification(hdc:pointer;nBreakExtra:integer;nBreakCount:integer):integer;stdcall;external "Gdi32.dll" name "SetTextJustification"; - function TransparentBlt( hdcDest:pointer; xoriginDest:integer; yoriginDest:integer; wDest:integer; hDest:integer; - hdcSrc:pointer; xoriginSrc:integer; yoriginSrc:integer; wSrc:integer; hSrc:integer; crTransparent:integer):integer;stdcall;external "Msimg32.dll" name "TransparentBlt"; - function AlphaBlend( hdcDest:pointer; xoriginDest:integer; yoriginDest:integer; wDest:integer; hDest:integer; - hdcSrc:pointer; xoriginSrc:integer; yoriginSrc:integer; wSrc:integer; hSrc:integer; ftn:integer):integer;stdcall;external "Msimg32.dll" name "AlphaBlend"; - function SetWindowExtEx(hdc:pointer;nXExtent:integer;nYExtent:integer;lpSize:pointer):integer;stdcall;external "Gdi32.dll" name "SetWindowExtEx"; - function IntersectClipRect(hdc :pointer;nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer):integer;stdcall;external "Gdi32.dll" name "IntersectClipRect"; - function GetDIBits(hdc:pointer; hbm:pointer;start:integer; cLines:integer;lpvBits:pointer;lpbmi:pointer; usage:integer):integer;stdcall;external "Gdi32.dll" name "GetDIBits"; - function GetDIBits2(hdc:pointer; hbm:pointer;start:integer; cLines:integer;var lpvBits:string;lpbmi:pointer; usage:integer):integer;stdcall;external "Gdi32.dll" name "GetDIBits"; - function SetDIBits2(hdc:pointer; hbmp:pointer;uStartScan:integer;cScanLines:integer;var lpvBits:string;lpbmi:pointer;fuColorUse:integer):integer;stdcall;external "Gdi32.dll" name "SetDIBits"; - Function GetBitmapBits(bmp :pointer;len:integer;bf:pointer{var bf: array of integer }):integer;stdcall;external "Gdi32.dll" name "GetBitmapBits"; - Function GetBitmapBits2(bmp :pointer;len:integer;var bf:string):integer;stdcall;external "Gdi32.dll" name "GetBitmapBits"; - Function SetBitmapBits(bmp :pointer;len:integer;bf:pointer{var bf: array of integer }):integer;stdcall;external "Gdi32.dll" name "SetBitmapBits"; - Function SetBitmapBits2(bmp :pointer;len:integer;var bf:string):integer;stdcall;external "Gdi32.dll" name "SetBitmapBits"; - Function SetBitmapDimensionEx(hBitmap:pointer;nWidth:integer; nHeight:integer;VAR lpSize:array of integer):integer;stdcall;external "Gdi32.dll" name "SetBitmapDimensionEx"; - Function GetBitmapDimensionEx(hBitmap:pointer;VAR ps:array of integer):integer;stdcall;external "Gdi32.dll" name "GetBitmapDimensionEx"; - { - https://msdn.microsoft.com/query/dev14.query?appId=Dev14IDEF1&l=ZH-CN&k=k(WINGDI%2FGetTextMetrics);k(GetTextMetrics);k(DevLang-C%2B%2B);k(TargetOS-Windows)&rd=true - } - Function GetTextMetricsA(hdc :pointer;TM:pointer):integer;stdcall;external "Gdi32.dll" name "GetTextMetricsA"; - Function MoveToEx(hdc :pointer;x:integer;y:integer;var point:array of integer):integer;stdcall;external "Gdi32.dll" name "MoveToEx" keepresident; - Function LineTo(hdc :pointer;x:integer;y:integer):integer;stdcall;external "Gdi32.dll" name "LineTo" keepresident; - Function TextOutA(hdc :pointer;X:integer;y:integer;txt:string;len:integer):integer;stdcall;external "Gdi32.dll" name "TextOutA"; - //gdi path******************** - function BeginPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "BeginPath"; - function EndPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "EndPath"; - function FillPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "FillPath"; - function StrokePath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "StrokePath"; - function StrokeAndFillPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "StrokeAndFillPath"; - function AbortPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "AbortPath"; - function CloseFigure(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "CloseFigure"; - function FlattenPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "FlattenPath"; - function GetMiterLimit(hdc:pointer;var plimit:Single):integer;stdcall;external "Gdi32.dll" name "GetMiterLimit"; - function GetPath(hdc:pointer;apt:array of integer;aj:integer;cpt:integer):integer;stdcall;external "Gdi32.dll" name "GetPath"; - function PathToRegion(hdc:pointer):pointer;stdcall;external "Gdi32.dll" name "PathToRegion"; - function SetMiterLimit(hdc:pointer;limit:Single;var od:Single):integer;stdcall;external "Gdi32.dll" name "SetMiterLimit"; - function WidenPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "WidenPath"; - function PatBlt(hdc:pointer;nleftrect:integer;ntoprect:integer;nwidth:integer;nheight:pointer;fdwrop:integer):integer;stdcall;external "Gdi32.dll" name "PatBlt"; - function drawbitmaptodc(bm,hdc,x,y,rc,flag,thdc); - begin - oldmp := SelectObject(thdc,bm); - if not flag then flag := 0xcc0020; - r := BitBlt(hdc,x,y,rc[2]-rc[0],rc[3]-rc[1],thdc,rc[0],rc[1],flag); - if oldmp then SelectObject(thdc,oldmp); - return r; - end - function drawbitmapstretchtodc(bm,hdc,drect,rc,flag,thdc); - begin - oldmp := SelectObject(thdc,bm); - if not flag then flag := 0xcc0020; - r := StretchBlt(hdc,drect[0],drect[1],drect[2]-drect[0],drect[3]-drect[1],thdc,rc[0],rc[1],rc[2]-rc[0],rc[3]-rc[1],flag); - if oldmp then SelectObject(thdc,oldmp); - return r; - end - - Function BitBlt(hdcDest:pointer;nXDest:integer;nYDest:integer;nWidth:integer;nHeight:integer; - hdcSrc :pointer;nXSrc:integer;nYSrc:integer;dwRop:integer):integer;stdcall;external "Gdi32.dll" name "BitBlt"; - Function StretchBlt(hdcDest:pointer;nXOriginDest:integer; nYOriginDest:integer;nWidthDest:integer; nHeightDest:integer; - hdcSrc :pointer;nXOriginSrc:integer;nYOriginSrc:integer; nWidthSrc:integer; nHeightSrc:integer; dwRop:integer - ):integer;stdcall;external "Gdi32.dll" name "StretchBlt"; - Function SetStretchBltMode(hdc:pointer;iStretchMode:integer):integer;stdcall;external "Gdi32.dll" name "SetStretchBltMode"; - function SelectObject(hdc :pointer;gdiobj:pointer):pointer;stdcall;external "Gdi32.dll" name "SelectObject"; - function DeleteObject(gdiobj :pointer):integer;stdcall;external "Gdi32.dll" name "DeleteObject"; - function CreateBitmap(nWidth:integer; nHeight:integer; cPlanes:integer;cBitsPerPel:integer; - lpvBits:pointer):pointer;stdcall;external "Gdi32.dll" name "CreateBitmap"; - function CreateBitmap2(nWidth:integer; nHeight:integer; cPlanes:integer;cBitsPerPel:integer; - var lpvBits:string):pointer;stdcall;external "Gdi32.dll" name "CreateBitmap"; - function CreateBitmaplndirect(bmp:pointer):pointer;stdcall;external "Gdi32.dll" name "CreateBitmaplndirect"; - function CreateCompatibleBitmap(hdc:pointer;x:integer;y:integer):pointer;stdcall;external "Gdi32.dll" name "CreateCompatibleBitmap"; - function CreatePen(fnPenStyle:integer;nWidth:integer;crColor:integer):pointer;stdcall;external "Gdi32.dll" name "CreatePen"; - function CreatePenIndirect(LOGPEN :pointer):pointer;stdcall;external "Gdi32.dll" name "CreatePen"; - function CreateSolidBrush(crColor:integer):pointer;stdcall;external "Gdi32.dll" name "CreateSolidBrush"; - function CreateBrushIndirect(Logb:pointer):pointer;stdcall;external "Gdi32.dll" name "CreateBrushIndirect"; - function CreatePatternBrush(bmp:pointer):pointer;stdcall;external "Gdi32.dll" name "CreatePatternBrush"; - function CreateHatchBrush(fnStyle:integer;clrref:integer):pointer;stdcall;external "Gdi32.dll" name "CreateHatchBrush"; - function CreateFontA(nHeight:integer;nWidth:integer;nEscapement:integer; nOrientation:integer;fnWeight:integer; - fdwItalic:integer;fdwUnderline:integer;fdwStrikeOut:integer;fdwCharSet:integer;fdwOutputPrecision:integer; - fdwClipPrecision:integer; fdwQuality:integer; fdwPitchAndFamily:integer;lpszFace:string):pointer;stdcall;external "Gdi32.dll" name "CreateFontA"; - function CreateFontIndirectA(lplf:pointer):pointer;stdcall;external "Gdi32.dll" name "CreateFontIndirectA"; - //https://msdn.microsoft.com/zh-cn/library/windows/desktop/dd183436(v=vs.85).aspx clipping functions - function GetStockObject(fnObject:integer):pointer;stdcall;external "Gdi32.dll" name "GetStockObject"; - function CreatePalette(LOGPALETTE:pointer):pointer;stdcall;external "Gdi32.dll" name "CreatePalette"; - function GetDeviceCaps(dc:pointer;idex:integer):integer;stdcall;external "Gdi32.dll" name "GetDeviceCaps"; - function SetPixel(dc:pointer;x:integer;y:integer;col:integer):integer;stdcall;external "Gdi32.dll" name "SetPixel"; - function CreateEllipticRgn(nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer):pointer;stdcall;external "Gdi32.dll" name "CreateEllipticRgn"; - - function CreatePolyPolygonRgn(ps:array of integer;pc:array of integer;len:integer;md:integer):pointer;stdcall;external "Gdi32.dll" name "CreatePolyPolygonRgn"; - function SetROP2(hdc:pointer;fnDrawMode:integer):integer;stdcall;external "Gdi32.dll" name "SetROP2"; - function CreateRectRgn(nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer):pointer;stdcall;external "Gdi32.dll" name "CreateRectRgn"; - function CreatePolygonRgn(ps:array of integer;len:integer;md:integer):pointer;stdcall;external "Gdi32.dll" name "CreatePolygonRgn"; - function CombineRgn(hrgnDest:pointer;hrgnSrc1:pointer;hrgnSrc2:pointer; fnCombineMode:integer):integer;stdcall;external "Gdi32.dll" name "CombineRgn"; - function SelectClipRgn(dc:pointer;rgn:pointer):integer;stdcall;external "Gdi32.dll" name "SelectClipRgn"; - function PtVisible(dc:pointer;x:integer;y:integer):integer;stdcall;external "Gdi32.dll" name "PtVisible"; - function RectVisible(dc:pointer;rect:array of integer):integer;stdcall;external "Gdi32.dll" name "RectVisible"; - function ExcludeClipRect(hdc:pointer;nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer;):integer;stdcall;external "Gdi32.dll" name "ExcludeClipRect"; - function SetWindowOrgEx(hdc:pointer;x:integer;y:integer;var lppt: array of integer):integer;stdcall;external "Gdi32.dll" name "SetWindowOrgEx"; - function SetViewportOrg(dc:pointer;x:integer;y:integer):integer;stdcall;external "Gdi32.dll" name "SetViewportOrg"; - function SetViewportOrgEx(dc:pointer;x:integer;y:integer;var pt:array of integer):integer;stdcall;external "Gdi32.dll" name "SetViewportOrgEx"; - Function FillRgn(dc:pointer;rgn:pointer;br:pointer):integer;stdcall;external "Gdi32.dll" name "FillRgn"; - Function SetTextAlign(dc:pointer;fMode:integer):integer;stdcall;external "Gdi32.dll" name "SetTextAlign"; - Function SetWorldTransform(dc:pointer;lpXform:pointer):integer;stdcall;external "Gdi32.dll" name "SetWorldTransform"; - Function SetGraphicsMode(dc:pointer;iMode:integer):integer;stdcall;external "Gdi32.dll" name "SetGraphicsMode"; - Function GetGraphicsMode(dc:pointer):integer;stdcall;external "Gdi32.dll" name "GetGraphicsMode"; - Function SetMapMode(dc:pointer;iMode:integer):integer;stdcall;external "Gdi32.dll" name "SetMapMode"; - Function SetBkColor(dc:pointer;clrref:integer):integer;stdcall;external "Gdi32.dll" name "SetBkColor"; - Function GetBkColor(dc:pointer):integer;stdcall;external "Gdi32.dll" name "GetBkColor"; - Function SetBkMode(dc:pointer;clrref:integer):integer;stdcall;external "Gdi32.dll" name "SetBkMode"; - Function GetBkMode(dc:pointer):integer;stdcall;external "Gdi32.dll" name "GetBkMode"; - Function GetObjectA(hgdiobj:pointer;cbBuffer:integer;lpvObject:pointer):integer;stdcall;external "Gdi32.dll" name "GetObjectA"; - //**************Comctl32.dll*************************************************************** - procedure GetEffectiveClientRect(hWnd:pointer;lprc:array of integer;lpInfo:array of integer);stdcall;external "Comctl32.dll" name "GetEffectiveClientRect"; - function ImageList_Add(himl:pointer;hbmImage:pointer; hbmMask:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_Add"; - function ImageList_AddMasked(himl:pointer;hbmImage:pointer; crMask:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_AddMasked"; - function ImageList_BeginDrag(himlTrack:pointer; iTrack:integer;dxHotspot:integer;dyHotspot:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_BeginDrag"; - function ImageList_DragMove(x:integer;y:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_DragMove"; - function ImageList_DragEnter(hwndLock:pointer;x:integer;y:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_DragEnter"; - function ImageList_DragLeave(hwndLock:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_DragLeave"; - procedure ImageList_EndDrag();stdcall;external "Comctl32.dll" name "ImageList_EndDrag"; - function ImageList_Create(cx:integer; cy:integer; flags:integer; cInitial:integer;cGrow:integer):pointer;stdcall;external "Comctl32.dll" name "ImageList_Create"; - function ImageList_Draw(himl:pointer;i:integer;hdcDst:pointer;x:integer;y:integer;fStyle:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_Draw"; - function ImageList_Destroy(himl:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_Add"; - function ImageList_Replace(himl:pointer;id:integer;hbmImage:pointer; hbmMask:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_Replace"; - function ImageList_Remove(himl:pointer;id:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_Remove"; - function ImageList_SetBkColor(himl:pointer;clrBk:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_SetBkColor"; - function ImageList_LoadImageA2(hi:pointer;lpbmp:pointer;cx:integer;cGrow:integer; crMask:integer;uType:integer;uFlags:integer):pointer;stdcall;external "Comctl32.dll" name "ImageList_LoadImageA"; - function ImageList_GetBkColor(himl:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_GetBkColor"; - function ImageList_GetDragImage(ppt:pointer;pptHotspot:pointer):pointer;stdcall;external "Comctl32.dll" name "ImageList_GetDragImage"; - function ImageList_GetImageCount(himl:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_GetImageCount"; - function ImageList_SetImageCount(himl:pointer;clrBk:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_SetImageCount"; - function ImageList_Copy(himlDst:pointer;iDst:integer; himlSrc:pointer;iSrc:integer;uFlags:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_Copy"; - function ImageList_Duplicate(himl:pointer):pointer;stdcall;external "Comctl32.dll" name "ImageList_Duplicate"; - function ImageList_Merge(himl1:pointer;i1:integer;himl2:pointer;i2:integer;dx:integer;dy:integer):pointer;stdcall;external "Comctl32.dll" name "ImageList_Merge"; - function ImageList_SetDragCursorImage(himlDrag:pointer;iDrag:integer;dxHotspot:integer;dyHotspot:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_SetDragCursorImage"; - function ImageList_GetImageInfo(himl:pointer; i:integer;pImageInfo:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_GetImageInfo"; - function ImageList_ReplaceIcon(himl:pointer;i:integer;hicon:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_ReplaceIcon"; - function ImageList_SetIconSize(himl:pointer;cx:integer;cy:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_SetIconSize"; - function ImageList_GetIconSize(himl:pointer;var cx:integer;var cy:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_GetIconSize"; - function ImageList_GetIcon(himl:pointer;i:integer;flags:integer):pointer;stdcall;external "Comctl32.dll" name "ImageList_GetIcon"; - function ImageList_DrawIndirect(pimldp:pointer):pointer;stdcall;external "Comctl32.dll" name "ImageList_DrawIndirect"; - function ImageList_DragShowNolock(fShow:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_DragShowNolock"; - function InitCommonControlsEx(it:pointer):integer;stdcall;external "Comctl32.dll" name "InitCommonControlsEx"; - function Comctl32DllGetVersion(it:pointer):pointer;stdcall;external "Comctl32.dll" name "DllGetVersion"; - function GetOpenFileNameA(LPOPENFILENAMEA:pointer):integer;stdcall;external "Comdlg32.dll" name "GetOpenFileNameA" keepresident; - function GetSaveFileNameA(LPOPENFILENAMEA:pointer):integer;stdcall;external "Comdlg32.dll" name "GetSaveFileNameA"; - function ChooseFontA(LOGFONTA:pointer):integer;stdcall;external "Comdlg32.dll" name "ChooseFontA"; - function ChooseColorA(LOGFONTA:pointer):integer;stdcall;external "Comdlg32.dll" name "ChooseColorA"; - //************************************ - function Shell_NotifyIconA(dwMessage:integer; lpData:pointer):integer;stdcall;external "Shell32.dll" name "Shell_NotifyIconA"; - function ILCreateFromPathA(pszPath:string):pointer;stdcall;external "Shell32.dll" name "ILCreateFromPathA"; - procedure ILFree(pidl:pointer);stdcall;external "Shell32.dll" name "ILFree"; - function SHBrowseForFolderA(LPITEMIDLIST:pointer):pointer;stdcall;external "Shell32.dll" name "SHBrowseForFolderA"; - function SHGetPathFromIDListA(LPBROWSEINFOA:pointer;var buf:string ):integer;stdcall;external "Shell32.dll" name "SHGetPathFromIDListA"; - function shell32DllGetVersion(it:pointer):pointer;stdcall;external "Shell32.dll" name "DllGetVersion"; - function ShellExecuteExA(pExecInfo :pointer):integer;stdcall;external "Shell32.dll" name "ShellExecuteExA"; - function SHGetFolderPathA(hwnd:pointer;csidl:integer;hToken:pointer;dwFlags:integer;var pszPath:string):integer;stdcall;external "Shell32.dll" name "SHGetFolderPathA"; - //socket - function socket(af:integer;tp:integer;protocol:integer):pointer;stdcall;external "Ws2_32.dll" name "socket"; - function WSAStartup(af:SHORT;DA:pointer):integer;stdcall;external "Ws2_32.dll" name "WSAStartup"; - function WSACleanup():integer;stdcall;external "Ws2_32.dll" name "WSACleanup"; - function htonl(hostlong:integer):integer;stdcall;external "Ws2_32.dll" name "htonl"; - function htons(hostshort:short):short;stdcall;external "Ws2_32.dll" name "htons"; - function ntohs(hostshort:short):short;stdcall;external "Ws2_32.dll" name "ntohs"; - function bind(s:pointer;name:pointer;len:integer):integer;stdcall;external "Ws2_32.dll" name "bind"; - function accept(s:pointer;name:pointer;var len:integer):pointer;stdcall;external "Ws2_32.dll" name "accept"; - function send(s:pointer;bufer:string;len:integer;flag:integer):integer;stdcall;external "Ws2_32.dll" name "send"; - function recv(s:pointer;var bufer:string;len:integer;flag:integer):integer;stdcall;external "Ws2_32.dll" name "recv"; - function listen(s:pointer;port:integer):integer;stdcall;external "Ws2_32.dll" name "listen"; - function closesocket(s:pointer):integer;stdcall;external "Ws2_32.dll" name "closesocket"; - function connect(s:pointer;name:pointer;len:integer):integer;stdcall;external "Ws2_32.dll" name "connect"; - function inet_addr(s:string):integer;stdcall;external "Ws2_32.dll" name "inet_addr"; - function WSAGetLastError():integer;stdcall;external "Ws2_32.dll" name "WSAGetLastError"; - function inet_ntoa(ad:integer):string;stdcall;external "Ws2_32.dll" name "inet_ntoa"; - function shutdown(s:pointer;how:integer):integer;stdcall;external "Ws2_32.dll" name "shutdown"; - function WSAAsyncSelect(s:pointer;hWnd:pointer;wMsg:integer;lEvent:integer):integer;stdcall;external "Ws2_32.dll" name "WSAAsyncSelect"; - function ioctlsocket(s:pointer;cmd:integer;var argp:integer):integer;stdcall;external "Ws2_32.dll" name "ioctlsocket"; - function setsockopt(s:pointer;level:integer;optname:integer;optval:string;optlen:integer):integer;stdcall;external "Ws2_32.dll" name "setsockopt"; - function getsockopt(s:pointer;level:integer;optname:integer;var optval:string;var optlen:integer):integer;stdcall;external "Ws2_32.dll" name "getsockopt"; - - {$endif} - end type TByteData = class(TByteDataOP) -end -type TSLUIBASE=class(TSLUICONST) //图像库基类 - {** - @explan(说明)图像库基类,提供基本的底层操作和常量 %% - **} - private - FReCycleState; - static FTSLkeyWords; - static TSLRCS_NONE; - static TSLRCS_BEGIN; - static TSLRCS_END; - static FHAPP; - static FEditTypes; - _hashdata; - _temppath; - function Gethapp(); - begin - return FHAPP; - end - function SetHapp(v); - begin - end - public - static _wapi; //windows api; - function create();virtual; //构造 - begin - _hashdata := array(); - sinit(); - FReCycleState := TSLRCS_NONE; - end - class function sinit();virtual; - begin - {** - @explan(说明)初始化win32接口对象_wapi - **} - if not(_wapi)then - begin - _wapi := gettswin32api(); - FTSLkeyWords := TSL_ReservedKeys2(); - end - if not FHAPP then - begin - FHAPP := _wapi.GetModuleHandleA(0); - TSLRCS_NONE := 0; - TSLRCS_BEGIN := 1; - TSLRCS_END := 2; - end - end - class Function isKeyWords(key); - begin - {** - @explan(说明) 判断是否为tsl关键字 %% - @param(key)(string) - **} - return ifstring(key)and ifarray(FTSLkeyWords)and(lowercase(key)in FTSLkeyWords); - return false; - end - class function DeleteItemsByIndexs(r,dxs); - begin - {** - @explan(说明) 删除数组下标, %% - @param(r)(array) 待删除下标的数组,采用字符串下标的数组,变参返回%%; - **} - if not ifarray(r)then exit; - rdx := array(); - for i,v in dxs do rdx[v]:= nil; - return reindex(r,rdx); - end - class function xor(a,b); - begin - {** - @explan(说明) 异或 运算 %% - @return(bool) - **} - return(a and not(b))or(b and not(a)); - end - class function bitcombination(s,v,f); - begin - {** - @explan(说明)bit位组合 %% - @param(s)(integer) 原有值 %% - @param(v)(integer) 追加或者删除 %% - @param(f)(integer) 0 为 or ,1 为 and ;2 表示 删除 v的值 %% - **} - if not(ifnumber(s)and ifnumber(v))then return 0; - case f of - 0:return s .| v; - 1:return s .& v; - 2:return(.!v).& s; - else return s; - end - hv :=((s .& v)=v); - if(hv)and f=2 then - begin - return(.!v).& s; - end else - if(f=0)and not(hv)then - begin - return s .| v; - end else - if(f=1)and not(hv)then - begin - return s .& v; - end else - return s; - end - function destroy();virtual; - begin - if FReCycleState=TSLRCS_NONE then Recycling(); - end - function NoRecycled(); - begin - {** - @explan(说明) 是否没有被回收 %% - @return(bool) 没有回收返回true ,否则返回false; - **} - return FReCycleState=TSLRCS_NONE; - end - function Recycling();virtual; - begin - {** - @explan(说明)析构准备;为消除循环引用的销毁 - **} - if FReCycleState=TSLRCS_END then return; - _Tag := nil; - _hashdata := array(); - FReCycling := true; - FReCycleState := TSLRCS_END; - end - function _execute_(); //函数执行 - begin - return callinarray(thisfunction(class(TSLUIBASE)._eventexec_),params); - end - function _eventexec_();virtual; //事件执行函数 - begin - if paramcount<1 then return 0; - ps := params; //事件执行变量 - fun := ps[0]; //函数 - if datatype(fun)=7 then - begin - return callinarray(fun,ps[1:]); - end - end - function hashset(i,v,f); - begin - {** - @explan(说明)设置一个哈希值 %% - @param(i)(string | integer) 下标 %% - @param(f)(bool) i=nil and f=1 and v=array 替换哈希表 %% - @param(v)() 值 - **} - if ifstring(i)or ifint(i)then - begin - _hashdata[i]:= v; - end else - if(ifnil(i)and ifarray(v)and(f=1))then _hashdata := v; - end - function hashget(i); - begin - {** - @explan(说明)获取一个哈希值 %% - @param(i)(string | integer) 下标 %% - @return() 值 - **} - if ifstring(i)or ifint(i)then - begin - return _hashdata[i]; - end else - if ifnil(i)then return _hashdata; - end - function hashdel(i,f); - begin - {** - @explan(说明)删除一个哈希值 %% - @param(i)(string | integer) 下标 %% - @param(f)(bool) i=nil and f=1 清空hash表 %% - @return(bool)是否成功 - **} - if ifstring(i)or ifint(i)then - begin - return reindex(_hashdata,array(i:nil)); - end else - if ifnil(i)and f=1 then _hashdata := array(); - end - function caption(s);virtual; - begin - return ""; - end - function temppath(); - begin - {** - @explan(说明) 获取一个可以读写的文件夹 %% - @return(string) 目录路径 %% - **} - if not(ifstring(_temppath)and _temppath)then _temppath := gettemppath()+"tinysoft"; - return _temppath; - end - class function RegPropertyType(v); //注册设计器编辑 - begin - RegComponentPropertyType(v); - end - class function GetPropertyType(n); //获得设计器编辑 - begin - return GetComponentPropertyType(n); - end - property happ read Gethapp write SetHapp; - property ReCycleState read FReCycleState; //write FReCycleState; - _Tag; //标签 - {** - @param(_wapi)(tswin32api) win32宏定义,以及api接口 %% - @param(_Tag)(obj) 调用者使用的成员变量 %% - **} -end - - +end ///////////////////////////内存对象////////////////////////////// - -type TTagMSG=class(tslcstructureobj) - {** - @explan(说明) 消息循环对象类 %% - **} - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("hwnd","intptr",0), - ("message","int",0), - ("wparam","intptr",0), - ("lparam","intptr",0), - ("time","int",0), - ("pt","int[2]", - (0,0)), - ("lprivate","int",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property hwnd index "hwnd" read _getvalue_ write _setvalue_; - property message index "message" read _getvalue_ write _setvalue_; - property wparam index "wparam" read _getvalue_ write _setvalue_; - property lparam index "lparam" read _getvalue_ write _setvalue_; - property time index "time" read _getvalue_ write _setvalue_; - property pt index "pt" read _getvalue_ write _setvalue_; - property lprivate index "lprivate" read _getvalue_ write _setvalue_; -end -type TtagSIZE=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - (0,"int",0), - (1,"int",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property cx index 0 read _getvalue_ write _setvalue_; - property cy index 1 read _getvalue_ write _setvalue_; -end -type TCPoint=class(TtagSIZE) - function create(p); - begin - inherited; - end -end - -type TCRect=class(tslcstructureobj) - {** - @explan(说明)矩形区域内存分配 %% - **} - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - (0,"int",0), - (1,"int",0), - (2,"int",0), - (3,"int",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property left index 0 read _getvalue_ write _setvalue_; - property top index 1 read _getvalue_ write _setvalue_; - property right index 2 read _getvalue_ write _setvalue_; - property bottom index 3 read _getvalue_ write _setvalue_; -end - -type TCRectF=class(tslcstructureobj) - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - (0,"float",0), - (1,"float",0), - (2,"float",0), - (3,"float",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property left index 0 read _getvalue_ write _setvalue_; - property top index 1 read _getvalue_ write _setvalue_; - property right index 2 read _getvalue_ write _setvalue_; - property bottom index 3 read _getvalue_ write _setvalue_; -end -type TCPointF=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - (0,"float",0), - (1,"float",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property cx index 0 read _getvalue_ write _setvalue_; - property cy index 1 read _getvalue_ write _setvalue_; -end -type TNOTIFYICONDATAA=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("cbsize","int",0), - ("hwnd","intptr",0), - ("uid","int",0), - ("uflags","int",0), - ("ucallbackmessage","int",0), - ("hicon","intptr",0), - ("sztip","char[128]",0), - ("dwstate","int",0), - ("dwstatemask","int",0), - ("szinfo","char[256]",0), - ("dummyunionname","int",0), - ("szinfotitle","char[64]",0), - ("dwinfoflags","int",0), - ("guiditem","user",( - ("data1","int",0),("data2","short",0),("data3","short",0),("data4","char[8]","") - )), - ("hballoonicon","intptr",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - cbsize := _size_(); - end - property cbsize index "cbsize" read _getvalue_ write _setvalue_; - property hwnd index "hwnd" read _getvalue_ write _setvalue_; - property uid index "uid" read _getvalue_ write _setvalue_; - property uflags index "uflags" read _getvalue_ write _setvalue_; - property ucallbackmessage index "ucallbackmessage" read _getvalue_ write _setvalue_; - property hicon index "hicon" read _getvalue_ write _setvalue_; - property sztip index "sztip" read _getvalue_ write _setvalue_; - property dwstate index "dwstate" read _getvalue_ write _setvalue_; - property dwstatemask index "dwstatemask" read _getvalue_ write _setvalue_; - property szinfo index "szinfo" read _getvalue_ write _setvalue_; - property uTimeout index "dummyunionname" read _getvalue_ write _setvalue_; - property uVersion index "dummyunionname" read _getvalue_ write _setvalue_; - property dummyunionname index "dummyunionname" read _getvalue_ write _setvalue_; - property szinfotitle index "szinfotitle" read _getvalue_ write _setvalue_; - property dwinfoflags index "dwinfoflags" read _getvalue_ write _setvalue_; - property guiditem index "guiditem" read _getvalue_ write _setvalue_; - property hballoonicon index "hballoonicon" read _getvalue_ write _setvalue_; -end - -type TSHBMP=class(tslcstructureobj) - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("bmtype","int",0), - ("bmwidth","int",0), - ("bmheight","int",0), - ("bmwidthbytes","int",0), - ("bmplanes","short",0), - ("bmbitspixel","short",0), - ("bmbits","intptr",0))); - return SSTRUCT; - end - function getstruct2() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("bmtype","int",0), - ("bmwidth","int",0), - ("bmheight","int",0), - ("bmwidthbytes","int",0), - ("bmplanes","byte",0), - ("bmbitspixel","byte",0), - {$ifdef win64} - ("nop1","byte[6]",array(0,0,0,0,0,0)), - {$else} - ("nop1","byte[2]",array(0,0)), - {$endif} - ("bmbits","intptr",100))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property bmtype index "bmtype" read _getvalue_ write _setvalue_; - property bmwidth index "bmwidth" read _getvalue_ write _setvalue_; - property bmheight index "bmheight" read _getvalue_ write _setvalue_; - property bmwidthbytes index "bmwidthbytes" read _getvalue_ write _setvalue_; - property bmplanes index "bmplanes" read _getvalue_ write _setvalue_; - property bmbitspixel index "bmbitspixel" read _getvalue_ write _setvalue_; - property nop1 index "nop1" read _getvalue_ write _setvalue_; - property bmbits index "bmbits" read _getvalue_ write _setvalue_; - {** - @ignore(忽略) %% - @param(bmwidth)(integer) 宽度%%; - @param(bmheight)(integer) 高度%%; - @param(bmwidthbytes)(integer) 行字节数%%; - @param(bmplanes)(integer) 调色板位数%%; - @param(bmbitspixel)(integer) 像素%%; - **} -end - - -type TSHICON=class(tslcstructureobj) - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("ficon","int",0), - ("xhotspot","int",0), - ("yhotspot","int",0), - ("hbmmask","intptr",0), - ("hbmcolor","intptr",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property ficon index "ficon" read _getvalue_ write _setvalue_; - property xhotspot index "xhotspot" read _getvalue_ write _setvalue_; - property yhotspot index "yhotspot" read _getvalue_ write _setvalue_; - property hbmmask index "hbmmask" read _getvalue_ write _setvalue_; - property hbmcolor index "hbmcolor" read _getvalue_ write _setvalue_; -end - -type ttagCHOOSECOLORA=class(tslcstructureobj) - {** - @explan(说明) 颜色选择结构体类 %% - **} - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("lstructsize","int",0), - ("hwndowner","intptr",0), - ("hinstance","intptr",0), - ("rgbresult","int",0), - ("lpcustcolors","user*",array((0,"int[16]",array(0)))), - ("flags","int",0), - ("lcustdata","intptr",0), - ("lpfnhook","intptr",0), - ("lptemplatename","char*",100))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - lstructsize := _size_(); - end - property lstructsize index "lstructsize" read _getvalue_ write _setvalue_; - property hwndowner index "hwndowner" read _getvalue_ write _setvalue_; - property hinstance index "hinstance" read _getvalue_ write _setvalue_; - property rgbresult index "rgbresult" read _getvalue_ write _setvalue_; - property lpcustcolors index "lpcustcolors" read _getvalue_ write _setvalue_; - property flags index "flags" read _getvalue_ write _setvalue_; - property lcustdata index "lcustdata" read _getvalue_ write _setvalue_; - property lpfnhook index "lpfnhook" read _getvalue_ write _setvalue_; - property lptemplatename index "lptemplatename" read _getvalue_ write _setvalue_; -end - -type ttagCHOOSEFONTA=class(tslcstructureobj) - {** - @explan(说明)字体选择结构体 %% - **} - private - static SSTRUCT; - Flogfont; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("lstructsize","int",0), - ("hwndowner","intptr",0), - ("hdc","intptr",0), - ("lplogfont","intptr",0), - ("ipointsize","int",0), - ("flags","int",0), - ("rgbcolors","int",0), - ("lcustdata","intptr",0), - ("lpfnhook","intptr",0), - ("lptemplatename","char*",100), - ("hinstance","intptr",0), - ("lpszstyle","intptr",100), - ("nfonttype","short",0), - ("___missing_alignment__","short",0), - ("nsizemin","int",0), - ("nsizemax","int",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - lg := inherited _getvalue_("lplogfont"); - Flogfont := new ttagLOGFONTA(lg ?: nil); - lplogfont := Flogfont._getptr_; - lstructsize := _size_(); - end - function _getvalue_(id);override; - begin - if id="lplogfont" then - begin - return new ttagLOGFONTA(inherited); - end else - return inherited; - end - function _setvalue_(id,v);override; - begin - if id="lplogfont" and ifnumber(v)and v then - begin - inherited _setvalue_(id,v); - end else - if v is class(ttagLOGFONTA)then - begin - inherited _setvalue_(id,v._getptr_); - end else - inherited; - end - function SetFontInfo(v); - begin - if ifarray(v)then - begin - for i,vi in v do - begin - Flogfont._setvalue_(i,vi); - end - end - end - property lstructsize index "lstructsize" read _getvalue_ write _setvalue_; - property hwndowner index "hwndowner" read _getvalue_ write _setvalue_; - property hdc index "hdc" read _getvalue_ write _setvalue_; - property lplogfont index "lplogfont" read _getvalue_ write _setvalue_; - property ipointsize index "ipointsize" read _getvalue_ write _setvalue_; - property flags index "flags" read _getvalue_ write _setvalue_; - property rgbcolors index "rgbcolors" read _getvalue_ write _setvalue_; - property lcustdata index "lcustdata" read _getvalue_ write _setvalue_; - property lpfnhook index "lpfnhook" read _getvalue_ write _setvalue_; - property lptemplatename index "lptemplatename" read _getvalue_ write _setvalue_; - property hinstance index "hinstance" read _getvalue_ write _setvalue_; - property lpszstyle index "lpszstyle" read _getvalue_ write _setvalue_; - property nfonttype index "nfonttype" read _getvalue_ write _setvalue_; - //property ___missing_alignment__ index "___missing_alignment__" read _getvalue_ write _setvalue_; - property nsizemin index "nsizemin" read _getvalue_ write _setvalue_; - property nsizemax index "nsizemax" read _getvalue_ write _setvalue_; -end - -type ttagLOGFONTA=class(tslcstructureobj) - {** - @explan(说明) 逻辑字体对象结构表示 %% - **} - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("height","int",15), - ("width","int",0), - ("escapement","int",0), - ("orientation","int",0), - ("weight","int",400), - ("italic","byte",0), - ("underline","byte",0), - ("strikeout","byte",0), - ("charset","byte",134), - ("outprecision","byte",3), - ("clipprecision","byte",2), - ("quality","byte",1), - ("pitchandfamily","byte",FIXED_PITCH), - ("facename","char[32]","新宋体"))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property height index "height" read _getvalue_ write _setvalue_; - property width index "width" read _getvalue_ write _setvalue_; - property escapement index "escapement" read _getvalue_ write _setvalue_; - property orientation index "orientation" read _getvalue_ write _setvalue_; - property weight index "weight" read _getvalue_ write _setvalue_; - property italic index "italic" read _getvalue_ write _setvalue_; - property underline index "underline" read _getvalue_ write _setvalue_; - property strikeout index "strikeout" read _getvalue_ write _setvalue_; - property charset index "charset" read _getvalue_ write _setvalue_; - property outprecision index "outprecision" read _getvalue_ write _setvalue_; - property clipprecision index "clipprecision" read _getvalue_ write _setvalue_; - property quality index "quality" read _getvalue_ write _setvalue_; - property pitchandfamily index "pitchandfamily" read _getvalue_ write _setvalue_; - property facename index "facename" read _getvalue_ write _setvalue_; -end -type TtagOFNA=class(tcstructwithcharptr) - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := array( - ("lstructsize","int",152), - ("hwndowner","intptr",0), - ("hinstance","intptr",0), - ("lpstrfilter","intptr",0), - ("lpstrcustomfilter","intptr",0), - ("nmaxcustfilter","int",0), - ("nfilterindex","int",1), - ("lpstrfile","char*",2049), - ("nmaxfile","int",2048), - ("lpstrfiletitle","char*",512), - ("nmaxfiletitle","int",511), - ("lpstrinitialdir","intptr",0), - ("lpstrtitle","intptr",0), - ("flags","int",0), //6148 - ("nfileoffset","byte[2]",(0,0)), - ("nfileextension","byte[2]",(0,0)), - ("lpstrdefext","intptr",0), - ("lcustdata","intptr",0), - ("lpfnhook","intptr",0), - ("lptemplatename","intptr",0), - ("pvreserved","intptr",0), - ("dwreserved","int",0), - ("flagsex","int",0)); - return SSTRUCT; - end - public - function create() - begin - inherited create(getstruct(),array( - "lpstrfiletitle":"nmaxfiletitle", - "lpstrfile":"nmaxfile", - "lpstrcustomfilter":"nmaxcustfilter", - "lpstrtitle":nil, - "lpstrdefext":nil),array( - "lpstrfilter":nil - )); - lstructsize := _size_(); - end - property lstructsize index "lstructsize" read _getvalue_ write _setvalue_; - property hwndowner index "hwndowner" read _getvalue_ write _setvalue_; - property hinstance index "hinstance" read _getvalue_ write _setvalue_; - property lpstrfilter index "lpstrfilter" read _getvalue_ write _setvalue_; - property lpstrcustomfilter index "lpstrcustomfilter" read _getvalue_ write _setvalue_; - property nmaxcustfilter index "nmaxcustfilter" read _getvalue_ write _setvalue_; - property nfilterindex index "nfilterindex" read _getvalue_ write _setvalue_; - property lpstrfile index "lpstrfile" read _getvalue_ write _setvalue_; - property nmaxfile index "nmaxfile" read _getvalue_ write _setvalue_; - property lpstrfiletitle index "lpstrfiletitle" read _getvalue_ write _setvalue_; - property nmaxfiletitle index "nmaxfiletitle" read _getvalue_ write _setvalue_; - property lpstrinitialdir index "lpstrinitialdir" read _getvalue_ write _setvalue_; - property lpstrtitle index "lpstrtitle" read _getvalue_ write _setvalue_; - property flags index "flags" read _getvalue_ write _setvalue_; - property nfileoffset index "nfileoffset" read _getvalue_ write _setvalue_; - property nfileextension index "nfileextension" read _getvalue_ write _setvalue_; - property lpstrdefext index "lpstrdefext" read _getvalue_ write _setvalue_; - property lcustdata index "lcustdata" read _getvalue_ write _setvalue_; - property lpfnhook index "lpfnhook" read _getvalue_ write _setvalue_; - property lptemplatename index "lptemplatename" read _getvalue_ write _setvalue_; - property lpeditinfo index "lpeditinfo" read _getvalue_ write _setvalue_; - property lpstrprompt index "lpstrprompt" read _getvalue_ write _setvalue_; - property pvreserved index "pvreserved" read _getvalue_ write _setvalue_; - property dwreserved index "dwreserved" read _getvalue_ write _setvalue_; - property flagsex index "flagsex" read _getvalue_ write _setvalue_; -end -type ttagTEXTMETRICA=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("tmheight","int",0), - ("tmascent","int",0), - ("tmdescent","int",0), - ("tminternalleading","int",0), - ("tmexternalleading","int",0), - ("tmavecharwidth","int",0), - ("tmmaxcharwidth","int",0), - ("tmweight","int",0), - ("tmoverhang","int",0), - ("tmdigitizedaspectx","int",0), - ("tmdigitizedaspecty","int",0), - ("tmfirstchar","byte",0), - ("tmlastchar","byte",0), - ("tmdefaultchar","byte",0), - ("tmbreakchar","byte",0), - ("tmitalic","byte",0), - ("tmunderlined","byte",0), - ("tmstruckout","byte",0), - ("tmpitchandfamily","byte",0), - ("tmcharset","byte",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property tmheight index "tmheight" read _getvalue_ write _setvalue_; - property tmascent index "tmascent" read _getvalue_ write _setvalue_; - property tmdescent index "tmdescent" read _getvalue_ write _setvalue_; - property tminternalleading index "tminternalleading" read _getvalue_ write _setvalue_; - property tmexternalleading index "tmexternalleading" read _getvalue_ write _setvalue_; - property tmavecharwidth index "tmavecharwidth" read _getvalue_ write _setvalue_; - property tmmaxcharwidth index "tmmaxcharwidth" read _getvalue_ write _setvalue_; - property tmweight index "tmweight" read _getvalue_ write _setvalue_; - property tmoverhang index "tmoverhang" read _getvalue_ write _setvalue_; - property tmdigitizedaspectx index "tmdigitizedaspectx" read _getvalue_ write _setvalue_; - property tmdigitizedaspecty index "tmdigitizedaspecty" read _getvalue_ write _setvalue_; - property tmfirstchar index "tmfirstchar" read _getvalue_ write _setvalue_; - property tmlastchar index "tmlastchar" read _getvalue_ write _setvalue_; - property tmdefaultchar index "tmdefaultchar" read _getvalue_ write _setvalue_; - property tmbreakchar index "tmbreakchar" read _getvalue_ write _setvalue_; - property tmitalic index "tmitalic" read _getvalue_ write _setvalue_; - property tmunderlined index "tmunderlined" read _getvalue_ write _setvalue_; - property tmstruckout index "tmstruckout" read _getvalue_ write _setvalue_; - property tmpitchandfamily index "tmpitchandfamily" read _getvalue_ write _setvalue_; - property tmcharset index "tmcharset" read _getvalue_ write _setvalue_; -end - -type TBrowseinfoA=class(tcstructwithcharptr) - {** - @explan(说明)文件夹选择结构 %% - **} - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("hwndowner","intptr",0), - ("pidlroot","intptr",0), - ("pszdisplayname","intptr",0), - ("lpsztitle","intptr",0), - ("ulflags","int",0), - ("lpfn","intptr",0), - ("lparam","intptr",0), - ("iimage","int",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),nil,array("lpsztitle":nil,"pszdisplayname":nil)); - lpsztitle := 1024; - pszdisplayname := 1024; - end - property hwndowner index "hwndowner" read _getvalue_ write _setvalue_; - property pidlroot index "pidlroot" read _getvalue_ write _setvalue_; - property pszdisplayname index "pszdisplayname" read _getvalue_ write _setvalue_; - property lpsztitle index "lpsztitle" read _getvalue_ write _setvalue_; - property ulflags index "ulflags" read _getvalue_ write _setvalue_; - property lpfn index "lpfn" read _getvalue_ write _setvalue_; - property lparam index "lparam" read _getvalue_ write _setvalue_; - property iimage index "iimage" read _getvalue_ write _setvalue_; -end - -type TNMHDR=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("hwndfrom","intptr",0), - ("idfrom","intptr",0), - ("code","int",0))); - return SSTRUCT; - end - public - class function memsize(); - begin - if not SSTRUCT then getstruct(); - if SSTRUCT then - begin - ldata := length(SSTRUCT)-1; - return SSTRUCT[ldata,3]+SSTRUCT[ldata,4]-SSTRUCT[0,3]; - end - return 0; - end - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property hwndfrom index "hwndfrom" read _getvalue_ write _setvalue_; - property idfrom index "idfrom" read _getvalue_ write _setvalue_; - property code index "code" read _getvalue_ write _setvalue_; -end -type TWINDOWINFO=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("cbsize","int",0), - ("rcwindow","int[4]", - (0,0,0,0)), - ("rcclient","int[4]", - (0,0,0,0)), - ("dwstyle","int",0), - ("dwexstyle","int",0), - ("dwwindowstatus","int",0), - ("cxwindowborders","int",0), - ("cywindowborders","int",0), - ("atomwindowtype","byte[2]",(0,0)), - ("wcreatorversion","short",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property cbsize index "cbsize" read _getvalue_ write _setvalue_; - property rcwindow index "rcwindow" read _getvalue_ write _setvalue_; - property rcclient index "rcclient" read _getvalue_ write _setvalue_; - property dwstyle index "dwstyle" read _getvalue_ write _setvalue_; - property dwexstyle index "dwexstyle" read _getvalue_ write _setvalue_; - property dwwindowstatus index "dwwindowstatus" read _getvalue_ write _setvalue_; - property cxwindowborders index "cxwindowborders" read _getvalue_ write _setvalue_; - property cywindowborders index "cywindowborders" read _getvalue_ write _setvalue_; - property atomwindowtype index "atomwindowtype" read _getvalue_ write _setvalue_; - property wcreatorversion index "wcreatorversion" read _getvalue_ write _setvalue_; -end -////////////////////////socket 结构体//////////////////////////////////// -type TSockaddr=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("sa_family","short",0), - ("sa_data","char[14]",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property sa_family index "sa_family" read _getvalue_ write _setvalue_; - property sa_data index "sa_data" read _getvalue_ write _setvalue_; -end -type TSockaddr_in=class(tslcstructureobj) - private - static SSTRUCT; - FOpr; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("sin_family","short",0), - ("sin_port","short",0), - ("sin_addr","int",0), - ("sin_zero","char[8]",0))); - return SSTRUCT; - end - function writeIntShortN(n,V); - begin - if not(n >= 0 and n <= 1)then exit; - nv := sin_addr; - bs := FOpr.IntToShorts(nv); - bs[n]:= v; - sin_addr := FOpr.ShortsToInt(bs); - end - function writeIntByteN(n,V); - begin - if not(n >= 0 and n <= 3)then exit; - nv := sin_addr; - bs := FOpr.IntAsBytes(nv); - bs[n]:= v; - sin_addr := FOpr.bytesasint(bs); - end - function ReadIntShortN(N); - begin - if not(n >= 0 and n <= 1)then exit; - nv := sin_addr; - bs := FOpr.IntToShorts(nv); - return bs[n]; - end - function ReadIntByteN(N); - begin - if not(n >= 0 and n <= 3)then exit; - nv := sin_addr; - bs := FOpr.IntAsBytes(nv); - return bs[n]; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - FOpr := new TByteData(); - end - property s_b1 index 0 read ReadIntByteN write writeIntByteN; - property s_b2 index 1 read ReadIntByteN write writeIntByteN; - property s_b3 index 2 read ReadIntByteN write writeIntByteN; - property s_b4 index 3 read ReadIntByteN write writeIntByteN; - property s_w1 index 0 read ReadIntShortN write writeIntShortN; - property s_w2 index 1 read ReadIntShortN write writeIntShortN; - property sin_family index "sin_family" read _getvalue_ write _setvalue_; - property sin_port index "sin_port" read _getvalue_ write _setvalue_; - property sin_addr index "sin_addr" read _getvalue_ write _setvalue_; - property sin_zero index "sin_zero" read _getvalue_ write _setvalue_; -end -type TSockaddr_in6=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("sin6_family","short",0), - ("sin6_port","short",0), - ("sin6_flowinfo","long",0), - ("sin6_addr","byte[16]",array()), //union byte16 short8 - ("sin6_scope_id","long",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property sin6_family index "sin6_family" read _getvalue_ write _setvalue_; - property sin6_port index "sin6_port" read _getvalue_ write _setvalue_; - property sin6_flowinfo index "sin6_flowinfo" read _getvalue_ write _setvalue_; - property sin6_addr index "sin6_addr" read _getvalue_ write _setvalue_; - property sin6_scope_id index "sin6_scope_id" read _getvalue_ write _setvalue_; -end -type TWSADATA=class(tslcstructureobj) //有点不理解 - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then - {$IFDEF win64} - SSTRUCT := MemoryAlignmentCalculate(array( - ("wversion","short",0), - ("whighversion","short",0), - ("imaxsockets","short",0), - ("imaxudpdg","short",0), - ("lpvendorinfo","char*",100), - ("szdescription","char[257]",0), - ("szsystemstatus","char[129]",0))); - {$ELSE} - SSTRUCT := MemoryAlignmentCalculate(array( - ("wversion","short",0), - ("whighversion","short",0), - ("szdescription","char[157]",0), - ("szsystemstatus","char[129]",0), - ("imaxsockets","short",0), - ("imaxudpdg","short",0), - ("lpvendorinfo","char*",100))); - {$ENDIF} - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property wversion index "wversion" read _getvalue_ write _setvalue_; - property whighversion index "whighversion" read _getvalue_ write _setvalue_; - property imaxsockets index "imaxsockets" read _getvalue_ write _setvalue_; - property imaxudpdg index "imaxudpdg" read _getvalue_ write _setvalue_; - property lpvendorinfo index "lpvendorinfo" read _getvalue_ write _setvalue_; - property szdescription index "szdescription" read _getvalue_ write _setvalue_; - property szsystemstatus index "szsystemstatus" read _getvalue_ write _setvalue_; -end -/////////////////////////////////////////////////////////////// -type tagWNDCLASSA=class(tslcstructureobj) // 窗口类对象 %% - static classstruct; - class function getstruct(); - begin - if not classstruct then - begin - classstruct := MemoryAlignmentCalculate(array( - ("cbsize","int",0), - ("style","int",0), - ("lpfnwndproc","intptr",0), - ("cbclsextra","int",0), - ("cbwndextra","int",0), - ("hinstance","intptr",0), - ("hicon","intptr",0), - ("hcursor","intptr",0), - ("hbrbackground","intptr",0), - ("lpszmenuname","intptr",0), //("lpszmenuname","char*",100), - ("lpszclassname","char*",100), - ("hiconsm","intptr",0))); - end - return classstruct; - end - function create(ptr); - begin - class(tslcstructureobj).create(getstruct(),ptr); - _setvalue_("cbsize",_size_()); - end - property style:integer index "style" read _getvalue_ write _setvalue_; - property cbsize:integer index "cbsize" read _getvalue_ write _setvalue_; - property lpfnwndproc:pointer index "lpfnwndproc" read _getvalue_ write _setvalue_; - property cbclsextra:integer index "cbclsextra" read _getvalue_ write _setvalue_; - property cbwndextra:integer index "cbwndextra" read _getvalue_ write _setvalue_; - property hinstance:pointer index "hinstance" read _getvalue_ write _setvalue_; - property cbwndextra:integer index "cbwndextra" read _getvalue_ write _setvalue_; - property hicon:pointer index "hicon" read _getvalue_ write _setvalue_; - property hcursor:pointer index "hcursor" read _getvalue_ write _setvalue_; - property lpszmenuname:pointer index "lpszmenuname" read _getvalue_ write _setvalue_; - property hbrbackground:pointer index "hbrbackground" read _getvalue_ write _setvalue_; - property lpszclassname:string index "lpszclassname" read _getvalue_ write _setvalue_; - property hiconsm:pointer index "hiconsm" read _getvalue_ write _setvalue_; -end //////////////////////////////////内存对象截止//////////////////////////////////////////////////// -type TFpList=class(tarray1dlk) - {** - @explan(说明) list类 %% - **} - function create(); - begin - inherited; - end - function indexof(v,f,lx); - begin - {** - @explan(说明) 查找值v在序列中的位置 %% - @param(v)(any) 任何类型 %% - @return(integer) 位置 ,等于-1 表示没查找到 %% - **} - return findvid(v,f,lx); - end - function operator[](index); - begin - {** - @explan(说明)获取序号为index的值 %% - @return(any) 数据 %% - **} - return geti(index); - end - function add(v); - begin - {** - @explan(说明)追加数据到链表 %% - @param(v)(any) 数据 %% - **} - return append(v); - end - function Remove(v); - begin - {** - @explan(说明)删除数据V %% - @param(v)(any) 数据 %% - **} - return deli(indexof(v)); - end - function last(); - begin - {** - @explan(说明)获取最后一个数据 %% - @return(any) 数据 %% - **} - return geti(self.Count()-1); - end - function Count(); - begin - {** - @explan(说明)获取数据个数 %% - @return(integer) %% - **} - return len(); - end -end - -type TCreateParams=class() - {** - @explan(说明) 窗口控件构造参数对象 %% - **} - {** - @ignore(忽略) - **} - private - FParams; - public - {** - @param(Caption)(string) 控件标题 %% - @param(Style)(integer) 控件样式 %% - @param(ExStyle)(integer) 控件扩展样式 %% - @param(winclass)() 窗口类样式 %% - **} - Caption:string; - Style:integer; - ExStyle:integer; - X,Y:Integer; - CreateWithSubClass; - Width,Height:Integer; - WndParent:HWnd; - Param:Pointer; - winclass:tagWNDCLASSA; - subclass:tagWNDCLASSA; - WinClassName:string; - {** - @param(tagWNDCLASSA)() 依赖标准控件基类 %% - @param(WinClassName)() 窗口类名称 %% - @param(SubClassName)() 依赖窗口基类名称 %% - @param(subclasswndproc)() 依赖窗口基类消息函数 %% - @param(Winclasswndproc)() 窗口类消息函数 %% - @param(cstyle)(integer) 窗口类样式 %% - @param(id)(integer) 窗口id 自动分配 %% - @param(happ)(pointer) 进程句柄 自动分配 %% - **} - SubClassName:string; - subclasswndproc:pointer; - Winclasswndproc:pointer; - id; - cstyle; - //cbrush; - happ; - public - function create(); - begin - FParams := array(); - Caption := ""; - Style := 0; - ExStyle := 0; - id := x := y := 0; - Width := Height := 0; - WndParent := 0; - Param := 0; - WinClassName := 0; - SubClassName := 0; - WinClassName := "tsui_window"; - subclasswndproc := 0; - Winclasswndproc := 0; - winclass := new tagWNDCLASSA(); - subclass := new tagWNDCLASSA(); - cbsize := winclass._size_(); - winclass._setvalue_("cbsize",cbsize); - subclass._setvalue_("cbsize",cbsize); - cstyle := 0; - end - function operator[](index); - begin - if ifstring(index)then - begin - nindex := lowercase(index); - try - return invoke(self(true),nindex); - except - return FParams[nindex]; - end - end else - return FParams[index]; - end - function operator[1](index,value); - begin - if ifstring(index)then - begin - nindex := lowercase(index); - try - invoke(self(true),index,1,value); - except - FParams[nindex]:= value; - end - end else - FParams[index]:= value; - end -end - - -type TFPPenEndCap=class(tenumeration) - static pecRound; - static pecSquare; - static pecFlat; -end -type TFPPenMode=class(tenumeration) - static pmBlack; - static pmWhite; - static pmNop; - static pmNot; - static pmCopy; - static pmNotCopy; - static pmMergePenNot; - static pmMaskPenNot; - static pmMergeNotPen; - static pmMaskNotPen; - static pmMerge; - static pmNotMerge; - static pmMask; - static pmNotMask; - static pmXor; - static pmNotXor; -end -type TMouseButton=class(tenumeration) - static mbLeft; - static mbRight; - static mbMiddle; - static mbExtra1; - static mbExtra2; -end - -type TDragKind=class(tenumeration) - static dkDrag; - static dkDock; -end -type TDragMode=class(tenumeration) - static dmManual; - static dmAutomatic; -end -type TPairSplitterType=class(tenumeration) - static pstHorizontal; - static pstVertical; -end -type TDockOrientation=class(tenumeration) - static doNoOrient; // zone contains a TControl and no child zones.; - static doHorizontal; // zone's children are stacked top-to-bottom.; - static doVertical; // zone's children are arranged left-to-right.; - static doPages; // zone's children are pages arranged left-to-right.; -end -type TShiftStateEnum=class(tenumeration) - static ssShift; - static ssAlt; - static ssCtrl; - static ssLeft; - static ssRight; - static ssMiddle; - static ssDouble; - static ssMeta; //// Extra additions - static ssSuper; - static ssHyper; - static ssAltGr; - static ssCaps; - static ssNum; - static ssScroll; - static ssTriple; - static ssQuad; - static ssExtra1; - static ssExtra2; -end -type TControlFlag=class(tenumeration) - static cfLoading; // set by TControl.ReadState; unset by TControl.Loaded when all on form finished loading; - static cfAutoSizeNeeded; - static cfLeftLoaded; // cfLeftLoaded is set; when 'Left' is set during loading.; - static cfTopLoaded; - static cfWidthLoaded; - static cfHeightLoaded; - static cfClientWidthLoaded; - static cfClientHeightLoaded; - static cfBoundsRectForNewParentValid; - static cfBaseBoundsValid; - static cfPreferredSizeValid; - static cfPreferredMinSizeValid; - static cfOnChangeBoundsNeeded; - static cfProcessingWMPaint; - static cfKillChangeBounds; - static cfKillInvalidatePreferredSize; - static cfKillAdjustSize; -end - -type TFormStyle=class(tenumeration) - static fsMDIChild; - static fsMDIForm; - static fsStayOnTop; - static fsSplash; - static fsSystemStayOnTop; -end -type TComponentState=class(tenumeration) - static csLoading; - static csReading; - static csWriting; - static csDestroying; - static csDesigning; - static csAncestor; - static csUpdating; - static csFixups; - static csFreeNotification; - static csInline; - static csDesignInstance; -end -type TComponentStyle=class(tenumeration) - static csInheritable; - static csCheckPropAvail; - static csSubComponent; - static csTransient; -end -type TOperation=class(tenumeration) - static opInsert; - static opRemove; -end -type TAlign=class(tenumeration) - {** - @explan(说明) 自动对齐类型常量 %% - **} - static alNone; - static alTop; - static alBottom; - static alLeft; - static alRight; - static alClient; - static alCustom; -end - -type TAnchorKind=class(tenumeration) - //akTop, akLeft, akRight, akBottom - static akTop; - static akLeft; - static akRight; - static akBottom; -end - -type TWinControlFlag=class(tenumeration) - static wcfClientRectNeedsUpdate; - static wcfColorChanged; - static wcfFontChanged; - static wcfAllAutoSizing; - static wcfAligningControls; - static wcfEraseBackground; - static wcfCreatingHandle; - static wcfInitializing; - static wcfCreatingChildHandles; - static wcfRealizingBounds; - static wcfBoundsRealized; - static wcfUpdateShowing; - static wcfHandleVisible; - static wcfAdjustedLogicalClientRectValid; - static wcfKillIntfSetBounds; -end - -type TControlStyleType=class(tenumeration) - static csAcceptsControls; // can have children in the designer; - static csCaptureMouse; // auto capture mouse when clicked; - static csDesignInteractive; // wants mouse events in design mode; - static csClickEvents; // handles mouse events; - static csFramed; // not implemented; has 3d frame; - static csSetCaption; // if Name=Caption; changing the Name changes the Caption; - static csOpaque; // the control paints its area completely; - static csDoubleClicks; // understands mouse double clicks; - static csTripleClicks; // understands mouse triple clicks; - static csQuadClicks; // understands mouse quad clicks; - static csFixedWidth; // cannot change its width; - static csFixedHeight; // cannot change its height (for example combobox); - static csNoDesignVisible; // is invisible in the designer; - static csReplicatable; // PaintTo works; - static csNoStdEvents; // standard events such as mouse; key; and click events are ignored.; - static csDisplayDragImage; // display images from dragimagelist during drag operation over control; - static csReflector; // not implemented; the controls respond to size; focus and dlg messages - it can be used as ActiveX control under Windows; - static csActionClient; // Action is set; - static csMenuEvents; // not implemented; - static csNoFocus; // control will not take focus when clicked with mouse.; - static csNeedsBorderPaint; // not implemented; - static csParentBackground; // tells WinXP to paint the theme background of parent on controls background; - static csDesignNoSmoothResize; // when resizing control in the designer do not SetBounds while dragging; - static csDesignFixedBounds; // can not be moved nor resized in designer; - static csHasDefaultAction; // implements useful ExecuteDefaultAction; - static csHasCancelAction; // implements useful ExecuteCancelAction; - static csNoDesignSelectable; // can not be selected at design time; - static csOwnedChildrenNotSelectable; // child controls owned by this control are NOT selectable in the designer; - static csAutoSize0x0; // if the preferred size is 0x0 then control is shrinked ot 0x0; - static csAutoSizeKeepChildLeft; // when AutoSize=true do not move children horizontally; - static csAutoSizeKeepChildTop; // when AutoSize=true do not move children vertically; - static csRequiresKeyboardInput; // If the device has no physical keyboard then show the virtual keyboard when this control gets focus (therefore available only to TWinControl descendents); -end - -type TControlStateType=class(tenumeration) - static csLButtonDown; - static csClicked; - static csPalette; - static csReadingState; - static csFocusing; - static csCreating; - static csPaintCopy; - static csCustomPaint; - static csDestroyingHandle; - static csDocking; - static csVisibleSetInLoading; -end - -type TDragState=class(tenumeration) - static dsDragEnter; - static dsDragLeave; - static dsDragMove; -end -type TDragMessage=class(tenumeration) - static dmDragEnter; - static dmDragLeave; - static dmDragMove; - static dmDragDrop; - static dmDragCancel; - static dmFindTarget; -end -type TCanvasStates=class(tenumeration) - static csHandleValid; - static csFontValid; - static csPenvalid; - static csBrushValid; - static csRegionValid; -end -type TFPPenStyle=class(tenumeration) - static psSolid; - static psDash; - static psDot; - static psDashDot; - static psDashDotDot; - static psinsideFrame; - static psPattern; - static psClear; -end -type TFPPenJoinStyle=class(tenumeration) - static pjsRound; - static pjsBevel; - static pjsMiter; -end - -type TFormBorderStyle=class(tenumeration) - static bsNone; - static bsSingle; - static bsSizeable; - static bsDialog; - static bsToolWindow; - static bsSizeToolWin; -end -type TActionListState=class(tenumeration) - static asNormal; - static asSuspended; - static asSuspendedEnabled; -end - -type TAlignStyleH3=class(tenumeration) - {** - @explan(说明) 水平对齐常量 %% - **} - static AL3_LEFT; //0 - static AL3_RIGHT; //1 - static AL3_CENTER; //2 -end -type TAlignStyle9=class(tenumeration) - {** - @explan(说明) 九宫格对齐常量 %% - **} - static AL9_DEFAULT; //0 - static AL9_TOPLEFT; //1 - static AL9_TOPCENTER; //2 - static AL9_TOPRIGHT; //3 - static AL9_CENTERLEFT; //4 - static AL9_CENTER; //5 - static AL9_CENTERRIGHT; //6 - static AL9_BOTTOMLEFT; //7 - static AL9_BOTTOMCENTER; //8 - static AL9_BOTTOMRIGHT; //9 -end -type TToolButtonStyle=class(tenumeration) - static tbsButton; - static tbsCheck; - static tbsDropDown; - static tbsSeparator; - static tbsDivider; - static tbsButtonDrop; -end - -type TRasterOperationConst=class - {** - @explan(说明) 光栅操作代码常量类 %% - **} - static SRCCOPY; - static SRCPAINT; - static SRCAND; - static SRCINVERT; - static SRCERASE; - static NOTSRCCOPY; - static NOTSRCERASE; - static MERGECOPY; - static MERGEPAINT; - static PATCOPY; - static PATPAINT; - static PATINVERT; - static DSTINVERT; - static BLACKNESS; - static WHITENESS; - static NOMIRRORBITMAP; -end - -type TSystemBitmap=class - {** - @explan(说明) 系统提供的bitmap id %% - **} - static OBM_CLOSE; - static OBM_UPARROW; - static OBM_DNARROW; - static OBM_RGARROW; - static OBM_LFARROW; - static OBM_REDUCE; - static OBM_ZOOM; - static OBM_RESTORE; - static OBM_REDUCED; - static OBM_ZOOMD; - static OBM_RESTORED; - static OBM_UPARROWD; - static OBM_DNARROWD; - static OBM_RGARROWD; - static OBM_LFARROWD; - static OBM_MNARROW; - static OBM_COMBO; - static OBM_UPARROWI; - static OBM_DNARROWI; - static OBM_RGARROWI; - static OBM_LFARROWI; - static OBM_OLD_CLOSE; - static OBM_SIZE; - static OBM_OLD_UPARROW; - static OBM_OLD_DNARROW; - static OBM_OLD_RGARROW; - static OBM_OLD_LFARROW; - static OBM_BTSIZE; - static OBM_CHECK; - static OBM_CHECKBOXES; - static OBM_BTNCORNERS; - static OBM_OLD_REDUCE; - static OBM_OLD_ZOOM; - static OBM_OLD_RESTORE; -end - -type TSystemCursor=class - {** - @explan(说明) 鼠标常量类,作为参考 %% - **} - static OCR_WAIT; //150 - static OCR_CROSS; //30; - static OCR_UP; //6 - static OCR_SIZE; //0 - static OCR_SIZENWSE; //14 - static OCR_SIZENESW; //12 - static OCR_SIZEWE; //70 - static OCR_SIZENS; //138 - static OCR_SIZEALL; //58 - static OCR_ICOCUR; // 0 - static OCR_NO; //0 - static OCR_HAND; //24 - static OCR_APPSTARTING; //126 - static OCR_IBEAM; //152 -end - -type TSysCursor=class(tenumeration) - class function basevalue();override; - begin - { - //gtk 对照 - IDC_ARROW :=2 ; - IDC_IBEAM :=152; - IDC_WAIT :=150 ; - IDC_CROSS :=30; - IDC_UPARROW := 6; - IDC_SIZE :=0; //*** - IDC_ICON := 64; - IDC_SIZENWSE := 14; - IDC_SIZENESW := 12; - IDC_SIZEWE :=70; - IDC_SIZENS :=138; - IDC_SIZEALL := 58; - IDC_NO :=0; - IDC_HAND := 24; - IDC_APPSTARTING := 126; - IDC_HELP :=92; - return ; - } - IDC_ARROW := 32512; - IDC_SIZE := 32540; - IDC_NO := 32548; - end - static IDC_ARROW; //MAKEINTRESOURCE(32512) - static IDC_IBEAM; //MAKEINTRESOURCE(32513) - static IDC_WAIT; //MAKEINTRESOURCE(32514) - static IDC_CROSS; //MAKEINTRESOURCE(32515) - static IDC_UPARROW; //MAKEINTRESOURCE(32516) - static IDC_SIZE; //MAKEINTRESOURCE(32640) /* OBSOLETE: use IDC_SIZEALL */ - static IDC_ICON; //MAKEINTRESOURCE(32641) /* OBSOLETE: use IDC_ARROW */ - static IDC_SIZENWSE; // MAKEINTRESOURCE(32642) - static IDC_SIZENESW; // MAKEINTRESOURCE(32643) - static IDC_SIZEWE; //MAKEINTRESOURCE(32644) - static IDC_SIZENS; //MAKEINTRESOURCE(32645) - static IDC_SIZEALL; //MAKEINTRESOURCE(32646) - static IDC_NO; //MAKEINTRESOURCE(32648) - static IDC_HAND; //MAKEINTRESOURCE(32649) - static IDC_APPSTARTING; // MAKEINTRESOURCE(32650) - static IDC_HELP; //MAKEINTRESOURCE(32651) -end - -type tconstant = class(talign,TAnchorKind,TFormStyle,TComponentState, - TComponentStyle,TOperation,TWinControlFlag, - TControlStyleType,TMouseButton,TShiftStateEnum, - TControlFlag,TDockOrientation,TDragKind,TDragMode, - TDragState,TDragMessage,TCanvasStates,TFPPenMode, - TFPPenEndCap,TFPPenJoinStyle,TControlStateType, - TFormBorderStyle,TAlignStyle9,TAlignStyleH3,TSysCursor, - TActionListState,TToolButtonStyle,TPairSplitterType - ) - {** - @explan(说明) 常量类集合 %% - **} -end //******************常量类型********************************** - ///////////////////////////////// - type TResourcescache=class - {** - @ignore(忽略) %% - @explan(说明)gdi资源等的缓存 - **} - private - FCache; - _wapi; - public - function create(); - begin - FCache := array(); - _wapi := gettswin32api(); - end - function reference(name);virtual; - begin - {** - @explan(说明)引用资源 %% - @param(name)(string) 资源名称 %% - **} - v := Fcache[name]; - if ifarray(v)then - begin - Fcache[name,"count"]+= 1; - return Fcache[name,"value"]; - end - return 0; - end - function unreference(name);virtual; - begin - {** - @explan(说明)取消引用资源 %% - @param(name)(string) 资源名称 %% - **} - v := Fcache[name]; - if ifarray(v)then - begin - count := v["count"]; - if count >= 1 then - begin - Fcache[name]["count"]-= 1; - return 1; - end - {else - begin - destroyresource(name); - end} - end - return 0; - end - function addsource(name,value);virtual; - begin - {** - @explan(说明)添加资源 %% - @param(name)(string) 资源名称 %% - @param(value)(obj) 资源值 %% - **} - //RETURN ; //不缓存 - v := Fcache[name]; - if not(v)then - begin - Fcache[name]["value"]:= value; - Fcache[name]["count"]:= 1; - //return 1; - end else - begin - if Fcache[name]["value"]=value then - begin - Fcache[name]["count"]++; - end else - if value then - begin - destroyresource(name); - return addsource(name,value); - end - end - FCacheLength := length(FCache); - maxlen := 256; - if FCacheLength>maxlen then - begin - ct := 0; - rdxs := array(); - for i,v in FCache do - begin - if v["count"]=0 then - begin - rdxs[ct++]:= i; - end - if FCacheLength-ct <= maxlen then - begin - break; - end - end - for i,v in rdxs do - begin - destroyresource(v); - end - end - return 0; - end - function destroyresource(name);virtual; - begin - {** - @explan(说明)删除指定的资源 %% - @param(name)(string) 资源名称 %% - **} - v := Fcache[name]; - if v then - begin - hd := v["value"]; - reindex(Fcache,array(name:nil)); - _wapi.DeleteObject(hd); - end - end -end - -type TCHECK_RESULT=class(tslcstructureobj) - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("errline","int",0), - ("errmsg","char[4096]",0) - )); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property errline index "errline" read _getvalue_ write _setvalue_; - property errmsg index "errmsg" read _getvalue_ write _setvalue_; -end - - -type TNMMOUSE=class(tslcstructureobj) - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("hdr","user",array( - ("hwndfrom","intptr",0), - ("idfrom","intptr",0), - ("code","int",0))), - ("dwitemspec","intptr",0), - ("dwitemdata","intptr",0), - ("pt","int[2]", - (0,0)), - ("dwhitinfo","intptr",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property hdr index "hdr" read _getvalue_ write _setvalue_; - property dwitemspec index "dwitemspec" read _getvalue_ write _setvalue_; - property dwitemdata index "dwitemdata" read _getvalue_ write _setvalue_; - property pt index "pt" read _getvalue_ write _setvalue_; - property dwhitinfo index "dwhitinfo" read _getvalue_ write _setvalue_; -end ///////////////////////////////// - - ///////////////////////////消息对象//////////////////////////////////// -type tuieventbase=class(TSLUICONST) - {** - @explan(说明) 消息基类 %% - **} - public - Message:integer; - Wparam:pointer; - Lparam:pointer; - Hwnd:pointer; - _tag; - {** - @param(Message)(integer) 消息id %% - @param(Wparam)(pointer) 消息wparam %% - @param(Lparam)(pointer) 消息lparam %% - @param(Hwnd)(pointer) 窗口句柄 %% - **} - private - Fhwparam; - Flwparam; - Fhlparam; - Fllparam; - //有符号数 - Fuhwparam; - Fulwparam; - Fuhlparam; - Fullparam; - //结果 - FSkip; - Fresult; - FSender; - function setSkip(v); - begin - if v then - begin - FSkip := true; - end else - begin - FSkip := false; - end - end - function GetSender(); - begin - return FSender; - end - Function SetSender(v); - begin - return FSender := v; - end - public - //FLparamdata; - //FWparamdata; - function create(m,w,l,h);virtual; - begin - {** - @explan(说明) 消息构造 %% - @param(m)(integer) 消息id %% - @param(w)(pointer) 消息wparam %% - @param(l)(pointer) 消息lparam %% - @param(h)(pointer) 窗口句柄 %% - **} - Message := m; - Wparam := w; - Lparam := l; - Hwnd := h; - end - function hilparam(); - begin - {** - @explan(说明) 高字节 %% - **} - if ifnil(Fhlparam)then - begin - lowuperdword(Lparam,Fllparam,Fhlparam); - end - return Fhlparam; - end - function lolparam(); - begin - {** - @explan(说明) 低字节 %% - **} - if ifnil(Fllparam)then - begin - lowuperdword(Lparam,Fllparam,Fhlparam); - end - return Fllparam; - end - function hiwparam(); - begin - {** - @explan(说明) 高字节 %% - **} - if ifnil(Fhwparam)then - begin - lowuperdword(Wparam,Flwparam,Fhwparam); - end - return Fhwparam; - end - function lowparam(); - begin - {** - @explan(说明) 低字节 %% - **} - if ifnil(Flwparam)then - begin - lowuperdword(Wparam,Flwparam,Fhwparam); - end - return Flwparam; - end - function hilparamsigned(); - begin - {** - @explan(说明) 高字作为符号数 - **} - if ifnil(Fuhlparam)then Fuhlparam := unsignedtosigned(hilparam()); - return Fuhlparam; - end - function lolparamsigned(); - begin - {** - @explan(说明) 低字作为符号数 - **} - if ifnil(Fullparam)then Fullparam := unsignedtosigned(lolparam()); - return Fullparam; - end - function hiwparamsigned(); - begin - {** - @explan(说明) 高字作为符号数 - **} - if ifnil(Fuhwparam)then Fuhwparam := unsignedtosigned(hiwparam()); - return Fuhwparam; - end - function lowparamsigned(); - begin - {** - @explan(说明) 低字作为符号数 - **} - if ifnil(Fulwparam)then Fulwparam := unsignedtosigned(lowparam()); - return Fulwparam; - end - property msg read Message; - property skip read FSkip write setSkip; - property Result read Fresult write Fresult; - property Handle read Hwnd write Hwnd; - property Sender read GetSender write SetSender; - {** - @param(msg)(integer) 消息id %% - @param(skip)(bool) 是否忽略底层消息处理函数 %% - @param(Result)(integer) 消息处理返回 %% - @param(Handle)(pointer) 窗口句柄 %% - @param(sender)(TControl) 发送消息的控件,如菜单消息的触发窗口 %% - **} -end - - -type TPAINTSTRUCT=class(tslcstructureobj) - {** - @expaln(说明)wm_paint消息结构体 %% - **} - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("hdc","intptr",0), - ("ferase","int",0), - ("rcpaint","int[4]", - (0,0,0,0)), - ("frestore","int",0), - ("fincupdate","int",0), - ("rgbreserved","byte[32]",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property hdc index "hdc" read _getvalue_; - property ferase index "ferase" read _getvalue_; - property rcpaint index "rcpaint" read _getvalue_; - property frestore index "frestore" read _getvalue_; - property fincupdate index "fincupdate" read _getvalue_; - property rgbreserved index "rgbreserved" read _getvalue_; -end -type TMNOTIFY=class(tuieventbase,tslcstructureobj) - {** - @explan(说明) 系统控件通知消息 %% - **} - STATIC SFSTRUCT; - function getstruct(); - begin - if not SFSTRUCT then SFSTRUCT := MemoryAlignmentCalculate(array( - ("hwndfrom","intptr",0), - ("idfrom","intptr",0), - ("code","int",0))); - return SFSTRUCT; - end - function create(m,w,l,h);override; - begin - inherited; - class(tslcstructureobj).create(getstruct(),l); - end - property hwndfrom index "hwndfrom" read _getvalue_; - property code index "code" read _getvalue_; - {** - @param(hwndfrom)(pointer) 子控件句柄 %% - @param(code)(integer) 通知码 %% - **} -end -type TMALIGN=class(tuieventbase) - value; - top:integer; - left:integer; - width:integer; - height:integer; - function create(m,w,l,h); - begin - inherited; - top := left := right := bottom := 0; - end -end -type TMANCHOR=class(tuieventbase) - prec; - function create(m,w,l,h); - begin - inherited; - prec := array(0,0,0,0); - end -end - -type TMMENUSELECT=class(tuieventbase) - {** - @explan(说明) 菜单选择消息 %% - **} - function create(m,w,l,h);override; - begin - inherited; - end - property itemid read lowparam; - property flags read hiwparam; - {** - @param(itemid)(integer) 菜单id %% - @param(flags)(integer) 状态 %% - **} -end -type TMKEY=class(tuieventbase) - {** - @param(说明) 按键消息 - **} - private - FShiftsate; - function getshiftsate(); - begin - if not ifarray(FShiftsate)then - begin - FShiftsate := array(); - w32 := gettswin32api(); - if getbitsfrominteger(w32.GetKeyState(VK_SHIFT),15,15)then FShiftsate[length(FShiftsate)]:= ssShift; - if getbitsfrominteger(w32.GetKeyState(VK_CONTROL),15,15)then FShiftsate[length(FShiftsate)]:= ssCtrl; - if getbitsfrominteger(w32.GetKeyState(VK_MENU),15,15)then FShiftsate[length(FShiftsate)]:= ssAlt; - //echo tostn(FShiftsate); - //echo getbitsfrominteger( w32.GetKeyState(VK_MENU),15,15),"*************\r\n"; - end - return FShiftsate; - end - FChar; - public - function create(m,w,l,h);override; - begin - inherited; - FChar := chr(w); - end - property char read FChar; - property CharCode read wparam; - property shiftstate read getshiftsate; - {** - @param(char)(string) 键符号 %% - @param(CharCode)(integer) ascii码 %% - @param(shiftstate)(arry of TShiftStateEnum member ) ascii码 %% - **} -end - -Type TtageDrawItem=class(tslcstructureobj) - private - static SFSTRUCT; - class function getstruct();virtual; - begin - if not SFSTRUCT then SFSTRUCT := MemoryAlignmentCalculate(array( - ("ctltype","int",0), - ("ctlid","int",0), - ("itemid","int",0), - ("itemaction","int",0), - ("itemstate","int",0), - ("hwnditem","intptr",0), - ("hdc","intptr",0), - ("rcitem","int[4]", - (0,0,0,0)), - ("itemdata","intptr",0))); - return SFSTRUCT; - end - public - function create(ptr); - begin - inherited create(getstruct(),ptr); - end - {** - @param(ctltype)(integer) 控件类型 %% - @param(ctlid)(integer) 控件id %% - @param(id)(integer) 待绘制的子项序号 %% - @param(itemstate)(member of TDrawitemState ) 状态%% - @param(hdc)(pointer) canvas句柄 %% - @param(hwnditem)(pointer) windows句柄 %% - @param(rcitem)(array of integer) array(左,上,右,下) %% - @param(itemaction)(integer) ODA_DRAWENTIRE or ODA_FOCUS or ODA_SELECT %% - **} - property ctltype index "ctltype" read _getvalue_ write _setvalue_; - property ctlid index "ctlid" read _getvalue_ write _setvalue_; - property id index "itemid" read _getvalue_ write _setvalue_; - property itemid index "itemid" read _getvalue_ write _setvalue_; - property itemaction index "itemaction" read _getvalue_ write _setvalue_; - property itemstate index "itemstate" read _getvalue_ write _setvalue_; - property rcitem index "rcitem" read _getvalue_ write _setvalue_; - property hdc index "hdc" read _getvalue_ write _setvalue_; - property hwnditem index "hwnditem" read _getvalue_ write _setvalue_; -end -type TMDRAWITEM=class(tuieventbase,TtageDrawItem) - public - function create(m,w,l,h);override; - begin - inherited; - class(TtageDrawItem).create(l); - end - function destroy();override; - begin - inherited; - class(TtageDrawItem).destroy(); - end - canvas; -end -type TGRIDMDRAWITEM=class(TMDRAWITEM) - {** - @explan(说明) 控件绘制消息类 %% - **} - private - FSubitemid; - FSubItemRect; - public - function create(m,w,l,h);override; - begin - inherited; - end - property Subitemid read FSubitemid write FSubitemid; - property SubItemRect read FSubItemRect write FSubItemRect; -end -type TMMEASUREITEM=class(tuieventbase,tslcstructureobj) - {** - @explan(说明) 系统控件测量消息 - **} - static SFSTRUCT; - class function getstruct(); - begin - if not SFSTRUCT then SFSTRUCT := MemoryAlignmentCalculate(array( - ("ctltype","int",0), - ("ctlid","int",0), - ("itemid","int",0), - ("itemwidth","int",0), - ("itemheight","int",0), - ("itemdata","intptr",0))); - return SFSTRUCT; - end - function create(m,w,l,h);override; - begin - inherited; - class(tslcstructureobj).create(getstruct(),l); - end - property ctlid index "ctlid" read _getvalue_; - property ctltype index "ctltype" read _getvalue_; - property id index "itemid" read _getvalue_; - property width index "itemwidth" read _getvalue_ write _setvalue_; - property height index "itemheight" read _getvalue_ write _setvalue_; - property itemid index "itemid" read _getvalue_; - property itemwidth index "itemwidth" read _getvalue_ write _setvalue_; - property itemheight index "itemheight" read _getvalue_ write _setvalue_; - {** - @param(ctlid)(integer) 控件id %% - @param(itemid)(integer) 控件在父窗口中的序号 %% - @param(width)(integer) 设置或者获取宽度 %% - @param(height)(integer) 设置或者获取高度 %% - **} -end -type TSIFTSTATE = class(TSLUICONST) - protected - FKeyState; - class function KeysToShiftState(Keys: PtrUInt): TShiftState; - begin - {** - @explan(说明) 解析按键状态 %% - **} - Result := array(); - if (Keys .& MK_Shift) <> 0 then includestate(Result, ssShift); - if (Keys .& MK_Control) <> 0 then includestate(Result, ssCtrl); - if (Keys .& MK_LButton) <> 0 then includestate(Result, ssLeft); - if (Keys .& MK_RButton) <> 0 then includestate(Result, ssRight); - if (Keys .& MK_MButton) <> 0 then includestate(Result, ssMiddle); - if (Keys .& MK_XBUTTON1) <> 0 then includestate(Result, ssExtra1); - if (Keys .& MK_XBUTTON2) <> 0 then includestate(Result, ssExtra2); - if (Keys .& MK_DOUBLECLICK) <> 0 then includestate(Result, ssDouble); - if (Keys .& MK_TRIPLECLICK) <> 0 then includestate(Result, ssTriple); - if (Keys .& MK_QUADCLICK) <> 0 then includestate(Result, ssQuad); - v := gettswin32api().GetKeyState(VK_MENU); - if _shr(v,15) then includestate(Result, ssAlt); - //if gettswin32api().GetKeyState(VK_MENU) < 0 then includestate(Result, ssAlt); - //if (GetKeyState(VK_LWIN) < 0) or (GetKeyState(VK_RWIN) < 0) then Include(Result, ssMeta); - return Result; - end; - - end -type TMMOUSEWHEEL=class(tuieventbase,TSIFTSTATE) - {** - @explan(说明)鼠标滚动消息类 %% - **} - function create(m,w,l,h);override; - begin - inherited; - end - function shiftstate(); - begin - {** - @explan(说明) 按键状态 %% - @return(array of TShiftStateEnum menuber) shift 键集合 - **} - if ifnil(FKeyState)then - begin - FKeyState := KeysToShiftState(lowparam()); - end - return FKeyState; - end - property delta read hiwparamsigned; - property ypos read hilparamsigned; - property xpos read lolparamsigned; - {** - @param(ypos)(integer)鼠标的y坐标 %% - @param(xpos)(integer)鼠标的x坐标 %% - @param(delta)(integer)运动距离 %% - **} -end -type TMMouse=class(tuieventbase,TSIFTSTATE) - {** - @explan(说明) 鼠标消息类 %% - **} - protected FButton; - public - function create(m,w,l,h);override; - begin - inherited; - end - {** - @param(xpos)(integer) x 位置 %% - @param(ypos)(integer) y 位置 %% - @param(FButton)(integer) 按键状态,继承时候使用 %% - **} - property xpos:integer read lolparamsigned; - property ypos:integer read hilparamsigned; - function pos(); - begin - return array(xpos(),ypos()); - end - property Dummy read Lparam; - function SetButton(v); - begin - {** - @ignore(忽略) %% - **} - if ifnumber(v)then FButton := v; - else return FButton; - end - function button(); - begin - {** - @explan(说明) 鼠标按键情况 %% - @return(member of TMouseButton) - **} - return FButton; - end - function shiftstate(); - begin - {** - @explan(说明) 按键状态 %% - @return( array of TShiftStateEnum menuber) %% - **} - if ifnil(FKeyState)then - begin - FKeyState := KeysToShiftState(Wparam); - end - return FKeyState; - end - function setshiftdouble(v); - begin - {** - @ignore(忽略) %% - **} - shiftstate(); - if ifnumber(v)then - begin - includestate(FKeyState,v); - end - end - function shiftdouble(); - begin - {** - @explan(说明) 是否双击 %% - @return(bool) 是否双击 - **} - shiftstate(); - return(ssDouble in FKeyState); - end -end -type TMSTYLECHANG=class(tuieventbase) - {** - @explan(说明)窗口样式改变消息 %% - **} - private - FSTyle; - function _getvalue_(n); - begin - return FSTyle._getvalue_(n); - end - function _setvalue_(n,v); - begin - return FSTyle._setvalue_(n,v); - end - public - function create(m,w,l,h);override; - begin - inherited; - FSTyle := new TSTYLESTRUCT(l); - end - property styleold index "styleold" read _getvalue_ write _setvalue_; - property stylenew index "stylenew" read _getvalue_ write _setvalue_; - {** - @param(stylenew)(integer) 新样式 %% - @param(styleold)(integer) 旧样式 %% - **} -end - ///////////////////////////消息对象//////////////////////////////////// -type TWMNCHITTEST=class(TSLUICONST) // hittest消息处理类 - function hitstyle(o,e); - begin - return hitstyle2(o,e.lolparam,e.hilparam); - end - function hitstyle2(o,x,y); - begin - //rec := o.clientrect(); //客户区 - //p := o.screentoclient(e.lolparam,e.hilparam); - rec := zeros(4); - o._wapi.GetWindowRect(o.Handle,rec); - p := array(x,y); // - r := borerhittest(p,rec,4); - r := inttohit(r); - return r; - end - function inttohit(i); - begin - r := HTCLIENT; - case i of - 1:r := HTTOPLEFT; - 2:r := HTTOPRIGHT; - 3:r := HTBOTTOMRIGHT; - 4:r := HTBOTTOMLEFT; - 5:r := HTLEFT; - 6:r := HTTOP; - 7:r := HTRIGHT; - 8:r := HTBOTTOM; - end; - return r; - end - function borerhittest(p,rec,dv); - begin - rec[0]+= 1; - rec[1]+= 1; - rec[2]-= 1; - rec[3]+= 1; - ps := array(rec[0:1],(rec[2],rec[1]),(rec[2],rec[3]),(rec[0],rec[3])); - ds := array(); - for i,v in ps do - begin - ds[i]:= integer(sqrt((p[0]-v[0])^2+(p[1]-v[1])^2)); - end - minds := minvalue(ds); - if minds0 then - begin - AComponent.FOwner := Nil; - return true; - end - return false; - end; - procedure RemoveNotification(AComponent:TComponent); - begin - FFreeNotifies.Remove(AComponent); - if FFreeNotifies.count()<1 then includestate(FComponentState,csFreeNotification); - end -#!end - protected -#!begin //protected methods - function SetName(v);virtual; - begin - if ifstring(v)and length(v)>1 and v <> FName then - begin - if isKeyWords(v)then return; - nv := lowercase(v); - if new TCharDiscrimi().IsVariableName(v)then - begin - r := RootOwner().FindComponentByName(nv); - if not r then - begin - FName := nv; - end - end - end - end - Procedure SetAncestor(Value:Boolean); - begin - If Value then includestate(FComponentState,csAncestor)else excludestate(FCOmponentState,csAncestor); - For Runner := 0 To FComponents.Count-1 do - begin - FComponents.geti(Runner).SetAncestor(Value); - end - end; - function ValidateContainer(AComponent:TComponent);virtual; - begin - if AComponent is class(tcomponent)then return AComponent.ValidateInsert(Self); - end - function ValidateInsert(AComponent:TComponent);virtual; - begin - return true; - end -public - function ExecuteCommand(cmd,p);virtual; - begin - - end - Procedure Notification(AComponent,Operation);virtual; - begin - {** - @explan(说明) 通知处理 %% - @param(AComponent)(tcomponent) 改变的对象 %% - @param(Operation)(member of TOperation) 通知码 %% - **} - If(Operation=opRemove)then - begin - RemoveFreeNotification(AComponent); - end - data := FComponents.data(); - C := length(data)-1; - While(C >= 0) do - begin - data[c].Notification(AComponent,Operation); - c--; - end; - end; -private - Procedure SetDesignInstance(Value); - begin - If Value then - includestate(FComponentState,csDesignInstance) - else - excludestate(FComponentState,csDesignInstance); - end; -public - procedure RemoveFreeNotification(AComponent:TComponent); - begin - RemoveNotification(AComponent); - AComponent.RemoveNotification(self); - end; -Procedure SetDesigning(Value,SetChildren);virtual; -begin - {** - @explan(说明) 设计器使用方法,设置为设计状态,或者解除设置状态 %% - @param(Value)(bool) 状态值 %% - @param(SetChildren)(bool) 是否修改子控件状态 %% - **} - if ifnil(SetChildren)then SetChildren := true; - If Value then - includestate(FComponentState,csDesigning); - else - excludestate(FComponentState,csDesigning); - if SetChildren then - begin - items := FComponents.data; - For Runner := 0 To length(items)-1 do - begin - items[Runner].SetDesigning(Value); - end - end -end; -protected - function SetParentComponent(Value);virtual; - begin - end - function GetChildren();virtual; - begin - end - procedure Updating;virtual; - begin - includestate(FComponentState,csUpdating); - end - procedure Updated;virtual; - begin - excludestate(FComponentState,csUpdating); - end - -#!end -public -#!begin //public methods - function create(AOwner);virtual; - begin - class(TSLUIBASE).create(); - FComponents := NEW TFpList(); - FFreeNotifies := NEW TFpList(); - FComponentStyle := array(csInheritable); - FComponentstate := array(); - SetOwner(AOwner); - FEventsProperties := array(); - FVariableProperties := array(); - FComponentCreated := true; - return; - If AOwner is class(tcomponent)then - begin - FOwner := AOwner; - AOwner.InsertComponent(Self); - end - end - function RootOwner(); - begin - if not(FOwner is class(TComponent))then return self(true); - return FOwner.RootOwner(); - end - function FindComponentByName(n); - begin - if n and n=FName then return self(true); - cps := Components; - for i := 0 to cps.Count-1 do - begin - r := cps[i].FindComponentByName(n); - if r then return r; - end - return false; - end - function isDescendant(cd); - begin - {** - @explan(说明) 判断节点是否为其子节点 %% - @param(cd)(tcomponent) 等判断节点 %% - @return(bool) true 为子节点 false 非子节点 %% - **} - if cd=self then return true; - for i := 0 to FComponents.count()-1 do - begin - if FComponents[i].isDescendant(cd)then return true; - end - return false; - end - function SetOwner(AOwner); - begin - {** - @explan(说明) 设置所有者,注意只能成功设置一次,之后设置无效 %% - @param(AOwner)(tcomponent) 所有者 %% - **} - if ifnil(FOwner)and(AOwner is class(tcomponent))then - begin - if isDescendant(AOwner)then exit; - FOwner := AOwner; - AOwner.InsertComponent(self(true)); - end - end - function Recycling();override; - begin - if not FComponentCreated then exit; - Destroying(); - DestroyComponents(); - If FOwner is class(tcomponent)Then FOwner.RemoveComponent(Self); - inherited; - end - function Destroy();virtual; - begin - inherited; - end; - function Destroying(); - begin - If csDestroying in FComponentstate Then Exit; - includestate(FComponentState,csDestroying); - if not FCOmponents then exit; - data := FCOmponents.data(); - for i,v in data do v.Destroying(); - end; - function ExecuteAction(act:TBasicAction):Boolean;virtual; - begin - {** - @explan(说明)执行action %% - **} - if act.HandlesTarget(Self)then - begin - act.ExecuteTarget(Self); - return True; - end else - return False; - end - function UpdateAction(act:TBasicAction):Boolean;virtual; - begin - {** - @explan(说明) 更新action %% - **} - if act.HandlesTarget(Self)then - begin - act.UpdateTarget(Self); - return True; - end else - return False; - end - function DestroyComponents(); - begin - {** - @explan(说明)删除子项 %% - **} - if not FComponents then exit; - FName := nil; - data := FComponents.data(); - FComponents.clean(); - for i,Acomponent in data do - begin - Acomponent.Recycling(); - end - end; - Procedure FreeNotification(AComponent:TComponent); - begin - {** - @explan(说明) 关联对象,在释放的时候相互通知 %% - @param(AComponent)(TComponent) 对象 %% - **} - if not(AComponent is class(tcomponent))then exit; - If(Owner <> Nil)and(AComponent=Owner)then exit; - If FFreeNotifies.IndexOf(AComponent)=-1 then - begin - FFreeNotifies.Add(AComponent); - AComponent.FreeNotification(self(true)); //添加当前的 - end; - end; - //function GetParentComponent(); virtual;begin end - //function HasParent(); virtual;begin end - function InsertComponent(AComponent);virtual; - begin - {** - @explan(说明)插入节点 %% - **} - if AComponent.ValidateContainer(Self)then - begin - self.Insert(AComponent); - If csDesigning in FComponentState then AComponent.SetDesigning(true); - Notification(AComponent,opInsert); - end - end; - Procedure RemoveComponent(AComponent); - begin - {** - @explan(说明)移除子节点 %% - **} - Notification(AComponent,opRemove); - if Remove(AComponent)then Acomponent.Setdesigning(False); - end; - function Assigned(o);virtual; - begin - return ifobj(o); - end -#!end - private - FEventsProperties; - FChangedProperties; - FVariableProperties; - function GetPublishInfo(); - begin - r := publishs(); - rr := array(); - ri := 0; - for i,v in r do - begin - if ifstring(v) then rr[ri++] := lowercase(v); - end - return rr; - end - function OrderPublish(r,od); //排序发布的东西 - begin - if od then - begin - r1 := array(); - for i,v in od do - begin - vi := r[v]; - if vi then r1[v]:= vi; - end - r := r1; - end - end -public - function publishs();virtual; - begin - //return array("currentcolor","lazyitems","range","firstdayofweek","align","mbbtnstyle","textalign","text","imagelist","canvs","images","items","bkbitmap","icon","popupmenu","mainmenu","cursor","height","width","left","top","enabled","visible","caption","color","font","onclick","rootfolder","initialdir"); - end - function GetPublishproperties();virtual; - begin - {** - @explan(说明) 获得properties,设计器使用%% - **} - ps := GetPropInfo(); - r := array(); - pps := GetPublishInfo(); - for i,v in ps do - begin - typ := v["type"]; - if typ="eventhandler" then continue; - otype := GetPropertyType(typ); - if otype then - begin - n := v["name"]; - if pps and not(n in pps)then continue; - if typ in array("variable","popupmenu","syscursor","tmainmenu")then - begin - r[n]:= otype.FormatEdit(FVariableProperties[n],v["write"]?true:false); - end else - r[n]:= otype.FormatEdit(invoke(self(true),n),v["write"]?true:false); - end - end - //次序处理 - //////////////////// - OrderPublish(r,pps); - //////////////////// - return r; - end - function GetPublishEvents();virtual; - begin - {** - @explan(说明) 获得event值,设计器使用 %% - @return(array) - **} - ps := GetPropInfo(); - r := array(); - pps := GetPublishInfo(); - for i,v in ps do - begin - typ := v["type"]; - if typ <> "eventhandler" then continue; - otype := GetPropertyType(typ); - if otype then - begin - n := v["name"]; - if pps and not(n in pps)then continue; - ne := FEventsProperties[n]; - r[n]:= otype.FormatEdit(ne,v["write"]?true:false); - end - end - OrderPublish(r,pps); - return r; - end - function GetChangedPropertiesn(n);virtual; - begin - return FChangedProperties[n]; - end - function GetChangedPublish();virtual; - begin - {** - @explan(说明)获取修改过的publish,设计器使用 %% - **} - r := array(); - if not FChangedProperties then return r; - ps := GetPropInfo(); - for i,vi in ps do - begin - n := vi["name"]; - vv := FChangedProperties[n]; - if ifnil(vv)then continue; - vit := vi["type"]; - otype := GetPropertyType(vit); - if vi["write"]and otype then - begin - r[n]:= otype.FormatTMF(vv); - end - end - return r; - end - function SetChangedPublish(n,v);virtual; - begin - {** - @explan(说明) 设计器相关函数 %% - **} - if not ifarray(FChangedProperties)then FChangedProperties := array(); - //reindex(FChangedProperties,array(n:nil)); - FChangedProperties[n]:= v; - end - function DeleteChangedPublish(n);virtual; - begin - if n and ifstring(n)then - begin - if not ifarray(FChangedProperties)then FChangedProperties := array(); - reindex(FChangedProperties,array(n:nil)); - end - end - function SetPublish(n,v);virtual; - begin - {** - @explan(说明) 修改单个值,设计器使用 %% - @param(n)(string) 名称 %% - @param(v)(any) 值 %% - **} - ps := GetPropInfo(); - for i,vi in ps do //获取信息 - begin - if n=vi["name"]then - begin - vit := vi["type"]; - otype := GetPropertyType(vit); //获得转换对象 - if ifobj(otype)then - begin - iv := otype.UnformatEdit(v); //反转换 - SetChangedPublish(n,iv); //保存 - if vit="eventhandler" then //分类保存 - begin - FEventsProperties[n]:= iv; - end else - begin - if vit in array("variable","popupmenu","syscursor","tmainmenu")then //分类保存 - begin - FVariableProperties[n]:= iv; - if vit="tmainmenu" then - begin - try - invoke(self(true),n,1,iv); - except - return false; - end; - end - end else - //if not ifnil(iv) then //设置到设计控件 - begin - try - //if n="visible" and (not((self(true) is class(tform)) and (self(true) is class(tpanelform)))) then - //else - invoke(self(true),n,1,iv); - except - return false; - end; - end - end - end - return true; - end - end - end - property Owner:tcomponent read FOwner; - {** - @param(Owner)(tcomponent) 所有者 %% - @param(ComponentState)() 状态集合 %% - @param(ComponentStyle)() 样式结合 %% - @param(ComponentCreated)(bool) 样式结合 %% - **} - //property DesignInfo read FDesignInfo write FDesignInfo; - property ComponentCreated read FComponentCreated; - property Components read FComponents; - property ComponentState read FComponentState write SetComponentState; - property ComponentStyle read FComponentStyle; - property Name:string read FName write SetName; - property Parent read ComponentGetParent write ComponentSetParent; - property Loader read GetLoader; -end type TGlobalComponentcache=class {** @@ -7000,7 +452,7 @@ type tapplication=class(tcomponent) end function SetMainForm(f); begin - if not(f is class(tform))then exit; + if not(f is class(TVCForm))then exit; if f=Fmainform then exit; if Fmainform then begin @@ -7017,7 +469,7 @@ type tapplication=class(tcomponent) f.parent := FApplicationWindow; end IC := f.FormIcon; - if(ic is class(TIcon))and ic.HandleAllocated then + if(ic is class(tcustomicon))and ic.HandleAllocated then begin FApplicationWindow._send_(WM_SETICON,1,ic.handle,1); end @@ -7074,7 +526,7 @@ type tapplication=class(tcomponent) begin {** @explan(说明) 构造主窗口%% - @param(classname)(class of tform) 主窗口类 %% + @param(classname)(class of TVCForm) 主窗口类 %% @param(varable)() tsl变量返回ClassName 构造的窗口对象 %% **} if paramcount<2 then exit; //变量不够 @@ -7082,7 +534,7 @@ type tapplication=class(tcomponent) begin if not(FApplicationWindow)then initialize(); varable := createobject(classname,FApplicationWindow); - if varable is class(tform)then + if varable is class(TVCForm)then begin varable.parent := FApplicationWindow; if not Fmainform then @@ -7167,7 +619,7 @@ type tapplication=class(tcomponent) {** @explan(说明) 关闭主窗口 %% **} - if FApplicationWindow is class(tform)then FApplicationWindow._send_(WM_CLOSE,0,0); + if FApplicationWindow is class(TVCForm)then FApplicationWindow._send_(WM_CLOSE,0,0); else _wapi.PostQuitMessage(0); end function Close(); @@ -7180,1892 +632,6 @@ type tapplication=class(tcomponent) property MainForm read Fmainform write SetMainForm; end - //托盘 -type TTray=class(TComponent) - {** - @explan(说明) 托盘类 %% - **} - private - FNid; - FTrayID; - FIcon; - FHaveadd; - FPopupMenu; - FOnclick; - FOnMouseMove; - static FSIDC; //id 构造器 - FCaption; - FForm; - function SetCaption(v); - begin - if v <> FCaption then - begin - if ifstring(v)then - begin - FCaption := v; - end else - begin - FCaption := ""; - end - FNid.sztip := FCaption; - if FHaveadd then - begin - _wapi.Shell_NotifyIconA(NIM_MODIFY,FNid._getptr_); - end - end - end - function seticonhandle(ic); - begin - if(ic is class(ticon))and ic.HandleAllocated()and FHaveadd then - begin - Fnid.uFlags := NIF_ICON .| NIF_MESSAGE .| NIF_TIP .| NIF_INFO; - Fnid.hicon := ic.Handle; - _wapi.Shell_NotifyIconA(NIM_MODIFY,FNid._getptr_); - end - end - function SetIcon(v); - begin - if v=FIcon then exit; - FIcon := v; - seticonhandle(FIcon); - end - function SetForm(f); - begin - if FForm=f then exit; - if FHaveadd then - begin - TrayDelete(); - end - FForm := f; - TrayAdd(); - end - public - function Create(AOwner);override; - begin - inherited; - FHaveadd := false; - if not FSIDC then FSIDC := new tidcreater(1); - FTrayID := FSIDC.CreateId(); - FNid := new TNOTIFYICONDATAA(); - FNid.uID := FTrayID; - FNid.ucallbackmessage := WM_TRAY; - end - function ShowTrayMessage(title,text); - begin - {** - @ignore(忽略) %% - @explan(说明) 显示托盘消息 %% - @param(title)(string)标题 %% - @param(text)(string) 消息 %% - - **} - if not FHaveadd then exit; - if not(ifstring(title)and ifstring(text))then exit; - if not((FForm is class(tform))and FForm.HandleAllocated)then exit; - FNid.szinfotitle := title+"\0"; - FNid.szinfo := text+"\0"; - FNid.utimeout := 1000; - _wapi.Shell_NotifyIconA(NIM_MODIFY,FNid._getptr_); - end - function ShowPopUpMenu(); - begin - if not FHaveadd then exit; - if FPopupMenu is class(TPopUpmenu)then - begin - ps := array(x,y); - _wapi.GetCursorPos(ps); - uf := TPM_LEFTALIGN .| TPM_TOPALIGN .| TPM_RIGHTBUTTON; - hd := FForm.Handle; - _wapi.SetForegroundWindow(hd); - _wapi.TrackPopupMenu(FPopupMenu.Handle,uf,ps[0],ps[1],0,hd,nil); - return true; - end - end - procedure Notification(AComponent:TComponent;Operation:TOperation);override; - begin - {** - @explan(说明) 通知消息处理 %% - **} - if Operation=opRemove then - begin - if FPopupMenu=AComponent then - begin - FPopupMenu := nil; - end - if FForm=AComponent then - begin - Form := nil; - end - end; - inherited; - end; - function Recycling();override; - begin - FIcon := nil; - TrayDelete(); - FForm := nil; - FPopupMenu := nil; - inherited; - end - //添加到托盘栏 - function TrayAdd(); - begin - {** - @ignore(忽略) %% - @explan(说明) 添加 %% - **} - if FHaveadd then exit; - if(FForm is class(tform))and FForm.HandleAllocated()then - begin - FNid.hWnd := FForm.Handle; - if not FIcon then FIcon := FForm.FormIcon; - if FIcon is class(ticon)then - begin - FNid.hIcon := FIcon.Handle; - end - if ifstring(FCaption)then FNid.sztip := FCaption; - else FNid.sztip := FForm.Caption; - //FNid.dwInfoFlags := 1; - Fnid.uFlags := NIF_ICON .| NIF_MESSAGE .| NIF_TIP .| NIF_INFO; - _wapi.Shell_NotifyIconA(NIM_ADD,FNid._getptr_); - FHaveadd := true; - end - end - //从托盘栏删除 - function TrayDelete(); - begin - {** - @ignore(忽略) %% - @explan(说明) 删除 %% - **} - if FHaveadd then - begin - _wapi.Shell_NotifyIconA(nim_delete,FNid._getptr_); - FHaveadd := false; - end - end - function publishs();override; - begin - return array("name","caption","icon","popupmenu","onclick"); - end - property Form read FForm write SetForm; - property Caption:string read FCaption write SetCaption; - property OnClick:eventhandler read FOnclick write FOnclick; - property OnMouseMove:eventhandler read FOnMouseMove write FOnMouseMove; - property Icon:ticon read FIcon write SetIcon; - property PopupMenu:TPopUpmenu read FPopupMenu write FPopupMenu; - property TrayId read FTrayID; -end - - -type tcontrol = class(tcomponent) - private //计量处数据 - #!begin //members - STATIC FSIDC; - FActionLink: TControlActionLink; - FCanvas: TCanvas; - FMessagehandle;//消息表 - FtagPAINTSTRUCT; - - //;数据 - //private - FAnchors; - FAnchorBounds; - - FCaption;//标题 - FCaptureMouseButtons;//鼠标样式 - FColor;//颜色 - FBKBitmap; - FControlFlags;//控件标记 - FControlStyle;//控件样式 - FDesktopFont; - FDockOrientation; - FDragCursor; - FFont; //字体 - FHostDockSite: TWinControl; - FLastDoChangeBounds: TRect; - FLastDoChangeClientSize: TPoint; - FLastResizeClientHeight: integer; - FLastResizeClientWidth: integer; - FLastResizeHeight: integer; - FLastResizeWidth: integer; - FOnClick; //点击 - Fonrclick; - FOnContextPopup; - FOnDblClick; //双击 - FOnDragDrop; - FOnDragOver; - FOnSize; - FOnMove; - FOnEditingDone; - FOnEndDock; - FOnEndDrag; - FOnMouseDown; //按下 - FOnMouseEnter; //进入 - FMouseEntereded; - FOnMouseLeave; //离开 - FOnMouseMove; //移动 - FOnPopupMenu; - FOnMouseUp; //弹起 - FOnMouseWheel; //滚动 - FOnMouseWheelDown; //滚动按下 - FOnMouseWheelUp; //滚动弹起 - //FOnQuadClick; - //FOnResize; // - FOnShowHint; - FOnStartDock; - FOnStartDrag; - //FOnTripleClick; - FBorder; - protected - //对齐 - FAlign;//对齐方式 - FUnAlignBounds; - - FParent;// TWinControl; //父节点 - //public - //FParentBiDiMode;//: Boolean; - FPopupMenu;//: TPopupMenu; - //FIsControl;//: Boolean; - FShowHint;//: Boolean; - //FParentColor;//: Boolean; - FParentFont;//: Boolean; - //FParentShowHint;//: Boolean; - //FAutoSizingAll;//: boolean; - //FAutoSizingSelf;//: Boolean; - FEnabled;//: Boolean; //有效 - //FMouseEntered;//: boolean; - FVisible;//: Boolean; //可见 - FID; - - FOnMeasureItem; - FOnDrawItem; - #!end - - //位置信息 - //protected - FLeft:integer; //左边 - FTop:integer;//: Integer; //上 - FWidth:integer; - FHeight:integer; //高度 - FControls; - FControlState; - FCursor; - {** - @param(FLeft)(integer) 左边 %% - @param(FTop)(integer) 上边 %% - @param(FWidth)(integer) 宽度 %% - @param(FHeight)(integer) 高度 %% - **} - function SetAction(Value);virtual; - begin - if csDesigning in ComponentState then - begin - FActionLink := Value; - return; - end - if ifnil(Value)then - begin - if FActionLink then - begin - FActionLink.SetAction(nil); - end - excludestate(FControlStyle,csActionClient); - end else - if Value is class(TBasicAction)then - begin - includestate(FControlStyle,csActionClient); - if ifnil(FActionLink)then FActionLink := createobject(GetActionLinkClass(),self); - FActionLink.Action := Value; - FActionLink.Onchange := thisfunction(DoActionChange); - ActionChange(Value,csLoading in Value.ComponentState); - Value.FreeNotification(Self); - end - end - procedure DoActionChange(Sender:TObject); - begin - if Sender=Action then ActionChange(Sender,False); - end - function GetAction();virtual; - begin - if csDesigning in ComponentState then - begin - return FActionLink; - end - if FActionLink then - begin - return FActionLink.Action; - end - end - function SetEnabled(v);virtual; - begin - nv := v?true:false; - if FEnabled <> nv then - begin - FEnabled := nv; - end - end - //protected - procedure SetAlign(Value:TAlign);virtual; - begin - if not(Value in array(alLeft,alRight,alBottom,alTop,alNone,alClient))then exit; - if FAlign=Value then exit; - bds := UnAlignBounds; - FAlign := Value; - //调其兄弟节点的位置 %% - if FParent is class(TWincontrol)and FParent.HandleAllocated()then - begin - if FAlign=alNone then - begin - //bds := UnAlignBounds; - SetBounds(bds[0],bds[1],bds[2],bds[3]); - end - FParent.DoControlAlign(); - end - end - procedure SetAnchors(Value);virtual; - begin - if not ifarray(Value)then exit; - if FAnchors=Value then exit; - FAnchorBounds := 0; - val := Value union2 array(); - aks := array(akLeft,akRight,akTop,akBottom); - for i,v in val do - begin - if not(v in aks)then exit; - end - FAnchors := val; - end - - private - function SetUnAlignBounds(Value); - begin - {** - @explan(说明) 设置非对齐的范围 %% - **} - if(align in array(alTop,alLeft,alRight,alBottom,alClient))then exit; - if CheckArrayIsControlBounds(Value)and FUnAlignBounds <> Value then - begin - FUnAlignBounds := Value; - if parent and(Align <> alNone)and Parent.HandleAllocated()then Parent.DoControlAlign(); - end - end - Function GetUnAlignBounds();virtual; //type_tcontrol - begin - if alNone=FAlign then - begin - FUnAlignBounds := GetBoundsRect(); - end - if not ifarray(FUnAlignBounds)then FUnAlignBounds := GetBoundsRect(); - return FUnAlignBounds; - end - function GetEnabled();virtual; - begin - return FEnabled; - end - - procedure SetLeft(Value:Integer); //type_tcontrol - begin - if Value>-5000000 and Value<5000000 and Value <> FLeft then SetBounds(Value,FTop,FWidth,FHeight); - end - procedure SetTop(Value:Integer); //type_tcontrol - begin - if Value>-5000000 and Value<5000000 and Value <> FTop then SetBounds(FLeft,Value,FWidth,FHeight); - end - procedure SetWidth(Value:Integer); //type_tcontrol - begin - if Value>-5000000 and Value<5000000 and Value <> FWidth then SetBounds(FLeft,FTop,Max(0,Value),FHeight); - end - procedure SetHeight(Value:Integer); //type_tcontrol - begin - if Value>-5000000 and Value<5000000 and Value <> FHeight then SetBounds(FLeft,FTop,FWidth,Max(0,Value)); - end - function GetText(); //type_tcontrol - begin - return RealGetText(); - end - procedure SetText(Value:string); //type_tcontrol - begin - return RealSetText(Value); - end - function SetParentFont(v:bool); - begin - nv := v?true:false; - if FParentFont <> nv then - begin - FParentFont := nv; - if nv then - begin - hd := GetParentFontHandle(); - if Parent then Parent.Perform(New tuieventbase(CMFONTCHANGED,hd,1)); - end - end - end - public - function PaintStruct(); - begin - {** - @explan(说明) 获取绘制消息结对象 %% - @return(TPAINTSTRUCT) 包含绘制 - **} - if not FtagPAINTSTRUCT then - begin - FtagPAINTSTRUCT := new TPAINTSTRUCT(); - end - return FtagPAINTSTRUCT; - end - function bindmessage(id,func); //type_tcontrol - begin - {** - @ignore 忽略 %% - @explan(说明) 绑定处理函数到消息id %% - **} - if not ifarray(FMessagehandle)then FMessagehandle := array(); - if ifnumber(id)and dataisfunction(func)then FMessagehandle[id]:= func; - end - private - static FClassDigestA; - class function CtlInfoAndDigest(idx,d); //通过类的指纹保存或者获取控件信息 - begin - if not ifarray(FClassDigestA)then FClassDigestA := array(); - if ifnil(d)then return FClassDigestA[idx]; - else FClassDigestA[idx]:= d; - end - function FindMessageFunctionstr(o);virtual; //type_tcontrol - begin - { - @explan(说明) 自动绑定消息函数到消息id %% - } - if not(o is class(tcontrol))then return array(); - t := o.classinfo; - idx := getmsgd_Crc32(tostm(t))+"%%"; - r := CtlInfoAndDigest(idx); - if ifarray(r)then return r; - r := array(); - hs := t["inherited"]; - for i,v in hs do - begin - //sbf := static call(thisfunction,findclass(v,o)) name v+"%%_%%"; - sbf := call(thisfunction,findclass(v,o)); - for ii,vv in sbf do - begin - r[ii]:= vv; - end - end - for i,v in t["subs"] do - begin - if v["access"]in array(2,3)then continue; - fstring := v["functionname"]; - if not ifstring(fstring)then continue; - //f := findfunction(fstring,o); - returntype := v["returntype"]; - try - if returntype then - begin - mid := invoke(o,returntype); - r[mid]:= fstring; - //bindmessage(mid,f); - end - except - end - end - CtlInfoAndDigest(idx,r); - return r; - end - function bindmessages(o);virtual; //type_tcontrol - begin - { - @explan(说明) 自动绑定消息函数到消息id %% - } - s := FindMessageFunctionstr(o); - for i,v in s do - begin - bindmessage(i,findfunction(v,o)); - end - return; - if not(o is class(tcontrol))then return; - t := o.classinfo; - hs := t["inherited"]; - for i,v in hs do - begin - call(thisfunction,findclass(v,o)); - end - for i,v in t["subs"] do - begin - if v["access"]in array(2,3)then continue; - fstring := v["functionname"]; - if not ifstring(fstring)then continue; - f := findfunction(fstring,o); - returntype := v["returntype"]; - try - if returntype then - begin - mid := invoke(o,returntype); - bindmessage(mid,f); - end - except - end; - end - end - protected - function GetControlFont();virtual; - begin - return FFont; - end - function SetControlFont(v);virtual; - begin - if ifarray(v)then - begin - FFont.SetValues(v); - end else - if v is class(tfont)then - begin - FFont.copyfont(v); - end - end - function CurrentFont(); - begin - if ParentFont and Parent then return Parent.CurrentFont(); - return Font; - end - function GetParentFontHandle();virtual; - begin - if ParentFont and Parent then return Parent.GetParentFontHandle(); - return Font.Handle; - end - function SetBorder(v);virtual; - begin - FBorder := v?true:false; - end - function SetZorder(n); - begin - f := Parent; - if f is class(TWincontrol)then - begin - return f.MoveControlOrder(self,n); - end - end - function GetZorder(); - begin - f := Parent; - if f is class(TWincontrol)then - begin - return f.Controls.indexof(self); - end - end - function RealGetText: - TCaption; - virtual; //type_tcontrol - begin - return FCaption; - end - procedure RealSetText(Value:TCaption);virtual; //type_tcontrol - begin - FCaption := Value; - end - -#!begin //资源处理 - function GetCursor();virtual; - begin - return FCursor; - end - procedure SetCursor(Value);virtual; - begin - if(FCursor is class(tcursor))and ifnumber(Value)and FCursor.id <> Value then - begin - FCursor.id := Value; - Perform(new tuieventbase(CM_CURSORCHANGED,0,0)); - end; - end - procedure SetVisible(Value);virtual; - begin - FVisible := Value?true:false; - end - procedure DoOnParentHandleDestruction;virtual; - begin - end - -#!end - protected - function messagecreater(hwnd,message,wparam,lparam);virtual; ////type_tcontrol - begin - {** - @explan(说明)根据消息参数构造消息对象; - **} - if message in array(WM_MOUSEMOVE,WM_LBUTTONDOWN, - WM_RBUTTONDOWN,WM_LBUTTONUP, - WM_RBUTTONUP,WM_LBUTTONDBLCLK, - WM_RBUTTONDBLCLK,WM_MBUTTONDOWN,WM_MBUTTONUP,WM_MBUTTONDBLCLK)then - begin - r := new TMMouse(message,wparam,lparam,hwnd); - end else - if message=WM_MENUSELECT then - begin - r := new TMMENUSELECT(message,wparam,lparam,hwnd); - end else - if message=WM_MEASUREITEM then - begin - r := new TMMEASUREITEM(message,wparam,lparam,hwnd); - end else - if message in array(WM_KEYDOWN,WM_KEYUP,WM_CHAR,WM_SYSKEYDOWN,WM_SYSKEYUP)THEN - begin - r := new TMKEY(message,wparam,lparam,hwnd); - end else - if message=WM_DRAWITEM then - begin - r := new TMDRAWITEM(message,wparam,lparam,hwnd); - end else - if message=WM_NOTIFY then - begin - r := new TMNOTIFY(message,wparam,lparam,hwnd); - end else - if message=WM_MOUSEWHEEL then - begin - r := new TMMOUSEWHEEL(message,wparam,lparam,hwnd); - end else - if message=WM_STYLECHANGED or message=WM_STYLECHANGING then - begin - r := new TMSTYLECHANG(message,wparam,lparam,hwnd); - end else - r := new tuieventbase(message,wparam,lparam,hwnd); - return r; - //return new tuieventbase(message,wparam,lparam,hwnd); - end - function GetClientOrigin();virtual; ////type_tcontrol - begin - if FParent then base := FParent.ClientOrigin(); - return array(base[0]+FLeft,base[1]+FTop); - end - function GetLogicalClientRect();virtual; //type_tcontrol - begin - return GetClientRect(); - end; - function GetClientScrollOffset();virtual; //type_tcontrol - begin - return array(0,0); - end - function GetScrolledClientRect();virtual; //type_tcontrol - begin - Result := GetClientRect(); - ScrolledOffset := GetClientScrollOffset(); - Result[0]+= ScrolledOffset[0]; - Result[1]+= ScrolledOffset[1]; - Result[2]+= ScrolledOffset[0]; - Result[3]+= ScrolledOffset[1]; - return Result; - end; - function GetControlOrigin();virtual; //type_tcontrol - begin - Result := array(FLeft,FTop); - if FParent <> nil then - begin - ParentsClientOrigin := FParent.ClientOrigin(); - Result[0]+= ParentsClientOrigin[0]; - Result[1]+= ParentsClientOrigin[1]; - end; - return Result; - end - function OnControlAppend(AControl);virtual; - begin - {** - @explan(说明) 子控件添加 %% - **} - end - function OnControlDelete(AControl);virtual; - begin - {** - @explan(说明) 子控件删除 %% - **} - end - function operatectrl(actrl,op);virtual; //type_tcontrol - begin - idx := FControls.indexof(actrl); - if op=opRemove then - begin - if(idx >= 0)then - begin - FControls.deli(idx); - aparent := actrl.FParent; - actrl.FParent := nil; - OnControlDelete(actrl); - //if (actrl.Align<>alNone) and (aparent is class(TWincontrol)) then aparent.DoControlAlign(); - ifop := true; - end - end else - if op=opInsert then - begin - if idx=-1 then - begin - FControls.append(actrl); - actrl.FParent := self(true); - OnControlAppend(actrl); - ifop := true; - end - end - return ifop; - end - function SetParent(NewParent);virtual; //type_tcontrol - begin - //1.为窗口类 - //2.可以作为父窗口 - //3.调用api 可以成功 - if NewParent=self then return; - if NewParent=FParent then return; - if NewParent is class(TWinControl)then - begin - if FParent then - begin - FParent.operatectrl(self(true),opRemove); - end - np := NewParent.Parent; - while np is class(TWinControl) do - begin - if np=self then return; - np := np.Parent; - end - NewParent.operatectrl(self(true),opInsert); - end else - begin - if Parent then FParent.operatectrl(self(true),opRemove); - end - end - procedure SetParentComponent(NewParentComponent);override; //type_tcontrol - begin - SetParent(NewParentComponent); - end - public - procedure Notification(AComponent:TComponent;Operation:TOperation);override; //type_tcontrol - begin - {** - @explan(说明) 通知消息处理 %% - **} - if Operation=opRemove then - begin - if AComponent=PopupMenu then - PopupMenu := nil ; - else - if AComponent=Action then Action := nil; - idx := FControls.indexof(AComponent); //删除子控件 - if idx >= 0 then - begin - FControls.deli(idx); - end - end; - inherited; - end; - protected - procedure UpdateMouseCursor(X, Y: integer); - begin - end - procedure ChangeBounds(ALeft,ATop,AWidth,AHeight:integer;KeepBase:boolean);virtual; //type_tcontrol - begin - SizeChanged :=(FWidth <> AWidth)or(FHeight <> AHeight); - PosChanged :=(FLeft <> ALeft)or(FTop <> ATop); - if(not SizeChanged)and(not PosChanged)then Exit; - // d := new ttagWINDOWPOS(); - d := new tvclwindowpos_class(0); - if SizeChanged then - begin - d.cx := AWidth; - d.cy := AHeight; - D.flags := SWP_NOMOVE; - e := new tuieventbase(WM_WINDOWPOSCHANGED,0,d._getptr_); - //e := new tuieventbase(WM_SIZE,0,makeposition(AWidth,AHeight)); - class(tcontrol).wndproc(e); - end - if PosChanged then - begin - d.x := ALeft; - d.y := ATop; - d.flags := SWP_NOSIZE; - e := new tuieventbase(WM_WINDOWPOSCHANGED,0,d._getptr_); - //e := new tuieventbase(WM_MOVE,6,makeposition( ALeft,ATop)); - class(tcontrol).wndproc(e); - end - {if SizeChanged or PosChanged then - begin - if (Parent is class(TWinControl)) and Parent.HandleAllocated then - begin - Parent.DoControlAlign(); - end - end } - end - function MouseHover(o,e);virtual; - begin - if not FMouseEntereded then - begin - DoMouseEnter(o,e); - FMouseEntereded := true; - end - end - function MouseLeave(o,e);virtual; - begin - if FMouseEntereded then - begin - DoMouseLeave(o,e); - FMouseEntereded := false; - end - end - function defaulthandler(e);virtual; - begin - return 0; - end - public - function MouseMove(o,e);virtual; - begin - end - function MouseDown(o,e);virtual; - begin - {** - @explan(说明) 鼠标按下消息 %% - @param(o)(TWinControl) 控件自身 %% - @param(e)(TMMouse) 消息 %% - **} - end - function MouseUp(o,e);virtual; - begin - {** - @explan(说明) 鼠标松开消息 %% - @param(o)(TWinControl) 控件自身 %% - @param(e)(TMMouse) 消息 %% - **} - end - function ContextMenu(o,e);virtual; - begin - {** - @explan(说明) 右键菜单 %% - @param(o)(TWinControl) 控件自身 %% - @param(e)(tuieventbase) 消息 %% - **} - if e.Result then exit; - if FPopupMenu is class(TPopUpmenu)then - begin - uf := TPM_LEFTALIGN .| TPM_TOPALIGN .| TPM_RIGHTBUTTON; - _wapi.TrackPopupMenu(FPopupMenu.Handle,uf,e.lolparamsigned,e.hilparamsigned,0,e.wparam,nil); - e.skip := true; - end - end - public - procedure FontChanged(Sender:TObject);virtual; - begin - if parent then parent.FontChanged(Sender); - end - function GetClientRect();virtual; // //type_tcontrol visual size of client area - begin - {** - @explan(说明) 获取客户区%% - @return( array of integer) 左上右下 %% - **} - return array(0,0,FWidth,Height); - end - -#!begin //消息处理 - function DoCNCOMMAND(o,e);virtual; - begin - {** - @explan(说明) 通知消息 %% - @param(o)(tcontrol) 控件自身 %% - @param(e)(tuieventbase) 消息 %% - **} - end - function CNCOMMAND(o,e):CN_COMMAND;virtual; - begin - DoCNCOMMAND(o,e); - end - function CNMEASUREITEM(o,e):CN_MEASUREITEM;virtual; - begin - CallMessgeFunction(FOnMeasureItem,o,e); - DoMeasureItem(o,e); - end - function DoMeasureItem(o,e);virtual; - begin - {** - @explan(说明) 控件测量通知消息 %% - @param(o)(TWinControl) 控件自身 %% - @param(e)(TMMEASUREITEM) 消息 %% - **} - end - function CNDRAWITEM(o,e):CN_DRAWITEM;virtual; - begin - //tb := new tbrush(); - //tbh := tb.handle; - //odh := _wapi.SelectObject(canvas.Handle,tbh); - DoDrawItem(o,e); - //_wapi.SelectObject(canvas.Handle,odh); - end - function DoDrawItem(o,e);virtual; - begin - { - @explan(说明) 控件绘制通知消息 %% - @param(o)(TWinControl) 控件自身 %% - @param(e)(TMDRAWITEM) 消息 %% - } - CallMessgeFunction(FOnDrawItem,o,e); - end - function DoMouseEnter(o,e);virtual; - begin - { - @explan(说明) 鼠标进入控件回调 %% - } - CallMessgeFunction(FOnMouseEnter,o,e); - end - function DoMouseLeave(o,e);virtual; - begin - { - @explan(说明) 鼠标离开控件回调 %% - } - CallMessgeFunction(FOnMouseLeave,o,e); - end - function DoCnNotify(o,e);virtual; - begin - {** - @expaln(说明) 父窗口通知回调 %% - **} - end - function CNNOTIFY(o,e):CN_NOTIFY;virtual; - begin - DoCnNotify(o,e); - end - function WMERASEBKGND(o,e):WM_ERASEBKGND;virtual; - begin - end - function WMCancelMode(o,e):LM_CANCELMODE;virtual; - begin - end - function WMContextMenu(o,e):LM_CONTEXTMENU;virtual; - begin - CallMessgeFunction(FOnPopupMenu,o,e); - ContextMenu(o,e); - end - function WMLButtonDown(o,e):LM_LBUTTONDOWN;virtual; - begin - e.SetButton(mbLeft); - CallMessgeFunction(FOnMouseDown,o,e); - MouseDown(o,e); - end - function WMRButtonDown(o,e):LM_RBUTTONDOWN;virtual; - begin - e.SetButton(mbRight); - CallMessgeFunction(FOnMouseDown,o,e); - MouseDown(o,e); - end - function WMMButtonDown(o,e):LM_MBUTTONDOWN;virtual; - begin - e.SetButton(mbMiddle); - CallMessgeFunction(FOnMouseDown,o,e); - MouseDown(o,e); - end - function WMLButtonDBLCLK(o,e):LM_LBUTTONDBLCLK;virtual; - begin - e.SetButton(mbLeft); - e.setshiftdouble(ssDouble); - CallMessgeFunction(FOnMouseDown,o,e); - MouseDown(o,e); - return; - if not(e.skip)then - begin - CallMessgeFunction(FOnDblClick,o,e); - end - end - function WMRButtonDBLCLK(o,e):LM_RBUTTONDBLCLK;virtual; - begin - { - @explan(说明) 鼠标右双击击消息 %% - @param(o)(TWinControl) 控件自身 %% - @param(e)(TMMouse) 消息 %% - } - e.SetButton(mbRight); - e.setshiftdouble(ssDouble); - CallMessgeFunction(FOnMouseDown,o,e); - MouseDown(o,e); - end - function WMMOUSEHOVER(o,e):WM_MOUSEHOVER;virtual; - begin - MouseHover(o,e); - end - function WMMOUSELEAVE(o,e):WM_MOUSELEAVE;virtual; - begin - MouseLeave(o,e); - end - function WMMouseMove(o,e):LM_MOUSEMOVE;virtual; - begin - CallMessgeFunction(FOnMouseMove,o,e); - MouseMove(o,e); - end - function WMLButtonUp(o,e):LM_LBUTTONUP;virtual; - begin - e.SetButton(mbLeft); - CallMessgeFunction(FOnMouseUp,o,e); - MouseUp(o,e); - end - function WMRButtonUp(o,e):LM_RBUTTONUP;virtual; - begin - e.SetButton(mbRight); - CallMessgeFunction(FOnMouseUp,o,e); - MouseUp(o,e); - if not e.skip then - begin - CallMessgeFunction(FOnrbuttonup,o,e); //右键点击 - end - end - function WMMButtonUp(o,e):LM_MBUTTONUP;virtual; - begin - e.SetButton(mbMiddle); - CallMessgeFunction(FOnMouseUp,o,e); - MouseUp(o,e); - end - function DoMouseWheel(o,e);virtual; - begin - {** - @explan(说明) 鼠标滚动消息 %% - @param(o)(TWinControl) 控件自身 %% - @param(e)(TMMOUSEWHEEL) 滚动消息 %% - **} - end - function WMMouseWheel(o,e):LM_MOUSEWHEEL;virtual; - begin - CallMessgeFunction(FOnMouseWheel,o,e); - if not e.Result then - begin - if e.delta<0 then CallMessgeFunction(FOnMouseWheelDown,o,e); - else CallMessgeFunction(FOnMouseWheelUp,o,e); - end - DoMouseWheel(o,e); - end - function DoCNALIGN(o,e);virtual; - begin - if FAlign=alNone then exit; - if not(Visible)then exit; - if(o is class(TWincontrol))and not(o.HandleAllocated())then - begin - exit; - end - if e.width<1 then exit; - if e.height<1 then exit; - bds := UnAlignBounds; - case Align of - alTop: - begin - ht := min(e.height,bds[3]-bds[1]); - if ht then - begin - SetBounds(e.left,e.top,e.width,ht); - //SetBoundsRect(array(e.left,e.top,e.width+e.left,e.top+ht)); - e.top += ht; - e.height -= ht; - end - end - alRight: - begin - wd := min(e.width,bds[2]-bds[0]); - SetBounds(e.left+e.width-wd,e.top,wd,e.height); - e.width := e.width-wd; - end - alLeft: - begin - wd := min(e.width,bds[2]-bds[0]); - SetBounds(e.left,e.top,wd,e.height); - e.left := e.left+wd; - e.width := e.width-wd; - end - alBottom: - begin - ht := min(e.height,bds[3]-bds[1]); - SetBounds(e.left,e.top+e.height-ht,e.width,ht); - e.height -= ht; - end - alClient: - begin - SetBounds(e.left,e.top,e.width,e.height); - e.height := 0; - e.width := 0; - end - end - {if self is class(TWinControl) then - begin - //InvalidateRect(nil,true); updateWindow(); - end } - end - function CNALIGN(o,e):CN_ALIGN;virtual; - begin - DoCNALIGN(o,e); - end - public - function CNANCHOR(o,e):CN_ANCHOR;virtual; - begin - if Align <> alNone then exit; - if not ifarray(FAnchors)then exit; - if not(Visible)then exit; - if(o is class(TWincontrol))and not(o.HandleAllocated())then - begin - exit; - end - if akLeft+akTop=sum(FAnchors)then exit; //左上 - c := e.Prec; - bds := GetBoundsRect(); - if not FAnchorBounds then - begin - FAnchorBounds := array(bds[0],bds[1],c[2]-bds[2],c[3]-bds[3]); - return; - end - w := width; - h := height; - dx := c[2]-c[0]-(FAnchorBounds[0]+w+FAnchorBounds[2]); - dy := c[3]-c[1]-(FAnchorBounds[1]+h+FAnchorBounds[3]); - dx1 := integer(dx/2); - dx2 := dx-dx1; - dy1 := integer(dy/2); - dy2 := dy-dy1; - L := bds[0]; - r := bds[2]; - t := bds[1]; - b := bds[3]; - if(akLeft in FAnchors)and(akRight in FAnchors)then - begin - R := c[2]-FAnchorBounds[2]; - end - if not(akLeft in FAnchors)and(akRight in FAnchors)then - begin - R := c[2]-FAnchorBounds[2]; - L := r-w; - end - if not(akLeft in FAnchors)and not(akRight in FAnchors)then - begin - L := FAnchorBounds[0]+dx1; - R := l+w; - end - //********************************** - if(akTop in FAnchors)and(akBottom in FAnchors)then - begin - T := FAnchorBounds[1]; - B := c[3]-FAnchorBounds[3]; - end - if not(akTop in FAnchors)and(akBottom in FAnchors)then - begin - B := c[3]-FAnchorBounds[3]; - T := b-h; - //T := bds[1]+dy; - // - end - if not(akTop in FAnchors)and not(akBottom in FAnchors)then - begin - b := c[3]-FAnchorBounds[3]+dy1; - t := B-h; - end - SetBoundsRect(array(L,T,R,B)); - return; - - end - function WMMove(o,e):LM_MOVE;virtual; - begin - CallMessgeFunction(OnMove,o,e); - end - function DoWMSIZE(o,e);virtual; - begin - end - function WMSize(o,e):LM_SIZE;virtual; - begin - CallMessgeFunction(OnSize,o,e); - DoWMSIZE(o,e); - end - - - function CMCursorChanged(o,e):CM_CURSORCHANGED;virtual; - begin - //if SetTempCursor(o.Cursor) then e.skip := true; - //return ; - if not(csDesigning in ComponentState)then - begin - if SetTempCursor(o.Cursor)then e.skip := true; - end else - begin - cr := new tcursor(); - cr.id := IDC_ARROW; - if SetTempCursor(cr)then e.skip := true; - end - end - public //暂时不用的消息 - { - function WMWindowPosChanged(o,e):LM_WINDOWPOSCHANGED;virtual; - begin - end - function CMChanged(o,e):CM_CHANGED;virtual; - begin - end - function LMCaptureChanged(o,e):LM_CaptureChanged;virtual; - begin - end - function CMBiDiModeChanged(o,e):CM_BIDIMODECHANGED;virtual; - begin - end - function CMSysFontChanged(o,e):CM_SYSFONTCHANGED;virtual; - begin - end - function CMEnabledChanged(o,e):CM_ENABLEDCHANGED;virtual; - begin - end - function CMHitTest(o,e):CM_HITTEST;virtual; - begin - end - function CMMouseEnter(o,e):CM_MOUSEENTER;virtual; - begin - end - function CMMouseLeave(o,e):CM_MOUSELEAVE;virtual; - begin - end - function CMHintShow(o,e):CM_HINTSHOW;virtual; - begin - end - function CMParentBiDiModeChanged(o,e):CM_PARENTBIDIMODECHANGED;virtual; - begin - end - function CMParentColorChanged(o,e):CM_PARENTCOLORCHANGED;virtual; - begin - end - function CMParentFontChanged(o,e):CM_PARENTFONTCHANGED;virtual; - begin - end - function CMParentShowHintChanged(o,e):CM_PARENTSHOWHINTCHANGED;virtual; - begin - end - function CMVisibleChanged(o,e):CM_VISIBLECHANGED;virtual; - begin - end - function CMTextChanged(o,e):CM_TEXTCHANGED;virtual; - begin - end } - -#!end //消息处理 - protected //key and mouse - function SetColor(v);virtual; - begin - if v <> FColor and ifnumber(v)then - begin - FColor := v; - end - end - function SetBitmap(v);virtual; - begin - if v <> FBKBitmap then - begin - FBKBitmap := v; - end - end - function GetActionLinkClass();virtual; - begin - {** - @explan(说明) 返回actionlinkclass %% - @return(TControlActionLink class) - **} - return class(TControlActionLink); - end - procedure ActionChange(Sender:TObject;CheckDefaults:Boolean);virtual; - begin - if Sender is class(TCustomAction)then - begin - NewAction := Sender; - if (not CheckDefaults) or (Caption='') or (Caption=Name)then Caption := NewAction.Caption; - if (not CheckDefaults) or Enabled then Enabled := NewAction.Enabled; - if (not CheckDefaults) or Visible then Visible := NewAction.Visible; - { - if not CheckDefaults or (Hint = '') then - Hint := NewAction.Hint; - if not CheckDefaults or (Self.HelpContext = 0) then - Self.HelpContext := HelpContext; - if not CheckDefaults or (Self.HelpKeyword = '') then - Self.HelpKeyword := HelpKeyword; - } - // HelpType is set implicitly when assigning HelpContext or HelpKeyword - end; - end - function click(o,e);virtual; //type_tcontrol - begin - end - function DblClick(o,e);virtual; //type_tcontrol - begin - end - public - function ScreenToClient(X,Y);virtual; - begin - if Parent then - begin - ps := Parent.ScreenToClient(x,y); - return array(ps[0]-Left,ps[1]-Top); - end - return array(x,y); - end - function ClientToScreen(x,y);virtual; - begin - if Parent then - begin - ps := array(x+Left,y+Top); - return Parent.ClientToScreen(x+Left,y+Top); - end - return array(x,y); - end - function IsContainer(cd);virtual; - begin - { - @explan(说明)判断当前是否可以作为容器 %% - @param(cd)(tcontrol 及其子类) cd 是否可以为子项 %% - } - return false; - end - function getid(); - begin - return Fid; - end - function create(Owner);override; //type_tcontrol - begin - inherited; - if ifnil(FSIDC)then FSIDC := new tidcreater(100); - FId := FSIDC.createid(); - //init(); - bindmessages(self(true)); - FControlStyle := array(csCaptureMouse,csClickEvents,csSetCaption,csDoubleClicks); - FAlign := alNone; - FAnchors := array(akLeft,akTop); - FControls := new TFpList(); - FVisible := True; - FParentBidiMode := True; - FParentColor := True; - FParentFont := false; - FDesktopFont := True; - FParentShowHint := True; - FIsControl := False; - FEnabled := True; - FDragCursor := crDrag; - FCaption := "title"; - FLeft := 10; - FTop := 10; - FFont := new TFontControl(); - FFont.Control := self(true); - FWidth := 120; - FHeight := 40; - FBorder := false; - FColor := 0xffffff; //_wapi.GetSysColor(COLOR_WINDOW);//0xffffff; - FCanvas := new TControlCanvs(); - FCursor := new tcursor(); - FCursor.id := IDC_ARROW; - end - procedure CheckNewParent(AParent:TWinControl);virtual; //type_tcontrol - begin - { - @ignore(忽略) - @explan(说明) 判断是否可以作为父节点 - } - return(AParent is class(TWinControl))and AParent.IsContainer(self(true)); - return false; - end - function Recycling();override; //type_tcontrol - begin - {** - @explan(说明) 资源回收,子类请override该方法然后在destroy中调用 %% - **} - FFont := nil; - FMessagehandle := array(); - {while true do - begin - ci := FControls.Count; - if ci<1 then break; - cvi := FControls[ci-1]; - cvi.SetParent(nil); - end } - FSIDC.deleteid(FID); - SetParent(nil); - FOnClick := nil; //点击 - FOnContextPopup := nil; - FOnDblClick := nil; //双击 - FOnDragDrop := nil; - FOnDragOver := nil; - FOnSize := nil; - FOnMove := nil; - FOnEditingDone := nil; - FOnEndDock := nil; - FOnEndDrag := nil; - FOnMouseDown := nil; //按下 - FOnMouseEnter := nil; //进入 - FMouseEntereded := nil; - FOnMouseLeave := nil; //离开 - FOnMouseMove := nil; //移动 - FOnPopupMenu := nil; - FOnMouseUp := nil; //弹起 - FOnMouseWheel := nil; //滚动 - FOnMouseWheelDown := nil; //滚动按下 - FOnMouseWheelUp := nil; //滚动弹起 - //FOnQuadClick := nil; - //FOnResize := nil; // - FOnShowHint := nil; - FOnStartDock := nil; - FOnStartDrag := nil; - FOnTripleClick := nil; - FBKBitmap := nil; - if FActionLink is class(TControlActionLink)then - begin - FActionLink.Recycling(); - FActionLink := nil; - end - inherited; - end - function destroy();override; - begin - inherited; - end - function GetBoundsRect(); //type_tcontrol - begin - {** - @explan(说明)获取矩形范围 %% - **} - return array(FLeft,FTop,FLeft+FWidth,FTop+FHeight); - end; - function SetBoundsRect(rect); - begin - {** - @explan(说明) 设置矩形范围 %% - **} - nt := 100000; - if ifarray(rect)and rect[0]0 and aHeight>0 then - begin - ChangeBounds(integer(ALeft),integer(ATop),integer(AWidth),integer(AHeight),false); - end - end - function GetBounds();virtual; //type_tcontrol - begin - //aLeft, aTop, aWidth, aHeight: integer - {** - @explan(说明) 获取控件范围 %% - @return( array of integer) array(aLeft, aTop, aWidth, aHeight: integer) %% - - **} - return array(Left,top,Width,height); - //ChangeBounds(ALeft, ATop, AWidth, AHeight, false); - end - procedure SetTempCursor(Value);virtual; - begin - if Parent then return Parent.SetTempCursor(Value); - end - // drag and dock - function Dragging(); - begin - //return DragManager.Dragging(Self); - end; - procedure BeginDrag(Immediate:Boolean;Threshold); - begin - if not ifnumber(Threshold)then Threshold :=-1; - //DragManager.DragStart(Self, Immediate, Threshold); - end - procedure EndDrag(Drop:Boolean); - begin - //if Dragging() then DragManager.DragStop(Drop); - end - function getmessagehandle(id);virtual; - begin - if ifnumber(id)and FMessagehandle then return FMessagehandle[id]; - end - function dispatch(o,e);virtual; //type_tcontrol - begin - {** - @explan(说明)消息分发函数 %% - @param(o)()控件自身 %% - @param(e)(tuieventbase) 消息类及其子类 %% - **} - func := getmessagehandle(e.Msg); - if func then call(func,o,e); - end - procedure DoControlAlign();virtual; - begin - end - procedure DoControlAnchor();virtual; - begin - end - procedure WndProc(TheMessage);virtual; //type_tcontrol - begin - {** - @explan(说明) 消息循环 %% - @param(e)(tuieventbase) 消息对象 %% - **} - TheMessage.Sender := self(true); - tmsg := TheMessage.msg; - case tmsg of - WM_WINDOWPOSCHANGED: - begin - //d := new ttagWINDOWPOS(TheMessage.lparam); - d := new tvclwindowpos_class(TheMessage.lparam); - flags := d.flags; - if not((flags .& SWP_NOMOVE)=SWP_NOMOVE)then - begin - x := d.x; - y := d.y; - if x <> FLeft then FLeft := x; - if y <> FTop then FTop := y; - end - if not((flags .& SWP_NOSIZE)=SWP_NOSIZE)then - begin - cx := d.cx; - cy := d.cy; - if cx <> FWidth then FWidth := cx; - if cy <> FHeight then FHeight := cy; - end - end - {WM_SIZE: - begin - x := TheMessage.lolparamsigned(); - dxsize := x-FClientWdith; - if FClientWdith<> x then FClientWdith := x; - y := TheMessage.hilparamsigned(); - dysize := y-FClientHeight; - if FClientHeight <> y then FClientHeight := y; - DoControlAnchor(array(dxsize,dysize)); - DoControlAlign(array(FClientLeft,FClientTop,x,y)); - end - WM_MOVE: - begin - x := TheMessage.lolparamsigned(); - if FClientLeft<> x then FClientLeft := x; - y := TheMessage.hilparamsigned(); - if FClientTop <> y then FClientTop := y; - end } - end; - if(csDesigning in ComponentState)then - begin - //calldatafunction(,self(true),TheMessage); - end else - if(tmsg >= LM_KEYFIRST)and(tmsg <= LM_KEYLAST)then - begin - // keyboard messages - //Form := GetParentForm(Self); - //if (Form <> nil) and (Form.WantChildKey(Self,TheMessage)) then exit; - end else - if((tmsg >= LM_MOUSEFIRST)and(tmsg <= LM_MOUSELAST))or((tmsg >= LM_MOUSEFIRST2)and(tmsg <= LM_MOUSELAST2))then - begin - // mouse messages - case tmsg of - LM_MOUSEMOVE: - begin - //Application.HintMouseMessage(Self, TheMessage); - end; - LM_LBUTTONDOWN,LM_LBUTTONDBLCLK: - begin - includestate(FControlState,csLButtonDown); - if FDragMode=dmAutomatic then - begin - end; - //BeginAutoDrag(); - end; - LM_LBUTTONUP: - begin - excludestate(FControlState,csLButtonDown); - end; - end; - end; - if tmsg=LM_PAINT then - begin - includestate(FControlFlags,cfProcessingWMPaint); - try - Dispatch(self(true),TheMessage); - finally - excludestate(FControlFlags,cfProcessingWMPaint); - end; - end else - begin - Dispatch(self(true),TheMessage); - end - end; - function Perform(e); - begin - {** - @explan(说明) 消息通知执行 %% - @param(e)(tuieventbase) - **} - WndProc(e); - return e.Result; - end - property ActionLink read FActionLink; //write FActionLink; - {public - procedure AdjustSize;virtual; // smart calling DoAutoSize - begin - includestate(FControlFlags,cfAutoSizeNeeded); - if Parent then - begin - Parent.AdjustSize(); // - end - end } - public - // standard properties, which should be supported by all descendants - property Action:taction read GetAction write SetAction; - property Anchors:anchors read FAnchors write SetAnchors; - property Align:align read FAlign write SetAlign; - protected - property UnAlignBounds read GetUnAlignBounds write SetUnAlignBounds; - {** - @param(Action)(taction) action对象 %% - @param(UnAlignBounds)(array of integer) 去除自动对齐时的范围 %% - @param(Align)(member of TAlign ) 默认 alNone 对齐方式 %% - @param(Anchors)( array of TAnchorKind member) 锚定位置 ,默认 array(akTop,akLeft) %% - **} - public - property ParentFont:bool read FParentFont write SetParentFont; - property Caption:string read GetText write SetText ; - property Enabled:bool read GetEnabled write SetEnabled; - property Cursor:syscursor read GetCursor write SetCursor; - {** - @param(Cursor)(tcursor 通过 member of TSystemCursor 设置) 系统鼠标 %% - **} - property Font:font read GetControlFont write SetControlFont;//write SetFont; - property OnMouseWheel read FOnMouseWheel write FOnMouseWheel; - {** - @param(Caption)(string) 控件标题 %% - @param(Enabled)(bool) 控件是否有效 %% - @param(OnMouseWheel)(function[TControl,TMMOUSEWHEEL]) 滚动回调函数 %% - **} - //property MouseEntered read FMouseEntered; - property OnSize:eventhandler read FOnSize write FOnSize; - property OnMove:eventhandler read FOnMove write FOnMove; - property OnMouseMove:eventhandler read FOnMouseMove Write FOnMouseMove; - property OnPopupMenu read FOnPopupMenu write FOnPopupMenu; - property OnMouseDown:eventhandler read FOnMouseDown write FOnMouseDown; - {** - @param(OnMouseMove)(function[TControl,TMMouse]) 鼠标移动回调函数 %% - @param(OnPopupMenu)(function[TControl,TMMouse]) 弹出菜单回调函数 %% - @param(OnMouseDown)(function[TControl,TMMouse]) 鼠标按下回调函数 %% - @param(OnMouseUp)(function[TControl,TMMouse]) 鼠标松开回调函数 %% - @param(OnClick)(function[TControl,TMMouse]) 鼠标点击回调函数 %% - @param(OnDblClick)(function[TControl,TMMouse]) 鼠标双击回调函数 %% - @param(PopupMenu)(tpopupmenu) 弹出菜单%% - @param(Parent)(tcontrol) 父控件 %% - @param(Visible)(bool) 是否可见 %% - **} - property OnMouseUp:eventhandler read FOnMouseUp write FOnMouseUp; - property OnClick:eventhandler read FOnClick write FOnClick; - property onrclick:eventhandler read Fonrclick write Fonrclick; - property OnDblClick:eventhandler read FOnDblClick write FOnDblClick; - //property OnResize read FOnResize write FOnResize; - property OnShowHint read FOnShowHint write FOnShowHint; - property Parent read FParent write SetParent; - property PopupMenu:tpopupmenu read FPopupMenu write FPopupMenu{read GetPopupmenu write SetPopupMenu}; - //property ShowHint read FShowHint write SetShowHint ; - property Visible:bool read FVisible write SetVisible ; - property ClientRect read GetClientRect; - property Height: Integer read FHeight write SetHeight; - property Width :integer read FWidth write SetWidth; - property Left :integer read FLeft write SetLeft; - property Top :integer read FTop write SetTop; - property Border:bool read FBorder write SetBorder; - {** - @param(ClientRect)(array of integer) 客户区矩形array(left,top,right,bottom) %% - @param(BoundsRect)(array of integer) 控件区矩形array(left,top,right,bottom) %% - @param(Height)(integer) 高度 %% - @param(Width)(integer) 宽度 %% - @param(Zorder)(integer) 设置控件在父窗口的次序,最底层为 0 %% - @param(Top)() 上方位置 %% - @param(Left)() 左边 %% - **} - property BoundsRect read GetBoundsRect write SetBoundsRect; - property Zorder read GetZorder write SetZorder; - property ControlState: TControlState read FControlState write FControlState; - property Color:color read FColor write SetColor;//FColor; - property BKBitmap:tbitmap read FBKBitmap write SetBitmap; - property OnMeasureItem read FOnMeasureItem write FOnMeasureItem; - property OnDrawItem read FOnDrawItem write FOnDrawItem; - //property OnMouseEnter:eventhandler read FOnMouseEnter write FOnMouseEnter; - //property OnMouseLeave:eventhandler read FOnMouseLeave write FOnMouseLeave; - property Controls read FControls; - property Canvas: TCanvas read FCanvas; - {** - @param(Canvas)(TCanvas) 画布对象 %% - @param(Controls)(TFpList of tcontrol) 子组件 %% - @param(OnMouseLeave)(function[TControl,tuieventbase]) 鼠标离开回调 %% - @param(OnMouseEnter)(function[TControl,tuieventbase]) 鼠标进入回调 %% - @param(OnMeasureItem)(function[TControl,TMMEASUREITEM]) 控件测量回调 %% - @param(OnDrawItem)(function[TControl,TMDRAWITEM]) 控件绘制回调 %% - @param(Color)(integer) 背景色 %% - **} - function isCustomPaint(); - begin - return csCustomPaint in FControlState ; - end -end -type TGraphicControl = class(TControl) - {** - @explan(说明) 自绘制控件 %% - **} - private - //FCanvas: TCanvas; - FOnPaint:TNotifyEvent; - protected - procedure ChangeBounds(ALeft,ATop,AWidth,AHeight:integer;KeepBase:boolean);override; //type_tcontrol - begin - rect1 := array(FLeft,FTop,FLeft+FWidth,FTop+FHeight); - rect2 := array(ALeft,ATop,ALeft+AWidth,ATop+AHeight); - inherited; - if rect1 <> rect2 then - begin - if Parent then - begin - //Parent.InvalidateRect(nil,false); - Parent.InvalidateRect(rect1,false); - Parent.InvalidateRect(rect2,false); - //Parent.updateWindow(); - end - end - end - function RealSetText(s);override; - begin - {** - @explan(说明) 修改标题 %% - **} - if ifstring(s)and caption <> s then - begin - inherited; - InvalidateRect(rec,true); - end - end - procedure Paint();virtual; - begin - {** - @explan(说明)控件绘制调用 ,使用Canvas属性和PAINTSTRUCT结构体 绘制控件 %% - **} - if(datatype(FOnPaint)<> 7)or(not call(FOnPaint,self(true)))then - begin - canvas.Font := font; - Canvas.DrawText(self.caption,self.ClientRect,DT_VCENTER .| DT_SINGLELINE .| DT_CENTER .| DT_NOPREFIX); - end - //_wapi.DrawFrameControl(Canvas.handle,const ClientRect,DFC_BUTTON,DFCS_BUTTONCHECK); - //_wapi.DrawEdge(Canvas.handle,const ClientRect,EDGE_ETCHED,BF_RECT); - //_wapi.DrawFocusRect(Canvas.Handle,const ClientRect); - end - procedure DoOnChangeBounds();override; - begin - end - procedure DoOnParentHandleDestruction;override; - begin - end - function InvalidateRectForce(); - begin - if Parent then - begin - nrec := array(FLeft,FTop,FLeft+FWidth,FTop+FHeight); - //return Parent.InvalidateRect(nrec,true); - return Parent.InvalidateRect(nrec,false); - end - end - public - procedure SetVisible(Value);virtual; - begin - nv := Value?true:false; - if nv <> Visible then - begin - inherited; - InvalidateRectForce(); - end - end - function InvalidateRect(rec,f); - begin - {** - @explan(说明)设置窗口区域无效 %% - @param(rec)(array) 无效区域,nil表示窗口整体无效,array(左上右下) %% - @param(f)(bool) 是否重画 %% - **} - if Visible {and Parent}then - begin - if not ifarray(rec)then return InvalidateRectForce(); - nrec := array(FLeft+rec[0],FTop+rec[1],FLeft+rec[2],FTop+rec[3]); - return Parent.InvalidateRect(nrec,false); - end - end - function WMPaint(o,Message:TLMPaint):LM_PAINT;override; - begin - //if csCustomPaint in ControlState then if Message.lparam<>2 then return ; - dc := Message.wparam; - if dc then - begin - //_wapi.ReleaseDC(Canvas.Handle); - //odh := canvas.Handle; - Canvas.Handle := dc; - try - _wapi.SetViewportOrgEx(dc,FLeft,FTop,nil); - //_send_(WM_ERASEBKGND,dc,1,1); - //Perform(new tuieventbase(WM_ERASEBKGND,dc,1)); - //Perform(messagecreater(nil,WM_ERASEBKGND,dc,1)); - WMERASEBKGND(self(true),messagecreater(nil,WM_ERASEBKGND,dc,2)); - Canvas.SaveDC(); - Paint(); - Canvas.RestoreDC(); - //Canvas. - finally - Canvas.Handle := odh; - end; - //Canvas.Handle := _wapi.GetDC(self.Handle); - end - end - function WMERASEBKGND(o,e):WM_ERASEBKGND;override; - begin - if e.wparam and e.lparam then - begin - if(BKBitmap is class(TBitmap))and BKBitmap.HandleAllocated()then - begin - //Canvas.StretchDraw(GetClientRect(),self.BKBitmap);//20210812 修正默认的背景绘图 - Canvas.DrawBitmap(self.BKBitmap,GetClientRect()); - end else - begin - cl := Color; - if ifnumber(cl)then - begin - Canvas.Brush.Color := cl; - Canvas.FillRect(GetClientRect()); - end - end - e.skip := true; - return 1; - end - end - function CMCursorChanged(var Message:TLMessage):CM_CURSORCHANGED;override; - begin - inherited; - end - procedure FontChanged(Sender:TObject);override; - begin - inherited; - end - function IsContainer(cd);override; - begin - return false; - end - function Create(AOwner:TComponent);override; - begin - inherited; - //inherited Create(AOwner); - FLeft := 10; - FTop := 10; - FWidth := 80; - FHeight := 25; - includestate(FControlState,csCustomPaint); - end - function Recycling();override; - begin - FOnPaint := nil; - inherited; - end - function SetParent(NewParent);override; //type_tcontrol - begin - op := parent; - if op=NewParent then return; - inherited; - if NewParent is class(TWinControl)then - begin - InvalidateRect(); - end - end - property OnPaint:eventhandler read FOnPaint write FOnPaint; - {** - @param(OnPaint)(function[TGraphicControl]:bool) 绘制回调,返回true不执行默认绘制 %% - **} -end; type TLabel = class(TGraphicControl) {** @explan(说明)标签控件 %% @@ -9119,7 +685,7 @@ type TLabel = class(TGraphicControl) @explan(说明) 在指定区域内按照对齐方式绘制文本%% @param(al)(member of TAlignStyle9) 对齐方式 %% **} - if not(dc is class(TCanvas))then exit; + if not(dc is class(TCustomcanvas))then exit; als := array(36,0,33 ,2,36 ,37 @@ -9143,2399 +709,7 @@ type TLabel = class(TGraphicControl) **} end //窗口 -type TWinControl = class(tcontrol) - {** - @explan(说明) 窗口控件 %% - **} - private //成员变量 - __wstyle; //窗口样式 - __wexstyle; //窗口扩展样式 - __wstylestruct; //样式消息结构体 - __clientsize; //客户区大小 - __oldclientsize; //旧客户区大小 - FClientleft; - FClientTop; - FClientWdith; - FClientHeight; - FWsPopUp; - //FTtageDrawItem; //已经移除 - FWMNCHITTEST; - FImageList; - //FTRACKMOUSEEVENT; - FHandle:HWND; //窗口句柄 - private //窗口相关 - FBorderStyle; - FParentWindow:HWND; //父窗口句柄 - static FDefaultProc; //windows默认句柄处理 - FWndproc; //消息句柄 - protected //消息 - FDefWndproc; //默认消息句柄 - private //时间指针 - FonKillFocus; - FonSetFocus; - FControlStyle; //控件样式 - FOnClose; - FOnDesinedsel; - FOnDesigDBLClick; - FOnDesinedRclick; - FOnActivate; - FOnKeyDown; - FOnKeyPress; - FOnKeyUp; - FTabStop; - FWsCaption; - FWsSizeBox; - FWsSysMenu; - FWsDlgModalFrame; - private //模态相关 - //*******showmodal****************** - FModaling; - FModalCode; - FMinWidth; - FMinHeigt; - //Ftagminmaxinfo; - FMaxWidth; - FMaxHeight; - FGtkEventOjbect; //gtkobject - private //窗口属性 - function SetMaxWidth(v); - begin - if v>0 and FMaxWidth <> V then - begin - FMaxWidth := v; - end - end - function SetMaxHeight(v); - begin - if v>0 and FMaxHeight <> v then - begin - FMaxHeight := v; - end - end - function SetMinWidth(v); - begin - if v>0 and FMinWidth <> v then - begin - FMinWidth := v; - if FMinWidth>width then width := FMinWidth; - end - end - function SetMinHeight(v); - begin - if v>0 and FMinHeigt <> v then - begin - FMinHeigt := v; - if FMinHeigt>height then height := FMinHeigt; - end - end - function DoModal() - begin - //标识处于模态状态中 - if not WsPopUp then - begin - exit; - end -{$ifdef gtkpaint} - if FModaling then exit; - if _wapi.gtk_window_showmodal(self(true))then - begin - FModaling := true; - initializeapplication().run(); - end - return FModalCode; - exit; -{$endif} - modp := parent; - {if not(modp is class(TWinControl)) then - begin - return -1; - end } - hWnd := Handle; - FModaling := TRUE; - FMSG := new TTagMSG(); - msg := FMSG._getptr_; - //显示自己 - _wapi.ShowWindow(hWnd,SW_SHOW); - _wapi.BringWindowToTop(hWnd); - //disable掉父窗口 - FModalRootWnd := 0; - if(modp is class(TWinControl))and modp.HandleAllocated()then - begin - hParentWnd := modp.Handle; - while(hParentWnd) do - begin - _wapi.EnableWindow(hParentWnd,FALSE); - wdobj := class(TGlobalComponentcache).getwndbyhwnd(hParentWnd); - if wdobj and wdobj.Modaling then - begin - FModalRootWnd := hParentWnd; - break; - end - hParentWnd := _wapi.GetParent(hParentWnd); - end - end - //接管消息循环 - while(FModaling) do - begin - ///////////////////////////////////////////// - if(_wapi.PeekMessageA(msg,0,0,0,0x1))then - begin - if FMSG.message=0x12 then - begin - return 1; - end else - begin - _wapi.TranslateMessage(msg); - _wapi.DispatchMessageA(msg); - end - end else - begin - tslprocessmessages(false); - RunWorkerThreadLoop(); - end - ////////////////////////////////////////// - {if (not _wapi.GetMessageA(msg, 0, 0, 0)) then break; - _wapi.TranslateMessage(msg); - _wapi.DispatchMessageA(msg);} - end - //模态已经退出 - //恢复父窗口的enable状态 - if(modp is class(TWinControl))and modp.HandleAllocated()then - begin - hParentWnd := modp.Handle; - while(hParentWnd) do - begin - _wapi.EnableWindow(hParentWnd,TRUE); - if FModalRootWnd=hParentWnd then break; - hParentWnd := _wapi.GetParent(hParentWnd); - end - end - //将自己隐藏 - _wapi.ShowWindow(hWnd,SW_HIDE); - return FModalCode; - end - private //窗口样式 - function SetWSsizeBox(v); - begin - nv := v?true:false; - if nv <> FWsSizeBox then - begin - FWsSizeBox := nv; - if HandleAllocated()then RecreateWnd(); - end - end - function GetWsSysMenu();virtual; - begin - return FWsSysMenu; - end - function SetWsSysMenu(v);virtual; - begin - nv := v?true:false; - if nv <> FWsSysMenu then - begin - FWsSysMenu := nv; - if HandleAllocated()then RecreateWnd(); - end - end - function SetWsDlgModalFrame(v);virtual; - begin - nv := v?true:false; - if nv <> FWsDlgModalFrame then - begin - FWsDlgModalFrame := nv; - if HandleAllocated()then - begin - RecreateWnd(); - end - end - end - protected - function SetWsPopUp(v);virtual; - begin - nv := v?true:false; - if nv <> FWsPopUp then - begin - FWsPopUp := nv; - if HandleAllocated()then RecreateWnd(); - end - end - function GetWsPopUp();virtual; - begin - return FWsPopUp; - end - private - function GetWsCaption(v);virtual; - begin - return FWsCaption; - end - function SetWsCaption(v);virtual; - begin - nv := v?true:false; - if nv <> FWsCaption then - begin - FWsCaption := nv; - if HandleAllocated()then RecreateWnd(); - end - end - function GetHandle(); //type_twinctrol - begin - //if not HandleAllocated then DebugLn('TWinControl.GetHandle Creating handle on the fly: ',DbgSName(Self)); - HandleNeeded(); - return FHandle; - end; - procedure SetHandle(NewHandle); //type_twinctrol - begin - if {NewHandle and}not(FHandle)then FHandle := NewHandle; - //if (NewHandle=0) and (AnsiCompareText(ClassName,'TPAGE')=0) then - // RaiseGDBException('TWincontrol.SetHandle'); - //FHandle:=NewHandle; - //InvalidatePreferredSize(); - end; - function SetTabStop(v); - begin - nv := V?true:false; - if nv <> FTabStop then - begin - FTabStop := nv; - if HandleAllocated()then - begin - if nv then appendwstyle(WS_TABSTOP); - else minuswstyle(WS_TABSTOP); - end - end - end - function GetControlCount():Integer; //type_twinctrol - begin - return FControls.Count(); - end; - procedure SetParentWindow(const AValue:HWND); //type_twinctrol - begin - {** - @ignore(忽略) %% - **} - if(ParentWindow=AValue)or Assigned(Parent)then Exit; - FParentWindow := AValue; - if HandleAllocated()then - begin - if(AValue <> 0)then //LCLIntf.SetParent(Handle, AValue) - else DestroyHandle(); - end - UpdateControlState(); - end - protected - function SetImageList(v); - begin - if FImageList=v then exit; - if FImageList is class(TControlImageList)then - begin - ti := FImageList; - FImageList := nil; - ti.deleteControl(self); - end - FImageList := v; - if v is class(TControlImageList)then v.addControl(self); - ImageChanged(); - end - class function getwndbyhwnd(hwnd); //type_twinctrol - begin - return class(TGlobalComponentcache).getwndbyhwnd(hwnd); - end - class function registerhandle(handle,o); //type_twinctrol - begin - //注册对象 %% - return class(TGlobalComponentcache).registerhandle(handle,o); - end - class function unregisterhandle(handle); //type_twinctrol - begin - //删除对象 %% - return class(TGlobalComponentcache).unregisterhandle(handle); - end - class function sinit();override; - begin - {** - @explan(说明)初始化 %% - **} - if ifnil(FDefaultProc)then FDefaultProc := getwinprocptr(1); - end - function SetBorder(v);override; //type_twinctrol - begin - nv := v?true:false; - if nv <> Border then - begin - inherited; - if nv then appendwstyle(WS_BORDER); - else minuswstyle(WS_BORDER); - Refresh(); - end - end - procedure CreateHandle();virtual; //type_twinctrol - begin - if csCreating in ControlState then return; - if(not HandleAllocated())then - begin - includestate(ControlState,csCreating); - CreateWnd(); - excludestate(ControlState,csCreating); - end - end; - procedure InitializeWnd();virtual; //type_twinctrol - begin - {** - @explan(说明) 窗口句柄初始化,在该函数设置窗口句柄的一些信息 %% - **} - //背景这些处理 - if HandleAllocated()then - begin - //Canvas.Handle := _wapi.GetDC(self.Handle); - if(Parent is class(TWinControl))and Parent.HandleAllocated()then - begin - //if Align<>alNone then - Parent.DoControlAlign(); - end - if ParentFont then - begin - hd := GetParentFontHandle(); - end else - hd := Font.Handle; - if hd then - begin - _send_(WM_SETFONT,hd,1,1); //send 修改为 post - end - ImageChanged(); - // "id:",self.caption,_wapi.GetWindowLongPtrA(FHandle,GWLP_ID); - end - end - function GetBorderStyle(); - begin - return FBorderStyle; - end - function SetBorderStyle(NewStyle);virtual; - begin - if FBorderStyle=NewStyle then exit; - if FBorderStyle in array(bsNone,bsSingle)then - begin - FBorderStyle := NewStyle; - if FBorderStyle=bsNone then - begin - minuswexstyle(WS_EX_CLIENTEDGE); - end else - appendwexstyle(WS_EX_CLIENTEDGE); - end - end - function CreateParams(p);virtual; //type_twinctrol - begin - {** - @explan(说明)构架窗口句柄使用 %% - @param(p)(var TCreateParams) 变参返回 %% - **} - if not(p is class(TCreateParams))then p := new TCreateParams(); - p.Caption := Caption; - //p.Style := WS_CHILD .| WS_CLIPSIBLINGS .| WS_CLIPCHILDREN ; - p.Style := WS_CHILD; - if FWsPopUp then - begin - p.Style := WS_POPUP; - end else - begin - p.Style := WS_CHILD; - end - //p.style .|= WS_CAPTION; //WS_SYSMENU .| - if WsCaption then p.style .|= WS_CAPTION; - if FWsSysMenu then P.Style .|= WS_CAPTION .| WS_SYSMENU; - if FWsSizeBox then p.style .|= WS_SIZEBOX; - if Border then p.Style := p.Style .| WS_BORDER; - if csAcceptsControls in FControlStyle then p.ExStyle := p.ExStyle .| WS_EX_CONTROLPARENT; - if BorderStyle=bsSingle then p.ExStyle := p.ExStyle .| WS_EX_CLIENTEDGE; - if WSDlgModalFrame then - begin - p.ExStyle .|= WS_EX_DLGMODALFRAME; - end - if TabStop then p.Style .|= WS_TABSTOP; - //op := parent; - if not(Enabled)then p.Style .|= WS_DISABLED; - if Visible then p.Style .|= WS_VISIBLE; - if Parent is class(TWinControl)then //if Parent.HandleAllocated() then - p.WndParent := Parent.Handle; - else p.WndParent := ParentWindow; - p.X := Left; - p.Y := Top; - p.Width := Width; - p.Height := Height; - p.happ := happ; - p.Style .|= WS_CLIPSIBLINGS .| WS_CLIPCHILDREN; - p.cstyle := CS_HREDRAW .| CS_VREDRAW .| CS_OWNDC .| CS_DBLCLKS; - end - procedure RealSetText(Value:TCaption);override; //type_twinctrol - begin - {** - @explan(说明) 设置标题 %% - @param(value)(string) 标题 %% - **} - if ifstring(Value)and(Caption <> Value)then - begin - inherited; - if HandleAllocated()then - begin - _wapi.SetWindowTextA(self.handle,self.Caption); - end - end - end - function createwndclass(p); //type_twinctrol - begin - {** - @param(p)(TCreateParams) 注册窗口类 %% - @explan(说明)注册窗口类 %% - **} - classobj := p.winclass; //new tagWNDCLASSA(); - subclass := p.subclass; - uiproc := getwinprocptr(); - dfproc := getwinprocptr(1); - p.subclasswndproc := dfproc; - tclass := new tagWNDCLASSA(); - classobj._setvalue_("lpszclassname",p.WinClassName); - for i,v in classobj._getdata_() do - begin - if i="lpfnwndproc" then tclass._setvalue_(i,uiproc); - else tclass._setvalue_(i,v); - end - regptr := _wapi.GetClassInfoExA(p.happ,p.WinClassName,classobj._getptr_); - if not regptr then - begin - for i,v in tclass._getdata_() do - begin - classobj._setvalue_(i,v); - end - end - if ifstring(p.SubClassName)and p.SubClassName then //存在subclass - begin - tcn := p.SubClassName; - subregptr := _wapi.GetClassInfoExA(p.Happ,tcn,subclass._getptr_); - if subregptr then - begin - p.subclasswndproc := subclass._getvalue_("lpfnwndproc"); - if p.subclasswndproc=uiproc then - begin - p.subclasswndproc := dfproc; - end - if not regptr then //窗口没有注册 - begin - for i,v in subclass._getdata_() do //填充子窗口信息 - begin - if i="lpfnwndproc" then - begin - classobj._setvalue_(i,uiproc); - end else - if i="lpszclassname" then - begin - tcn := p.WinClassName; - classobj._setvalue_(i,tcn); - end else - begin - classobj._setvalue_(i,v); - end - end - end - end - end else //不存在subclass 默认回调为 defaultproc - begin - if p.cstyle then classobj.style := p.cstyle; - p.subclasswndproc := dfproc; - end - if regptr then - begin - if uiproc <> classobj._getvalue_("lpfnwndproc")then - begin - messageboxA("窗口类注册冲突!","错误",1); - end - end else - begin - regptr := _wapi.RegisterClassExA(classobj._getptr_); - end - end - function UpdateControlState(); ////type_twinctrol - begin - end - procedure ChangeBounds(ALeft,ATop,AWidth,AHeight:integer;KeepBase:boolean);override; //type_twinctrol - begin - if HandleAllocated()then - begin - //_wapi.MoveWindow(self.Handle,ALeft,ATop,AWidth,AHeight,true); - _wapi.SetWindowPos(self.Handle,0,integer(ALeft),integer(ATop),integer(AWidth),integer(AHeight),SWP_NOZORDER .| SWP_NOACTIVATE); //.| SWP_NOACTIVATE - end else - begin - inherited; - //class(tcontrol).ChangeBounds(ALeft, ATop, AWidth, AHeight,KeepBase); - end - end - function SetEnabled(v);override; - begin - inherited; - if HandleAllocated()then _wapi.EnableWindow(FHandle,v?true:false); - end - function SetVisible(v);override; - begin - inherited; - if HandleAllocated()then - begin - _wapi.ShowWindow(FHandle,v?SW_SHOW:SW_HIDE); - if(Parent is class(TWinControl))and parent.HandleAllocated()then - begin - if Align <> alNone then Parent.DoControlAlign(); - end - {if V then - begin - DoControlAlign(); - end } - end - end - function Hitcontrol(p); - begin - {** - @explan(说明) 命中控件 %% - **} - for i := ControlCount-1 downto 0 do - begin - it := Controls[i]; - if it is class(TGraphicControl)then - begin - if it.Enabled and it.Visible and pointinrect(p,it.GetBoundsRect)then - begin - return it; - end - end - end - end - function MouseHover(O,e);override; - begin - inself := true; - initem := 0; - for i := ControlCount-1 downto 0 do - begin - it := FControls[i]; - if(it is class(TGraphicControl))and it.visible then - begin - if inself and pointinrect(array(e.lolparamsigned,e.hilparamsigned),it.GetBoundsRect)and it.Enabled then - begin - initem := it; - inself := false; - end else - begin - it.Perform(messagecreater(nil,WM_MOUSELEAVE,0,0)); - end - end - end - if inself then return inherited; - else self.Perform(messagecreater(nil,WM_MOUSELEAVE,0,0)); - if initem then initem.Perform(messagecreater(nil,WM_MOUSEHOVER,0,0)); - end - function GetParentFontHandle();override; - begin - {** - @explan(说明) 获取字体的句柄 %% - @return(pointer) - **} - if ParentFont and Parent then return Parent.GetParentFontHandle(); - if HandleAllocated()then - begin - return _send_(WM_GETFONT,0,0); - end else - return inherited; - end - public //消息绑定函数 - function WMMouseMove(o,e):LM_MOUSEMOVE;override; - begin - it := Hitcontrol(e.pos); - if it then - begin - return it.WMMouseMove(it,new TMMouse(LM_MOUSEMOVE,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); - //return it.Perform(new TMMouse(LM_MOUSEMOVE,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); - end - inherited; - end - function WMLButtonUp(o,e):LM_LBUTTONUP;override; - begin - it := Hitcontrol(e.pos); - if it then - begin - return it.WMLButtonUp(it,new TMMouse(LM_LBUTTONUP,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); - end - inherited; - end - function WMRButtonUp(o,e):LM_RBUTTONUP;override; - begin - it := Hitcontrol(e.pos); - if it then - begin - return it.WMRButtonUp(it,new TMMouse(LM_RBUTTONUP,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); - end - inherited; - end - function WMMButtonUp(o,e):LM_MBUTTONUP;override; - begin - it := Hitcontrol(e.pos); - if it then - begin - return it.WMMButtonUp(it,new TMMouse(LM_MBUTTONUP,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); - end - inherited; - end - function WMContextMenu(o,e):LM_CONTEXTMENU;override; - begin - ps := array(e.lolparamsigned,e.hilparamsigned); - _wapi.ScreenToClient(Handle,ps); - it := Hitcontrol(ps); - if it then - begin - ev := new TMMouse(e.msg,e.wparam,e.lparam); - return it.Perform(ev); - end - return inherited; - end - function WMLButtonDown(o,e):LM_LBUTTONDOWN;override; - begin - it := Hitcontrol(e.pos); - if it then - begin - return it.WMLButtonDown(it,new TMMouse(LM_LBUTTONDOWN,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); - end - inherited; - end - function WMRButtonDown(o,e):LM_RBUTTONDOWN;override; - begin - it := Hitcontrol(e.pos); - if it then - begin - return it.WMRButtonDown(it,new TMMouse(LM_RBUTTONDOWN,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); - //return it.Perform(new TMMouse(LM_MOUSEMOVE,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); - end - inherited; - end - function WMMButtonDown(o,e):LM_MBUTTONDOWN;override; - begin - it := Hitcontrol(e.pos); - if it then - begin - return it.WMMButtonDown(it,new TMMouse(LM_MBUTTONDOWN,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); - end - inherited; - end - function WMLButtonDBLCLK(o,e):LM_LBUTTONDBLCLK;override; - begin - it := Hitcontrol(e.pos); - if it then - begin - return it.WMLButtonDBLCLK(it,new TMMouse(LM_LBUTTONDBLCLK,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); - end - inherited; - end - public //设计器相关杂项 - class function CaptionHeight(); - begin - {** - @explan(说明) caption的高度 %% - @return(integer) 高度 %% - **} - return _wapi.GetSystemMetrics(SM_CYCAPTION); - end - function DesigningSelect(v); - begin - if ifnil(FDesignSelect)then FDesignSelect := false; - if ifnil(v)then return FDesignSelect; - if WsPopUp then return; - if not(csDesigning in ComponentState)then return; - nv := v?true:false; - if nv=FDesignSelect then return; - FDesignSelect := nv; - {$ifdef linux} - return InvalidateRect(nil,false); - {$endif} - rec := array(left,top,left+width,top+height); - rec[2:3]+= 1; - SetBoundsRect(rec); - rec[2:3]-= 1; - SetBoundsRect(rec); - end - private - FDesignSelect; - public //消息绑定函数 - function ImageChanged();virtual; - begin - end - function WMNCPAINT(o,e):LM_NCPAINT;virtual; - begin - if (csDesigning in ComponentState) and FDesignSelect then - begin - hWnd := Handle; - rec := zeros(4); - {$ifdef linux} - - cvs := Canvas; - cvs.Handle := e.lparam;; - pc := cvs.pen.Color; - cvs.Pen.Color := rgb(224,0,0); - ps := cvs.Pen.Style; - pw := cvs.Pen.width; - cvs.Pen.Style := PS_SOLID; - cvs.Pen.width := 2; - _wapi.gtk_widget_get_allocation(hWnd,rec); - rec[0]:=0; - rec[1] := 0; - //rec[2]-=2; - //rec[3]-=2; - //cvs.FillRect(array(0,0,width,height)); //array(0,0,width,height) - cvs.Draw("Polyline",array((0,0),(rec[2]-rec[0]-1,0),(rec[2]-rec[0]-1,rec[3]-rec[1]-1),(0,rec[3]-rec[1]-1),(0,0))); - cvs.Pen.Color := pc; - cvs.Pen.width := pw; - cvs.Pen.Style := ps; - cvs.Handle := 0; - return ; - {$endif} - _wapi.GetWindowRect(hwnd,rec); - rect := array(0,0,0,0); - _wapi.GetClientRect(self.Handle,rect); - region := new TRGNRECT(); - region.Rect := rec; - if e.wparam =1 then - begin - end else - begin - _wapi.CombineRgn(region.Handle,e.wparam,nil,RGN_COPY); - end - hdc := _wapi.GetDCEx(hWnd, region.Handle, DCX_WINDOW .| DCX_CACHE .| DCX_INTERSECTRGN .| DCX_LOCKWINDOWUPDATE); - if hdc=0 then return ; - cvs := Canvas; - cvs.Handle := hdc; - cvs.Pen.Color := rgb(224,0,0); - cvs.Pen.Style := PS_SOLID; - cvs.Pen.width := 2; - defaulthandler(e); - //cvs.FillRect(array(0,0,width,height)); //array(0,0,width,height) - cvs.Draw("Polyline",array((0,0),(rec[2]-rec[0]-1,0),(rec[2]-rec[0]-1,rec[3]-rec[1]-1),(0,rec[3]-rec[1]-1),(0,0))); - _wapi.ReleaseDC(hWnd,hdc); - e.skip := true; - e.Result := 0; - end - end - procedure FontChanged(Sender:TObject);override; - begin - if(HandleAllocated()and not(ParentFont))then - begin - _send_(WM_SETFONT,Font.Handle,1); - end - end - function CMPARENTFONTCHANGED(o,e):CM_PARENTFONTCHANGED;virtual; - begin - if ParentFont then - begin - _send_(WM_SETFONT,e.wparam,1); - end - end - function WMGETMINMAXINFO(o,e):WM_GETMINMAXINFO;virtual; - begin - {** - @explan(说明) 最小窗口设置 %% - **} - k := 0; - if FMinWidth>0 then - begin - k .|= 1; - end - if FMinHeigt>0 then - begin - k .|= 2; - end - if FMaxHeight>0 then - begin - k .|= 4; - end - if FMaxWidth>0 then - begin - k .|= 8; - end - if k then - begin - d := new Ttagminmaxinfo(e.lparam); - ts := d.ptmintracksize; - case k of - 1:ts[0]:= FMinWidth; - 2:ts[1]:= FMinHeigt; - 3:ts := array(FMinWidth,FMinHeigt); - end; - d.ptmintracksize := ts; - end - end - function CMFONTCHANGED(o,e):CM_FONTCHANGED;virtual; - begin - hd := e.wparam; - for i := 0 to ControlCount-1 do - begin - it := Controls[i]; - it.Perform(new tuieventbase(CM_PARENTFONTCHANGED,hd,1,0)); - end - end - function WMSETFONT(o,e):WM_SETFONT;virtual; - begin - defaulthandler(e); - Perform(new tuieventbase(CM_FONTCHANGED,e.wparam,e.lparam,0)); - end - function WMACTIVATE(o,e):WM_ACTIVATE;virtual; - begin - CallMessgeFunction(OnActivate,o,e); - end - function GetClientRect();override; - begin - {** - @explan(说明)获得客户区大小 %% - @return(array of integer) 客户区矩形 %% - **} - ret := inherited; - if HandleAllocated()then - begin - if ifnumber(FClientWdith)and ifnumber(FClientHeight)then - begin - ret := array(0,0,FClientWdith,FClientHeight); - end else - _wapi.GetClientRect(self.Handle,ret); - end - //else ret := array(0,0,FClientWdith,FClientHeight); - return ret; - end - -#!begin //消息 - function DoCNALIGN(o,e);override; - begin - if(wstyle().& WS_POPUP)=WS_POPUP then exit; - inherited; - end - function DoWMCLOSE(o,e);virtual; - begin - EndModal(); - end - function WMCLOSE(o,e):WM_CLOSE;virtual; - begin - CallMessgeFunction(OnClose,o,e); - DoWMCLOSE(o,e); - end - function WMCREATE(o,e):WM_CREATE;virtual; - begin - if e.lparam then - begin - co := new TCREATESTRUCT(e.lparam); - __wstyle := co.style; - __wexstyle := co.dwexstyle; - end - end - function WMSETCURSOR(o,e):WM_SETCURSOR;virtual; - begin - if e.lolparam=HTCLIENT then - begin - ne := new tuieventbase(CM_CURSORCHANGED,0,0); - Perform(ne); - if ne.skip then - begin - e.skip := true; - e.result := true; - end - end - end - function WMSTYLECHANGING(o,e):WM_STYLECHANGING;virtual; - begin - end - function WMNCDESTROY(o,e):WM_NCDESTROY;virtual; - begin - FHandle := nil; - for i := 0 to FControls.count-1 do - begin - item := FControls.geti(i); - if(item is class(TWinControl))and item.WsPopUp then - begin - item.DestroyHandle(); - end - end - end - function WMSTYLECHANGED(o,e):WM_STYLECHANGED;virtual; - begin - end - function WMNCCALCSIZE(o,e):WM_NCCALCSIZE;virtual; - begin - if(csDesigning in ComponentState)and FDesignSelect then - begin - wd := 1; - hwd := wd; - rc := new TCRect(e.lparam); - rc.top += hwd; - rc.left += wd; - rc.bottom -= wd; - rc.right -= wd; - end - end - function WMMOUSEHOVER(o,e):WM_MOUSEHOVER;virtual; - begin - MouseHover(o,e); - end - function WMMOUSELEAVE(o,e):WM_MOUSELEAVE;virtual; - begin - MouseLeave(o,e); - end - function WMMENURBUTTONUP(o,e):WM_MENURBUTTONUP;virtual; - begin - if PopupMenu is class(TPopUpmenu)then PopupMenu.dispatch(e); - end - function WMMENUSELECT(o,e):WM_MENUSELECT;virtual; - begin - if PopupMenu is class(TPopUpmenu)then PopupMenu.dispatch(e); - end - function WMINITMENUPOPUP(o,e):WM_INITMENUPOPUP;virtual; - begin - if PopupMenu is class(TPopUpmenu)then PopupMenu.dispatch(e); - end - function WMERASEBKGND(o,e):WM_ERASEBKGND;override; - begin - {** - @explan(说明) 背景绘制 %% - **} - if not HandleAllocated()then return; - mtic; - //if not(csCustomPaint in ControlState) and not(e.lparam) then return ; - dc := e.wparam; - if dc {and e.lparam}then - begin - cl := Color; - rect := array(0,0,0,0); - if e.lparam=2 then - begin - rect := PAINTSTRUCT().rcpaint(); - end - _wapi.GetClientRect(self.Handle,rect); - if ifnumber(cl)then - begin - Canvas.Brush.Color := cl; - Canvas.Handle := dc; - Canvas.FillRect(rect); - end else - begin - cl := _wapi.GetStockObject(WHITE_BRUSH); - _wapi.FillRect(dc,rect,cl); - end - if(BKBitmap is class(TBitmap))and BKBitmap.HandleAllocated()then - begin - Canvas.Handle := dc; - //Canvas.StretchDraw(rect,BKBitmap); - Canvas.DrawBitmap(self.BKBitmap,rect); - end - e.skip := true; - e.Result := 1; - end - end - Function WMDRAWITEM(o,e):WM_DRAWITEM;virtual; //type_twinctrol - begin - {** - @ignore(忽略) %% - @explan(说明) 自绘制消息处理 %% - @param(o)(TWincontrol) 窗口控件 %% - @param(e)(TMDRAWITEM) 消息 %% - **} - e.canvas := canvas; - dc := e.hdc; - //dc := _wapi.GetDC(SELF.hANDLE); - //dcid := _wapi.SaveDC(dc); - canvas.handle := dc; - if(e.wparam=0)and(PopupMenu is class(TPopUpmenu))then - begin - r := PopupMenu.dispatch(e); - if r then - begin - e.canvas := nil; - exit; - end - end - ctrl := getwndbyhwnd(e.hwndItem); - if ctrl then - begin - e.message := CN_DRAWITEM; - h := e.hwnd; - try - ctrl.Perform(const e); - except - end; - e.hwnd := h; - e.message := WM_DRAWITEM; - end - //if dcid then - // "\r\nrestor:",_wapi.RestoreDC(dc,-1); - e.canvas := nil; - // _wapi.ReleaseDC(Handle,Canvas.handle); - end - function WMMEASUREITEM(o,e):WM_MEASUREITEM;virtual; - begin - {** - @ignore(忽略) %% - @explan(说明) 测量消息处理 %% - @param(o)()控件本身 %% - @param(e)(TMMEASUREITEM)测量消息 %% - **} - if(e.wparam=0 and e.ctltype=ODT_MENU)and(PopupMenu is class(tpopupmenu))and PopupMenu.Dispatch(e)then exit; - for i := 0 to FControls.count-1 do - begin - it := FControls[i]; - if it and it.getid=e.ctlid then - begin - h := e.hwnd; - e.message := CN_MEASUREITEM; - it.Perform(e); - e.message := WM_MEASUREITEM; - e.hwnd := h; - return; - end - end - end - function WMNOTIFY(o,e):WM_NOTIFY;virtual; - begin - {** - @explan(说明) 子控件通知父控件 %% - @param(e)(TMNOTIFY) 通知消息 %% - **} - hd := e.hwndfrom; - if hd then - begin - ctrl := getwndbyhwnd(hd); - if ctrl then - begin - nr := new tuieventbase(CN_NOTIFY,e.code,e.lparam); - ctrl.Perform(nr); - e.skip := nr.skip; - end - end - end - function WMCTLCOLORBTN(o,e):WM_CTLCOLORBTN;virtual; - begin - hd := e.lparam; - if hd then - begin - ctrl := getwndbyhwnd(hd); - if ctrl then - begin - ce := new tuieventbase(CN_CTLCOLORBTN,e.wparam,e.lparam,e.lparam); - ctrl.Canvas.handle := e.lparam; - ctrl.Perform(ce); - if ce.Result then - begin - e.result := ce.result; - e.skip := true; - end - end - end - end - function WMSYSCOMMAND(o,e):WM_SYSCOMMAND;virtual; - begin - //sysmenu.dispatch(); - end - function WMCOMMAND(o,e):WM_COMMAND;virtual; - begin - if(popupmenu is class(tmenu))and popupmenu.dispatch(e)then exit; - hd := e.lparam; - if hd then - begin - ctrl := getwndbyhwnd(hd); - if ctrl then - begin - wp := e.wparam; - ctrl.Perform(new tuieventbase(CN_COMMAND,wp,0)); - end - end - end - function WMKEYDOWN(o,e):WM_KEYDOWN;virtual; - begin - CallMessgeFunction(FOnkeyDown,o,e); - if e.skip then return; - if HandleAllocated()and(e.wParam=VK_TAB)then - begin - cfoc := _wapi.GetFocus(); - if Handle=cfoc then - begin - if TabStop then //发送给父控件 - begin - if Parent then Parent._Send_(WM_KEYDOWN,VK_TAB,e.lparam,nil); - end - end else //遍历子控件 设置下一个focus - begin - cts := Controls; - Thec := false; - pc := 0; - for i := 0 to cts.Count-1 do - begin - ci := cts[i]; - if(ci is class(TWinControl))and ci.Enabled and ci.Visible and ci.TabStop and ci.HandleAllocated()then - begin - if ci.Handle=cfoc then //找到了当前 - begin - Thec := true; - if pc and(ssShift in e.shiftstate)then - begin - pc.SetFocus(); - break; - end - continue; - end - pc := ci; - if Thec then - begin - ci.SetFocus(); - break; - end - end - end - end - end - return KeyDown(o,e); - end - function WMKEYUP(o,e):WM_KEYUP;virtual; - begin - CallMessgeFunction(FOnKeyUp,o,e); - keyup(o,e); - end - function WMCHAR(o,e):WM_CHAR;virtual; - begin - CallMessgeFunction(FOnKeyPress,o,e); - return keypress(o,e); - end - function WMSETFOCUS(o,e):WM_SETFOCUS;virtual; - begin - CallMessgeFunction(FonSetFocus,o,e); - dosetfocus(o,e); - end - function WMKILLFOCUS(o,e):WM_KILLFOCUS;virtual; - begin - CallMessgeFunction(FonKillFocus,o,e); - dokillfocus(o,e); - end - function WMPAINT(O,e):LM_PAINT;virtual; - begin - hd := e.hwnd; - if e.wparam then - begin - PaintHandler(e); - end else - if csCustomPaint in ControlState then - begin - ps := PaintStruct(); - DC := _wapi.BeginPaint(hd,ps._getptr_); - if DC=0 then exit; - try - c := ClientRect; - memdc := dc; -{$ifdef gdipaint} - mdc := _wapi.GetDC(0); - if not mdc then exit; - mbit := _wapi.CreateCompatibleBitmap(mdc,c[2],c[3]); - if not mbit then exit; - memdc := _wapi.CreateCompatibleDC(0); - if not memdc then exit; - oldmp := _wapi.SelectObject(memdc,mbit); -{$endif} - e.wparam := memdc; - if Color then - begin - Dispatch(o,new tuieventbase(LM_ERASEBKGND,memdc,2)); - end - Dispatch(o,e); - e.wparam := 0; - rc := ps.rcpaint; -{$ifdef gdipaint} - _wapi.BitBlt(dc,rc[0],rc[1],rc[2]-rc[0],rc[3]-rc[1],memdc,rc[0],rc[1],SRCCOPY); //_wapi.BitBlt(dc,c[0],c[1],c[2],c[3],memdc,0,0,SRCCOPY); -{$endif} - finally - _wapi.EndPaint(hd,ps._getptr_); -{$ifdef gdipaint} - _wapi.ReleaseDC(0,mdc); - _wapi.SelectObject(memdc,oldmp); - _wapi.DeleteDC(memdc); - _wapi.DeleteObject(mbit); -{$endif} - end - end else - begin -{$ifdef gdipaint} - ctls := Controls; - if not ctls then return; // e.skip := false; - if ctls.Count<1 then return; // e.skip := false ; - flag := true; - for i := 0 to ctls.Count-1 do - begin - ci := ctls[i]; - if ci is class(TGraphicControl)then - begin - flag := false; - break; - end - end - if flag then - begin - return; - end - rec := zeros(4); - _wapi.GetUpdateRect(hd,rec,false); - defaulthandler(e); - dc := _wapi.GetDC(hd); - if not dc then - begin - return e.skip := true; - end - e.wparam := dc; - try - pts := PaintStruct(); - pts._setvalue_("rcpaint",rec); - pts._setvalue_("hdc",dc); - //Perform(e); - Dispatch(o,e); - finally - _wapi.ReleaseDC(hd,dc); - e.wparam := 0; - e.skip := true; - end -{$endif} - end - e.skip := true; - e.result := true; - end - -#!end - function KeyUp(o,e);virtual; - begin - {** - @explan(说明) key 松开 %% - @param(o)(TWinControl) 控件自身 %% - @Param(e)(TMKEY) 消息对象 %% - **} - end - function KeyDown(o,e);virtual; - begin - {** - @explan(说明) key 按下 %% - @param(o)(TWinControl) 控件自身 %% - @Param(e)(TMKEY) 消息对象 %% - **} - end - function keypress(o,e);virtual; - begin - {** - @explan(说明) char 消息处理 %% - @param(o)(TWinControl) 控件自身 %% - @Param(e)(TMKEY) 消息对象 %% - **} - end - function dosetfocus(o,e);virtual; - begin - {** - @explan(说明) 控件获得焦点 %% - @param(o)(TWinControl) 控件自身 %% - @Param(e)(tuieventbase) 消息对象 %% - **} - end - function dokillfocus(o,e);virtual; - begin - {** - @explan(说明) 控件失去焦点 %% - @param(o)(TWinControl) 控件自身 %% - @Param(e)(tuieventbase) 消息对象 %% - **} - end - protected //样式相关 - function SetColor(v);override; - begin - oc := color; - if oc <> v and ifnumber(v)then - begin - inherited; - if HandleAllocated()then invalidaterect(nil,false); - end - end - function SetBitmap(v);override; - begin - if v <> BKBitmap then - begin - inherited; - if HandleAllocated()then invalidaterect(nil,false); - end - end - function Refresh(); - begin - if HandleAllocated()then - begin - _wapi.SetWindowPos(self.Handle,0,0,0,0,0,SWP_DEFERERASE .| SWP_NOMOVE .| SWP_NOSIZE .| SWP_NOZORDER .| SWP_NOSENDCHANGING .| SWP_NOACTIVATE .| SWP_DRAWFRAME); - end - end - procedure PaintControls(DC:HDC;First:TControl); //type_twinctrol - begin - end - procedure PaintHandler(var TheMessage:TLMPaint); //type_twinctrol - begin - PaintWindow(TheMessage.wparam); - //c := ClientRect; - c := array(0,0); //设置基准点,为00 20201112 修改 - rcpaint := PaintStruct().rcpaint; - if sum(rcpaint)<4 then exit; - rgC := _wapi.CreateRectRgn(0,0,10,10); - rga := _wapi.CreateRectRgn(rcpaint[0],rcpaint[1],rcpaint[2],rcpaint[3]); - try - for i := 0 to ControlCount-1 do - begin - it := FControls[i]; - if it is class(TGraphicControl)then - begin - if not(it.Visible)then continue; - itbounds := it.GetBoundsRect(); - if not(intersectrect(itbounds,rcpaint,outrect))then - begin - continue; - end - //rgb := _wapi.CreateRectRgn(itbounds[0],itbounds[1],itbounds[2],itbounds[3]); //控件区域 - rgb := _wapi.CreateRectRgn(outrect[0],outrect[1],outrect[2],outrect[3]); //控件区域 - _wapi.CombineRgn(rgC,rga,rgb,RGN_AND); //控件绘画区域 - bkrg := _wapi.SelectClipRgn(TheMessage.wparam,rgc); //裁剪区域 - try - pts := it.PaintStruct(); - pts._setvalue_("rcpaint",array(outrect[0]-itbounds[0],outrect[1]-itbounds[1],outrect[2]-itbounds[0],outrect[3]-itbounds[1])); - pts._setvalue_("hdc",TheMessage.wparam); - ne := new tuieventbase(LM_PAINT,TheMessage.wparam,TheMessage.lparam,TheMessage.hwnd); - it.Perform(ne); - _wapi.SetViewportOrgEx(TheMessage.wparam,c[0],c[1],nil); //恢复基准点 - finally - _wapi.SelectClipRgn(TheMessage.wparam,bkrg); //恢复区域 - _wapi.DeleteObject(rgb); //销毁区域 - end; - end - end - finally - _wapi.DeleteObject(rga); - _wapi.DeleteObject(rgc); - end; - end - procedure PaintWindow(DC:HDC);virtual; - begin - end - function SetTempCursor(Value);override; - begin - if(Value is class(tcursor))and Value.HandleAllocated()and HandleAllocated()and Enabled and Visible then - begin - return Value.Show(); - end - end - //public - function wstyle(v); - begin - { - @explan(说明)设置或者获取样式 %% - @param(v)(integer)为空获取样式,为整数 设置样式%% - @return(integer)当前样式 - } - if v and ifnumber(v)then - begin - if(v <> __wstyle)and HandleAllocated()then _wapi.SetWindowLongPtrA(FHandle,GWL_STYLE,v); - end else - return __wstyle; - end - function wexstyle(v); - begin - { - @explan(说明)设置或者获取扩展样式 %% - @param(v)(integer)为空获取样式,为整数 设置样式%% - @return(integer)当前扩展样式 - } - if v and ifnumber(v)then - begin - if(v <> __wexstyle)and HandleAllocated()then _wapi.SetWindowLongPtrA(FHandle,GWL_EXSTYLE,v); - end else - return __wexstyle; - end - function minuswstyle(v); - begin - { - @explan(说明)剔除样式 %% - @param(v)(integer) 剔除的样式 %% - } - if ifnumber(v)then - begin - s := wstyle(); - ns := bitcombination(s,v,2); - if ns <> s then - begin - wstyle(ns); - end - end - end - function appendwstyle(v); - begin - { - @explan(说明)在原有样式中追加 样式%% - @param(v)(integer) 追加的样式 %% - } - if ifnumber(v)then - begin - s := wstyle(); - ns := bitcombination(s,v,0); - if ns <> s then - begin - wstyle(ns); - end - end - end - function minuswexstyle(v); - begin - { - @explan(说明)剔除扩展样式 %% - @param(v)(integer) 剔除的样式 %% - } - if ifnumber(v)then - begin - s := wexstyle(); - ns := bitcombination(s,v,2); - if ns <> s then - begin - wexstyle(ns); - end - end - end - function appendminuswstyple(ap,mi); - begin - { - @explan(说明)添加and剔除样式 %% - @param(ap)(integer) 添加的样式 %% - @param(mi)(integer) 剔除的样式 %% - } - if ifnumber(ap)or ifnumber(mi)then - begin - s := wstyle(); - ns := s; - if ifnumber(ap)then ns := bitcombination(ns,ap,0); - if ifnumber(mi)then ns := bitcombination(ns,mi,2); - if ns <> s then - begin - wstyle(ns); - end - end - end - - function appendminuswexstyple(ap,mi); - begin - { - @explan(说明)添加and剔除样式 %% - @param(ap)(integer) 添加的样式 %% - @param(mi)(integer) 剔除的样式 %% - } - if ifnumber(ap)or ifnumber(mi)then - begin - s := wexstyle(); - ns := s; - if ifnumber(ap)then ns := bitcombination(ns,ap,0); - if ifnumber(mi)then ns := bitcombination(ns,mi,2); - if ns <> s then - begin - wexstyle(ns); - end - end - end - function appendwexstyle(v); - begin - { - @explan(说明)在原有扩展样式中追加 样式%% - @param(v)(integer) 追加的样式 %% - } - if ifnumber(v)then - begin - s := wexstyle(); - ns := bitcombination(s,v,0); - if ns <> s then - begin - wexstyle(ns); - end - end - end - public //常用接口 - function MonitorHandle(); - begin - if HandleAllocated()then - begin - return _wapi.MonitorFromWindow(self.Handle,MONITOR_DEFAULTTONEAREST); - end - return 0; - end - function clienttowindow(x,y); - begin - {** - @explan(说明) 客户区坐标到窗口坐标的转换%% - **} - if WsPopUp and HandleAllocated()then - begin - xy := clienttoscreen(0,0); - rect := zeros(4); - _wapi.GetWindowRect(self.Handle,rect); - nxy := xy-rect[0:1]; - r := array(x,y)+nxy; - return r; - end - return array(x,y); - end - function ClientToScreen(x,y);override; - begin - ps := array(x,y); - if HandleAllocated()then - begin - _wapi.ClientToScreen(self.Handle,ps); - end - return ps; - end - function ScreenToClient(x,y);override; - begin - ps := array(x,y); - if HandleAllocated()then - begin - _wapi.ScreenToClient(self.Handle,ps); - end - return ps; - end - function show(sw); - begin - {** - @explan(说明) 显示窗口 %% - @param(sw)(nil) 空 %% - **} - if ifnil(sw)then sw := SW_SHOW; - if not(sw >= 0)then return; - h := self.Handle; - if SW=SW_SHOW then return Visible := true; - if SW=SW_HIDE then return Visible := false; - _wapi.ShowWindow(h,sw); - class(TControl).Visible := true; - end -function showmodal();virtual; -begin - return DoModal(); -end - function EndModal(endc);virtual; - begin - {** - @explan(说明)关闭模态窗口 %% - @param(endc)(any) 为非nil 将作为EndModalCode %% - **} - if not ifnil(endc)then EndModalCode := endc; -{$ifdef gtkpaint} - if FModaling then - begin - if HandleAllocated()then _wapi.gtk_window_endmodal(self(true)); - FModaling := false; - ExitMessageLoop(); - end - return EndModalCode; -{$endif} - if not FModaling then return EndModalCode; - FModaling := FALSE; - if not HandleAllocated()then return EndModalCode; - _wapi.PostMessageA(0,0,0,0); - if Parent and Parent.HandleAllocated()then - begin - hParentWndt := parent.Handle; - hParentWnd := hParentWndt; - while(hParentWnd) do - begin - hParentWndt := _wapi.GetParent(hParentWnd); - if not hParentWndt then - begin - _wapi.BringWindowToTop(hParentWnd); - end - hParentWnd := hParentWndt; - end - end - return EndModalCode; - end - function UpdateWindow(); - begin - {** - @explan(说明) 刷新窗口客户区 %% - @return(integer) 非0 成功 %% - **} - if HandleAllocated()then return _wapi.UpdateWindow(self.Handle); - end - function SetFocus(); - begin - if HandleAllocated()then - begin - _wapi.SetFocus(self.Handle); - end - end - function DescendantHwnd(hwnd); - begin - { - @explan(说明)判断窗口句柄是否为当前窗口句柄的子窗口 %% - } - if not _wapi.IsWindow(hwnd)then return 0; - if not HandleAllocated()then return 0; - shd := self.Handle; - wnd := hwnd; - while wnd do - begin - if wnd=shd then return true; - nwnd := _wapi.GetParent(wnd); - wnd := nwnd; - end - return false; - end - function MoveControlOrder(Acomponent,n); - begin - {** - - @explan(说明) 移动控件的层 %% - @param(Acomponent)(tcontrol) 控件 %% - @param(n)(integer) 次序 %% - **} - dqid := FControls.IndexOf(Acomponent); - odp := FControls[n]; - if n <> dqid and n >= 0 then - begin - FControls.setorder(dqid,n); - end - if odp is class(TWincontrol)and Acomponent is class(TWincontrol)and(Acomponent.HandleAllocated())and(odp.HandleAllocated())then - begin - _wapi.SetWindowPos(Acomponent.Handle,odp.Handle,0,0,0,0,SWP_NOMOVE .| SWP_NOSIZE); - end - if HandleAllocated()and(Acomponent.Align <> alNone)then - begin - DoControlAlign(); - end - end - function BeginUpDate(); - begin - FUpDateCount++; - end - function IsUpDating(); - begin - return FUpDateCount; - end - function EndUpDate(); - begin - if FUpDateCount>0 then - begin - FUpDateCount--; - DoEndUpDate(); - end - end - function DoEndUpDate();virtual; - begin - if FUpDateCount=0 then - begin - if FPaintRects then - begin - if HandleAllocated()then - begin - ValidFlag := true; - for i,v in FPaintRects do - begin - if ifnil(v)then - begin - _wapi.InvalidateRect2(FHandle,nil,0); - ValidFlag := false; - break; - end - end - if ValidFlag then - begin - for i,v in FPaintRects do - begin - _wapi.InvalidateRect(FHandle,v,f); - end - end - end - FPaintRects := array(); - end - end - end - function InvalidateRect(rec,f);virtual; - begin - {** - @explan(说明)设置窗口区域无效 %% - @param(rec)(array) 无效区域,nil表示窗口整体无效,array(左上右下) %% - @param(f)(bool) 是否重画 %% - **} - if HandleAllocated()then - begin - if IsUpDating()then - begin - if not ifarray(FPaintRects)then FPaintRects := array(); - FPaintRects[length(FPaintRects)]:= rec; - return; - end - if not(ifarray(rec)and rec)then r := _wapi.InvalidateRect2(FHandle,nil,f); - else r := _wapi.InvalidateRect(FHandle,rec,f); - return r; - end - end - function ContainsControl(Control:TControl):bool; - begin - while(Control <> nil)and(Control <> Self) do Control := Control.Parent; - return Control=Self; - end - function create(owner);override; //type_twinctrol - begin - inherited; - FUpDateCount := 0; - FTabStop := false; - FControls := new TFpList(); - FBorderStyle := bsNone; - //FTRACKMOUSEEVENT := NEW TTRACKMOUSEEVENT(); - FWsPopUp := false; - FWsSysMenu := false; - FWsCapton := false; - WSSizebox := FALSE; - __wstyle := 0; //窗口样式 - __wexstyle := 0; //窗口扩展样式 - FWsDlgModalFrame := false; - //FTtageDrawItem := new TtageDrawItem(); //移除了 - FWMNCHITTEST := new TWMNCHITTEST(); - FMinWidth := 1; //添加最小限制 - FMinHeigt := 1; - end - function destroy();override; //type_twinctrol - begin - inherited; - end - function Recycling();override; - begin - DestroyHandle(); - //FTtageDrawItem := nil; - FOnClose := nil; - FOnDesinedsel := nil; - FOnDesigDBLClick := nil; - FOnDesinedRclick := nil; - FOnDesignBeginMove := nil; - FOnDesignEndMove := nil; - FOnActivate := nil; - FOnKeyDown := nil; - FOnKeyPress := nil; - FOnKeyUp := nil; - ImageList := nil; - FonSetFocus := nil; - FonKillFocus := nil; - inherited; - end - function RecreateWnd();virtual; - begin - if csDestroying in ComponentState then exit; - if HandleAllocated()then - begin - DestroyHandle(); - HandleNeeded(); - end - end - function CreateWnd();virtual; //type_twinctrol - begin - {** - @explan(说明)构建窗口句柄 %% - **} - //if not(Parent and Parent.HandleAllocated or (self(true) is class(tapplicationwindow))) then exit; - CreateParams(p); - //_wapi.GetSystemMetrics(SM_CXSCREEN) DIV 2; - //此处处理构造句柄 - id := 0; - if p.style .& WS_CHILD then id := getid(); - tcc := p.Caption; - stl := p.style; - x := p.x; - y := p.y; - sx := p.width; - sy := p.height; - try - selfid := int64(self(true)); - except - selfid := gettslvariableptr(self(true)); - end; - saveobj := new TGlobalValues(selfid,self(true)); - createwndclass(p); - FDefWndproc := p.subclasswndproc; - tcn := P.WinClassName; - f := _wapi.CreateWindowExA(p.ExStyle,tcn,tcc,stl,x,y,sx,sy,p.WndParent,id,p.happ,selfid); - InitializeWnd(); - if HandleAllocated()then ControlCreateWnd(); - end - protected - function ControlCreateWnd(); - begin - for i := 0 to FControls.count-1 do - begin - item := FControls.geti(i); - if(item is class(TWinControl))then - begin - item.HandleNeeded(); - end - end - end - public - function HandleAllocated(); //type_twinctrol - begin - {** - @explan(说明)构建窗口句柄是否构造 %% - @param(bool) - **} - //return ifnumber(FHandle) and _wapi.IsWindow(FHandle); - return ifnumber(FHandle)and(FHandle <> 0); - end; - function DestroyHandle();virtual; - begin - {** - @explan(说明)析构窗口句柄 %% - **} - EndModal(); - if HandleAllocated()then - begin - {FTRACKMOUSEEVENT.hwndtrack := handle; - if OnMouseEnter or OnMouseLeave then - begin - FTRACKMOUSEEVENT.dwflags := TME_CANCEL .| TME_HOVER .| TME_LEAVE; - _wapi.TrackMouseEvent(FTRACKMOUSEEVENT._getptr_); - end } - _wapi.DestroyWindow(self.Handle); - end - FHandle := 0; - end - procedure HandleNeeded();virtual; //type_twinctrol - begin - {** - @explan(说明)构建窗口句柄,以及子控件句柄 %% - @return(pointer) 窗口句柄 - **} - {if (not HandleAllocated()) then - begin - if self.Parent = Self then - begin - - end - else begin - if (Parent is class(TWinControl)) then - begin - Parent.HandleNeeded(); - if HandleAllocated() then exit; - end; - end; - CreateHandle(); - end; } - if(not HandleAllocated())and(not(csDestroying in ComponentState))then - begin - if self.Parent=Self then - begin - end else - begin - if {(Parent <> nil)}(Parent is class(TWinControl))then - begin - Parent.HandleNeeded(); - if HandleAllocated()then exit; - end; - end; - CreateHandle(); - end; - end - function SetParent(NewParent);override; //type_twinctrol - begin - if(NewParent=parent)and(NewParent is class(TWinControl))then //避免wrapcontrol句柄发生改变的问题 - begin - if HandleAllocated()and NewParent.HandleAllocated()then - begin - if _wapi.GetParent(self.Handle)=NewParent.Handle then return; - end - end - if NewParent is class(TWinControl)then - begin - //if not CheckNewParent(NewParent) then return ; - //都有句柄 - callparent := false; - callalocate := false; - if HandleAllocated()and NewParent.HandleAllocated()then - begin - if WsPopUp then - begin - DestroyHandle(); - callalocate := true; - end else - if _wapi.SetParent(FHandle,NewParent.handle)then callparent := true; - end else - if HandleAllocated()and not(NewParent.HandleAllocated())then - begin - DestroyHandle(); - callparent := true; - end else - if not(HandleAllocated())and NewParent.HandleAllocated()then - begin - callparent := true; - callalocate := true; - end else - begin - callparent := true; - end - if callparent then - begin - class(tcontrol).SetParent(NewParent); - if Align <> alNone then - begin - NewParent.DoControlAlign(); - end - end - if callalocate then HandleNeeded(); - end else - begin - if HandleAllocated()then DestroyHandle(); - inherited SetParent(NewParent); - end - end - procedure SetBounds(ALeft,ATop,AWidth,AHeight:integer);override; //type_twinctrol - begin - {** - @explan(说明)设置窗口矩形区域 %% - **} - //设置bonds - OldBounds := BoundsRect; - OldBounds := array(OldBounds[0],OldBounds[1],OldBounds[2]-OldBounds[0],OldBounds[3]-OldBounds[1]); - newbounds := array(ALeft,ATop,AWidth,AHeight); - if not(CompareRect(OldBounds,newbounds))then - begin - inherited; - //class(tcontrol).SetBounds(ALeft, ATop, AWidth, AHeight); - end - end - private //绘制相关成员 - FPaintRects; - FUpDateCount; - public - function gethitstyle(x,y); - begin - return FWMNCHITTEST.hitstyle2(self(true),x,y); - end - public //消息分发 - function MainWndProc(hwnd,message,wparam,lparam);virtual; //type_twinctrol - begin - {** - @explan(说明)窗口主循环 %% - **} - //if message=0x85 and not( WsCaption or border or WsDlgModalFrame) then return ; - e := messagecreater(hwnd,message,wparam,lparam); - e.sender := self(true); - if message = WM_SYSKEYDOWN or message = WM_KEYDOWN then //快捷键实现 - begin - WndProc(const e); - if e.skip then return 1; - ////////////解析热键///////////////////// - ec := e.CharCode; - sa := array(); - if ec>=65 and ec<=90 then - begin - sa["w"] := chr(ec); - end - if ec>=0x70 and ec<=0x7b then - begin - sa["f"] := "F"+inttostr(ec-0x6F); - end - st := e.shiftstate; - if ssCtrl in st then sa["c"] := 1; - if ssAlt in st then sa["a"] := 1; - if ssShift in st then sa["s"] := 1; - if sa["w"] and (sa["c"] or sa["a"] or sa["s"]) then - begin - st := sa; - end else - if sa["f"] then - begin - st := sa; - end else - st := array(); - - if st then - begin - st := formatshortcut(st); - if st then - begin - if dispatchctlshortcut(self(true),st)= "havedoshortcut" then return 1; //执行本控件 - if dispatchshortcut(getapplication(),st) = "havedoshortcut" then - begin - return 1; - end - end - end - //热键处理完成 - return defaulthandler(e); - end - if message=WM_NCCREATE then - begin - FHandle := hwnd; - //echo "\r\nsethandle:",hwnd; - class(TGlobalComponentcache).registerhandle(hwnd,self(true)); - end else - if message=WM_SIZE then - begin - x := e.lolparamsigned(); - if x <> 0 then - begin - //dxsize := x-FClientWdith; - cc := 0; - if FClientWdith <> x then - begin - FClientWdith := x; - cc := true; - end - y := e.hilparamsigned(); - //dysize := y-FClientHeight; - if FClientHeight <> y then - begin - FClientHeight := y; - //cc := true; - end - if true then - begin - DoControlAnchor(); - DoControlAlign(); - end - end - end else - if message=WM_MOVE then - begin - x := e.lolparamsigned(); - if FClientLeft <> x then FClientLeft := x; - y := e.hilparamsigned(); - if FClientTop <> y then FClientTop := y; - end else - //if message = WM_MOUSEMOVE then - if message=WM_NCHITTEST then // - begin - {if OnMouseEnter or OnMouseLeave then - begin - FTRACKMOUSEEVENT.hwndtrack := hwnd; - FTRACKMOUSEEVENT.dwflags := TME_HOVER .| TME_LEAVE; - FTRACKMOUSEEVENT.dwhovertime := 600; - _wapi.TrackMouseEvent(FTRACKMOUSEEVENT._getptr_); - end } - end else - if message=WM_STYLECHANGED then - begin - if e.wparam=GWL_EXSTYLE then - begin - __wexstyle := e.stylenew; - end else - begin - __wstyle := e.stylenew; - end - end - (**else - if message = WM_NCCALCSIZE then - begin - if e.wparam=1 then - begin - dt := new tNCCALCSIZE_PARAMS(e.lparam)._getvalue_("rgrc"); - if dt[0]=-32000 then - begin - //echo "\r\n隐藏到工具栏"; - end - else if dt[4] = -32000 then - begin - //echo "\r\n从工具栏弹出"; - end - else - begin - //rect1 := dt[0:3]; - //rect2 := dt[4:7]; - //rect3 := dt[8:]; - {dx := dt[2]-dt[0]-(dt[6]-dt[4]); - dy := dt[3]-dt[1]-(dt[7]-dt[5]); - __clientsize := array(dt[10]-dt[8]+dx,dt[11]-dt[9]+dy); - x := __clientsize[0]; - dxsize := x-FClientWdith; - if FClientWdith<> x then FClientWdith := x; - y := __clientsize[1]; - dysize := y-FClientHeight; - if FClientHeight <> y then FClientHeight := y; - DoControlAnchor(array(dxsize,dysize)); - DoControlAlign(array(0,0,x,y));} - //__oldclientsize := array(dt[10]-dt[8],dt[11]-dt[9]); - end - - end - else - begin - //echo "\r\n++++calc:",caption,tostn(new tcrect(e.lparam)._getdata_); - end - //echo "\r\ncalcsize:",o.caption,"****",e.wparam; - //echo "\r\nleft:", new tcrect(e.lparam).left; - end - **) - WndProc(const e); - if not(e.skip)then - begin - ret := defaulthandler(e); - end else - begin - {$ifdef linuxgtk} - if WM_NCHITTEST=e.msg then return e.Result; - return true; - {$endif} - ret := e.Result; - end - return ret; - end - function DesigningSizer();virtual; - begin - {** - @explan(说明) 设计模式下面是否可以调整大小 %% - @return(bool) - **} - return true; - end - function DesigningClick();virtual; - begin - {** - @explan(说明) 设计模式下面是否可以响应原有的点击消息 %% - @return(bool) - **} - return false; - end - function DesigningMove();virtual; - begin - {** - @explan(说明) 设计模式下面是否可以移动 %% - @return(bool) - **} - return true; - end - function HitWindowborder(o,e,hit);virtual; - begin - if not(WsSizeBox)and DesigningSizer()and(Align=alNone)then - begin - e.Result := hit; - e.skip := true; - end - end - private //设计器相关,消息 - FClickTime; - FClickPos; - public //消息分发 - procedure WndProc(e);override; //type_twinctrol - begin - //WM_NCHITTEST - if (csDesigning in ComponentState) then - begin - msg := e.msg; - if msg = WM_NCHITTEST then - begin - - r := FWMNCHITTEST.hitstyle(self(true),e); - if r<>HTCLIENT then - begin - HitWindowborder(self(true),e,r); - end else - begin - return e.Result := Wnddefaulthandler(e); - end - end else - if msg= WM_LBUTTONDOWN then - begin - if not(WsCaption) and DesigningMove() and (Align=alNone) then - begin - _Send_(WM_NCLBUTTONDOWN,HTCAPTION,0,0); - e.skip := true; - end - CallMessgeFunction(OnDesignClick,self(true),e); - //保留原有的点击消息 - {if DesigningClick() then - begin - CallMessgeFunction(FOnMouseUp,self(true),e); - end } - end else - if msg = WM_LBUTTONDBLCLK then - begin - CallMessgeFunction(OnDesignDBLClick,self(true),e); - end else - if msg = WM_RBUTTONDOWN then - begin - CallMessgeFunction(OnDesignRClick,self(true),e); - end - end - inherited; - end; - procedure DoControlAlign({rect});override; - begin - {** - @explan(说明) 控件对齐 %% - **} - if not HandleAllocated()then exit; - if not ifarray(rect)then - begin - rect := ClientRect; - {$ifdef linuxgtk} - if Border or WSSizebox or WSDlgModalFrame then //处理gtk的情况 - begin - rect[0]+=1; - rect[1]+=1; - rect[2]-=1; - rect[3]-=1; - end - {$endif} - end - e := new TMALIGN(CN_ALIGN,0,0,0); - E.left := rect[0]; - e.top := rect[1]; - e.width := rect[2]; - e.height := rect[3]; - for i := 0 to ControlCount-1 do - begin - it := Controls[i]; - if it is class(tcontrol)then - begin - //if it.Align=alNone then continue; - it.Dispatch(it,e); - //it.Perform(e); - end - end - end - procedure DoControlAnchor();override; - begin - {** - @explan(说明) 控件锚定调整 %% - **} - if not HandleAllocated()then exit; - e := new TMANCHOR(CN_ANCHOR,0,0,0); - c := ClientRect; - for i := 0 to ControlCount-1 do - begin - it := Controls[i]; - if not it then continue; - if it.Align <> alNone then continue; - if not ifarray(it.Anchors)then continue; - if it is class(TWinControl)then - begin - if it.WsPopUp then continue; - end - e.prec := c; - it.Dispatch(it,e); - end - end - function Wnddefaulthandler(e); //type_twinctrol - begin - {** - @explan(说明)win32默认消息处理函数 %% - @param(e)(tuieventbase) - **} - r := _wapi.CallWindowProcA(FDefaultProc,e.Hwnd,e.msg,e.wparam,e.lparam); - e.skip := true; - return r; - end - function defaulthandler(e);override; - begin - {** - @explan(说明) 执行默认句柄 %% - @param(e)(tuieventbase) - **} - r := _wapi.CallWindowProcA(FDefWndproc,e.Hwnd,e.msg,e.wparam,e.lparam); - e.skip := true; - return r; - end - procedure BroadCast(e); - begin - {** - @explan(说明) 广播消息 %% - @param(e)(tuieventbase) - **} - for I := 0 to ControlCount-1 do - begin - Controls[I].WindowProc(e); - if e.skip then Exit; - if not ifnil(e.Result)then Exit; - end; - end; - procedure NotifyControls(Msg); //type_twinctrol - begin - ToAllMessage := new tuieventbase(msg,0,0,0); - Broadcast(ToAllMessage); - end - function _send_(msg,wparam,lparam,f,d);virtual; //type_twinctrol - begin - {** - @explan(说明) 发送消息给窗口 %% - @param(msg)(integer)消息号 %% - @param(wparam)(integer)wparam %% - @param(lparam)(integer)lparam %% - @param(param)(bool) true 采用post false 采用send %% - @return(pointer) - - **} - if not(ifnumber(msg)and ifnumber(wparam)and ifnumber(lparam))then - begin - //messagebox("参数必须为数字,如果字符串参数,请用tslcstructre构造然后传入指针!","提示",1); - exit; - end - if HandleAllocated()then - begin - if f then - begin - return _wapi.PostMessageA(FHandle,msg,wparam,lparam {$ifdef linux},d {$endif}); - end else - begin - return _wapi.SendMessageA(FHandle,msg,wparam,lparam); - end - end else - begin - e := messagecreater(nil,msg,wparam,lparam); - Perform(e); - return e.result; - end - end - function setwndhandle(h); - begin - {** - @ignore 忽略 %% - **} - DestroyHandle(); - if _wapi.IsWindow(h)then - begin - ph := _wapi.SetWindowLongPtrA(h,_wapi.GWLP_WNDPROC,getwinprocptr()); - FDefWndproc := ph; - MainWndProc(h,WM_NCCREATE,0,0); - end - end - public //对外property - property MinWidth:natural read FMinWidth write SetMinWidth; - property MinHeight:natural read FMinHeigt write SetMinHeight; - //property MaxWidth:integer read FMaxWidth write SetMaxWidth; - //property MaxHeight:integer read FMaXHeight write SetMaxHeight; - property BorderStyle read GetBorderStyle write SetBorderStyle; - //property ParentWindow read FParentWindow write SetParentWindow; - property Handle read GetHandle write SetHandle; - property TabStop:bool read FTabStop write SetTabStop; - property ControlCount read GetControlCount; - property OnActivate:eventhandler read FOnActivate write FOnActivate; - property OnClose:eventhandler read FOnClose write FOnClose; - property OnKeyDown:eventhandler read FOnKeyDown write FOnKeyDown; - property OnKeyUp:eventhandler read FOnKeyUp write FOnKeyUp; - property OnKeyPress:eventhandler read FOnKeyPress write FOnKeyPress; - property OnDesignClick read FOnDesinedsel write FOnDesinedsel; - property OnDesignDBLClick read FOnDesigDBLClick write FOnDesigDBLClick; - property OnDesignRClick read FOnDesinedRclick write FOnDesinedRclick; - property WsPopUp:bool read GetWsPopUp write SetWsPopUp; - property WsDlgModalFrame:bool read FWsDlgModalFrame write SetWsDlgModalFrame; - property WsCaption:bool read GetWsCaption write SetWsCaption; - Property WSSizebox:bool read FWsSizeBox Write SetWSsizeBox; - property WSsysMenu:bool read FWsSysMenu write SetWsSysMenu; - property EndModalCode read FModalCode write FModalCode; - property ImageList:tcontrolimagelist read FImageList write SetImageList; - property onKillFocus:eventhandler read FonKillFocus write FonKillFocus; - property onSetFocus:eventhandler read FonSetFocus write fonSetFocus; - private //模态相关 - property Modaling read FModaling; - {** - @param(BorderStyle)(bsNone|bsSingle) 边框样式 %% - @param(Handle)(pointer) 窗口句柄 %% - @param(WsDlgModalFrame)(bool) dlg边框效果 %% - @param(ControlCount)(integer) 子控件数量 %% - @param(OnClose)(function[TWincontrol,tuieventbase]) 窗口关闭消息回调 %% - @param(OnKeyDown)(function[TWincontrol,TMKEY]) 按键按下回调 %% - @param(OnKeyUp)(function[TWincontrol,TMKEY]) 按键松开 %% - @param(OnKeyPress)(function[TWincontrol,TMKEY]) 字符消息 %% - **} -end type TSysControl=class(TWincontrol) {** @explan(说明) 系统绘制窗口,屏蔽绘制和背景处理,加快速度 %% @@ -11573,7 +747,7 @@ type TWinControlWraper=class(TWinControl) begin if oh then begin - WMNCDESTROY(self(true),new tsluibase(0,0,0,0)); + WMNCDESTROY(self(true),new tuieventbase(0,0,0,0)); end _wapi.GetWindowInfo(h,FWindowInfo._getptr_); rc := FWindowInfo.rcwindow; @@ -11583,7 +757,7 @@ type TWinControlWraper=class(TWinControl) FHeight := rc[3]-rc[1]; old := _wapi.SetWindowLongPtrA(h,GWLP_WNDPROC,getwinprocptr()); FDefWndproc := old; - class(TGlobalComponentcache).registerhandle(h,self(true)); + class(tUIglobalData).uigetdata("TGlobalComponentcache").registerhandle(h,self(true)); Handle := h; end end @@ -11599,7 +773,7 @@ type TWinControlWraper=class(TWinControl) begin h := Handle; _wapi.SetWindowLongPtrA(h,GWLP_WNDPROC,FDefWndproc); - class(TGlobalComponentcache).unregisterhandle(h); + class(tUIglobalData).uigetdata("TGlobalComponentcache").unregisterhandle(h); end inherited; end @@ -11626,441 +800,7 @@ type TWinControlWraper=class(TWinControl) **} end end -type TCustomControl=class(TWinControl) - {** - @explan(说明) 自绘制窗口控件 %% - **} - private - FOnPaint:TNotifyEvent; - protected - procedure PaintWindow(DC:HDC);override; - begin - //odh := canvas.Handle; - Canvas.Handle := dc; - Canvas.ClipRect := PAINTSTRUCT().rcpaint(); - try - Paint(); - finally - Canvas.Handle := odh; - end; - end - procedure Paint();override; - begin - inherited; - if datatype(FOnPaint)=7 then call(FOnPaint,self(true)); - end - public - function Create(AOwner:TComponent);override; - begin - inherited; - includestate(FControlState,csCustomPaint); - //FCanvas := new tcanvas(); - end - function CreateParams(p);override; - begin - inherited; - //p.style .|= WS_CLIPSIBLINGS .| WS_CLIPCHILDREN; - end - function Recycling();override; - begin - FOnPaint := nil; - inherited; - end - function DoVScroll(o,e);virtual; - begin - end - function DoHScroll(o,e);virtual; - begin - end - public - function WMVScroll(o,e):LM_VScroll;virtual; - begin - return DoVScroll(o,e); - end - function WMHScroll(o,e):LM_HSCROLL;virtual; - begin - return DoHScroll(o,e); - end - property OnPaint:eventhandler read FOnPaint write FOnPaint; - {** - @param(OnPaint)(function[TCustomControl,tuieventbase]) 窗口关闭消息回调 %% - **} -end; - -type TCustomScrollControl = class(TCustomControl) - {** - @explan(说明) 带滚动条的自绘制窗口 %% - **} - private - FLocalX;//水平基准 - FLocalXold; - FLocalY;//垂直基准 - FLocalYold; - FSI; //滚动条结构 - FAutoScroll; //自动滚动条 - FThumbTrack; //thunmtrack - FWhileStep ;//滚动步长 - function SetAutoScroll(v); - begin - if(v in array(0,1,2,3))and v <> FAutoScroll then - begin - FAutoScroll := v; - InitialScroll(); - end - end - function SetWhileStep(v); - begin - if not v>=1 then return ; - nv := integer(v); - if FWhileStep=nv then return ; - FWhileStep := nv; - end - protected - function GetXScrollDelta();virtual; //x间隔 - begin - {** - @explan(说明) 获得x间隔 %% - **} - return 10; - end - function GetYScrollDelta();virtual; //y 间隔 - begin - {** - @explan(说明) 获得y间隔 %% - **} - return 10; - end - function GetClientXCapacity();virtual; //宽度容量 - begin - {** - @explan(说明) 客户区x容量 %% - **} - return 0; - end - function GetClientYCapacity();virtual; //高度容量 - begin - {** - @explan(说明) 客户区y容量 %% - **} - return 0; //integer((yClient) / FDeltaY); - end - function GetClientXCount();virtual; //宽度间隔 - begin - {** - @explan(说明) 客户区x数量 %% - **} - return 0; - end - function GetClientYCount();virtual; //高度项 - begin - {** - @explan(说明) 客户区y数量 %% - **} - return 0; - end - function PositionChanged();virtual; //基准点改变 - begin - {** - @explan(说明) 基准点改变回调 %% - **} - end - function GetDeltaXpos();virtual; //水平变化 - begin - r := FLocalX-FLocalXold; - FLocalXold := FLocalX; - return r; - end - function GetDeltaYpos();virtual; //垂直变化 - begin - r := FLocalY-FLocalYold; - FLocalYold := FLocalY; - return r; - end - function GetXPos();virtual; - begin - return FLocalX; - end - function GetYPos();virtual; - begin - return FLocalY; - end - function SetXpos(x);virtual; - begin - nx := integer(x); - if not HandleAllocated()then return FLocalX := nx; - if nx <> FLocalX then - begin - hwnd := Handle; - FSI.fMask := SIF_POS; //SIF_ALL; - _wapi.GetScrollInfo(hwnd,SB_HORZ,FSI._getptr_); - ypos := FSI.nPos; - hwnd := Handle; - FSI.fMask := SIF_POS; - FSI.nPos := nx; - _wapi.SetScrollInfo(hwnd,SB_HORZ,FSI._getptr_,TRUE); - // 获得滚动条滑块的位置，由于窗口调整，它可能不是同一个值 - _wapi.GetScrollInfo(hwnd,SB_HORZ,FSI._getptr_); - if FSI.nPos <> ypos then - begin - FLocalXold := FLocalX; - FLocalX := FSI.nPos; - PositionChanged(); - end - end - end - function SetYpos(y);virtual; - begin - nx := integer(y); - if not HandleAllocated()then return FLocalY := nx; - if nx <> FLocalY then - begin - hwnd := Handle; - FSI.fMask := SIF_POS; //SIF_ALL; - _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); - ypos := FSI.nPos; - FSI.nPos := nx; - FSI.fMask := SIF_POS; - _wapi.SetScrollInfo(hwnd,SB_VERT,FSI._getptr_,TRUE); - // 获得滚动条滑块的位置，由于窗口调整，它可能不是同一个值 - _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); - if FSI.nPos <> ypos then - begin - FLocalYold := FLocalY; - FLocalY := FSI.nPos; - PositionChanged(); - end - end - end - function InitialScroll();virtual; - begin - if not HandleAllocated()then return; - hwnd := Handle; - // 设置垂直滚动条范围和页面大小（设置页面大小将决定滑块的粗细） - FSI.fMask := SIF_POS .| SIF_RANGE .| SIF_PAGE; - FSI.nMin := 0; - FSI.nPos := FLocalY; //20200709 - FSI.nMax :=(FAutoScroll .& 1)?(GetClientYCount()):0; - FSI.nPage := GetClientYCapacity(); - _wapi.SetScrollInfo(hwnd,SB_VERT,FSI._getptr_,true); - {if FSI.nMax>FSI.nPage then - begin - FLocalYold := FLocalY; - FLocalY := 0; - end else - begin } - FSI.fMask := SIF_POS; - _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); - FLocalYold := FLocalY; - FLocalY := FSI.nPos; - //end - // 设置水平滚动条范围和页面大小（设置页面大小将决定滑块的粗细） - FSI.cbSize := FSI._size_; - FSI.fMask := SIF_RANGE .| SIF_PAGE .| SIF_POS; - FSI.nMin := 0; - FSI.nPos := FLocalX; - FSI.nMax :=(FAutoScroll .& 2)?(GetClientXCount()):0; - FSI.nPage := GetClientXCapacity(); - _wapi.SetScrollInfo(hwnd,SB_HORZ,FSI._getptr_,TRUE); - {if FSI.nMax>FSI.nPage then - begin - FLocalXold := FLocalX; - FLocalX := 0; - end else - begin } - FSI.fMask := SIF_POS; - _wapi.GetScrollInfo(hwnd,SB_HORZ,FSI._getptr_); - FLocalXold := FLocalX; - FLocalX := FSI.nPos; - //end - PositionChanged(); - end - function DoVScroll(o,e);override; - begin - // 获得垂直滚动条的所有信息 - if csDesigning in ComponentState then return; - FSI.fMask := SIF_ALL; - hwnd := e.hwnd; - _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); - // 保存当前滑块位置，迟些进行比较 - yPos := FSI.nPos; - case e.lowparam of - // 用户点击键盘 Home 按键 - SB_TOP: - begin - FSI.nPos := FSI.nMin; - end - // 用户点击键盘 End 按键 - SB_BOTTOM: - begin - FSI.nPos := FSI.nMax; - end - // 用户点击滚动条上边的三角形 - SB_LINEUP: - begin - FSI.nPos -= 1; - end - // 用户点击滚动条下边的三角形 - SB_LINEDOWN: - begin - FSI.nPos += 1; - end - // 用户点击滑块上边的滚动条轴 - SB_PAGEUP: - begin - //return ; - FSI.nPos -= FSI.nPage; - end - // 用户点击滑块下边的滚动条轴 - SB_PAGEDOWN: - begin - //return ; - FSI.nPos += FSI.nPage; - end - // 用户拖动滚动条 - SB_THUMBTRACK: - begin - if ThumbTrack then - begin - FSI.nPos := FSI.nTrackPos; - end - end - SB_THUMBPOSITION: - begin - FSI.nPos := FSI.nTrackPos; - end - end - // 设置滚动条滑块的新位置 - if FSI.nPos=yPos then return; - return SetYpos(FSI.nPos); - FSI.fMask := SIF_POS; - _wapi.SetScrollInfo(hwnd,SB_VERT,FSI._getptr_,TRUE); - // 获得滚动条滑块的位置，由于窗口调整，它可能不是同一个值 - _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); - // 与此前的保存的值进行比较，如果不同则滚动窗口 - FLocalY := FSI.nPos; - if(FSI.nPos <> yPos)then - begin - PositionChanged(); - end - return 0; - end - function DoHScroll(o,e);override; - begin - if csDesigning in ComponentState then return; - FSI.fMask := SIF_ALL; - _wapi.GetScrollInfo(e.hwnd,SB_HORZ,FSI._getptr_); - // 保存当前滑块位置，迟些进行比较 - xPos := FSI.nPos; - case e.lowparam of - // 用户点击滚动条左边的三角形 - SB_LEFT: - begin - FSI.nPos := FSI.nMin; - end - SB_RIGHT: - begin - FSI.nPos := FSI.nMax; - end - SB_LINELEFT: - begin - FSI.nPos -= 1; - end - // 用户点击滚动条右边的三角形 - SB_LINERIGHT: - begin - FSI.nPos += 1; - end - // 用户点击滑块左边的滚动条轴 - SB_PAGELEFT: - begin - FSI.nPos -= FSI.nPage; - end - // 用户点击滑块右边的滚动条轴 - SB_PAGERIGHT: - begin - FSI.nPos += FSI.nPage; - end - // 用户拖动滚动条 - SB_THUMBTRACK: - begin - if ThumbTrack then - begin - FSI.nPos := FSI.nTrackPos; - end - end - SB_THUMBPOSITION: - begin - //return ; - FSI.nPos := FSI.nTrackPos; - end - end; - if FSI.nPos=xPos then return; - return SetXpos(FSI.nPos); - // 设置滚动条滑块的新位置 - FSI.fMask := SIF_POS; - _wapi.SetScrollInfo(e.hwnd,SB_HORZ,FSI._getptr_,TRUE); - // 获得滚动条滑块的位置，由于窗口调整，它可能不是同一个值 - _wapi.GetScrollInfo(e.hwnd,SB_HORZ,FSI._getptr_); - // 与此前的保存的值进行比较，如果不同则滚动窗口 - FLocalX := FLocalX; - FLocalX := FSI.nPos; - if(FSI.nPos <> xPos)then - begin - PositionChanged(); - end - end - function DoMouseWheel(o,e);override; - begin - if csDesigning in ComponentState then return; - hwnd := self.Handle; - FSI.fMask := SIF_ALL; - _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); - // 保存当前滑块位置，迟些进行比较 - yPos := FSI.nPos; - dd := 0; - if e.delta<0 and FSI.nMax>yPos then - begin - //dd++; - dd += FWhileStep; - end - if e.delta>0 and FSI.nMin FCaption then + begin + if ifstring(v)then + begin + FCaption := v; + end else + begin + FCaption := ""; + end + FNid.sztip := FCaption; + if FHaveadd then + begin + _wapi.Shell_NotifyIconA(NIM_MODIFY,FNid._getptr_); + end + end + end + function seticonhandle(ic); + begin + if(ic is class(tcustomicon))and ic.HandleAllocated()and FHaveadd then + begin + Fnid.uFlags := NIF_ICON .| NIF_MESSAGE .| NIF_TIP .| NIF_INFO; + Fnid.hicon := ic.Handle; + _wapi.Shell_NotifyIconA(NIM_MODIFY,FNid._getptr_); + end + end + function SetIcon(v); + begin + if v=FIcon then exit; + FIcon := v; + seticonhandle(FIcon); + end + function SetForm(f); + begin + if FForm=f then exit; + if FHaveadd then + begin + TrayDelete(); + end + FForm := f; + TrayAdd(); + end + public + function Create(AOwner);override; + begin + inherited; + FHaveadd := false; + if not FSIDC then FSIDC := new tidcreater(1); + FTrayID := FSIDC.CreateId(); + FNid := new TNOTIFYICONDATAA(); + FNid.uID := FTrayID; + FNid.ucallbackmessage := WM_TRAY; + end + function ShowTrayMessage(title,text); + begin + {** + @ignore(忽略) %% + @explan(说明) 显示托盘消息 %% + @param(title)(string)标题 %% + @param(text)(string) 消息 %% + + **} + if not FHaveadd then exit; + if not(ifstring(title)and ifstring(text))then exit; + if not((FForm is class(TVCForm))and FForm.HandleAllocated)then exit; + FNid.szinfotitle := title+"\0"; + FNid.szinfo := text+"\0"; + FNid.utimeout := 1000; + _wapi.Shell_NotifyIconA(NIM_MODIFY,FNid._getptr_); + end + function ShowPopUpMenu(); + begin + if not FHaveadd then exit; + if FPopupMenu is class(TcustomPopupmenu)then + begin + ps := array(x,y); + _wapi.GetCursorPos(ps); + uf := TPM_LEFTALIGN .| TPM_TOPALIGN .| TPM_RIGHTBUTTON; + hd := FForm.Handle; + _wapi.SetForegroundWindow(hd); + _wapi.TrackPopupMenu(FPopupMenu.Handle,uf,ps[0],ps[1],0,hd,nil); + return true; + end + end + procedure Notification(AComponent:TComponent;Operation:TOperation);override; + begin + {** + @explan(说明) 通知消息处理 %% + **} + if Operation=opRemove then + begin + if FPopupMenu=AComponent then + begin + FPopupMenu := nil; + end + if FForm=AComponent then + begin + Form := nil; + end + end; + inherited; + end; + function Recycling();override; + begin + FIcon := nil; + TrayDelete(); + FForm := nil; + FPopupMenu := nil; + inherited; + end + //添加到托盘栏 + function TrayAdd(); + begin + {** + @ignore(忽略) %% + @explan(说明) 添加 %% + **} + if FHaveadd then exit; + if(FForm is class(TVCForm))and FForm.HandleAllocated()then + begin + FNid.hWnd := FForm.Handle; + if not FIcon then FIcon := FForm.FormIcon; + if FIcon is class(tcustomicon)then + begin + FNid.hIcon := FIcon.Handle; + end + if ifstring(FCaption)then FNid.sztip := FCaption; + else FNid.sztip := FForm.Caption; + //FNid.dwInfoFlags := 1; + Fnid.uFlags := NIF_ICON .| NIF_MESSAGE .| NIF_TIP .| NIF_INFO; + _wapi.Shell_NotifyIconA(NIM_ADD,FNid._getptr_); + FHaveadd := true; + end + end + //从托盘栏删除 + function TrayDelete(); + begin + {** + @ignore(忽略) %% + @explan(说明) 删除 %% + **} + if FHaveadd then + begin + _wapi.Shell_NotifyIconA(nim_delete,FNid._getptr_); + FHaveadd := false; + end + end + function publishs();override; + begin + return array("name","caption","icon","popupmenu","onclick"); + end + property Form read FForm write SetForm; + property Caption:string read FCaption write SetCaption; + property OnClick:eventhandler read FOnclick write FOnclick; + property OnMouseMove:eventhandler read FOnMouseMove write FOnMouseMove; + property Icon:ticon read FIcon write SetIcon; + property PopupMenu:TPopUpmenu read FPopupMenu write FPopupMenu; + property TrayId read FTrayID; +end +type TVCForm = class(TScrollingWinControl) {** @explan(说明)主窗口类 %% **} @@ -12184,7 +1100,7 @@ type tform = class(TScrollingWinControl) if(FTray is class(TTray))then begin tp := FTray.PopupMenu; - if tp is class(TPopUpmenu)then + if tp is class(TcustomPopupmenu)then begin return tp; end @@ -12205,7 +1121,7 @@ type tform = class(TScrollingWinControl) end function seticonhandle(); begin - if HandleAllocated()and(FFormIcon is class(TIcon))and FFormIcon.HandleAllocated()then + if HandleAllocated()and(FFormIcon is class(tcustomicon))and FFormIcon.HandleAllocated()then begin _send_(WM_SETICON,1,FFormIcon.handle,1); end else @@ -12221,7 +1137,7 @@ type tform = class(TScrollingWinControl) FFormIcon := v; return; end - if v is class(TBitmap)then + if v is class(tcustombitmap)then begin if v.HandleAllocated()then begin @@ -12230,7 +1146,7 @@ type tform = class(TScrollingWinControl) end if ifarray(v)or ifarray(vn)then begin - if not(FFormIcon is class(ticon))then FFormIcon := new ticon(); + if not(FFormIcon is class(tcustomicon))then FFormIcon := new tcustomicon(); FFormIcon.readvcon(v?v:vn); seticonhandle(); end //else @@ -12261,13 +1177,13 @@ type tform = class(TScrollingWinControl) if FMainMenu <> mu then begin OM := FMainMenu; - if OM is class(tmainmenu)then + if OM is class(TcustomMainmenu)then begin OM.DestroyHandle(); //删除句柄 %% OM.Hwnd := 0; //if HandleAllocated() then _wapi.SetMenu(self.Handle,0); //删除窗口上面的菜单句柄 end - if(mu is class(tmainmenu))then + if(mu is class(TcustomMainmenu))then begin if HandleAllocated()then begin @@ -12386,7 +1302,7 @@ type tform = class(TScrollingWinControl) {** @explan(说明) command 消息处理 **} - if(FMainMenu is class(TMainmenu))and FMainMenu.dispatch(e)then exit; + if(FMainMenu is class(TcustomMainmenu))and FMainMenu.dispatch(e)then exit; trp := traypopmenu(); if trp and trp.dispatch(e)then exit; inherited; @@ -12398,35 +1314,35 @@ type tform = class(TScrollingWinControl) end function WMMEASUREITEM(o,e):WM_MEASUREITEM;override; begin - if e.wparam=0 and(FMainMenu is class(TMainmenu))and FMainMenu.dispatch(e)then exit; + if e.wparam=0 and(FMainMenu is class(TcustomMainmenu))and FMainMenu.dispatch(e)then exit; trp := traypopmenu(); if trp and trp.dispatch(e)then exit; inherited; end function WMMENURBUTTONUP(o,e):WM_MENURBUTTONUP;override; begin - if(FMainMenu is class(TMainmenu))and FMainMenu.dispatch(e)then exit; + if(FMainMenu is class(TcustomMainmenu))and FMainMenu.dispatch(e)then exit; trp := traypopmenu(); if trp and trp.dispatch(e)then exit; inherited; end function WMMENUSELECT(o,e):WM_MENUSELECT;override; begin - if(FMainMenu is class(TMainmenu))and FMainMenu.dispatch(e)then exit; + if(FMainMenu is class(TcustomMainmenu))and FMainMenu.dispatch(e)then exit; trp := traypopmenu(); if trp and trp.dispatch(e)then exit; inherited; end function WMINITMENUPOPUP(o,e):WM_INITMENUPOPUP;override; begin - if(FMainMenu is class(TMainmenu))and FMainMenu.dispatch(e)then exit; + if(FMainMenu is class(TcustomMainmenu))and FMainMenu.dispatch(e)then exit; trp := traypopmenu(); if trp and trp.dispatch(e)then exit; inherited; end function WMDRAWITEM(o,e):WM_DRAWITEM;override; begin - if e.wparam=0 and(FMainMenu is class(tmainmenu))then + if e.wparam=0 and(FMainMenu is class(TcustomMainmenu))then begin e.canvas := canvas; canvas.handle := e.hdc; @@ -12474,7 +1390,7 @@ type tform = class(TScrollingWinControl) end function DestroyHandle();override; begin - if FMainMenu is class(tmainmenu)then + if FMainMenu is class(TcustomMainmenu)then begin FMainMenu.DestroyHandle(); end @@ -12488,7 +1404,7 @@ type tform = class(TScrollingWinControl) begin if HandleAllocated()then begin - if FMainMenu is class(TMainmenu)then + if FMainMenu is class(TcustomMainmenu)then begin FMainMenu.Hwnd := handle; end @@ -12541,9 +1457,9 @@ type tform = class(TScrollingWinControl) end end -type TVCForm=class(TForm) +type tform=class(TVCForm) {** - @explan(说明) 为避免和全局重名提供的主窗口接口 %% + @explan(说明) 可能和web全局重名不建议使用 %% **} function Create(AOwner);override; begin @@ -13107,1108 +2023,13 @@ end end end end -type teditable = class(TSLUIBASE) - private - FInsertState; - FReadOnly; - FLineWrap; - FString; - FCaretX; - FLeftCharCount; - Flimitlength; - - FSelBegin; - FSelLength; - - FCanShowCaret; - FFontWidth; - FFontHeight; - FCaretY; - FMouseLbuttonDown; - FHafChar; //半个中文 - FBorder; - ////////////////////// - FHost; // - FHostDc; - FClientRect; - FFont; - FVisible; - function SetVisible(v); - begin - nv := v?true:false; - if nv<>FVisible then - begin - FVisible := nv; - if not(FVisible) and FSetFocused then - begin - KillFocus(); - InvalidateRect(nil,false); - end - CalcFontSize(); - end - end - function SetFont(f); - begin - if f then - begin - FFont := f; - if FCanShowCaret and FHost and FHost.HandleAllocated() and FHost.Handle=_wapi.GetFocus() then - begin - recreateCarete(); - return InvalidateRect(nil,false); - end - CalcFontSize(); - InvalidateRect(nil,false); - updatecaret(); - end - end - function InvalidateRect(rec,flg); - begin - if FHost and FHost.HandleAllocated() then - begin - FHost.InvalidateRect(rec?rec:FClientRect,flg); - end - end - function SetHost(host); - begin - if FHost=host then return ; - ohost := FHost; - FHost := nil; - if host is class(TWinControl) then - begin - - SetFont(host.font); - FHost := host; - end else - begin - if ohost then ohost.InvalidateRect(GetEntryRect(),false); - end - end - function SetBorder(v); - begin - n := v?true:false; - if n<>FBorder then - begin - FBorder := n; - InvalidateRect(nil,false); - end - end - Function Setplaceholder(p); - begin - if p and ifstring(p) and Fplaceholder<>p then - begin - Fplaceholder := p; - if FHost and not(FString) and FHost.HandleAllocated() then InvalidateRect(nil,false); - end - end - function recreateCarete(); - begin - DestroyCaret(); - CreateCaret(); - end - function CreateCaret(); //构造光标 - begin - if not(FReadOnly) and not(FCanShowCaret) and FHost and FHost.HandleAllocated() then - begin - CalcFontSize(); - h := FFontHeight+4; - hd := FHost.Handle; - _wapi.CreateCaret(hd, nil, 1, h ); - _wapi.ShowCaret(hd); - FCanShowCaret := true; - end - FIsCaretShow := true; - end - function DestroyCaret(); //销毁光标 - begin - if FCanShowCaret and FHost and FHost.HandleAllocated() then - begin - _wapi.HideCaret(FHost.Handle); - _wapi.DestroyCaret(); - FCanShowCaret := false; - end - FIsCaretShow := false; - end - function updatecaret(); - begin - if FCanShowCaret and FHost and FHost.HandleAllocated() then - begin - rec := GetEntryRect(); - cx := (FCaretX-FLeftCharCount-1)*FFontWidth+rec[0]; - _Wapi.SetCaretPos(cx,FCaretY); - end - end - function InitSel(); - begin - FSelBegin :=FCaretX; - FSelLength := 0; - end - function GetCharPosByX(x); - begin - rc := GetEntryRect(); - cp := FLeftCharCount+ integer((x-rc[0])/FFontWidth+0.4)+1; - if bytetype(FString,cp) =2 then return cp+1; - return cp; - end - function CalcFontSize(); - begin - FFontWidth := font.width; - FFontHeight := font.Height; - rec := GetEntryRect(); - FCaretY := max(0,integer((rec[1]+(rec[3]-rec[1]-FFontHeight)/2))-2); - end - function setReadOnly(v); - begin - nv := v?true:false; - if nv<>FReadOnly then - begin - FReadOnly := nv; - InvalidateRect(nil,false); - end - end - function setEditText(s); - begin - if ifstring(s) and s<>FString then - begin - s1 := filterstring(s); - if s1=fstring then return ; - FString := s1; - if FCaretX=1 then - begin - InitSel(); - InvalidateRect(nil,false); - end - else - MoveCaretTo(1,0); - doOnChange(); - end - end - function setLimitLength(n); - begin - if n>=0 and n<>Flimitlength then - begin - Flimitlength := n; - end - end - function MoveCaretTo(x_,ifsel); - begin - if x_<1 then x := 1 ; - else - x := min(x_,length(FString)+1); - if x=FCaretX then return ; - rec := GetEntryRect(); - x1 := FLeftCharCount+1;//rec[0]; - fw := font.width; - x2 := integer((rec[2]-rec[0])/fw); - if x(x1+x2) then - begin - FLeftCharCount+=(x-x1-x2); - end - FCaretX := x; - ////////////显示光标位置//////////////////// - //_wapi.SetCaretPos(); - if ifsel then - begin - FSelLength := x-FSelBegin; - end else InitSel(); - InvalidateRect(nil,false); - updatecaret(); - end - - function selectall(); - begin - if FString and (FSelBegin<>1 or FSelLength<>length(FString)) then - begin - FSelBegin := 1; - FSelLength := length(FString); - InvalidateRect(nil,false); - end - end - function getselstring(b,e); - begin - if FSelLength<>0 then - begin - x1 := FSelBegin-(FSelLength<0); - X2 :=FSelBegin+FSelLength-(FSelLength>0); - b := min(x1,x2); - e := max(x1,x2); - return FString[b:e]; - end - return ""; - end - function DeleteSel(); - begin - if FSelLength<>0 then - begin - x1 := FSelBegin-(FSelLength<0); - X2 :=FSelBegin+FSelLength-(FSelLength>0); - b := min(x1,x2); - e := min(max(x1,x2),length(FString)); - FString[b:e] := ""; - cx := max(1,min(x1,x2)); - InitSel(); - BeginUpDate(); - InvalidateRect(nil,false); - MoveCaretTo(cx,0); - DeletePerfect(); - EndUpDate(); - doOnChange(); - end - end - function DeletePerfect(); - begin - if FLeftCharCount>0 then - begin - sz := FFontWidth*(length(FString)-FLeftCharCount); - rec := GetEntryRect(); - syl := ((rec[2]-rec[0]-sz)/FFontWidth); - if syl>1 then - begin - FLeftCharCount := max(0,FLeftCharCount-integer(syl)); - updatecaret(); - InvalidateRect(nil,false); - end - end - end - function dodelete(); - begin - if FReadOnly then return ; - if FSelLength<>0 then return deletesel(); - len := length(FString); - if FCaretX<=length(FString) then - begin - if bytetype(FString,FCaretX)=1 then - begin - FString[(FCaretX):(FCaretX+1)]:=""; - end else - begin - FString[(FCaretX):(FCaretX)]:=""; - end - BeginUpDate(); - InvalidateRect(nil,false); - DeletePerfect(); - EndUpDate(); - doOnChange(); - end - end - function BeginUpDate(); - begin - if FHost and FHost.HandleAllocated() then - begin - FHost.BeginUpDate(); - end - end - function EndUpDate(); - begin - if FHost and FHost.HandleAllocated() then - begin - FHost.EndUpDate(); - end - end - function dobackspace(); - begin - if FReadOnly then return ; - if FSelLength<>0 then return deletesel(); - len := length(FString); - if FCaretX>1 then - begin - cx := FCaretX; - if bytetype(FString,FCaretX-1)=2 then - begin - FString[(FCaretX-2):(FCaretX-1)]:=""; - cx-=2; - end else - begin - FString[(FCaretX-1):(FCaretX-1)]:=""; - cx--; - end - BeginUpDate(); - MoveCaretTo(cx,0); - DeletePerfect(); - EndUpDate(); - doOnChange(); - end - end - function GetCBoard(); - begin - if not FCopyer then - begin - FCopyer := new TClipBoard(initializeapplication()); - end - return FCopyer; - end - function CopyToClipboard(); //复制选择 - begin - r := getselstring(); - GetCBoard().text := r; - end - function PasteFromClipBoard(); - begin - if readonly then return ; - t := GetCBoard().text; - if t then InsertChar(t); - end - protected - function doOnChange();virtual; - begin - - end - function doonmaxtext();virtual; - begin - - end - function doonsetfocus();virtual; - begin - - end - function doonkillfocus();virtual; - begin - - end - function filterstring(c);virtual; //过滤 - begin - s1 := ""; - if ifstring(c) and c then - begin - s1 := replacetext(c,"\r",""); - s1 := replacetext(s1,"\n",""); - s1 := replacetext(s1,"\t"," "); - end - return s1; - end - function PaintBorder();virtual; - begin - if FBorder or (FFocusBorder and FSetFocused) then - begin - - rbc := ClientRect; - if ifarray(rbc) and rbc[2]>rbc[0] and rbc[3]>rbc[1] then - begin - dc := FHost.Canvas; - dc.pen.width := 1; - if FSetFocused then dc.pen.color := rgb(200,150,150); - else - dc.pen.color := rgb(180,180,180); - dc.brush.Color := FHost.Color; - dc.draw("RoundRect",array(rbc[0:1],rbc[2:3],array(3,3))); - end - end - end - function PaintPlaceHolder(rec);virtual; - begin - if not(FString) and Fplaceholder and ifstring(Fplaceholder) then - begin - dc := FHost.Canvas; - bc := dc.font.color ; - dc.font.color := Fplaceholdercolor; - dc.drawtext(Fplaceholder,rec,DT_VCENTER .| DT_SINGLELINE); - dc.font.color := bc; - return true; - end - end - function PaintText(s,rec);virtual; - begin - if FHost and FHost.HandleAllocated() and ifstring(s) and s then - begin - dc := FHost.Canvas; - if not dc.HandleAllocated() then return ; - neb := not(FHost.Enabled) ; - if neb then - begin - dc.font.Color := 0xc0c0c0; - end - if FMarked then - begin - ns := s; - if ifstring(FPassWordChar) and FPassWordChar then vc := FPassWordChar[1]; - else vc := "#"; - for i:= 1 to length(ns) do - begin - ns[i] := vc; - end - dc.drawtext(ns,rec,DT_VCENTER .| DT_SINGLELINE); - end else - dc.drawtext(s,rec,DT_VCENTER .| DT_SINGLELINE); - end - end - public - function create(); - begin - Fplaceholdercolor := rgb(200,200,200); - fselbkcolor := rgb(51,153,255); - freadonlyColor := rgb(240,240,240); - FVisible := true; - FReadOnly := false; - FFocusBorder := true; - FString := ""; - FSelBegin := 1; - FSelLength := 0; - FBorder := true; - FCaretX := 1; - FLeftCharCount := 0;//1; - FFont := new TFont(); - end - function InsertChar(c_);//插入 - begin - if FSelLength<>0 then - begin - dobackspace(); - end - len := length(FString); - c := filterstring(c_); - if not(ifstring(c) and c) then return ; - if Flimitlength>0 then - begin - if Flimitlength<=len then - begin - doonmaxtext(); - return ; - end else - begin - clen := length(c); - nct := Flimitlength-len; - if nct(rc[2]-rc[0]) then return ; - end - if FCaretX=1 then - begin - FString := c+FString; - end else - if FCaretX = length(FString)+1 then - begin - FString +=c; - end else - begin - FString[FCaretX:0]:=c; - end - MoveCaretTo(FCaretX+length(c),0); - doOnChange(); - end - function ExecuteCommand(cmd,pm);virtual; - begin - case cmd of - "echome": - begin - MoveCaretTo(1,pm); - end - "ecend": - begin - MoveCaretTo(length(FString)+1,pm); - end - "ecreadonlycolor": - begin - if pm>0 or pm<0 then freadonlyColor := pm; - return freadonlyColor; - end - "ecselbkcolor": - begin - if pm>0 or pm<0 then fselbkcolor := pm; - return fselbkcolor; - end - "ecplaceholdercolor": - begin - if pm>0 or pm<0 then Fplaceholdercolor := pm; - return Fplaceholdercolor; - end - "ecinsert": - begin - if ifstring(pm) and pm then InsertChar(pm); - end - "ecleft": - begin - if FCaretX>1 then - MoveCaretTo(FCaretX-(1+(bytetype(FString,FCaretX-1)=2)),pm); - end - "ecright": - begin - if FCaretX<=length(FString) then - MoveCaretTo(FCaretX+(1+(bytetype(FString,FCaretX)=1)),pm); - end - "ecselall": - begin - selectall(); - end - "ecsel": - begin - if ifarray(pm) and pm[0]>0 and pm[1]>0 then - begin - MoveCaretTo(pm[0],0); - MoveCaretTo(Pm[1],1); - end - end - "ecclcsel": - begin - if FSelLength<>0 then - begin - InitSel(); - InvalidateRect(nil,false); - end - end - "ecgetsel": - begin - r := getselstring(b,e); - pm := array(b,e); - return r; - end - "ecdelete": - begin - dodelete(); - end - "ecbackspace": - begin - dobackspace(); - end - "eccopy": - begin - CopyToClipboard(); - end - "ecpaste": - begin - PasteFromClipBoard(); - end - "eccut": - begin - CopyToClipboard(); - DeleteSel(); - end - "ecpasswordchar": - begin - if ifstring(pm) and pm then FPassWordChar := pm[1]; - else return FPassWordChar; - end - "ecmarked": - begin - if ifnil(pm) then - begin - return FMarked; - end else - begin - nv := pm?true:false; - if FMarked<>nv then - begin - FMarked := nv; - InvalidateRect(nil,false); - end - end - end - "ecgetposbyx": - begin - if x>=0 or x<0 then - return GetCharPosByX(x); - end - "eccaretpos": - begin - return FCaretX; - end - end; - end - function GetEntryRect();virtual; - begin - r := ClientRect; - if not ifarray(r) then return array(0,0,0,0); - r[0]+=1; - r[2]-=1; - r[1]+=1; - r[3]-=1; - return r; - end - function WMKEYDOWN(o,e);virtual; - begin - fsft := ssShift in e.shiftstate; - fctl := ssCtrl in e.shiftstate; - case e.CharCode of - VK_INSERT: - begin - FInsertState := not FInsertState ; - end - VK_LEFT: - begin - ExecuteCommand("ecleft",fsft); - end - VK_RIGHT: - begin - ExecuteCommand("ecright",fsft); - end - VK_DELETE: - begin - dodelete(); - end - VK_HOME: - begin - ExecuteCommand("echome",fsft); - end - VK_END: - begin - ExecuteCommand("ecend",fsft); - end - ord("C"): - begin - if fctl then - begin - ExecuteCommand("eccopy"); - end - end - ord("V"): - begin - if fctl then - begin - ExecuteCommand("ecpaste"); - end - end - ord("X"): - begin - if fctl then - begin - ExecuteCommand("eccut"); - end - end - ord("A"): - begin - if fctl then selectall(); - end - end - end - function WMCHAR(o,e);virtual; - begin - c := e.CharCode; - case c of - VK_BACK: - begin - return dobackspace(); - end - end - if c<32 then return ; - if FReadOnly then return ; - if c .& 0x80 then - begin - if FHafChar then - begin - InsertChar(FHafChar+e.char); - FHafChar :=""; - end - else - begin - FHafChar := e.char; - end - end else InsertChar(e.char); - end - function FontChanged(o);override; - begin - if FHost and FHost.HandleAllocated() then - begin - if _wapi.GetFocus() = FHost.Handle then - begin - recreateCarete(); - end else - begin - CalcFontSize(); - InvalidateRect(nil,false); - end - end - end - function Paint(); - begin - if not FVisible then return ; - if not(FHost and FHost.HandleAllocated() and FHost.Canvas.HandleAllocated()) then return ; - dc := FHost.Canvas; - dc.font := font; - rec := GetEntryRect(); - if FReadOnly then - begin - dc.brush.color := freadonlyColor; - dc.FillRect(rec); - end - PaintBorder(); - if PaintPlaceHolder(rec) then return ; - fw := FFontWidth; - fh := FFontHeight; - if FSelLength<>0 then //绘制阴影 - begin - x1 := FSelBegin-FLeftCharCount-1; - if FSelLength>0 then - begin - x2 := x1+ FSelLength; - end else - begin - x2 := x1; - x1 := x2+FSelLength; - end - x1 := max(0,x1); - x2 := max(0,x2); - if x2>x1 then - begin - bc := dc.brush.color; - dc.brush.color := fselbkcolor;////rgb(0,220,220); - rcb := rec; - rcb[0] := x1*fw+rec[0]; - rcb[2] := x2*fw+rec[0]; - if dh>0 then - begin - rcb[1]+= FCaretY; - rcb[3]-= FCaretY; - end - dc.FillRect(rcb); - dc.brush.color := bc; - - end - end - if FLeftCharCount>0 then - begin - if bytetype(FString,FLeftCharCount)=1 then - begin - rec[0]-=fw; - dstr := FString[FLeftCharCount:]; - end else dstr := FString[(FLeftCharCount+1):]; - end else dstr := FString; - PaintText(dstr,rec); - //dc.drawtext(dstr,rec,DT_VCENTER .| DT_SINGLELINE); - end - function MouseUp(o,e); - begin - if not (FHost and FHost.HandleAllocated()) then return ; - FMouseLbuttonDown := false; - _wapi.ClipCursor(0); - end - function MouseMove(o,e); - begin - if not FVisible then return ; - if not (FHost and FHost.HandleAllocated()) then return ; - //move ; - if not FMouseLbuttonDown then return ; - rec := GetEntryRect(); - x := e.xpos; - if xrec[2]-2 then x+=FFontWidth*3; - nx := GetCharPosByX(x); - MoveCaretTo(nx,true); - end - function MouseDown(o,e); - begin - if not FVisible then return ; - if not (FHost and FHost.HandleAllocated()) then return ; - rec := GetEntryRect(); - if not(pointinrect(e.pos,FClientRect)) then return ; - x := e.xpos; - if xrec[0] then - begin - if e.button()= mbLeft then - begin - x := GetCharPosByX(e.xpos); - MoveCaretTo(x,0); - FMouseLbuttonDown := true; - crect := rec; - if FHost then //固定区域 - begin - ps := array(FHost.clienttoscreen(crect[0],crect[1]),FHost.clienttoscreen(crect[2],crect[3])); - _wapi.ClipCursor(ps); - end - end - if not FIsCaretShow then - return SetFocus(); - end - end - function SetFocus(); - begin - if not FVisible then return ; - FSetFocused := true; - if FHost and FHost.HandleAllocated() then - begin - if _wapi.GetFocus()<>FHost.Handle then return FHost.SetFocus(); - end - CreateCaret(); - updatecaret(); - if FFocusBorder then InvalidateRect(nil,false); - doonsetfocus(); - end - function KillFocus(); - begin - FMouseLbuttonDown := false; _wapi.ClipCursor(0); //添加输入焦点处理 - FSetFocused := false; - DestroyCaret(); - if FFocusBorder then InvalidateRect(nil,false); - doonkillfocus(); - end - function Recycling();override; - begin - FKillFocus := 0; - FOnSetFocus := 0; - FPassWordChar := "#"; - FMarked := 0; - FOnMaxText := 0; - FOnUpdate := 0; - FOnChange := 0; - Fplaceholder := 0; - FHost := nil; - FFont := nil; - inherited; - end - property Visible read FVisible write SetVisible; - property text:string read FString write setEditText; - property onmaxtext:eventhandler read FOnMaxText write FOnMaxText;//eventhandler 修改 - property placeholder:string read Fplaceholder write Setplaceholder; - property readonly:bool read FReadOnly write setReadOnly; - property limitlength:integer read Flimitlength write setLimitLength; - property LineWrap:bool read FLineWrap write FLineWrap; - property Border read FBorder write SetBorder; - property Font read FFont write SetFont; - property ClientRect read FClientRect write FClientRect; //区域 - property host read FHost write SetHost; - property HasFocus read FSetFocused ; - property Focusedborder read FFocusBorder write FFocusBorder; - private - FIsCaretShow; - FKillFocus; - FOnSetFocus; - FPassWordChar; - FMarked; - FOnMaxText; - FOnUpdate; - FOnChange; - Fplaceholder; - FSetFocused; - FFocusBorder; - Fplaceholdercolor; - fselbkcolor; - freadonlyColor; - static FCopyer; -end //edit -type tedit =class(TCustomControl) -{** - @explan(说明) 单行文本编辑框类 %% - **} - private - FEditable; - type TEntryEditable = class(teditable) - function Create(); - begin - inherited; - end - function doonmaxtext();override; - begin - if host then host.doonmaxtext(); - end - function doOnChange();override; - begin - if host then host.DoChanged(); - end - end - public - function Create(AOwner);override; +type tedit = class(tcustomedit) + function create(AOwner);override; begin inherited; - Left := 10; - Top := 10; - //Ftextalign := 0; - Width := 80; - Height := 25; - FEditable := new TEntryEditable(); - FEditable.host := self(true); end - function ExecuteCommand(cmd,pm);override; - begin - if FEditable then return FEditable.ExecuteCommand(cmd,pm); - end - function SetSel(bgid,edid); - begin - {** - @explan(说明)设置选择文本 %% - @param(bgid)(integer) 开始位置 默认为0 %% - @param(edid)(integer) 结束位置 默认为整体长度 %% - **} - - return ExecuteCommand("ecsel",array(bgid+1,edid+1)); - end - function Paint();override; - begin - if FEditable then FEditable.Paint(); - end - function MouseUp(o,e);override; - begin - if csDesigning in ComponentState then return ; - - if e.skip then return ; - if FEditable then FEditable.MouseUp(o,e); - inherited; - - end - function MouseMove(o,e);override; - begin - if csDesigning in ComponentState then return ; - if e.skip then return ; - if FEditable then FEditable.MouseMove(o,e); - inherited; - end - function MouseDown(o,e);override; - begin - if csDesigning in ComponentState then return ; - - if e.skip then return ; - if FEditable then FEditable.MouseDown(o,e); - inherited; - end - - function dosetfocus(o,e);override; - begin - if csDesigning in ComponentState then return ; - if FEditable then - begin - FEditable.SetFocus(); - end - inherited; - end - function dokillfocus(o,e);override; - begin - if csDesigning in ComponentState then return ; - if FEditable then - begin - FEditable.killFocus(); - end - inherited; - end - function DoWMSIZE(o,e);override; - begin - if FEditable then - begin - rc := ClientRect; - FEditable.ClientRect := rc; - end - inherited; - end - function keypress(o,e);override; - begin - if csDesigning in ComponentState then return ; - if e.skip then return ; - if FEditable then - begin - FEditable.WMCHAR(o,e); - end - inherited; - end - function KeyDown(o,e);override; - begin - if csDesigning in ComponentState then return ; - if e.skip then return ; - if FEditable then FEditable.WMKEYDOWN(o,e); - inherited; - end - function doonmaxtext(); - begin - calldatafunction(FOnMaxText,self(true),new tuieventbase(0,0,0,0)); - end - function DoChanged(); - begin - calldatafunction(FOnChange,self(true),new tuieventbase(0,0,0,0)); - calldatafunction(FOnUpdate,self(true),new tuieventbase(0,0,0,0)); - end - function FontChanged(sender);override; - begin - inherited; - FEditable.font := Font; - end - function Recycling();override; - begin - inherited; - FOnUpdate := nil; - FOnChange := nil; - fonmaxtext := nil; - if FEditable then FEditable.Recycling(); - FEditable := nil; - end - function publishs();override; - begin - return array("name","align","anchors","font","enabled","popupmenu","visible","height","width","left","top","text","placeholder" - ,"readonly","limitlength","linewrap","tabstop","onmousemove","onpopupmenu","onmousedown","onmouseup","onkeyup" - ,"onkeydown","onkeypress","onmaxtext","onkillfocus","onsetfocus","onchange"); - end - property text:string read getentrytext write setentrytext; - property onmaxtext:eventhandler read Fonmaxtext write fonmaxtext; - property onupdate read FOnUpdate write FOnUpdate; - property onchange read FOnChange write FOnChange; - property readonly:bool read getReadOnly write setReadOnly; - property limitlength:integer read getlimitlength write setLimitLength; - property LineWrap:bool read getLineWrap write setLineWrap; - property placeholder:string read getplaceholder write Setplaceholder; - property Border read getBorder write SetBorder; - {** - @param(LineWrap)(bool)自动换行,默认为false不自动换行%% - @param(onmaxtext)(fpointer)达到文本最大回调%% - @param(onupdate)(fpointer)文本更新回调%% - @param(onchange)(fpointer)文本改变回调%% - @param(readonly)(bool)只读%% - @param(onlimitlength)(integer)设置输入字符的长度%% - **} - private - function getBorder(); - begin - if FEditable then return FEditable.Border; - end - function setBorder(s);override; - begin - if FEditable then return FEditable.Border := s; - end - function getentrytext(); - begin - if FEditable then return FEditable.text; - return ""; - end - function setentrytext(s); - begin - if FEditable then return FEditable.text := s; - end - function getplaceholder(); - begin - if FEditable then return FEditable.placeholder; - end - function setplaceholder(v); - begin - if FEditable then return FEditable.placeholder := v; - end - function getReadOnly(); - begin - if FEditable then return FEditable.readonly; - end - function setReadOnly(v); - begin - if FEditable then return FEditable.readonly := v; - end - function getlimitlength(); - begin - if FEditable then return FEditable.limitlength; - end - function setLimitLength(n); - begin - if FEditable then return FEditable.limitlength := n; - end - function getLineWrap(); - begin - if FEditable then return FEditable.LineWrap; - end - function setLineWrap(v); - begin - if FEditable then return FEditable.LineWrap := v; - end - FOnUpdate; - FOnChange; - fonmaxtext; end type tpassword = class(tedit) {** @@ -14785,907 +2606,15 @@ type TRadioGroupBox=class(TGroupbox) **} end //listbox -type TCustomListBox=class(TCustomScrollControl) - {** - @explan(说明) listbox基类 - **} - private - FItemCount; - FMaxItemWidth; - protected /////////////////滚动条相关////////////////////////////////////////// - function GetClientXCapacity();virtual; //宽度容量 - begin - r := integer(ClientRect[2]/GetXScrollDelta()); - return r; - end - function GetClientYCapacity();virtual; //高度容量 - begin - return integer(ClientRect[3]/GetYScrollDelta()); - end - function GetClientXCount();virtual; //宽度间隔 - begin - return FMaxItemWidth; - end - function GetClientYCount();virtual; //高度项 - begin - return FItemCount-1; - end - function GetXScrollDelta();override; - begin - return FFontWidth; - end - function GetYScrollDelta();override; - begin - return FFontHeight+4; - end - function PositionChanged();virtual; - begin - InvalidateRect(nil,false); - end - private - function PaintLines(FirstLine,LastLine); - begin - cvs := Canvas; - for i := FirstLine to LastLine do - begin - rc := GetIdxRect(i); - PaintIdx(i,rc,cvs); - end - end - public - function Create(AOwner);override; + +type TListBox = class(TcustomListBox) + function create(AOwner); begin inherited; - FMaxItemWidth := 1; - FItemCount := 0; - FFontHeight := font.Height; - FFontWidth := font.Width; - left := 0; - top := 0; - height := 100; - width := 125; - autoscroll := 1; - ThumbTrack := true; - FScroolChanged := false; - end - function UpDateScrollBar(); //滚动条改变 - begin - DoControlAlign(); - end - function IncPaintLock(); //锁定刷新 - begin - BeginUpdate(); - end - function DecPaintLock(); //释放刷新 - begin - EndUpdate(); - end - function DoEndUpDate();override; //锁定刷新释放 - begin - if not(IsUpDating())then - begin - if FScroolChanged then - begin - FScroolChanged := false; - return UpDateScrollBar(); - 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)/GetYScrollDelta())); - LastLine := integer(min(FItemCount-1,yPos+(bo)/GetYScrollDelta())); - cvs := Canvas; - cvs.Font := font; - PaintLines(FirstLine,LastLine); - end - function MouseUp(o,e);override; - begin - if e.Button()=mbLeft then - begin - calldatafunction(onclick,o,e); - end - e.skip := true; - end - function MouseDown(o,e);override; - begin - if e.Button()=mbLeft and e.shiftdouble()then - begin - CallDataFunction(ondblclick,o,e); - e.skip := true; - end - end - function PaintIdx(idx,rc,cvs);virtual; - begin - {** - @explan(说明)绘制项 %% - @param(idx)(integer) 序号%% - @param(rc)(array) 绘制区域%% - @param(cvs)(tcanvas) 画布 %% - **} - end - function InvalidateIdxRect(idx,cnt);virtual; - begin - if idx >= 0 and idx= 1)then cnt := 1; - rc := ClientRect; - y := GetYPos(); - dy := GetYScrollDelta(); - idxtop :=(idx-y)* dy; - if idxtop >= rc[3]then - begin - return; - end - if(idxtop+cnt * dy)<= 0 then - begin - return; - end - rc[1]:= idxtop; - rc[3]:= min(rc[3],idxtop+cnt * dy); - InvalidateRect(rc,false); - end - end - function GetIdxByYpos(y);virtual; - begin - py := GetYPos(); - r := integer(y/GetYScrollDelta())+py; - if r >= FItemCount then return-1; - return r; - end - function GetIdxRect(idx);virtual; - begin - {** - @explan(说明)通过序号获得项绘制区域 %% - @param(idx)(integer) 项序号 %% - @return(array) array(左上右下) %% - **} - if idx >= 0 then - begin - rc := ClientRect; - yp := GetYPos(); - xp := GetXpos(); - DY := GetYScrollDelta(); - rc[1]:=(idx-yp)* DY; - rc[0]:=(0-xp)* GetXScrollDelta(); - rc[3]:= rc[1]+DY; - return rc; - end - return array(); - end - function InsureIdxInClient(idx); //确保指定项在区域中 - begin - {** - @explan(说明)确保指定项在区域中 %% - @param(idx)(integer) 项序号 %% - **} - rc := GetIdxRect(idx); - c := ClientRect; - if rc[1]c[3]then - begin - SetYpos(1+GetYPos()+(rc[3]-c[3]+1)/GetYScrollDelta()); - end - end - function GetClientIdxs();virtual; - begin - {** - @explan(说明)获得客户区项的序号 %% - @return(array) 序号数组 %% - **} - rc := ClientRect; - r := GetRectIdxs(rc); - return r[0]-> r[1]; - end - function doControlALign();override; - begin - if(IsUpDating())then - begin - FScroolChanged := true; - end else - begin - FMaxItemWidth := GetMaxItemWidth(); - InitialScroll(); - end - end - function EnsureIdxVisible(idx); - begin - if idx >= FItemCount then idx := FItemCount-1; - if not(idx >= 0)then return; - rc := ClientRect; - idxs := GetRectIdxs(rc); - if idx <= idxs[0]then - begin - SetYpos(idx); - end else - if idx >= idxs[1]then - begin - ndx := integer((rc[3]-rc[1])/GetYScrollDelta()); - SetYpos(idx-ndx); - end - end - function FontChanged(o);override; - begin - wd := font.width; - h := font.Height; - if h <> FFontHeight or wd <> FFontWidth then - begin - FFontHeight := h; - FFontWidth := wd; - UpDateScrollBar(); - end - end - function GetItemCount();virtual; - begin - return FItemCount; - end - property ItemCount read GetItemCount write SetItemCount; - property ItemHeight read GetYScrollDelta; - {** - @param(ItemCount)(integer) 项数量 %% - **} - protected - function SetItemCount(n);override; - begin - if not(n >= 0)then return; - nn := integer(n); - if nn <> FItemCount then - begin - FItemCount := nn; - UpDateScrollBar(); - end - end - private - FFontHeight; - FFontWidth; - FScroolChanged; //滚动条修改 - function GetRectIdxs(rc); - begin - yp := GetYPos(); - tp := rc[1]; - bo := rc[3]; - FirstLine := integer(tp/GetYScrollDelta())+yp; - LastLine := integer((bo)/GetYScrollDelta())+yp; - return array(FirstLine,LastLine); - end - function GetMaxItemWidth();virtual; - begin - return 1; - end -end -type TListBox = class(TCustomListBox) - {** - @explan(说明) listbox控件 %% - **} - function Create(AOwner);override; - begin - inherited; - border := true; - FitemData := new TMyArrayB(); - FSelBegin :=-1; - FSelEnd :=-1; - FMultisel := false; - end - function MouseUp(o,e);override; - begin - if FIsMouseDown then - begin - _wapi.clipcursor(ps); - FIsMouseDown := false; - selchange := 0; - case FMultisel of - 0: - begin - selchange := FFormerSelBegin <> FSelBegin; - end - 1: - begin - selchange :=((FFormerSelBegin <> FSelBegin)or(FFormerSelEnd <> FSelEnd))and((FFormerSelBegin <> FSelEnd)or(FFormerSelEnd <> FSelBegin)); - end - 2: - begin - selchange := 1; - end - end; - if selchange then calldatafunction(FselectionChange,o,e); - end - inherited; - end - function MouseDown(o,e);override; - begin - if csDesigning in ComponentState then return; - if(e.Button()=mbLeft)and not(e.shiftdouble())then - begin - FFormerSelBegin := FSelBegin; - FFormerSelEnd := FSelEnd; - idx := GetIdxByYpos(e.ypos); - IncPaintLock(); - if FMultisel=2 then - begin - if FMultisel3Data[idx]then Reindex(FMultisel3Data,array(idx:nil)); - else FMultisel3Data[idx]:= not FMultisel3Data[idx]; - InvalidateIdxRect(idx); - end else - if idx <> FSelBegin and idx <> FSelEnd then - begin - SelRange(false); - FSelBegin := FSelEnd := idx; - SelRange(true); - end - DecPaintLock(); - FIsMouseDown := true; - crect := ClientRect; - ps := array(clienttoscreen(crect[0],crect[1]),clienttoscreen(crect[2],crect[3])); - _wapi.clipcursor(ps); - end else - FIsMouseDown := false; - inherited; - end - function MouseMove(o,e);override; - begin - if FIsMouseDown then - begin - rc := ClientRect; - y := e.ypos; - dy := GetYScrollDelta(); - if y>rc[3]-4 then - begin - y += dy; - end else - if y<4 then - begin - y -= dy; - end - idx := GetIdxByYpos(y); - if idx<0 then return; - if FMultisel=2 then - begin - end else - if idx <> FSelEnd then - begin - IncPaintLock(); - SelRange(false); - if FMultisel=1 then FSelEnd := idx; - else - begin - FSelBegin := FSelEnd := idx; - end - SelRange(true); - DecPaintLock(); - end - EnsureIdxVisible(idx); - end - end - function PaintIdx(idx,rc,cvs);virtual; - begin - {** - @explan(说明)绘制项 %% - @param(item)(TCustomListItem) 项 %% - @param(rc)(array) 绘制区域%% - @param(cvs)(tcanvas) 画布 %% - **} - PaintIdxBkg(idx,rc,cvs); - PaintIdexText(idx,rc,cvs); - end - function PaintIdexText(idx,rc,cvs);virtual; - begin - cvs.DrawText(getItemText(idx),rc,DT_NOPREFIX); - end - function getCurrentSelection();virtual; - begin - {** - @explan(说明)获取当前选中项的索引，仅用于单选的列表框%% - **} - if FMultisel=0 then - begin - return FSelBegin; - end - return-1; - end - function setCurrentSelection(n);virtual; - begin - {** - @explan(说明)设置当前选中项的索引，仅用于单选的列表框%% - @param(n)(integer)%% - **} - if FMultisel=1 then - begin - if isValidIndex(n)then - begin - FSelBegin := FSelEnd := n; - InvalidateRect(nil,false); - end else - if ifarray(n)and isValidIndex(n[1])and isValidIndex(n[0])then - begin - FSelBegin := MinValue(n); - FSelEnd := MaxValue(n); - end - return; - end else - if FMultisel=2 then - begin - FMultisel3Data := array(); - if isValidIndex(n)then - begin - FMultisel3Data[n]:= true; - end else - if ifarray(n)then - begin - for i,v in n do - begin - if isValidIndex(v)then - begin - FMultisel3Data[v]:= true; - end - end - end - return; - end - if not isValidIndex(n)or n=FSelBegin then return; - SelRange(false); - FSelBegin := FSelEnd := n; - SelRange(true); - calldatafunction(FselectionChange,self(true),new tuieventbase(0,0,0,0)); - end - function getItemSelectedState(n); - begin - {** - @explan(说明)获取指定项的选中状态%% - @param(n)(integer)指定项下标%% - @return(bool)是否被选中%% - **} - if not isValidIndex(n)then return nil; - case FMultisel of - 0: - begin - return n=FSelBegin; - end - 1: - begin - if FSelBegin <= FSelEnd then return n >= FSelBegin and n <= FSelEnd; - return n >= FSelEnd and n <= FSelBegin; - end - 2: - begin - return FMultisel3Data[n]=1; - end - end - return nil; - end - function setItemSelectedState(n,state); - begin - {** - @explan(说明)设置指定项选中状态，仅用于非连续多选的列表框%% - @param(n)(integer)指定项索引%% - @param(state)(bool)状态%% - **} - b := state?1:0; - if FMultisel <> 2 or not isValidIndex(n)or b=getItemSelectedState(n)then return; - if b then FMultisel3Data[n]:= b; - else reindex(FMultisel3Data,array(n:nil)); - calldatafunction(FselectionChange,self(true),new tuieventbase(0,0,0,0)); - InvalidateIdxRect(n); - end - function appendItem(item);virtual; - begin - {** - @explan(说明)在列表框最后添加一个项%% - @param(item)(string)要添加的字符串%% - @return(integer)所添加项在列表框中的索引%% - **} - if CheckListItem(item)then - begin - FitemData.Push(item); - class(TCustomListBox).ItemCount := FitemData.length(); - return ItemCount-1; - end - return-1; - end - function appendItems(ari);virtual; - begin - {** - @explan(说明)在列表框最后添加多个项%% - @param(ari)(array)要添加的字符串组成的数组%% - @return(integer)所添加的最后一项在列表框中的索引%% - **} - if CheckListItems(ari)then - begin - FitemData.Pushs(ari); - class(TCustomListBox).ItemCount := FitemData.length(); - return ItemCount-1; - end - return-1; - end - function insertItem(item,n);virtual; - begin - {** - @explan(说明)在指定索引处插入一项%% - @param(item)(string)插入的字符串%% - @param(n)(integer)指定下标索引%% - @return(integer)返回插入的字符串的下标，出错则返回-1%% - **} - if ifnil(n)then return appendItem(item); - if FitemData.Length()<1 then return appendItem(item); - if isValidIndex(n)and CheckListItem(item)then - begin - SelectedChangeSwitch(n,1,1); - FitemData.splice(n,0,item); - class(TCustomListBox).ItemCount := FitemData.length(); - return n; - end - return-1; - end - function insertItems(ari,n);virtual; - begin - {** - @explan(说明)在指定索引处插入多个项，将该函数用于多选列表框将会导致所有选择项丢失%% - @param(ari)(array of string)插入项组成的数组%% - @param(n)(integer)指定下标索引，缺省则插至末尾%% - @return(integer)返回插入的最后的字符串的下标，出错则返回-1%% - **} - if ifnil(n)then return appendItems(ari); - if FitemData.Length()<1 then return appendItems(item); - if CheckListItems(ari)and isValidIndex(n)then - begin - SelectedChangeSwitch(n,length(ari),1); - FitemData.splices(n,0,ari); - class(TCustomListBox).ItemCount := FitemData.length(); - return n+length(ari)-1; - end else - return-1; - end - function deleteItem(n);override; - begin - {** - @explan(说明)删除指定的合法下标索引的项%% - @param(n)(integer)指定项下标索引%% - @return(integer)剩余的项的数量，出错则返回-1%% - **} - if not isValidIndex(n)then return-1; - SelectedChangeSwitch(n,1,0); - FitemData.splice(n,1); - class(TCustomListBox).ItemCount := FitemData.length(); - return FitemData.Length(); - end - function deleteItems(n,cnt); - begin - {** - @explan(说明)删除指定的合法下标处开始多个项%% - @param(n)(integer)指定项下标索引%% - @param(cnt)(integer)删除项数，当删除的项超过尾项时，删至尾项%% - @return(integer)剩余的项的数量，出错则返回-1%% - **} - if not isValidIndex(n)or cnt <= 0 then return-1; - SelectedChangeSwitch(n,cnt,0); - FitemData.splice(n,cnt); - class(TCustomListBox).ItemCount := FitemData.length(); - return FitemData.Length(); - end - function DeleteSelectedItems(); - begin - {** - @explan(说明) 删除选中的项目 %% - **} - if FMultisel=2 then - begin - if FMultisel3Data then - begin - r := array(); - ri := 0; - for i := 0 to FitemData.length()-1 do - if not FMultisel3Data[i] then r[ri++]:= FitemData[i]; - setdata(r); - end - end else - begin - if FSelBegin >= 0 and FSelEnd >= FSelBegin then - deleteItems(const FSelBegin,FSelEnd-FSelBegin+1); - end - end - function findStrBeginwith(str,b,n);virtual; - begin - {** - @explan(说明)在列表框中指定项之后查找以字符串开头的项，到达末尾即从头开始%% - @param(str)(string)给定字符串%% - @param(b)(bool)1:不区分大小写，0:区分大小写%% - @param(n)(integer)指定项下标，默认为-1%% - @return(integer)返回找到的项的下标，未找到则返回-1%% - **} - if ifnil(b)then b := 0; - if ifnil(n)then n :=-1; - if CheckListItem(str)and ifnumber(n)then - begin - if not isValidIndex(n)then n :=-1; - if b then - begin - return findBeginwithCaseIndepent(str,n); - end else - return findBeginwith(str,n); - end - ShowErrorMessage("function findStrBeginwith:ErrorParameter(s)"); - return-1; - end - function findStrExact(str,b,n);virtual; - begin - {** - @explan(说明)在列表框中指定项之后查找与字符串相同的项，到达末尾即从头开始%% - @param(str)(string)给定字符串%% - @param(b)(bool)1:不区分大小写，0:区分大小写，默认为0%% - @param(n)(integer)指定项下标，默认为-1%% - @return(integer)匹配项的索引，查找失败则返回-1%% - **} - if ifnil(b)then b := 0; - if ifnil(n)then n :=-1; - if CheckListItem(str)and ifnumber(n)then - begin - if not isValidIndex(n)then n :=-1; - if b then return findExactCaseIndepent(str,n); - else return findExact(str,n); - end - ShowErrorMessage("function findStrExact:ErrorParameter(s)"); - return-1; - end - function setData(ari);virtual; - begin - IncPaintLock(); - Clean(); - AppendItems(ari); - DecPaintLock(); - end - function getSelectedIndexes();virtual; - begin - {** - @explan(说明)获取列表框内当前选中项的索引组成的数组%% - @return(array)当未选中任何项时，返回空数组%% - **} - r := array(); - case FMultisel of - 0: - begin - return FSelBegin=-1?r:array(FSelBegin); - end - 1: - begin - if FSelBegin<0 then return r; - if FSelBegin <= FSelEnd then return FSelBegin -> FSelEnd; - else return FSelEnd -> FSelBegin; - end - 2: - begin - ri := 0; - for i,v in FMultisel3Data do r[ri++]:= i; - return r; - end - end - end - function getItem(n); - begin - {** - @explan(说明)获取指定项%% - @param(n)(integer)指定项下标%% - @return()指定项%% - **} - return FitemData[n]; - end - function getItemText(i);virtual; - begin - {** - @explan(说明) 获得item的文本 %% - @param(i)(integer) 序号 %% - @return(string) 项显示字符串 %% - **} - r := FitemData[i]; - if ifstring(r)then return r; - return ""; - end - function clean();virtual; - begin - FitemData.splice(0,FitemData.Length()); - cleanAllSelectedState(); - class(TCustomListBox).ItemCount := 0; - end - function Recycling();override; - begin - FselectionChange := nil; - return inherited; - end - property ItemCount read GetItemCount; - property Multisel:bool read FMultisel write SetMultisel; - property onSelectionChange:eventhandler read FselectionChange write FselectionChange; - property Items:strings read GetData write setData; - function publishs();override; - begin - return array("name","caption","anchors","align","enabled", - "font","visible","border","color", - "height","width","left","top","items", - "multisel","popupmenu","wsdlgmodalframe", - "onmousedown","onmouseup", - "onselectionchange" - ); - end - protected - function CheckListItems(s); - begin - if ifarray(s)then - begin - for i := 0 to length(s)-1 do if not CheckListItem(s[i])then return 0; - return 1; - end else - return 0; - end - function CheckListItem(s);virtual; - begin - {** - @explan(说明) 项检查,重写该方法可以控制项的类型 %% - **} - return ifstring(s); - end - function isValidIndex(n); - begin - return(n >= 0)and n= min(FSelBegin,FSelEnd)and idx <= max(FSelBegin,FSelEnd))or(FMultisel=2 and FMultisel3Data[idx])then - begin - cvs.brush.Color := rgb(204,231,255); - end else - cvs.Brush.Color := Color; - cvs.FillRect(rc); - end - function SetMultisel(n); - begin - if n <> FMultisel and(n in array(0,1,2))then - begin - SelRange(false); - FSelBegin := FSelEnd :=-1; - if n=2 then - begin - FMultisel3Data := array(); - end - FMultisel := n; - end - end - function GetData(); - begin - return FitemData.Data; - end - function findBeginwith(str,n); - begin - len := class(TCustomListBox).ItemCount; - while i++<> len do if AnsiStartsStr(str,getItem((i+n)%len))then return(i+n)%len; - return-1; - end - function findBeginwithCaseIndepent(str,n); - begin - len := class(TCustomListBox).ItemCount; - while i++<> len do if AnsiStartsText(str,getItem((i+n)%len))then return(i+n)%len; - return-1; - end - function findExact(str,n); - begin - len := class(TCustomListBox).ItemCount; - while i++<> len do if getItem((i+n)%len)=str then return(i+n)%len; - return-1; - end - function findExactCaseIndepent(str,n); - begin - len := class(TCustomListBox).ItemCount; - while i++<> len do if UpperCase(getItem((i+n)%len))=UpperCase(str)then return(i+n)%len; - return-1; - end - function SelRange(sel); - begin - if FSelBegin >= 0 and FSelEnd >= 0 then - begin - InvalidateIdxRect(min(FSelBegin,FSelEnd),abs(FSelBegin-FSelEnd)+1); - end - end - function SelectedChangeSwitch(idx,cnt,isAdd); - begin - case FMultisel of - 0: - begin - SelectedChange(idx,cnt,isAdd); - end - 1: - begin - cleanAllSelectedState(); - end - 2: - begin - MultiSelectedChange(idx,cnt,isAdd); - end - end; - end - function SelectedChange(idx,cnt,isAdd); - begin - //单选列表框在列表框项数增加或者删除时处理选中项的变动 - //idx 增删开始处索引 - //cnt 元素数量 - //isAdd 1：添加，0：删除 - if FSelBegin= idx+cnt then t := FSelBegin-cnt; - else - begin - t :=-1; - selchange := 1; - end - end - FSelBegin := FSelEnd := t; - if selchange then calldatafunction(FselectionChange,self(true),nil); - end - function MultiSelectedChange(idx,cnt,isAdd); - begin - //非连续的多选类型在列表框项数增加或者删除时处理选中项的变动 - //idx 增删开始处索引 - //cnt 元素数量 - //isAdd 1：添加，0：删除 - d := array(); - if isAdd then - begin - for i,v in FMultisel3Data do if v then d[i >= idx?i+cnt:i]:= 1; - end else - begin - selchange := 0; - back := idx+cnt; - for i,v in FMultisel3Data do if v then - begin - if i= back then d[i-cnt]:= 1; - else selchange := 1; - end - end - FMultisel3Data := d; - if selchange then calldatafunction(FselectionChange,self(true),nil); - end - function cleanAllSelectedState(); - begin - selchange := 0; - if FMultisel=2 then - begin - for i,v in FMultisel3Data do if v then selchange := 1; - FMultisel3Data := array(); - end else - begin - if FSelBegin <>-1 then selchange := 1; - FSelBegin := FSelEnd :=-1; - FFormerSelBegin := FFormerSelEnd :=-1; - end - if selchange then calldatafunction(FselectionChange,self(true),nil); - end - // FselectionCancel; - FselectionChange; - FSelBegin; - FSelEnd; - FIsMouseDown; - FMultisel; - FMultisel3Data; - FFormerSelBegin; - FFormerSelEnd; -end -type TColorbox=class(TListBox) + end + +end +type TColorbox=class(TcustomListBox) {** @explan(说明) color box 控件 %% **} @@ -15788,164 +2717,8 @@ type TColorbox=class(TListBox) end //combobox -type TCustomComboBox = class(TCustomControl) - {** - @explan(说明) combox 基类 %% - **} - function Create(AOwner);override; - begin - inherited; - FBtnWidth := 20; - FmaxListItemShow := 10; - FScreenRect := _wapi.GetScreenRect(); - FListBox := CreateAlist(); - if FListBox is class(TWinControl)then - begin - //FListBox.Parent := self(true); - FListBox.OnClose := function(o,e) - begin - e.skip := true; - o.Visible := false; - end - end - SetBoundsRect(array(0,0,100,23)); - end - function CreateAlist();virtual; - begin - {** - @expaln(说明) 构造一个弹出框 %% - @return(twincontrol) 弹出窗口 %% - **} - return ""; - end - function Paint();override; - begin - rc := ClientRect; - FBtnRect := rc; - dc := canvas; - FBtnRect[0]:= FBtnRect[2]-FBtnWidth; - dc.Draw("framecontrol",array(FBtnRect[0:1],FBtnRect[2:3]),DFC_SCROLL,1); - end - function MouseUp(o,e);override; - begin - if csDesigning in ComponentState then return; - x := e.xpos; - y := e.ypos; - if x>FBtnRect[0]and xFBtnRect[1]and y0 then - begin - nv := integer(v); - if nv <> FmaxListItemShow then - begin - FmaxListItemShow := nv; - end - end - end - function SetBtnWidth(n); - begin - if not(n>10 and n<100)then return; - nn := int(n); - if nn <> FBtnWidth then - begin - SetBtnWidth := nn; - InValidateRect(nil,false); - DoControlAlign(); - end - end - function GetItemIndex();virtual; - begin - end - function SetItemIndex();virtual; - begin - end -end -type TColorCombobox=class(TCustomComboBox) + +type TColorCombobox=class(TCustomComboBoxbase) {** @explan(说明) Tcolorcombobox 是一种颜色选择的combobox%% **} @@ -16066,216 +2839,13 @@ type TColorCombobox=class(TCustomComboBox) return FListBox.GetCurrentSelection(); end end -type TComboBox=class(TCustomComboBox) - {** - @explan(说明) comboBox下拉框 %% - **} - private - type TComboListBox=class(TListBox) - function Create(AOwner); - begin - inherited; - caption := "combox list box"; - end - function MouseUp(o,e);override; - begin - inherited; - visible := false; - end - end - public - function create(AOwner);override; +type TComboBox = class(TcustomComboBox) + + function create(AOwner); begin inherited; - FEdit := new TEdit(self); - FEdit.OnKeyDown := function(o,e) - begin - case e.charcode of - VK_UP: - begin - ItemIndex -= 1; - e.skip := true; - end - VK_DOWN: - begin - ItemIndex += 1; - e.skip := true; - end - end; - end - FEdit.onchange := function(o,e); - begin - if not o.Readonly then - begin - CallDataFunction(Foneditchanged,o,e); - end - end - FEdit.onupdate := function(o,e); - begin - if not o.Readonly then - begin - CallDataFunction(FoneditUpdate,o,e); - end - end - Freadonly := true; - FListBox.Border := true; - FListBox.Visible := false; - FListBox.WsPopUp := true; - FListBox.onselectionchange := function(o,e); - begin - FEdit.Text := getCurrentItemText(); - ShowDropDown(false); - calldatafunction(OnSelchanged,self,true); - end - FEdit.Readonly := Freadonly; - FListBox.parent := self; - FEdit.parent := self; - end - function CreateAlist();override; - begin - r := new TComboListBox(self); - return r; - end - function SetDesigning(Value,SetChildren);override; - begin - inherited; - if FEdit then FEdit.Enabled := not Value; - end - function DoControlAlign();override; - begin - rc := ClientRect; - rc[2]-= 20; - FEdit.SetBoundsRect(rc); - end - function appendItem(str);virtual; - begin - {** - @explan(说明)添加子项数据%% - @param(str)(string) 子项字符串%% - **} - FListBox.appendItem(str); - end - function AppendItems(arr);virtual; - begin - {** - @explan(说明)添加子项数据%% - @param(arr)(array of string) 子项字符串数组%% - **} - FListBox.appendItems(arr); - end - function insertItem(str,i);virtual; - begin - {** - @explan(说明)插入子项 %% - @param(str)(string) 显示标题 %% - @param(i)(integer) 在i前插入子项 %% - **} - FListBox.insertItem(str,i); - end - function deleteItem(i);virtual; - begin - {** - @explan(说明)删除子项 %% - @param(i)(integer) 删除子项的位置 %% - **} - FListBox.deleteItem(i); - end - function clean() - begin - {** - @explan(说明)清空数据 %% - **} - FListBox.Clean(); - end - function getitems(); - begin - {** - @explan(说明)获得所有数据 %% - @return(array of string) 字符串项 %% - **} - return FListBox.items(); - end - function GetItem(n); - begin - return FListBox.GetItem(n); - end - function getItemCount(); - begin - {** - @explan(说明)统计子项个数 %% - @return(integer)子项个数 %% - **} - //return _send_(CB_GETCOUNT,0,0); - return FListBox.ItemCount; - end - function getItemText(i); - begin - {** - @explan(说明)获取第i个子项的内容 %% - @param(i)(integer) 子项的位置 %% - @return(string) 子项标题 %% - **} - return FListBox.getItemText(i); - end - function getCurrentItemText(); - begin - {** - @explan(说明)获取选中的子项字符串 %% - @return(string) 子项字符串 %% - **} - return getItemText(FListBox.GetCurrentSelection()); - end - property readonly:bool read Freadonly write setReadOnly; - property textheight read FTextHeight Write FTextHeight; - property itemheight read FItemHeight write FItemHeight; - property items:strings read Getitems write setItems; - property oneditchanged:eventhandler read Foneditchanged write Foneditchanged; - property onEditUpdate:eventhandler read FoneditUpdate write FoneditUpdate; - property onkillfocus read Fonkillfocus write Fonkillfocus; - property onsetfocus read Fonsetfocus write Fonsetfocus; - property Editer read FEdit; - {** - @param(oneditchanged)(function[tcomboBox,tuieventbase])文本被改变回调,文本显示后调用%% - **} - function publishs();override; - begin - return array("name","font","border", - "visible","anchors","align","enabled", - "height","width","left","top", - "readonly","itemindex", - "items","oncloseup","ondropdown","onselchanged","oneditchanged","oneditupdate"); - end - function setReadOnly(v); - begin - nv := v?true:false; - if nv <> Freadonly then - begin - Freadonly := nv; - FEdit.Readonly := nv; - end - end - private - function GetItemIndex();override; - begin - return FListBox.GetCurrentSelection(); - end - function SetItemIndex(idx);override; - begin - return FListBox.SetCurrentSelection(idx); - end - FTextHeight; - FItemHeight; - Freadonly; - Foneditchanged; - FoneditUpdate; - Fonkillfocus; - Fonsetfocus; - FEdit; - function setItems(d); - begin - return FListBox.SetData(d); - end -end + end +end //工具栏,状态栏 type ttagNMCUSTOMDRAWINFO=class(tslcstructureobj) @@ -16313,791 +2883,19 @@ type ttagNMCUSTOMDRAWINFO=class(tslcstructureobj) end - type TToolButton = class(tcomponent) -{** - @explan(说明) 工具栏项 %% -**} - function Create(AOwner);override; +type TToolButton = class(TcustomToolButton) + function create(AOwner); begin inherited; - FCaption := "toolbtn"; //标题 - FImageId := -1; //imageid - FEnabled := true; //有效 可以点击 - FVisible := true; //可见 - end - - function ExecuteCommand(cmd,d);override; - begin - if cmd ="doshortcut" then //shortcut - begin - if csDesigning in ComponentState then return ; - if Enabled and Visible then - begin - if d = ShortCut then - begin - DoOnClick(self,new tuieventbase(0,0,0,0)); - return "havedoshortcut"; - end - end - end end - function DoOnClick(o,e);virtual; - begin - if action and action.Execute() then - begin - - end else - CallMessgeFunction(OnClick,o,e); - end - function GetRect(); - begin - {** - @explan(说明) 获得区域%% - @return(array) 区域 %% - **} - if parent and parent.HandleAllocated() then - return parent.GetItemRect(self); - end - function publishs();override; - begin - return array("name","caption","enabled","imageid","visible","onclick"); - end - function Recycling();override; - begin - if FToolbar then - begin - FToolbar.DeleteButton(self(true)); - end - - if FActionLink is class(TControlActionLink)then - begin - FActionLink.Recycling(); - FActionLink := nil; - end - FToolbar := nil; - inherited; - FCaption := ""; //标题 - FOnClick := nil; //点击 - FImageId := -1; //imageid - FEnabled := true; //有效 可以点击 - FVisible := true; //可见 - - end - property OnClick:eventhandler read FOnClick write FOnClick; - property Caption:string read FCaption write SetCaption; - property ImageId:integer read FImageId write SetImageId; - property Enabled:bool read FEnabled write SetEnabled; - property Visible:bool read FVisible write SetVisible; - property ToolBar read FToolbar write SetParent; - property Parent read FToolbar write SetParent; - property willaddBar read FWillAddbar; - property Action:taction read GetAction write SetAction; - property ShortCut read getShortCut write SetShortCut; - {** - @param(OnClick)(function[o:TToolButton;e:tuieventbase]) 点击消息 %% - @param(Caption)(string) 标题 %% - @param(ImageId)(integer) 图标id %% - @param(Enabled)(bool) 是否有效 %% - @param(Visible)(bool) 是否可见 %% - **} - private - FShortCut; - function getShortCut(); - begin - return formatshortcut(FShortCut); - end - - function SetShortCut(v); - begin - if v and ifstring(v) then - begin - nst := parsershortcutstr(v); - end else nst := nil; - if nst <> FShortCut then - begin - FShortCut := nst; - end - end - function SetParent(tb); - begin - if FToolbar=tb then return ; //相同 - if FWillAddbar = tb and tb then - begin - FToolbar :=tb; - FWillAddbar := nil; - return ; - end - if FToolbar<>tb then - begin - if FToolbar is class(TToolBar) then //删除 - begin - FWillAddbar := -1986; - FToolbar.DeleteButton(self(true)); - FWillAddbar := nil; - FToolbar := nil; - end - end - if tb is class(TToolBar) then - begin - FWillAddbar := tb; - tb.AddButton(self(true)); - SetParent(tb); - end - FWillAddbar := nil; - end - function SetCaption(s); - begin - if ifstring(s) and s<>FCaption then - begin - FCaption := s; - end - end - function SetEnabled(v); - begin - nv := v?true:false; - if nv <> FEnabled then - begin - FEnabled := nv; - if FToolbar then FToolbar.BtnChanged(); - end - end - function SetVisible(v); - begin - nv := v?true:false; - if nv<>FVisible then - begin - FVisible := nv; - if FToolbar then FToolbar.BtnChanged(); - end - end - - protected //action - function SetAction(Value);virtual; - begin - if ifnil(Value)then - begin - if FActionLink then - begin - FActionLink.SetAction(nil); - end - excludestate(FControlStyle,csActionClient); - end else - if Value is class(TBasicAction)then - begin - includestate(FControlStyle,csActionClient); - if ifnil(FActionLink)then FActionLink := createobject(GetActionLinkClass(),self); - FActionLink.Action := Value; - FActionLink.Onchange := thisfunction(DoActionChange); - ActionChange(Value,csLoading in Value.ComponentState); - Value.FreeNotification(Self); - end - end - procedure DoActionChange(Sender:TObject); - begin - if Sender=Action then ActionChange(Sender,False); - end - function GetAction();virtual; - begin - if FActionLink then - begin - return FActionLink.Action; - end - end - function GetActionLinkClass();virtual; - begin - {** - @explan(说明) 返回actionlinkclass %% - @return(TMenuActionLink class) - **} - return class(TtoolbuttonActionLink); - end - procedure ActionChange(Sender:TObject;CheckDefaults:Boolean);virtual; - begin - if Sender is class(TCustomAction)then - begin - NewAction := Sender; - if (not CheckDefaults) or (Caption='') or (Caption=Name) then Caption := NewAction.Caption; - if (not CheckDefaults) then ShortCut := NewAction.ShortCut; - if (not CheckDefaults) or Enabled then Enabled := NewAction.Enabled; - //if not CheckDefaults or FChecked then Checked := NewAction.Checked; - end; - end - protected - function SetImageId(id);virtual; - begin - if ifnumber(id) and id<>FImageId then - begin - FImageId := id; //刷新一下 - if FToolbar then FToolbar.BtnChanged();//FToolbar.InvalidateRect(nil,false); - end - end - private - FCaption; //标题 - FOnClick; //点击 - FCommandId; //command id 可以不要 - FImageId; //imageid - FEnabled; //有效 可以点击 - FVisible; //可见 - FToolbar; //工具栏 - FWillAddbar; - FActionLink; end -type TToolBar = class(TCustomControl) - {** - @explan(说明) 工具栏控件 %% - **} - function Create(AOwner);override; +type TToolBar = class( TcustomToolBar) + function create(AOwner); begin inherited; - height := 34; - Width := 300; - Align := alTop; - FButtons := new TMyArrayB(); - caption := "ToolBar"; - FBtnRects := array(); - FTipWnd := new TTipWnd(self); - FTipWnd.Parent := self; - FTimer := new TTimer(self); - FTimer.Interval := 200; - FTimer.Ontimer := thisfunction(DoTimerShowTip); - end - function MouseDown(o,e);override; - begin - if csDesigning in ComponentState then return ; - FShowLoked := true; - if e.Button()= mbLeft then - begin - FMouseDownIdx := PosInBtn(e.pos); - EndShowWnd(); - if FMouseDownIdx>=0 then - begin - if not(FButtons[FMouseDownIdx].Enabled) then - begin - FMouseDownIdx := -1; - return; - end - InvalidateRect(nil,false); - end - end - end - function MouseUp(o,e);override; - begin - if csDesigning in ComponentState then return ; - FShowLoked := false; - if e.Button()= mbLeft then - begin - idx := PosInBtn(e.pos); - if idx>=0 then - begin - if FMouseDownIdx = idx then begin - bi := FButtons[idx]; - bi.DoOnClick(bi,e); - end ; - end - end - if FMouseDownIdx >=0 then - begin - FMouseDownIdx := -1; - InvalidateRect(nil,false); - end - end - function MouseMove(o,e);override; - begin - if csDesigning in ComponentState then return ; - if FTimer.Enabled then return ; - idx := PosInBtn(e.pos); - if idx<0 then return; - FShowtimeIndexA := idx; - FTimer.Start(); - end - function CNALIGN(o,e):CN_ALIGN;override; - begin - case Align of - alTop,alBottom: - begin - bs := UnAlignBounds; - nh := CalcHeightFixWidth(e.width); - dh := nh-(bs[3]-bs[1]); - bs[3] +=dh; - FUnAlignBounds := bs; - end - alLeft,alRight: - begin - bs := UnAlignBounds; - nh := CalcWidthFixHeight(e.height); - dh := nh-(bs[2]-bs[0]); - bs[2] +=dh; - FUnAlignBounds := bs; - end - end - inherited; - end - function DoTimerShowTip(); //定时器 - begin - FCurrentPos := array(0,0); - _wapi.getcursorPos(FCurrentPos); - - FCurrentPos := ScreenToClient(FCurrentPos[0],FCurrentPos[1]); - idx := PosInBtn(FCurrentPos); - if idx<0 then - begin - EndShowWnd(); - FShowLoked := false; - FMouseDownIdx := -1; - InvalidateRect(nil,false); - return ; - end - if FShowLoked then return; - if FShowTimeIndexA = idx then //依然存在 - begin - if not FTipWnd.Visible then - begin - st := FButtons[idx].ShortCut; - FTipWnd.Tip := FButtons[idx].Caption + (st?(" ("+st+")"):"") ; - FTipWnd.ShowTIp(); - end - end else - begin - EndShowWnd(); - end end +end - function AddButton(btn); - begin - {** - @explan(说明) 添加工具栏项%% - **} - InsertButton(btn); - end - function SetBtnIndex(btn,idx); - begin - {** - @explan(说明) 修改按钮的位置 %%; - @param(btn)(TToolButton) 工具栏项 %% - @param(idx)(TToolButton | integer) 位置 %% - **} - if not(idx>=0) then return -1; - cidx := IndexOfBtn(btn); - if cidx<0 then return -1; - if cidx=idx then return idx; - btnlength := FButtons.Length(); - if idx>cidx then - begin - for i := cidx to min(btnlength-1,idx)-1 do - begin - FButtons.swap(i,i+1); - end - end else - begin - for i:= idx to cidx-1 do - begin - FButtons.swap(i,i+1); - end - end - if Btn.Visible then InvalidateRect(nil,false); - return cidx; - end - function InsertButton(btn,idx); - begin - {** - @explan(说明) 在指定位置插入按钮 %% - @param(btn)(TToolButton) 工具栏项 %% - @param(idx)(TToolButton | integer) 位置 %% - **} - if not(btn is class(TToolButton)) then return ; - cidx := IndexOfBtn(btn); - //位置计算 - if cidx>=0 then return ; - if btn.willaddBar<>self then - begin - return btn.parent := self(true); - end - FButtons.push(btn); - - nidx := nil; - if idx>=0 then nidx := idx; - else - if ifobj(idx) then nidx := IndexOfBtn(idx); - if nidx>=0 then - SetBtnIndex(btn,nidx); - - if btn.Visible then - begin - IncPaintLock(); - InvalidateRect(nil,false); - FWillModifyToolbar := true; - DecPaintLock(); - end - - end - function DeleteButton(btn); //删除按钮 - begin - {** - @explan(说明) 在删除按钮 %% - @explan(说明) 删除button %% - @param(btn)(TToolButton) 工具栏项%% - **} - idx := IndexOfBtn(btn); - if idx=-1 then return -1; - if btn.willaddBar<>-1986 then - begin - return btn.Parent := nil; - end - FButtons.splice(idx,1); - if btn.Visible then - begin - IncPaintLock(); - InvalidateRect(nil,false); - FWillModifyToolbar := true; - DecPaintLock(); - end - - end - function GetItemRect(btn); //获得按钮区域 - begin - {** - @explan(说明) 获得按钮的区域 %% - @param(btn)(TToolButton) 工具栏项%% - @return(array) 区域 %% - **} - idx := IndexOfBtn(btn); - if idx>=0 then - begin - return FBtnRects[idx]; - end - end - function IncPaintLock(); //锁定刷新 - begin - {** - @explan(说明) 锁定绘制,和 DecPaintLock() 成对使用 %% - **} - BeginUpdate(); - end - function DecPaintLock(); //释放刷新 - begin - {** - @explan(说明) 取消绘制锁定,和 IncPaintLock() 成对使用 %% - **} - EndUpdate(); - end - function CalcHeightFixWidth(w); - begin - {** - @explan(说明) 固定宽度计算工具栏高度 %% - @param(w)(integer) 给定宽度 %% - @return(intger) 计算的高度 %% - **} - bw := 0; - if WSSizebox then - begin - bw := 16; - end else - if WsDlgModalFrame then - begin - bw := 6; - end else - if Border then bw := 2; - imglst := ImageList; //图标 - imgw := 36; - imgh := 36; - if imglst is class(TCustomImageList) then - begin - imgw := imglst.Width+4; - imgh := imglst.height+4; - end - nh := w-bw; - bct := 0; - for i:= 0 to FButtons.Length()-1 do //调整大小 - begin - bi := FButtons[i]; - if not(bi.Visible) then - begin - continue; - end - bct++; - end - if bct=0 then return imgh+bw; - rct := integer((nh+2)/(imgw+1)); - if rct<1 then rct := 1; - //echo "总共:",bct,"每行:",rct,"===行数",(integer( bct/rct)+1),"\r\n"; - nt := bct/rct; - return ((frac(nt)>0)?(integer(nt)+1):(nt))*(imgh+1)+bw; - return (integer( bct/rct)+1)*(imgh+1)+bw; - end - function CalcWidthFixHeight(h); - begin - {** - @explan(说明) 固定高度计算工具栏宽度 %% - @param(w)(integer) 给定高度 %% - @return(intger) 宽度 %% - **} - bw := 0; - if WSSizebox then - begin - bw := 16; - end else - if WsDlgModalFrame then - begin - bw := 6; - end else - if Border then bw := 2; - imglst := ImageList; //图标 - imgw := 36; - imgh := 36; - if imglst is class(TCustomImageList) then - begin - imgw := imglst.Width+4; - imgh := imglst.height+4; - end - nh := h-bw; - bct := 0; - for i:= 0 to FButtons.Length()-1 do - begin - bi := FButtons[i]; - if not(bi.Visible) then - begin - continue; - end - bct++; - end - if bct=0 then return imgw+bw; - rct := integer((nh+2)/(imgh+1)); - if rct<1 then rct := 1; - nt := bct/rct; - return ((frac(nt)>0)?(integer(nt)+1):(nt))*(imgw+1)+bw; - return (integer( bct/rct)+1)*(imgw+1)+bw; - end - function Paint();override; - begin - c := canvas; - for i := 0 to FButtons.length()-1 do - begin - bi := FButtons[i]; - if not(bi.Visible) then continue; - ci := FBtnRects[i]; - if not ifarray(ci) then return ; - if FMouseDownIdx=i then - begin - c.draw("framecontrol",array(ci[0:1],ci[2:3]),DFC_BUTTON,DFCS_BUTTONCHECK); - end else - c.draw("framecontrol",array(ci[0:1],ci[2:3]),DFC_BUTTON,DFCS_BUTTONPUSH); - igslist := ImageList; - if igslist is class(TCustomImageList) then - begin - igid := bi.ImageId; - if igid>=0 and igid=0表示正确序号 %% - **} - for i := 0 to FButtons.Length()-1 do - begin - if btn=FButtons[i] then return i; - end - return -1; - end - function Recycling();override; - begin - while FButtons.Length()>0 do - begin - DeleteButton(FButtons[0]); - end - inherited; - FShowLoked := true; - FBtnRects := nil; - FButtons := nil; - FTipWnd := nil; - FShowtimeIndexA := nil; - FTimer := nil; - FCurrentPos := nil; - FMouseDownIdx := -1; - end - function BtnChanged(); - begin - CalcButtonsRect(); - InvalidateRect(nil,false); - end - function publishs();override; - begin - return array("name","align","caption","enabled","font","left","top","width","height", - "visible","imagelist"); - if Align<>alNone then - begin - return array("name","align","caption","enabled","font", - "visible","imagelist"); - end else - return array("name","align","caption","enabled","font","left","top","width","height", - "visible","imagelist"); - end - protected - procedure SetAlign(Value: TAlign); override; - begin - if Align = Value then exit; - if Value in array(alClient) then - begin - return ; - end - inherited; - end - function ImageChanged();override; - begin - if IsUpDating() then return ; - if Parent then - begin - Parent.DoControlAlign(); - CalcButtonsRect(); - InvalidateRect(nil,false); - end - end - private - function EndShowWnd(); - begin - FShowTimeIndexA := -1; - FTimer.Stop(); - FTipWnd.Visible := false; - end - function CalcButtonsRect(); - begin - if (IsUpDating()) then - begin - FWillModifyToolbar := true; - return ; - end - imglst := ImageList; //图标 - imgw := 36; - imgh := 36; - if imglst is class(TCustomImageList) then - begin - imgw := imglst.Width+4; - imgh := imglst.height+4; - end - rc := ClientRect; - FBtnRects := array(); - x := y := 0; - rct := 0; - - case Align of - alLeft,alRight: - begin - for i:= 0 to FButtons.Length()-1 do //调整大小 - begin - bi := FButtons[i]; - if not(bi.Visible) then - begin - FBtnRects[i] := array(0,0,0,0); - continue; - end - if y+imgh>rc[3] then - begin - if rct=0 then - begin - FBtnRects[i] := array(x,y,x+imgw,y+imgh); - y := 0; - x+=imgw+1; - end else - begin - y := 0; - x+=imgw+1; - FBtnRects[i] := array(x,y,x+imgw,y+imgh); - y+=imgh+1; - rct := 1; - end - end else - begin - FBtnRects[i] := array(x,y,x+imgw,y+imgh); - y+=imgh+1; - rct++; - end - end - end - else - begin - for i:= 0 to FButtons.Length()-1 do //调整大小 - begin - bi := FButtons[i]; - if not(bi.Visible) then - begin - FBtnRects[i] := array(0,0,0,0); - continue; - end - if x+imgw>rc[2] then - begin - if rct=0 then - begin - FBtnRects[i] := array(x,y,x+imgw,y+imgh); - x := 0; - y+=imgh+1; - end else - begin - x := 0; - y+=imgh+1; - FBtnRects[i] := array(x,y,x+imgw,y+imgh); - x+=imgw+1; - rct := 1; - end - end else - begin - FBtnRects[i] := array(x,y,x+imgw,y+imgh); - x+=imgw+1; - rct++; - end - end - end - end; - end - function PosInBtn(p); - begin - for i := 0 to FButtons.length()-1 do - begin - ri := FBtnRects[i]; - - if ri and pointinrect(p,ri) then - begin - return i; - end - end - return -1; - end - FShowLoked; - FBtnRects; - FButtons; - FTipWnd; - FShowtimeIndexA; - FTimer; - FCurrentPos; - FMouseDownIdx; - FWillModifyToolbar; -end type TStatusBar=class(TCustomControl) {** @explan(说明) 状态栏 %% @@ -17232,1169 +3030,20 @@ type TStatusBar=class(TCustomControl) **} end //树控件 -type TTreeCtlNode = class(TVirtualListItem) - {** - @explan(说明) 树结点 %% - **} - protected - FItems; //子项 - FParent; //父节点 - private - FBasePos;//周边基准位置 - FCheckPos; //checkbox位置 - FExpandPos; //展开按钮位置 - FExpandWidth; //展开按钮宽度 - FCheckWidth; //checkbox宽度 - FFocusColor; - //FNodeHash; - FHierarchyWidth; - function DrawCheckBox(cvs,x,rec,sz,flag); //绘制checkbox - begin - y := rec[1]; - h := rec[3]; - ys := y+(h-sz)/2; - dr := array((x,ys),(x+sz,ys+sz)); - ow := Owner; - dflg := flag; - if ow.OnlyLeafNodeCheckMark and ItemCount>0 then dflg := false; - cvs.Draw("FrameControl",dr,DFC_BUTTON,dflg?DFCS_CHECKED:DFCS_BUTTONCHECK); - if(not dflg)and(ItemCount>0)then - begin - if allChildChecked()then - begin - cvs.Draw("FrameControl",dr,DFC_BUTTON,DFCS_CHECKED); - end else - if ChildChecked()then - begin - cvs.brush.color := rgb(10,10,10); - cvs.fillrect(dr[0]+8 union dr[1]-4); - ow := Owner; - if self=ow.CurrentNode then cvs.brush.color := FFocusColor[ow.hasFocus()]; - else cvs.brush.color := ow.Color; - end - end - end - function DrawExpand(cvs,x,rec,sz,flag); //绘制展开按钮 - begin - sz2 := integer(sz/2); - y := rec[1]; - h := rec[3]; - ys := y+(h-sz)/2; - dr := array(array(x,ys),array(x+sz,ys+sz)); - cvs.draw("rectangle",dr); - cvs.MoveTo(array(x+2,ys+sz/2)); - cvs.LineTo(array(x+sz-2,ys+sz/2)); - if not flag then - begin - cvs.MoveTo(array(x+sz/2,ys+2)); - cvs.LineTo(array(x+sz/2,ys+sz-2)); - end - end - - function ChildChecked(); - begin - for i := 0 to FItems.Count-1 do - begin - it := FItems[i]; - ow := Owner; - if ow and ow.OnlyLeafNodeCheckMark then - begin - if it.checked and it.ItemCount<1 then return true; - if it.ChildChecked()then return true; - end else - begin - if it.Checked then return true; - if it.ChildChecked()then return true; - end - end - return false; - end - function allChildChecked(); - begin - if FItems.Count<1 then return false; - for i := 0 to FItems.Count-1 do - begin - it := FItems[i]; - if it.ItemCount<1 then - begin - if not it.Checked then return false; - end else - begin - if not it.allChildChecked()then return false; - end - end - return true; - end - public - function Paint(cvs,x,y,w,h);override; //绘制 - begin - {** - @explan(说明)绘制节点%% - **} - ow := Owner; - if not ow then return; - cvs.Pen.Color := rgb(50,50,50); - cvs.Pen.style := PS_SOLID; - cvs.Pen.width := 1; - inv := 3; - BasePos := FBasePos+x; - FCheckPos := BasePos; - fitemcountflg := ItemCount or FDirtype; - for i := 1 to Hierarchy do - BasePos += FHierarchyWidth; - cbase := BasePos; - itc := 0; - ExpWidth := FExpandWidth; - ifsel := false; - if self=ow.CurrentNode then - begin - ifsel := true; - cvs.brush.Color := FFocusColor[ow.hasFocus()]; - end else - cvs.brush.Color := ow.Color; - if fitemcountflg then - begin - itc := true; - BasePos += inv; - FExpandPos := BasePos; - DrawExpand(cvs,BasePos,array(x,y,w,h),ExpWidth-2,FExpanded); - BasePos += ExpWidth; - end else //else ExpWidth := 0; - begin - BasePos += ExpWidth+inv; - end - CheckWidth := FCheckWidth; - if ow.CheckBox then - begin - BasePos += inv; - FCheckPos := BasePos; - DrawCheckBox(cvs,BasePos,array(x,y,w,h),CheckWidth,FChecked); - BasePos += CheckWidth; - BasePos += inv; - end else - CheckWidth := false; - img := ow.ImageList; - iwidth := 0; - if(img and img.HandleAllocated())then - begin - if(ifsel and FSelImgId >= 0)or(FImgId >= 0)or(FExpandImgId >= 0 and fitemcountflg>0 and FExpanded)then //绘制selimage - begin - if(FExpandImgId >= 0)and fitemcountflg>0 and FExpanded then - begin - img.Draw(FExpandImgId,cvs,BasePos,y+1,nil); - end else - if(ifsel and FSelImgId >= 0)then - begin - img.Draw(FSelImgId,cvs,BasePos,y+1,nil); - end else - if FImgId >= 0 then - begin - img.Draw(FImgId,cvs,BasePos,y+1,nil); - end - BasePos += img.Height; - BasePos += inv; - end - //echo "\r\nimg"; - end - FCaptionRect := array(BasePos,y,x+1000,y+h); - cvs.FillRect(FCaptionRect); - cvs.drawtext(FCaption,FCaptionRect,DT_VCENTER .| DT_SINGLELINE .| DT_NOPREFIX); - if ow.HasLine then - begin - cvs.Pen.Color := rgb(150,150,150); - cvs.Pen.style := PS_DOT; - for i,v in ow.GetHierarchyByHandle(self.Handle) do - begin - FLG := TRUE; - //nx := cbase-FHierarchyWidth*(i+1)+6; - nx := cbase+FHierarchyWidth *(i-FHierarchy-1)+6; - if nx>cbase-5 then break; - cvs.MoveTo(array(nx,y)); - if i=FHierarchy and Parent.LastChild=self then - cvs.LineTo(array(nx,y+h/2+1)); - else cvs.LineTo(array(nx,y+h)); - end - cvs.MoveTo(array(cbase+ExpWidth,y+h/2)); - cvs.LineTo(array(cbase-FHierarchyWidth+6,y+h/2)); - end - end - function MouseUp(o,e); - begin - {** - @explan(说明) 点击消息处理 - **} - ps := e.pos; - px := ps[0]; - rec := o.GetIndexRect(o.GetItemIndexByYpos(e.ypos)); //获得位置 - recx := rec[0]; - if(FItems.Count or FDirtype)and px >= FExpandPos and px <=(FExpandPos+FExpandWidth)then //点击展开 - begin - if mbLeft=e.button()then - begin - if FExpanded then UnExpand(); - else Expand(); - end else - begin - e.skip := true; - end - end else - if Owner.CheckBox and MouseCanChecked and px >= FCheckPos and px <=(FCheckPos+FCheckWidth)then //点击checkbox - begin - //setprofiler(1+2+4); - if mbLeft=e.button()then - begin - Checked := not FChecked; - p := parent; - while p and(p is class(TTreeCtlNode)) do - begin - Owner.InvalidateItem(p,0); - p := p.parent; - end - end else - e.skip := true; - //exportfile(ftstream(),"","d:\\tst\\abc.stm",getprofilerinfo(true)); - end else - if px>FCheckPos then //点击文本 - begin - return true; - end - return false; - end - function Create(AOwner);override; +type TTreeCtlNode = class( TcustomTreeCtlNode) + function create(AOwner); begin inherited; - FMouseCanChecked := true; - FModifyChildrenChecked := true; - FFocusColor := array(rgb(230,240,250),rgb(0,192,250)); - //FNodeHash := array(); - FCheckWidth := 16; - FExpandWidth := 12; - FBasePos := 10; - FHierarchyWidth := 20; - FItems := new TFpList(); //子项 - FHierarchy :=-1; - FEexpanded := false; - FChecked := false; - FExpandImgId :=-1; - end - function GetNodeByIndex(idx); - begin - {** - @explan(说明) 通过序号获得子节点%% - @param(idx)(TTreeCtlNode) %% - **} - if idx >= 0 then return FItems[idx]; - return nil; - end - function indexof(v); //获得序号 - begin - return FItems.indexof(v); - end - function UpDateHierarchy(); //更新层级 - begin - if not Parent then return; - ph := Parent.Hierarchy; - nh := ph+1; - if FHierarchy <> nh then - begin - FHierarchy := nh; - for i := 0 to FItems.Count-1 do - begin - FItems[i].UpDateHierarchy(); - end - end - UpDateWidth(); - end - function AppendNodeStr(s);override; - begin - {** - @explan(说明) 追加一个节点 %% - @param(s)(string) 字符串 %% - @return(TTreeCtlNode) 新节点 %% - **} - ow := Owner; - idx := FItems.Count; - return InsertNodeStr(s,idx); - end - function InsertNodeStr(s,idx);override; - begin - {** - @explan(说明) 插入一个节点 %% - @param(s)(string) 字符串 %% - @param(idx)(integer) 序号 %% - @return(TTreeCtlNode) 新节点 %% - **} - if not(idx >= 0)then idx := 0; - ow := Owner; - if not ow then return; - it := ow.CreateTreeNode(ow); //new TTreeCtlNode(ow); - it.Caption := s; - InsertNode(it,idx); - return it; - end - function GetIndex();virtual; - begin - {** - @explan(说明) 获得在父节点中的序号 %% - @return(integer) 序号 %% - **} - if Parent then Parent.indexof(self); - end - function AncestorIsExpand();virtual; - begin - {** - @explan(说明) 是否一致展开 %% - @return(bool) 展开为true,否则为false %% - **} - r := Expanded; - if not(r)then return false; - if Parent then return Parent.AncestorIsExpand(); - return r; - end - function AppendNode(it);virtual; - begin - {** - @explan(说明) 插入一个节点 %% - @param(it)(TTreeCtlNode) 节点 %% - @return(bool) 是否成功 %% - **} - return InsertNode(it,FItems.Count); - end - function HasNode(nd);virtual; - begin - {** - @explan(说明) 是否为某个节点的祖先节点 %% - @param(nd)(TTreeCtlNode) 子节点 %% - @return(TTreeCtlNode|0) 如果为祖先节点,就返回查询节点的父节点 %% - **} - if not(nd is class(TTreeCtlNode))then return 0; - ow := Owner; - if not ow then return; - if ow <> nd.Owner then return 0; - p1 := nd.Parent; - p := p1; - while p do - begin - if p=self then return p1; - if p is class(TTreeCtlNode)then p := p.Parent; - end - return 0; - end - function DeleteNode(nd);virtual; - begin - {** - @explan(说明) 删除节点 %% - @param(nd)(TTreeCtlNode) 待删除节点 %% - **} - if nd=self then return 0; - pn := HasNode(nd); - if not pn then return; - return pn.DeleteChildNode(nd); - end - - function DeleteChildNode(nd); - begin - {** - @explan(说明) 删除子节点%% - @param(nd)(TTreeCtlNode) 节点 %% - **} - idx :=-1; - idx := indexof(nd); - if idx=-1 then return 0; - return DeleteNodeByIndex(idx); - end - function DeleteNodeByIndex(idx); - begin - {** - @explan(说明) 根据位置删除节点%% - @param(idx)(integer) 序号 %% - **} - nd := FItems[idx]; - if not nd then return; - try - Owner.IncPaintLock(); - nd.UnExpand(); - if Owner.NodeInList(nd)then //在显示 - begin - Owner.DeleteItemByIndex(Owner.GetItemIndex(nd)); - end - FItems.Deli(idx); - CurrentDeleteNode := nd; - nd.parent := self(true); - CurrentDeleteNode := nil; - finally - Owner.DecPaintLock(); - end - return true; - end - function DeleteChildren();virtual; // - begin - {** - @explan(说明) 删除所有的子节点%% - **} - try - Owner.IncPaintLock(); - r := true; - if self=Owner.RootNode then - begin - while ItemCount>0 DO - begin - DeleteChildNode(FItems[0]); - end - r := false; - end - if r then - begin - UnExpand(); //折叠 - while ItemCount>0 do - begin - idx := 0; //ItemCount-1; - it := FItems[idx]; - CurrentDeleteNode := it; - it.parent := self(true); - CurrentDeleteNode := nil; - FItems.Deli(idx); - end - end - finally - Owner.DecPaintLock(); - end - end - function GetLastShowNode(); - begin - {** - @explan(说明) 获得展示的最后第一个节点 %% - @return(TTreeCtlNode) %% - **} - if FItems.Count<1 or not(FExpanded)then return self; - it := FItems[FItems.Count-1]; - return it.GetLastShowNode(); - end - function InsertNodes(its,idx);virtual; - begin - {** - @explan(说明) 插入一个节点 %% - @param(it)( array of TTreeCtlNode) 字符串 %% - @param(idx)(integer) 序号 %% - **} - idx0 := idx; - if not(idx >= 0)then idx0 := 0; - if idx>FItems.Count then idx0 := FItems.Count; - nits := array(); - nitsi := 0; - flag := false; - bidx := idx0; - for i,it in its do - begin - if(it is class(TTreeCtlNode))and(not it.Parent)then - begin - odexp := it.Expanded; - it.UnExpand(); - FItems.InsertBefor(it,idx0); - CurrentAddNode := it; - it.Parent := self(true); - CurrentAddNode := nil; - it.UpDateHierarchy(); - nits[nitsi++]:= it; - idx0++; - flag := true; - end - end - if flag and Expanded and Owner.NodeInList(self)then - begin - preItem := FItems[bidx-1]; - bx := 0; - //if preItem then bx := Owner.GetItemIndex( preItem.GetLastShowNode())+1; - if preItem then bx := Owner.GetItemIndex(preItem.GetLastShowNode(),bidx)+1; - else bx := owner.GetItemIndex(self)+1; - owner.InsertItems(nits,bx); - end - end - function InsertNode(it,idx);virtual; - begin - {** - @explan(说明) 插入一个节点 %% - @param(it)(TTreeCtlNode) 字符串 %% - @param(idx)(integer) 序号 %% - **} - if(it is class(TTreeCtlNode))and(not it.Parent)then - begin - if idx<0 then idx := 0; - if idx>FItems.Count then idx := FItems.Count; - if not(idx >= 0)then idx := 0; - odexp := it.Expanded; - it.UnExpand(); - FItems.InsertBefor(it,idx); - CurrentAddNode := it; - it.Parent := self(true); - CurrentAddNode := nil; - it.UpDateHierarchy(); - if Expanded and Owner.NodeInList(self)then - begin - preItem := FItems[idx-1]; - bx := 0; - if preItem then bx := Owner.GetItemIndex(preItem.GetLastShowNode())+1; - else bx := owner.GetItemIndex(self)+1; - owner.InsertItem(it,bx); - end - return true; - end - end - function Expand();virtual; //展开 - begin - {** - @explan(说明) 展开节点 %% - **} - if Owner and Owner.RootNode=self then return; - if FExpanded then return; - if ItemCount<1 then //空节点展开 - begin - if FDirtype then - begin - Owner.EmptyNodeExpanding(self(true)); - end - return; - end - //if not Owner.NodeInList(self) then return; - idx :=-1; - if(Owner.NodeInList(self))then - begin - its := GetShowNodes(); - idx := Owner.GetItemIndex(self); - Owner.InsertItems(its,idx+1); - end - FExpanded := true; - //return true; - if Owner.SingleExpand then - begin - p := Parent; - if p is class(TTreeCtlNode)then - begin - PItems := p.FItems; - ct := PItems.Count; - if ct>1 then - begin - Owner.UpDateWindow(); - for i := 0 to ct-1 do - begin - vi := PItems[i]; - if vi=self then continue; - vi.UnExpand(); - end - end - end - end - if idx >= 0 then - begin - owner.InvalidateItem(self,flag); - end - return true; - end - function UnExpand();virtual; //折叠 - begin - {** - @explan(说明) 折叠节点 %% - **} - if Owner and Owner.RootNode=self then return; - if not FExpanded then return; - if ItemCount<1 then return; - idx :=-1; - idx := Owner.GetItemIndex(self); - it := GetLastShowNode(); - idx2 := Owner.GetItemIndex(it,idx); - owner.DeleteItemByBounds(idx+1,idx2); - //父节点为展开 - FExpanded := false; - if idx >= 0 then - begin - Owner.InvalidateItem(self,flag); - end - end - function RecyclingChildren();virtual; - begin - while ItemCount>0 do - begin - it := FItems[0]; - //echo "\r\n删除",it.Caption; - it.Recycling(); - end - end - function Recycling();override; - begin - p := FParent; - if p then - begin - p.DeleteNode(self); - end - while ItemCount>0 do - begin - it := FItems[0]; - it.Recycling(); - end - //if self<>Owner.RootNode then - inherited; - end - function GetShowItemCount(); - begin - r := 1; - if not FExpanded then return r; - for i := 0 to FItems.Count-1 do - begin - it := FItems[i]; - r++; - if it.ItemCount and it.Expanded then r += it.GetShowItemCount(); - end - return r; - end - function GetShowNodes(); - begin - {** - @explan(说明) 获得展开的所有子节点 %% - @return(array of TTreeCtlNode) %% - **} - lst := array(); - for i := 0 to FItems.Count-1 do - begin - it := FItems[i]; - lst union=array(it); - if it.ItemCount and it.Expanded then lst union=it.GetShowNodes(); - end - return lst; - end - function toarray();virtual; - begin - {** - @explan(说明) 转换为数组 %% - **} - r := array(); - r["type"]:= "treenode"; - r["caption"]:= FCaption; - mid := FImgId; - smid := FSelImgId; - r["imgid"]:= mid >= 0?mid:(-1); - r["selimgid"]:= smid >= 0?smid:(-1); - if _tag then r["tag"]:= _tag; - if Checked then r["checked"]:= true; - if ItemCount then - begin - r["nodes"]["type"]:= "treenodes"; - for i := 0 to ItemCount-1 do - begin - r["nodes"]["items"][i]:= GetNodeByIndex(i).toarray(); - end - end - return r; - end - property ImgId read FImgId write SetImgId; - property SelImgId read FSelImgId write SetSelImgId; - property ExpandImgId read FExpandImgId write SetExpandImgId; - property ItemCount read GetItemCount; //节点数 - property Hierarchy Read FHierarchy; //层次 - property Expanded read GetExpanded; //展开 - property Parent read FParent write SetParent; //父节点 - property Checked read FChecked write SetChecked; //选择 - property LastChild read GetLstChild; - property dirtype read FDirtype write FDirtype; //目录类型 - property Caption read FCaption write SetCaption; //标题 - property MouseCanChecked read FMouseCanChecked write FMouseCanChecked; - property ModifyChildrenChecked read FModifyChildrenChecked write FModifyChildrenChecked; - {** - @param(ItemCount)(integer) 子节点数量 %% - @param(Hierarchy)(integer) 层级 %% - @param(Handle)(pointer) 句柄 %% - @param(Expanded)(bool) 是否展开 %% - @param(Parent)(TTreeCtlNode) 父节点 %% - **} - protected property CurrentDeleteNode read FCurrentDeleteNode write FCurrentDeleteNode; - property CurrentAddNode read FCurrentAddNode write FCurrentAddNode; - function Gitems(); - begin - return FItems; - end - function SetParent(V);virtual; - begin - ow := Owner; - if not ow then return; - if ow.RootNode=self then return; - tp := Parent; - if(v is class(TTreeCtlNode))and v.Owner=ow then - begin - if v.CurrentAddNode=self then - begin - FParent := v; //新节点 - end else - if v.CurrentDeleteNode=self then //从节点移除 - begin - FParent := nil; - end else - begin - if tp=v then return; - if tp then - begin - tp.DeleteNode(self(true)); - end - v.InsertNode(self(true),v.ItemCount); - end - end else - begin - if tp then tp.DeleteNode(self(true)); - end - end - function SetChecked(v);virtual; //设置checked - begin - nv := v?true:false; - if nv <> FChecked then - begin - FChecked := nv; - if ModifyChildrenChecked then - begin - for i := 0 to ItemCount-1 do - begin - FItems[i].Checked := nv; - end - end - ow := Owner; - if ow then ow.InvalidateItem(self,false); - end - end - private - function GetLstChild(); - begin - return FItems[FItems.Count-1]; - end - function SetImgId(id); - begin - if(id>-2)and(id<1000)and id <> FImgId then - begin - FImgId := integer(id); - end - end - function SetExpandImgId(id); - begin - if id>-2 and(id<1000)and id <> FExpandImgId then - begin - FExpandImgId := integer(id); - end - end - function SetSelImgId(id); - begin - if(id>-2)and(id<1000)and id <> FSelImgId then - begin - FSelImgId := id; - end - end - FDirtype; - FImgId; - FMouseCanChecked; - FModifyChildrenChecked; - FSelImgId; - FCurrentDeleteNode; - FCurrentAddNode; - FExpanded; - FExpandImgId; - FHierarchy; //层级 - FCaption; //标题 - FChecked; //选择 - function SetCaption(v);virtual; //设置标题 - begin - if ifstring(v)and V <> FCaption then - begin - FCaption := v; - UpDateWidth(); - end - end - function UpDateWidth(); - begin - bwid := 60; - for i := 1 to FHierarchy do - begin - bwid += FHierarchyWidth; - end - if ifstring(FCaption)and FCaption then - begin - fw := 8; - if Owner then - begin - ft := Owner.Font; - fw := abs(ft.Width); - if fw=0 then fw := integer(abs(ft.Height)/2); - end - bwid += length(FCaption)* fw; - end - width := bwid; - end - function GetExpanded();virtual; //已经展开 - begin - if Owner and Owner.RootNode=self then return true; - return FExpanded; - end - function GetItemCount(); //子节点数 - begin - return FItems.Count; - end + end + end -type TTreeCtl = class(TVirtualList) - {** - @explan(说明) 树控件 %% - **} - type TTreeSelCHngedEvent=class(tuieventbase) - {** - @explan(说明) 导航选择改变消息%% - **} - function create(m,w,l,h);override; - begin - inherited; - end - ItemOld; - ItemNew; - Item; - end - function Create(AOwner);override; +type TTreeCtl = class(TcustomTreeCtl) + + function create(AOwner);override; begin inherited; - FSingleExpand := false; - FCheckBox := false; - FHasLine := false; - FNodeHierarchyWidth := 20; - FMulSelected := false; - FMulSelects := array(); - end - function InsertItem(it,idx);override; - begin - if it is class(TTreeCtlNode)then return inherited; - return false; - end - function InsertItems(its,idx);override; - begin - lst := array(); - lsti := 0; - for i,it in its do if it is class(TTreeCtlNode)then lst[lsti++]:= it; - inherited InsertItems(lst,idx); - end - function WMKEYUP(o,e):WM_KEYUP;virtual; - begin - if not FCurrentNode then return; - case e.charcode of - VK_UP,VK_DOWN: - begin - id := GetItemIndex(FCurrentNode); - setsel(GetItemByIndex((VK_UP=e.charcode)?(id-1):(id+1))); - end - VK_LEFT: - begin - if FCurrentNode.Expanded then - begin - FCurrentNode.UnExpand() - end - else - begin - p := FCurrentNode.Parent; - if RootNode=p then return ; - SetSel(p); - end - end - VK_RIGHT: - begin - FCurrentNode.Expand(); - end - end; - end - function hasFocus();virtual; - begin - return true; - end - function AppendItem(it);override; - begin - if it is class(TTreeCtlNode)then return inherited; - return false; - end - function SetSel(it);virtual; - begin - {** - @explan(说明) 设置选中节点 %% - @param(it)(TTreeCtlNode) 节点 %% - **} - if(it is class(TTreeCtlNode))and it.Owner=self then - begin - r := CallSelChange(it); - if r then return; - IF HandleAllocated()then - begin - GoToNode(it); - end - if not r then InValidateRect(nil,false); - //CallSelChange(it); - end - end - function GoToNode(it); - begin - if NodeInList(it)then - begin - //return SetTopLine(GetItemIndex(it)); //滚动 - idxs := GetClientItemIndexs(); - id := GetItemIndex(it); - if(idxs[0]<= id)and(idxs[length(idxs)-1]>= id)then //在可视窗口不需要滚动 - begin - return; - end else - begin - return SetTopLine(max(0,id-integer(length(idxs)/2))); //滚动 +integer(length(idxs)/2) - end - end else - begin - p := it.Parent; - while p do - begin - p.Expand(); - if NodeInList(p)then - begin - f := true; - break; - end - p := p.parent; - end - if f then return GoToNode(it); - end - end - function InitializeWnd();override; - begin - inherited; - if FCurrentNode then GoToNode(FCurrentNode); - end - function imageChanged();override; - begin - if imageList is class(TCustomImageList)then - begin - FBKItemHeight := ItemHeight; - ItemHeight := imageList.Height+2; - end else - begin - if FBKItemHeight>5 then ItemHeight := FBKItemHeight; - end - inherited; - end - function CreateNode();virtual; - begin - {** - @ignore(忽略) %% - **} - return CreateTreeNode(); - r := new TTreeCtlNode(self(true)); - return r; - end - function CreateTreeNode();virtual; - begin - r := new TTreeCtlNode(self(true)); - return r; - end - function DeleteNode(nd);virtual; - begin - if FRootItem then FRootItem.DeleteNode(nd); - end - function NodeInList(it); - begin - {** - @explan(说明)节点是否在窗口中展示 %% - **} - if it=FRootItem then return FRootItem; - return ItemInList(it); - end - function MouseDown(o,e);override; - begin - if e.shiftdouble()and e.button()=mbLeft then //双击 - begin - //添加双击折叠展开 - it := GetItemByYpos(e.ypos); - if it and(it.ItemCount or it.dirtype)and not(it.Expanded)then it.Expand(); - else if it and it.ItemCount and it.Expanded then - begin - it.UnExpand(); - end else - CallMessgeFunction(ondblclick,o,e); - end - end - function MouseUp(o,e);override; - begin - {** - @explan(说明)点击%% - **} - if csDesigning in ComponentState then return; - it := GetItemByYpos(e.ypos); - if it then - begin - if it.MouseUp(o,e)then - begin - SetSel(it); - //CallSelChange(it); //单选 - //多选 - end - end - bt := e.button(); - if bt=mbRight then - begin - CallMessgeFunction(onrclick,o,e); - end else - if bt=mbLeft then - begin - CallMessgeFunction(onclick,o,e); - end - //e.skip := true; - end - function Recycling();override; - begin - //setprofiler(1+2+4); - //exportfile(ftstream(),"","d:\\tst\\abc.stm",getprofilerinfo(true)); - if FRootItem then FRootItem.Recycling(); - FRootItem := nil; - FCurrentNode := nil; - FOnSelChanging := nil; - FonEmptyNodeExapanding := nil; - FNodeHierarchyWidth := 20; - inherited; - end - function GetHierarchyByHandle(h); - begin - if FPaintArray then return FPaintArray[h]; - end - function EmptyNodeExpanding(item); - begin - if HandleAllocated()then - begin - e := new TTreeSelCHngedEvent(self.Handle,0,0,0); - e.item := item; - e.ItemNew := item; - e.ItemOld := item; - calldatafunction(onEmptyNodeExapanding,self(true),e); - end - end - function Clean();override; - begin - if FRootItem then - begin - FRootItem.DeleteChildren(); - end - end - property CurrentNode read FCurrentNode; - property CheckBox:bool read FCheckBox write SetCheckBox; - property HasLine:bool read FHasLine write SetHasLine; - property OnlyLeafNodeCheckMark read FOnlyLeafNodeCheckMark write FOnlyLeafNodeCheckMark; - //property NodeHierarchyWidth read FNodeHierarchyWidth write SetNodeHierarchyWidth; - property RootNode read GetRootNode; - //property MulSelected read FMulSelected write FMulSelected; - property SingleExpand read FSingleExpand write FSingleExpand; - property OnSelChanged:eventhandler read FOnSelChanged write FOnSelChanged; - property OnSelChanging:eventhandler read FOnSelChanging write FOnSelChanging; - property onEmptyNodeExapanding read FonEmptyNodeExapanding write FonEmptyNodeExapanding; - protected - function GetRootNode();virtual; //获得根节点 - begin - if not(FRootItem)or(ifobj(FRootItem)and(FRootItem.ReCycleState <> 0))then - begin - FRootItem := CreateTreeNode(); - end - //echo FRootItem.Owner,"\r\n"; - return FRootItem; - end - private - FOnlyLeafNodeCheckMark; - FNodeHierarchyWidth; - FMulSelected; - FMulSelects; - function SetNodeHierarchyWidth(v); - begin - if v >= 0 and FNodeHierarchyWidth <> v then - begin - end - end - function CallSelChange(it); - begin - r := 0; - if FCurrentNode <> it then - begin - t1 := FCurrentNode; - //if t1 then InvalidateItem(t1,false); - //InvalidateItem(it,false); - ne := new TTreeSelCHngedEvent(self.Handle,1,1,1); - ne.ItemOld := t1; - ne.ItemNew := it; - ne.Item := it; - CallDatafunction(FOnSelChanging,self(true),ne); - if ne.Skip then return true; - FCurrentNode := it; - CallDataFunction(FOnSelChanged,self(true),ne); - end - return r; - end - FOnSelChanging; - FonEmptyNodeExapanding; - FSingleExpand; - FBKItemHeight; - FOnSelChanged; - FCurrentNode; - FRootItem; - FCheckBox; - FHasLine; - FPaintArray; - function PrevPaint(begid,endid);virtual; - begin - if not FHasLine then return; - currentline := array(); - FPaintArray := array(); - lasthi := 0; - Chi := 0; - //sh := new TMyArrayB(); - for i := ItemCount-1 downto begid do - begin - if not it then - begin - it := GetItemByIndex(i); - lasthi := it.Hierarchy; - if lasthi<1 then continue; - currentline[lasthi]:= 1; - end else - begin - it2 := GetItemByIndex(i); - chi := it2.Hierarchy; - if chi>0 then - begin - currentline[chi]:= 1; - if chi= lasthi then - begin - currentline[chi]:= 1; - end - end - end - lasthi := chi; - if it2 then it := it2; - if i <= endid and it then - begin - FPaintArray[it.Handle]:= currentline; - //sh.unshift( array(array2str(mrows( currentline,1),","),"===>"+inttostr(it.Hierarchy),"%%"+it.caption)); - end - end - end - function SetHasLine(v); //hasline - begin - nv := v?true:false; - if nv <> FHasLine then - begin - FHasLine := nv; - InvalidateRect(nil,false); - end - end - function SetCheckBox(v); - begin - bv := v?true:false; - if bv <> FCheckBox then - begin - FCheckBox := bv; - end - end -end + end +end type TTreeNode=class(TTreeCtlNode) {** @@ -19900,1189 +4549,14 @@ type ttagNMLISTVIEW=class(tslcstructureobj) inherited create(getstruct(),ptr); end end +type TGridCtl = class(TcustomGridCtl) -type TGridCtl = class(TCustomControl) - {** - @explan(说明) 自绘制表格控件 %% - **} - function Create(AOwner);override; + function create(AOwner);override; begin inherited; - FLocalX := 0; - FLocalY := 0; - Width := 300; - Height := 260; - FMouseSizeColumnWidth := 1; - FAutoScroll := 3; - FItemCount := 0; - FFixedRows := 1; - FColumFixed := 0; - FColWidth := 5; //10; - FRowWidth := 10; - FC_NORMAL := OCR_NORMAL; - FC_SIZE := OCR_SIZEWE; - FC_SIZE2 := OCR_SIZENS; - FMarginLeft := 1; - FMarginTop := 1; - FMarginRight := 0; - FMarginBottom := 0; - FRowHeight := 30; - FColsWidths := new TMyArrayB(); - FRowsHeight := new TMyArrayB(); - FVariableRows := false; - FSI := new TScrollinfo(); - end - function GetItemRect(i);virtual; - begin - {** - @explan(说明) 获得行的区域 %% - @param(i)(integer) 行号 %% - @return(array) array(左,上,右,下); - **} - yrct := GetItemYBound(i); - if not yrct then return nil; - basex := FMarginLeft-FColWidth * GetXpos(); - //r := array(basex,yrct[0],yrct[1],0); - r := array(basex,yrct[0],0,yrct[1]); - for ii := 0 to FColsWidths.length()-1 do - begin - basex += FColsWidths[ii]; - end - r[2]:= basex; - return r; - end - function GetItemStartY(i);virtual; - begin - {** - @explan(说明) 获得行的区域范围 %% - @param(i)(integer) 行号 %% - @return(array) array(上,下); - **} - if(i<0 or i >= GetItemCount())then return nil; - yb := FMarginTop; - itv := FRowHeight; - if FVariableRows then - begin - for ii := 0 to i-1 do - begin - yb += FRowsHeight[ii]; - end - itv := FRowWidth; - end else - yb += i * FRowHeight; - if i= 0 and j= x then return i; - if basex >= x then return i; - end - return r; - end - function InvalidateItem(i);virtual; - begin - {** - @explan(说明) 刷新行%% - @param(i)(integer) 行号 %% - **} - bd := GetItemYBound(i); - if not bd then return false; - rec := ClientRect; - if bd[1]>rec[3]or bd[0]rec[3]or rec1[3]rec[2]or rec1[2]= x then return i; - if basex >= x then return i; - end - end else - begin - r := integer((y-FMarginTop)/FRowHeight); - if y <= FYfiexed then - begin - if r >= FItemCount then return-1; - return r; - end - ybase := GetYPos(); - r += ybase; - if r >= FItemCount then return-1; - return r; - end - return r; - end - function SetColumns(cls,beg,len);virtual; - begin - {** - @explan(说明) 设置列宽信息 %% - @param(cls)(array of integer) 列宽 %% - @param(beg)(integer) 开始位置 %% - @param(len)(integer) 替代长度 %% - **} - clsa := array(); - for i,v in cls do - begin - if v >= 0 then clsa[length(clsa)]:= v; - end - FColsWidths.splices(beg>0?beg:0,len >= 0?len:FColsWidths.Length(),clsa); - InitialScroll(nil,nil,0); - end - function SetRows(rows,beg,len);virtual; - begin - if not FVariableRows then return; - clsa := array(); - for i,v in rows do - begin - if v>0 then clsa[length(clsa)]:= v; - end - FRowsHeight.splices(beg>0?beg:0,len >= 0?len:FRowsHeight.Length(),clsa); - InitialScroll(nil,nil,0); - end - function GetColumnWidth(i); - begin - {** - @explan(说明) 获得第i列宽度 %% - @param(i)(integer) 列号 %% - @return(integer) 宽度 %% - **} - return FColsWidths[i]; - end - function SetColumnWidth(i,w); - begin - {** - @explan(说明) 设置列宽 %% - @param(i)(integer) 列序号 %% - @param(w)(integer) 新宽度 0 %% - **} - vi := FColsWidths[i]; - if vi >= 0 and w >= 0 and vi <> w then UpDateColumWidth(i,w); - end - function DrawCell(cvs,rec,i,j);virtual; - begin - {** - @explan(说明) 绘制单元格 %% - @param(cvs)(tcanvas) 画布 %% - @param(rec)(array) array(左上右下) %% - @param(i)(integer) 行号 %% - @param(j)(integer) 列号 %% - **} - dr := array(rec[0:1],rec[2:3]); - if i0 then ps[2]:= min(ClientRect[2]-FMarginRight,ps[2]); - if FMarginBottom>0 then ps[3]:= min(ClientRect[3]-FMarginBottom,ps[3]); - FValidateRect := ps; - tp := ps[1]; - bo := ps[3]; - //***************计算表头区域******************* - basex := FMarginLeft-xpos * FColWidth; - x := basex; - x2 := FMarginLeft; - cvs.Font := font; - drawcol := array(); - for i,v in FColsWidths.Data do - begin - if i= ps[0])and x2= FColumFixed then - begin - if(x+v >= ps[0])and x= ps[1])and y2= FFixedRows then - begin - if(y+v >= ps[1])and y= vj[1]then continue; - for i,vi in drawrow do - begin - if i= FColumFixed then - begin - if FindMerge(i,j,mergb)then - begin - end else - partb[partbl++]:= array(array(vj[0],vi[0],vj[1],vi[1]),i,j); - end else - if i >= FFixedRows and j= FFixedRows and j >= FColumFixed then - begin - if FindMerge(i,j,mergd)then - begin - end else - partd[partdl++]:= array(array(vj[0],vi[0],vj[1],vi[1]),i,j); - end - end - end - if parta or merga then - begin - DrawAllParts(cvs,parta,merga,array(FMarginLeft,FMarginTop,FXfiexed,FYfiexed)); - end - if partb or mergb then - begin - DrawAllParts(cvs,partb,mergb,array(FXfiexed,FMarginTop,ps[2],FYfiexed)); - end - if partc or mergc then - begin - DrawAllParts(cvs,partc,mergc,array(FMarginLeft,FYfiexed,FXfiexed,ps[3])); - end - if partd or mergd then - begin - DrawAllParts(cvs,partd,mergd,array(FXfiexed,FYfiexed,ps[2],ps[3])); - end - end - function MouseDown(o,e);override; - begin - if csDesigning in ComponentState then return false; - if e.button()<> mbLeft then return false; - if FC_CURRENT=FC_SIZE then //调整大小 - begin - FSizeColum := 1; - _wapi.ClipCursor(FCursorRect); - return true; - end else - if FC_CURRENT=FC_SIZE2 then - begin - FSizeColum := 2; - _wapi.ClipCursor(FCursorRect); - return true; - end - end - function MouseUp(o,e);override; - begin - if FSizeColum then - begin - FSizeColum := false; - _wapi.ClipCursor(0); - return true; - end - end - function MouseMove(o,e);override; - begin - if csDesigning in ComponentState then return false; - if not FMouseSizeColumnWidth then - begin - setcursornormal(); - return 0; - end - y := e.yPos; - X := e.xpos; - if FMouseSizeColumnWidth .& 1>0 then - begin - if x0)and FVariableRows then - begin - basey := FMarginTop; - if y >= FYfiexed then - begin - xdx := GetYpos(); - basey := FMarginTop-FRowWidth * xdx; - end - end - if(FMouseSizeColumnWidth=0)then - begin - setcursornormal(); - return 0; - end - if FColsWidths.length()>0 and GetItemCount()>0 and x>(FMarginLeft+5)and y>(FMarginTop+5) {and y<(FMarginTop+FRowHeight*FFixedRows) }then - begin - if FSizeColum=1 then - begin - wd := FColsWidths[FCurrentSizeId]; - UpDateColumWidth(FCurrentSizeId,wd+x-FCurrentSizePos); - FCurrentSizePos := x; - return true; - end else - if FSizeColum=2 then - begin - wd := FRowsHeight[FCurrentSizeId]; - UpDateRowWidth(FCurrentSizeId,wd+y-FCurrentSizePos); - FCurrentSizePos := y; - return true; - end else - begin - bx := basex; - rc := ClientRect; - if FMouseSizeColumnWidth .& 1>0 then - begin - for i,v in FColsWidths.Data do - begin - if abs(x-bx-v)<3 then - begin - FCurrentSizeId := i; - FCurrentSizePos := x; - FCursorRect := array(clientToScreen(max(bx+6,rc[0]+6),y-10),clientToScreen(rc[2],y+10)); - setcursorsize(); - return true; - end - bx += v; - end - end - if FVariableRows and(FMouseSizeColumnWidth .& 2>0)then - begin - bx := basey; - for i,v in FRowsHeight.Data do - begin - if abs(y-bx-v)<3 then - begin - FCurrentSizeId := i; - FCurrentSizePos := y; - FCursorRect := array(clientToScreen(x-10,max(rc[1]+6,bx+6)),clientToScreen(x+10,rc[3])); - setcursorsize2(); - return true; - end - bx += v; - end - end - end - end - setcursornormal(); - return false; - end - //系统处理函数 - function DoWMSIZE(o,e);override; //大小调整 - begin - InitialScroll(e.lolParam,e.hilparam); - inherited; - end - function DoMouseWheel(o,e);override; - begin - hwnd := self.Handle; - FSI.fMask := SIF_ALL; - _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); - // 保存当前滑块位置，迟些进行比较 - yPos := FSI.nPos; - dd := 0; - if e.delta<0 and FSI.nMax>yPos then - begin - dd++; - end - if e.delta>0 and FSI.nMin yPos)then - begin - //_wapi.ScrollWindow(hwnd, 0, FRowHeight * (yPos - FSI.nPos), nil, ClipScroll()); - ivrect := ClientRect; - ivrect[1]:= FYfiexed; //FMarginTop+FRowHeight*FFixedRows; - InvalidateRect(ivrect,false); - //UpdateWindow(hwnd); - end - return 0; - end - function DoHScroll(o,e);override; - begin - FSI.fMask := SIF_ALL; - _wapi.GetScrollInfo(e.hwnd,SB_HORZ,FSI._getptr_); - // 保存当前滑块位置，迟些进行比较 - xPos := FSI.nPos; - case e.lowparam of - // 用户点击滚动条左边的三角形 - SB_LEFT: - begin - FSI.nPos := FSI.nMin; - end - SB_RIGHT: - begin - FSI.nPos := FSI.nMax; - end - SB_LINELEFT: - begin - FSI.nPos -= 1; - end - // 用户点击滚动条右边的三角形 - SB_LINERIGHT: - begin - FSI.nPos += 1; - end - // 用户点击滑块左边的滚动条轴 - SB_PAGELEFT: - begin - FSI.nPos -= FSI.nPage; - end - // 用户点击滑块右边的滚动条轴 - SB_PAGERIGHT: - begin - FSI.nPos += FSI.nPage; - end - // 用户拖动滚动条 - SB_THUMBTRACK: - begin - FSI.nPos := FSI.nTrackPos; - end - end; - if FSI.nPos=xPos then return; - // 设置滚动条滑块的新位置 - FSI.fMask := SIF_POS; - _wapi.SetScrollInfo(e.hwnd,SB_HORZ,FSI._getptr_,TRUE); - // 获得滚动条滑块的位置，由于窗口调整，它可能不是同一个值 - _wapi.GetScrollInfo(e.hwnd,SB_HORZ,FSI._getptr_); - // 与此前的保存的值进行比较，如果不同则滚动窗口 - FLocalX := FSI.nPos; - if(FSI.nPos <> xPos)then - begin - //_wapi.ScrollWindow(e.hwnd, FColWidth * (xPos - FSI.nPos), 0, NIL,ClipScroll()); - ivrect := ClientRect; - ivrect[0]:= FXfiexed; //FMarginTop+FRowHeight*FFixedRows; - InvalidateRect(ivrect,false); - //UpdateWindow(hwnd); - end - end - function MergeCells(cells); - begin - {** - @explan(说明) 单元格 %% - @param(cells)(array) array(开始行,开始列,结束行,结束列) %% - **} - nm := new TMerger(); - nm.SetMergeCells(cells); - if nm.isok then - begin - if not ifarray(FMergers)then FMergers := array(); - FMergers[length(FMergers)]:= nm; - end - end - function GetMergeInfo(); - begin - {** - @explan(说明) 获得合并信息 %% - **} - r := array(); - for i,v in FMergers do - begin - r[i]:= v.FCells; - end - return r; - end - function CleanMergeCells(); - begin - {** - @explan(说明) 清空合并信息 %% - **} - FMergers := array(); - end - function GetGridMargin(); - begin - return array(FMarginLeft,FMarginTop,FMarginRight,FMarginBottom); - end - function SetGridMargin(l,t,r,b); - begin - if l >= 0 then nl := integer(l); - if t >= 0 then nt := integer(t); - if r >= 0 then nr := integer(r); - if b >= 0 then nb := integer(b); - f := false; - if nl >= 0 and nl <> FMarginLeft then - begin - f := true; - FMarginLeft := nl; - end - if nt >= 0 and nt <> FMarginTop then - begin - f := true; - FMarginTop := nt; - end - if nr >= 0 and nr <> FMarginRight then - begin - //f := true; - FMarginRight := nr; - end - if nb >= 0 and nb <> FMarginBottom then - begin - //f := true; - FMarginBottom := nb; - end - if f then InitialScroll(nil,nil,0); - end - //******************* - property AutoScroll read FAutoScroll write setAutoScroll; - property ItemCount read GetItemCount write SetItemCount; - property ItemHeight read FRowHeight write SetRowHeigt; - property MouseSizeCell read FMouseSizeColumnWidth write FMouseSizeColumnWidth; - property FixedRows read FFixedRows write SetFixedRows; - property FixedColumns read FColumFixed write SetFixedColumns; - property ColumnCount read GetColumnCount; - property VariableRows read FVariableRows write SetVariableRows; - {** - @param(ItemCount)(integer) 行数 %% - @param(MouseSizeCell)(bool) 鼠标改变列宽 %% - @param(FixedRows)(integer) 固定的行数作为列标 %% - **} - protected - function ItemUpDated(flag,idx);virtual; - begin - {** - @explan(说明) 更新状态 %% - @param(flag)(bool) 是否强制刷新,默认当项宽度不变的时候不刷新 %% - @param(idx)(integer) 更新id以后的序号 %% - **} - if HandleAllocated()and not(IsUpDating())then - begin - InitialScroll(nil,nil,idx); - end - end - function InitialScroll(x,y,idx);virtual; - begin - if not HandleAllocated()then return; - UpDateFixed(); - if IsUpDating()then return; - if not(x>0 and y>0)then - begin - rc := ClientRect; - xClient := rc[2]; - yClient := rc[3]; - end else - begin - xClient := x; - yClient := y; - end - xClient -= FXfiexed; - yClient -= FYfiexed; - if xClient FVariableRows then - begin - if not FVariableRows then - begin - if FItemCount>0 then - begin - FRowsHeight.splices(0,FRowsHeight.length(),(zeros(FItemCount)+FRowHeight)); - end - end else - begin - FItemCount := FRowsHeight.Length(); - end - FVariableRows := nv; - InitialScroll(nil,nil,0); - end - end - function setAutoScroll(sc); - begin - if not(nv in array(0,1,2,3))then return 0; - if FAutoScroll <> sc then - begin - FAutoScroll := sc; - InitialScroll(nil,nil,0); - end - end - function GetColumnCount(); - begin - return FColsWidths.length(); - end + end +end - function SetItemCount(ct); - begin - if FItemCount <> ct and ct >= 0 then - begin - FItemCount := ct; - if not FVariableRows then InitialScroll(nil,nil,0); - end - end - function SetRowHeigt(h); - begin - if FRowHeight <> h and h >= 5 then - begin - FRowHeight := h; - InitialScroll(nil,nil,0); - end - end - function SetFixedColumns(rs); - begin - if rs >= 0 and FColumFixed <> rs then - begin - FColumFixed := rs; - InitialScroll(nil,nil,0); - end - end - function SetFixedRows(rs); - begin - if rs >= 0 and FFixedRows <> rs then - begin - FFixedRows := rs; - InitialScroll(nil,nil,0); - end - end - - function UpDateColumWidth(idx,value); - begin - if idx >= 0 and value >= 0 then - begin - if FColsWidths[idx]=value then return; - FColsWidths[idx]:= value; - InitialScroll(nil,nil,0); - end - end - function UpDateRowWidth(idx,value); - begin - if FVariableRows and idx >= 0 and value>0 then - begin - if FRowsHeight[idx]=value then return; - FRowsHeight[idx]:= value; - InitialScroll(nil,nil,0); - end - end - - function UpDateFixed(); //更新固定宽度 - begin - xfix := 0; - FxWidth := 0; - nx := min(FColumFixed,FColsWidths.length())-1; - for i := 0 to FColsWidths.length()-1 do - begin - vi := FColsWidths[i]; - if i <= nx then xfix += vi; - FxWidth += vi; - end - if FVariableRows then - begin - FyHeight := FMarginTop; - FYfiexed := FMarginTop; - ny := min(FFixedRows,FRowsHeight.length())-1; - for i := 0 to FRowsHeight.length()-1 do - begin - vi := FRowsHeight[i]; - if i <= ny then FYfiexed += vi; - FyHeight += vi; - end - end else - begin - FYfiexed := FMarginTop+FFixedRows * FRowHeight; - end - FXfiexed := FMarginLeft+xfix; - end - function setcursorsize2(); - begin - IF FC_CURRENT <> FC_SIZE2 then - begin - cursor := FC_SIZE2; - FC_CURRENT := FC_SIZE2; - end - end - function setcursorsize(); - begin - IF FC_CURRENT <> FC_SIZE then - begin - cursor := FC_SIZE; - FC_CURRENT := FC_SIZE; - end - end - function setcursornormal(); - begin - if FC_CURRENT <> FC_NORMAL then - begin - cursor := FC_NORMAL; - FC_CURRENT := FC_NORMAL; - end - end - function GetHeaderRect(); - begin - end - type TPAINTCOUNT=class - {** - @explan(说明) 绘制计数 %% - **} - function create(v); - begin - if v is class(TControl)then - begin - FPainter := v; - v.BeginUpDate(); - end - end - function Destroy(); - begin - if FPainter then FPainter.EndUpDate(); - FPainter := nil; - end - FPainter; - end - type TMerger=class - public - FCells; - function Create(); - begin - FCells := array(); // r,c value - end - function isok(); - begin - return length(FCells); - end - function mergeid(i,j); - begin - i := FCells[0]; - j := FCells[1]; - end - function CellInMerge(i,j); - begin - if isok()then - begin - if i >= FCells[0]and i <= FCells[2]and j >= FCells[1]and j <= FCells[3]then return true; - end - return false; - end - function GetRange(); - begin - r := array(); - if isok()then - begin - return FCells; - end - return r; - end - function SetMergeCells(rec); - begin - FCells := array(); - if not ifarray(rec)then return; - if(rec[2]>= rec[0]and rec[3]>rec[1])or(rec[2]>rec[0]and rec[3]>= rec[1])then FCells := rec; - end - end - FMergers; - FAutoScroll; - //固定*********** - FXfiexed; - FYfiexed; - //********鼠标************* - FC_NORMAL; - FC_SIZE; - FC_SIZE2; - FC_CURRENT; - //******位置*************** - FMarginLeft; - FMarginTop; - FMarginRight; - FMarginBottom; - //*******表头*********** - FColWidth; - FRowWidth; // 变高基础高度 - FxWidth; - FyHeight; - FFixedRows; - FColsWidths; - FRowsHeight; - FColumFixed; - FRowHeight; - FVariableRows; //列高可变 - //****************表体******************* - FItemCount; - //*******滚动条******* - FSI; - //调整列宽 - FMouseSizeColumnWidth; - FSizeColum; - FCursorRect; - FCurrentSizeId; - FCurrentSizePos; -end type TGRidBase = class(TGridCtl) {** @explan(说明)表格基础类 %% @@ -22294,567 +5768,7 @@ type tprogressbar=class(TCustomControl) end end end -type tVirtualCalender = class(TSLUIBASE) -{** - @explan(说明) 月历控件虚拟类 -**} - function create(); - begin - inherited; - FFont := new TFont(); - FDateRows := 8; - FCalenderState := 3; - FLeft := 0; - FTop := 0; - FCellWidth := 30; - FCellHeight := 16; - FYear := 2021; - FMonth := 3; - FDate := 3; - FHasMonthSel := true; - FHasToday := true; - FTodayHeight := 20; - FMonthselheight := 25; - FDateMatrix := array(); - CalcDateMatrx(); - end - function InvalidateRect(rec,f); - begin - if FHost and FHost.HandleAllocated() then - begin - FHost.InvalidateRect(rec?:GetCalenderRect,f); - end - end - function dodatechanged();virtual; - begin - if FHost and FHost.HandleAllocated() then - begin - FHost.DoDatechanged(); - end - end - function ExecuteCommand(cmd,p); - begin - case cmd of - "metodaybutton": - begin - if ifnil(p) then return FHasToday; - else - begin - nv := p?true:false; - if FHasToday<>nv then - begin - FHasToday := nv ; - CalcDateMatrx(); - InvalidateRect(nil,false); - end - end - end - "mestate": - begin - if (p<> FCalenderState) and (p in array(1,2,3)) then - begin - FCalenderState := p; - CalcDateMatrx(); - InvalidateRect(nil,false); - end else - return FCalenderState; - end - "meyear": - begin - //设置年 - if (p>0 or p<=0) and p<>FYear then - begin - FYear := p; - CalcDateMatrx(); - InvalidateRect(nil,false); - dodatechanged(); - end - return FYear; - end - "meminc": - begin - d := incmonth(encodedate(FYear,FMonth,FDate),not(p>0 or p<1)?1:(p)); - decodedate(d,y,m,d); - FYear := y; - FMonth := max(m,1); - FDate := max(d,1); - CalcDateMatrx(); - InvalidateRect(nil,false); - dodatechanged(); - end - "memonth": - begin - //设置月 - if FMonth<>p and (p>0 or p<13) then - begin - ModifyDate(FYear,p,FDate); - FMonth := p; - CalcDateMatrx(); - InvalidateRect(nil,false); - dodatechanged(); - end - return FMonth; - end - "meyearmonth": - begin - //设置年,月 - if ifarray(p) and ifnumber(p[0]) and ifnumber(p[1]) then - begin - if p[0]<>FYear or p[1]<>FMonth then - begin - ExecuteCommand("meymd",encodedate(p[0],p[1],FDate)); - end - end - end - "medate": - begin - if p<>FDate and p>0 and p<= getmonthdates(FYear,FMonth) then - begin - FDate := p; - CalcDateMatrx(); - InvalidateRect(nil,false); - dodatechanged(); - end - return FDate; - end - "meymd": - begin - if p>=0 or p<0 then - begin - decodedate(p,y,m,d); - if y<>FYear or FMonth <>m or FDate<>d then - begin - FYear := y; - FMonth := m; - FDate := d ; - CalcDateMatrx(); - InvalidateRect(nil,false); - dodatechanged(); - end - end else - return encodedate(FYear,FMonth,FDate); - end - "meselbypos": - begin - r := ExecuteCommand("megetbypos",p); - if not r then return ; - if r = "today" then - begin - FCalenderState := 3; - ExecuteCommand("meymd",date()); - end - case FCalenderState of - 3: - begin - ExecuteCommand("medate",r); - end - 2: - begin - FCalenderState := 3; - m := FMonth; - d := FDate; - y := FYear; - ExecuteCommand("memonth",r); - if (m=FMonth ) and (d=FDate) and (y := FYear) then - begin - CalcDateMatrx(); - InvalidateRect(nil,false); - end - end - 1:begin - FCalenderState := 2; - m := FMonth; - d := FDate; - y := FYear; - ExecuteCommand("meyear",r); - if (m=FMonth ) and (d=FDate) and (y := FYear) then - begin - CalcDateMatrx(); - InvalidateRect(nil,false); - end - end - end ; - - return r; - end - "mestatebypos": //切换状态 - begin - r := ExecuteCommand("megetstatepos",p); - ExecuteCommand("mestate",r); - return r; - end - "megetstatepos": //状态改变区域 - begin - if not(FYearRect and FMonthRect) then return ; - if(p) then - begin - p0 := p[0]; - p1 := p[1]; - if not(p0>0 or p0<0 ) then return ; - if not(p1>0 or p1<0 ) then return ; - x := p0-FLeft; - y := p1-FTop; - pp := array(x,y); - if pointinrect(pp,FYearRect) then return 1; - if pointinrect(pp,FMonthRect) then return 2; - return 0; - end - end - "megetincpos": //获得month inc month dec - begin - if not(FIncRect and FDecRect) then return ; - if(p) then - begin - p0 := p[0]; - p1 := p[1]; - if not(p0>0 or p0<0 ) then return ; - if not(p1>0 or p1<0 ) then return ; - x := p0-FLeft; - y := p1-FTop; - pp := array(x,y); - if pointinrect(pp,FIncRect) then return 1; - if pointinrect(pp,FDecRect) then return -1; - end - end - "megetbypos": - begin - if ifarray(p) then - begin - p0 := p[0]; - p1 := p[1]; - if not(p0>0 or p0<0 ) then return ; - if not(p1>0 or p1<0 ) then return ; - x := p0-FLeft; - y := p1-FTop-(FHasMonthSel*FMonthselheight); - pp := array(x,y); - if pointinrect(pp,FTodyRect) then - begin - return "today"; - end - if FCalenderState = 3 then - begin - for i:= 1 to 6 do - begin - for j := 0 to 6 do - begin - d := FDateMatrix[i,j]; - if ifarray(d) then - begin - rec := d["rec"]; - if pointinrect(pp,rec) then - begin - return d["value"]; - end - end - end - end - end else - if FCalenderState in array(2,1) then - begin - for i,d in FDateMatrix do - begin - if ifarray(d) then - begin - rec := d["rec"]; - if pointinrect(pp,rec) then - begin - return d["value"]; - end - end - end - end - end - end - end - end - function paint(); - begin - if not (host and host.HandleAllocated()) then return ; - dc := host.Canvas; - if not(dc and dc.HandleAllocated()) then return ; - dc.font := font; - if FHasMonthSel then - begin - dc.brush.color := rgb(200,220,220); - dc.fillrect(array(FLeft,FTop,FLeft+FCellWidth*7,FTop+FMonthselheight)); - - if FDecRect then - dc.draw("framecontrol",array((FDecRect[0]+FLeft,FDecRect[1]+FTop),(FDecRect[2]+FLeft,FDecRect[3]+FTop)),DFC_SCROLL,DFCS_SCROLLLEFT); - if FIncRect then - dc.draw("framecontrol",array((FIncRect[0]+FLeft,FIncRect[1]+FTop),(FIncRect[2]+FLeft,FIncRect[3]+FTop)),DFC_SCROLL,DFCS_SCROLLRIGHT); - if FYearRect then - begin - rec := FYearRect; - rec[0]+=FLeft; - rec[2]+=FLeft; - rec[1]+=FTop; - rec[3] += FTop; - if FCalenderState = 1 then - begin - dc.brush.color := rgb(240,240,250); - dc.fillrect(rec); - end - dc.font.weight:= 700; - dc.drawtext(inttostr(FYear)+"年",rec,DT_CENTER); - end - if FMonthRect then - begin - rec := FMonthRect; - rec[0]+=FLeft; - rec[2]+=FLeft; - rec[1]+=FTop; - rec[3] += FTop; - if FCalenderState = 2 then - begin - dc.brush.color := rgb(240,240,250); - dc.fillrect(rec); - end - dc.font.weight:= 700; - dc.drawtext(inttostr(FMonth)+"月",rec,DT_CENTER); - end - end - t := FTop+(FMonthselheight*FHasMonthSel); - if FCalenderState in array(1,2) then - begin - for i,d in FDateMatrix do - begin - if not ifarray(d) then continue ; - rec := d["rec"]; - if not rec then continue ; - - rec[0]+=FLeft; - rec[2]+=FLeft; - rec[1]+=t; - rec[3] += t; - if d["sel"] then - begin - dc.brush.color := rgb(200,200,100); - dc.FillRect(rec); - end - dc.drawtext(d["text"],rec,DT_CENTER .|DT_VCENTER .| DT_SINGLELINE); - end - end else - if FCalenderState = 3 then - begin - for i:=0 to 6 do - begin - for j := 0 to 6 do - begin - d := FDateMatrix[i,j]; - if not ifarray(d) then continue ; - rec := d["rec"]; - if not rec then continue ; - rec[0]+=FLeft; - rec[2]+=FLeft; - - rec[1]+=t; - rec[3] += t; - if d["sel"] then - begin - dc.brush.color := rgb(200,200,100); - dc.FillRect(rec); - end - if i=0 then dc.font.weight:= 700; - else dc.font.weight:= 400; - dc.drawtext(d["text"],rec,DT_CENTER .| DT_VCENTER .| DT_SINGLELINE); - end - end - dc.pen.width := 1; - dc.pen.color := 0; - dc.moveto(array(FLeft,t+FCellHeight)); - dc.LineTo(array(FLeft+FCellWidth*7,t+FCellHeight)); - end - if FTodyRect then - begin - rec := FTodyRect; - rec[0]+=FLeft; - rec[2]+=FLeft; - rec[1]+=t; - rec[3] += t; - dc.brush.color := rgb(200,200,200); - dc.fillrect(rec); - dc.drawtext(" today: "+datetimetostr(date()),rec,DT_LEFT); - end - end - function recycling();override; - begin - inherited; - FHost := nil; - FFont := nil; - end - public - property Left read FLeft write SetLeft; - property top read FTop write SetTop; - property host read FHost write sethost; - property ClientRect read GetCalenderRect; - private - function ModifyDate(y,m,d); - begin - ct := getmonthdates(y,m); - if d>ct then d := ct; - end - function sethost(h); - begin - if host <> h then - begin - FHost := h; - end - end - function SetLeft(v); - begin - if FLeft<>v then - begin - - FLeft := integer(v); - InvalidateRect(nil,false); - end - end - function settop(v); - begin - if FTop<>v then - begin - FTop := integer(v); - InvalidateRect(nil,false); - end - end - function GetCalenderRect(); - begin - return array(FLeft,FTop,FLeft+FCellWidth*7,FTop+FHasMonthSel*FMonthselheight+FCellHeight*FDateRows+FHasToday*FTodayHeight); - end - function CalcDateMatrx(); - begin - FDecRect := array(); - FIncRect := array(); - FTodyRect := array(); - if FHasMonthSel then - begin - FDecRect := array(5,2,25,22); - x := 7*FCellWidth-25; - FIncRect := array(x,2,x+20,22); - FYearRect := array(60,2,110,22); - FMonthRect := array(115,2,165,22); - end - if FHasToday then - begin - x := 7*FCellWidth; - y := FDateRows*FCellHeight; - FTodyRect := array(0,y,x,y+FTodayHeight); - end - FDateMatrix:= array(); - if FCalenderState = 3 then - begin - for i,v in array("日","一","二","三","四","五","六") do - begin - x0 := i*FCellWidth; - x1 := x0+FCellWidth; - y0 := cidx*FCellHeight; - y1 := y0+FCellHeight; - data := array(); - data["rec"] := array(x0,y0,x1,y1); - data["text"] := v; - FDateMatrix[0,i] := data; - end - if FYear>0 and FMonth>0 then - begin - ct := getmonthdates(FYear,FMonth); - cidx := 1; - for i:= 1 to ct do - begin - dt := encodedate(FYear,FMonth,i); - dw := (dayofweek(dt)-1); - if i = 1 then //之前的 - begin - //上一个月 - end - x0 := dw*FCellWidth; - x1 := x0+FCellWidth; - y0 := cidx*FCellHeight; - y1 := y0+FCellHeight; - data := array(); - data["rec"] := array(x0,y0,x1,y1); - data["text"] := inttostr(i); - data["value"] := i; - data["sel"] := (FDate = i); - FDateMatrix[cidx,dw] := data; - if dw = 6 then - begin - cidx++; - end - if i = ct then - begin - //下一个月 - end - - end - end - end else - if FCalenderState = 2 then //月选择 - begin - cw := integer(FCellWidth*1.5); - ch := integer(FCellHeight*2); - for i := 1 to 12 do - begin - data := array(); - divmod(i-1,4,a,b); - x0 := b*cw+10; - x1 := x0+cw; - y0 := a*ch+10; - y1 := y0+ch; - data := array(); - data["rec"] := array(x0,y0,x1,y1); - data["text"] := inttostr(i)+"月"; - data["value"] := i; - data["sel"] := (FMonth = i); - FDateMatrix[i]:= data; - end - end else - if FCalenderState = 1 then //年选择 - begin - cw := integer(FCellWidth*1.5); - ch := (FCellHeight); - for i,v in ((FYear-13) -> (FYear+14)) do - begin - data := array(); - divmod(i,4,a,b); - x0 := b*cw+10; - x1 := x0+cw; - y0 := a*ch+10; - y1 := y0+ch; - data := array(); - data["rec"] := array(x0,y0,x1,y1); - data["text"] := inttostr(v); - data["value"] := v; - data["sel"] := (FYear = v); - FDateMatrix[i]:= data; - end - end - - - end - private - FFont; - FDateRows; - FYearRect; - FMonthRect; - FCalenderState; - FTodyRect; - FHasToday; - FTodayHeight; - FIncRect; - FDecRect; - FMonthselheight; - FHasMonthSel; - FDateMatrix; - FDate; - FMonth; - FYear; - FHost; - FLeft; - FTop; - FCellWidth; - FCellHeight; -end type tmonthcalendar = class(TCustomControl) {** @explan(说明)月历控件 @@ -22983,325 +5897,7 @@ type tmonthcalendar = class(TCustomControl) FonSelectChange; end -type tthreeEntry = class(TCustomControl) - private - type tpickerEditer = class(teditable) - function Create(); - begin - inherited; - border := false; - end - function valuemodify(); - begin - //修改日期 - if host then - Host.ExecuteCommand("dtchanged",self); - end - fprev; - fnext; - protected - function doonsetfocus();override; - begin - ExecuteCommand("ecselall"); - end - function doonkillfocus();override; - begin - valuemodify(); - ExecuteCommand("ecclcsel"); - end - public - function GetEntryRect();override; - begin - r := ClientRect; - if not ifarray(r) then return array(0,0,0,0); - return r; - end - function WMCHAR(o,e);override; - begin - case e.char of - "0" to "9" : return inherited; - end ; - case e.CharCode of - VK_DELETE,VK_BACK : inherited; - end ; - end - function WMKEYDOWN(o,e);override; - begin - case e.CharCode of - 13: - begin - return valuemodify(); - end - VK_LEFT: - begin - return GoToPrev(); - end - VK_RIGHT: - begin - return gotonext(); - end - VK_UP: - begin - return inc(); - end - VK_DOWN: - begin - return dec(); - end - end - inherited; - end - function inc(); - begin - s := text; - text := inttostr( strtointdef(s,0)+1); - valuemodify(); - end - function dec(); - begin - s := text; - text := inttostr( strtointdef(s,0)-1); - valuemodify(); - end - private - function gotonext(); - begin - valuemodify(); - if fnext then - begin - KillFocus(); - fnext.SetFocus(); - end - end - function GoToPrev(); - begin - valuemodify(); - if fprev then - begin - KillFocus(); - fprev.SetFocus(); - end - end - end - public - function create(aowner); - begin - inherited; - border := true; - left:=0; - top:=0; - height:=24; - width:=105; - FFontWidth := font.width; - //color := rgb(100,100,100); - FEntrys := array(); - for i := 0 to 2 do - begin - o := new tpickerEditer(); - FEntrys[i] := o; - o.limitlength := getEntryWidth(i); - end - - for i:= 0 to 2 do - begin - FEntrys[i].fnext := FEntrys[(i+1) mod 3]; - FEntrys[(i+1) mod 3].Fprev := FEntrys[i]; - end - calcCtls(); - FEntrys::mcell.host := self(true); - - end - function paint();override; - begin - for i,v in FEntrys do - begin - v.paint(); - end - dc := Canvas; - for i,v in FSymInfo do - begin - if not ifarray(v) then continue; - dc.drawtext(v["sym"],v["rec"],DT_CENTER .| DT_VCENTER .| DT_SINGLELINE); - end - PaintBtn(); - end - function PaintBtn();virtual; - begin - if FBtnRect then - begin - dc := Canvas; - dc.Draw("framecontrol",array(FBtnRect[0:1],FBtnRect[2:3]),DFC_SCROLL,DFCS_SCROLLDOWN); - end - end - - function DoWMSIZE(o,e);override; - begin - calcCtls(); - InvalidateRect(nil,false); - inherited; - end - function dosetfocus(o,e);override; - begin - if csDesigning in ComponentState then return ; - for i,v in FEntrys do - begin - if v.HasFocus then return v.SetFocus(); - end - for i,v in FEditable do - begin - return v.SetFocus(); - end - inherited; - end - function dokillfocus(o,e);override; - begin - if csDesigning in ComponentState then return ; - for i,v in FEntrys do - begin - if v.HasFocus then return v.killFocus(); - end - inherited; - end - function keypress(o,e);override; - begin - if csDesigning in ComponentState then return ; - if e.skip then return ; - for i,v in FEntrys do - begin - if v.HasFocus then return v.WMCHAR(o,e); - end - inherited; - end - function KeyDown(o,e);override; - begin - if csDesigning in ComponentState then return ; - - if e.skip then return ; - for i,v in FEntrys do - begin - if v.HasFocus then return v.WMKEYDOWN(o,e); - end - inherited; - end - function btnClicked(p);virtual; - begin - if pointinrect(p,FBtnRect) then - begin - return 1; - end - end - function MouseUp(o,e);override; - begin - if csDesigning in ComponentState then return ; - if e.skip then return ; - if e.button()=mbLeft then - begin - p := e.pos; - if btnClicked(p) then return ; - for i,v in FEntrys do - begin - if v.HasFocus then - return v.MouseUp(o,e); - end - end - inherited; - end - function MouseMove(o,e);override; - begin - if csDesigning in ComponentState then return ; - - if e.skip then return ; - for i,v in FEntrys do - begin - if v.HasFocus then - begin - return v.MouseMove(o,e); - end - end - inherited; - end - function MouseDown(o,e);override; - begin - if csDesigning in ComponentState then return ; - if e.skip then return ; - if e.button()=mbLeft then - begin - p := e.pos; - if pointinrect(p,FBtnRect) then return ; - idx := -1; - for i,v in FEntrys do - begin - if pointinrect(p,v.GetEntryRect()) then - begin - idx := i; - end else v.KillFocus(); - end - if idx>=0 then return FEntrys[idx].MouseDown(o,e); - end - inherited; - end - function recycling();override; - begin - inherited; - For i,v in FEntrys do - begin - v.recycling(); - end - FEntrys := array(); - FSymInfo := array(); - end - function FontChanged(o);override; - begin - //改变 - FFontWidth := font.width; - for i,v in FEntrys do v.Font := font; - calcCtls(); - end - protected - function calcCtls();virtual; - begin - rec := ClientRect; - h := rec[3]-rec[1]; - wd := rec[2]-rec[0]; - FBtnRect := array(max(0,integer(rec[2]-min(25,h))),rec[1],rec[2]-1,rec[3]-1); - x := rec[0]+1; - FSymInfo := array(); - for i,v in FEntrys do - begin - nx := x+integer(FFontWidth*(getEntryWidth(i))+2); - rc := array(x,rec[1],nx,rec[3]); - v.ClientRect := rc; - x := nx; - if i =2 then return ; - nx := x+FFontWidth+1; - rc := array(x,rec[1],nx,rec[3]); - FSymInfo[i,"sym"] := getSym(i); - FSymInfo[i,"rec"] := rc; - x := nx; - end - end - property BtnRect Read FBtnRect; - property entrys read FEntrys; - private - function getEntryWidth(i);virtual; - begin - case i of - 0: return 4; - else return 2; - - end - end - function getSym(i);virtual; - begin - return "/"; - end - FSymInfo ; - FBtnRect; - FFontWidth; - FEntrys; - -end type tdatetimepicker = class(tthreeEntry) {** @explan(说明) 日期选择控件 %% @@ -24073,265 +6669,7 @@ type tIPAddr = class(TCustomControl) "ipaddr","HasPort","onAddrChange","border","wsdlgmodalframe"); end end -type TCustomSpinEdit = class(TCustomControl) - {** - @explan(说明)spinedit控件 - **} - private - FEdit; - FUDwidth; - FUPrect; - FDownrect; - FCI; - CI_UP; - CI_DOWN; - CIS_NONE; - CIS_MOUSEDOWN; - CIS_MOUSEUP; - CIS_MOUSEON; - FIncrement: Double; - FDecimals: Integer; - FMaxValue: Double; - FMinValue: Double; - FValue: Double; - FOnIncrease; - FOnDecrease; - FLeveTimer; - function DrawItem(id,f); - begin - ys := 0; - case id of - CI_UP: - begin - rec := FUPrect; - ys := DFCS_SCROLLup; - end - CI_DOWN: - begin - rec := FDownrect; - ys := DFCS_SCROLLDOWN; - end else - return; - end - case f of - CIS_MOUSEDOWN: - begin - //_wapi.DrawFrameControl(Canvas.Handle,rec,DFC_BUTTON,DFCS_BUTTONPUSH); - Canvas.Draw("framecontrol",array(rec[0:1],rec[2:3]),DFC_BUTTON,DFCS_BUTTONPUSH) - end - CIS_NONE: - begin - Canvas.Draw("framecontrol",array(rec[0:1],rec[2:3]),DFC_SCROLL,ys); - end - CIS_MOUSEON: - begin - //canvas.pen.color := rgb(100,200,100); - //canvas.draw("Rectangle",array(rec[0:1],rec[2:3])); - end - end; - end - type TSpinCEdit=class(tedit) - function create(AOwner);override; - begin - inherited; - border := false; - caption := "0"; - end - function SetDesigning(f,fc); - begin - if f then Enabled := false; - else Enabled := true; - end - end - FChar; - protected - function UpdateControl();virtual; - begin - FEdit.Text := inttostr(FValue); - end - function GetValue();virtual; - begin - if FEdit.HandleAllocated()then - begin - r := FEdit.text; - r := StrToIntDef(r,FValue); - if r <> FValue then - begin - FValue := r; - end - end - return FValue; - end - procedure SetValue(const AValue:Double);virtual; - begin - if AValue <> FValue then - begin - if AValue >= FMinValue and AValue <= FMaxValue then - begin - FValue := AValue; - UpdateControl(); - end - end - end - procedure SetMaxValue(const AValue:Double);virtual; - begin - if AValue <> FMaxValue then - begin - FMaxValue := AValue; - end - end - procedure SetMinValue(const AValue:Double);virtual; - begin - if AValue <> FMinValue then - begin - FMinValue := AValue; - end - end - procedure SetIncrement(const AIncrement:Double);virtual; - begin - nv := integer(AIncrement); - if FIncrement <> nv and nv>0 then - begin - FIncrement := nv; - end - end - function doIncrease(o,e);virtual; - begin - nv := GetValue()+FIncrement; - if nv <= FMaxValue and nv >= FMinValue then - begin - CallMessgeFunction(FOnDecrease,o,e); - if not e.skip then - begin - FValue := nv; - UpdateControl(); - end - end else - begin - if nv>FMaxValue then SetValue(FMaxValue); - else if nv= FMinValue then - begin - CallMessgeFunction(FOnDecrease,o,e); - if not e.skip then - begin - FValue := nv; - UpdateControl(); - end - end else - begin - if nv>FMaxValue then SetValue(FMaxValue); - else if nv FBKColor then - begin - FBKColor := c; - if HandleAllocated()then - begin - _wapi.ImageList_SetBkColor(FHandle,c); - end - end - end - function readinfo() - begin - {** - @explan(说明) 读取信息 %% - **} - if HandleAllocated()then - begin - FimageCount := 0; - FimageCount := _wapi.ImageList_GetImageCount(FHandle); - xy := GetIconSize(); - FBKColor := _wapi.ImageList_GetBkColor(FHandle); - FWidth := xy[0]; - FHeight := xy[1]; - end - end - function indexvalidate(i); - begin - {** - @explan(说明) 是否有效 %% - **} - return HandleAllocated()and i-0.5; - end - function hcreateimagelist(); - begin - if not HandleAllocated()then - begin - hd := _wapi.ImageList_Create(FWidth,FHeight,0x00000001,FInitialCount,FcGrow); - if hd then - begin - _wapi.ImageList_SetBkColor(hd,FBKColor); - SetHandle(hd); - FAutoDestroy := true; - FChanged := true; - change(); - end - end - end - protected - function SetHandle(H); - begin - {** - @explan(说明) 设置句柄 %% - **} - if h and ifnumber(h)and h <> FHandle then - begin - DestroyHandle(); - FHandle := h; - readinfo(); - FAutoDestroy := true; - end - end - function SetWidth(w); - begin - if w>0 and w <> FWidth then - begin - FWidth := w; - FChanged := true; - DestroyHandle(); - addbmps(); - if inDesigning()then change(); - end - end - function SetHeight(h); - begin - if h>0 and FHeight <> h then - begin - FHeight := h; - FChanged := true; - DestroyHandle(); - addbmps(); - if inDesigning()then change(); - //if not inDesigning() then DestroyHandle(); - end - end - function HandleNeeded(); - begin - if not HandleAllocated()then hcreateimagelist(); - return FHandle; - end - public - function create(Owner);override; - begin - FcGrow := 100; - FWidth := 24; - FHeight := 24; - FInitialCount := 100; - FAutoDestroy := true; - FimageCount := 0; - FBKColor := rgb(255,255,255); - FBmpItems := new TMyArrayB(); - //FDrawBimpFirst := true; - inherited; - end - function HandleAllocated(); - begin - {** - @explan(说明) 句柄是否有效 %% - **} - return ifnumber(FHandle)and FHandle <> 0; - end - function DestroyHandle(); - begin - {** - @explan(说明)销毁句柄 %% - **} - if HandleAllocated()and FAutoDestroy then _wapi.ImageList_Destroy(FHandle); - FHandle := 0; - FimageCount := 0; - FBmpItems := new TMyArrayB(); - end - function add(Image,Mask); - begin - {** - @ignore 忽略%% - @explan(说明) 添加位图 %% - **} - if not FAutoDestroy then exit; - if not(Image is class(tbitmap))then exit; - HandleNeeded(); - r :=-1; - if mask is class(tbitmap)then - begin - r := _wapi.ImageList_Add(FHandle,Image.Handle,Mask.Handle); - end else - if ifnumber(mask)then - begin - r := _wapi.ImageList_AddMasked(FHandle,Image.Handle,Mask); - end else - r := _wapi.ImageList_Add(FHandle,Image.Handle,nil); - if r>-0.5 then - begin - FimageCount := _wapi.ImageList_GetImageCount(FHandle); - end - return r; - end - function addbmp(bmp); - begin - {** - @explan(说明) 添加bitmap 到imagelist %% - @param(bmp)(tbitmap) %% - **} - if not FAutoDestroy then exit; - if not(bmp is class(tbitmap))then exit; - HandleNeeded(); - if not(HandleAllocated())then exit; - ct := FimageCount; - FBmpAdding := true; - try - addIcon(bmp.ToIcon()); - if FimageCount>ct then - begin - //////////////拷贝bitamp不销毁/////////////////// - nbmp := new TBitmap(); - bmp.AutoDestroy := false; - nbmp.Handle := bmp.Handle; - nbmp.AutoDestroy := true; - ////////////////////////////// - FBmpItems.push(nbmp); - end - finally - FBmpAdding := false; - end; - end - function addIcon(ico); - begin - {** - @explan(说明) 添加图标 %%; - **} - if not(ico is class(ticon))then exit; - if not(ico.HandleAllocated())then exit; - HandleNeeded(); - if not(HandleAllocated())then exit; - h := Handle; - _wapi.ImageList_ReplaceIcon(h,-1,ico.Handle); - ct := FimageCount; - FimageCount := _wapi.ImageList_GetImageCount(h); - if not FBmpAdding then - begin - if FimageCount>ct then - begin - FBmpItems.push(ico.Tobitmap()); - end - end - return; - end - function draw(i,dc,x,y,flag); - begin - {** - @explan(说明) 绘制imge %% - @param(i)(integer) 序号 %% - @param(dc)(tcanvas) dc 对象 %% - @param(x)(integer) x坐标 %% - @param(y)(integer) y坐标 %% - @param(flag)(member of TImageListDrawStyle) 标记 %% - **} - if not(dc is class(tcanvas))then exit; - if not dc.HandleAllocated()then exit; - if indexvalidate(i)then - begin - if not(flag >= 0)then flag := ILD_NORMAL; - if DrawBimpFirst then - begin - bmp := FBmpItems[i]; - if bmp then - begin - rc := array(x,y,x+height,y+width); - bmp.StretchDraw(dc,rc,(flag=ILC_COLOR4?SRCAND:nil)); // - end else - begin - _wapi.ImageList_Draw(Fhandle,i,DC.Handle,x,y,flag); - end - end else - begin - _wapi.ImageList_Draw(Fhandle,i,DC.Handle,x,y,flag); - end - end - end - function Removeimge(i); - begin - {** - @explan(说明) 删除 %% - **} - if indexvalidate(i)then - begin - if _wapi.ImageList_Remove(FHandle,i)then - begin - FBmpItems.splices(i,1); - FimageCount--; - end - end - end - function Replaceimge(i,btmap,msk); - begin - {** - @explan(说明) 替换 image %% - @param(i)(integer) 位置 %%; - @param(btmap)(tbitmap) 位图 %% - @param(msk)(tbitmap|hbitmap) mask %% - **} - hmsk := 0; - if indexvalidate(i)then - begin - if(btmap is class(tbitmap))and(btmap.HandleAllocated())then - begin - if(msk is class(tbitmap))and(msk.HandleAllocated())then hmsk := msk.Handle; - else if ifnumber(mask)then hmsk := mask; - if _wapi.ImageList_Replace(FHandle,i,btmap.Handle,hmsk)then - begin - FBmpItems.splices(i,1,array(btmap)); - end - end - end - end - function GetIcon(i,flag); - begin - {** - @explan(说明) 获取ticon 对象 %% - @param(i)(integer) 序号 %% - @param(flag)(member of TImageListDrawStyle) 样式 %% - **} - if HandleAllocated()and i-0.5 then - begin - hi := _wapi.ImageList_GetIcon(FHandle,i,flag); - if hi then - begin - r := new ticon(); - r.handle := hi; - r.AutoDestroy := true; - return r; - end - end - end - function loadfromsysbmp(id,cx,cGrow); - begin - {** - @ignore 忽略 %% - @explan(说明) 导入系统位图生成imagelist %% - **} - hd := _wapi.ImageList_LoadImageA2(nil,id,cx,cGrow,CLR_NONE,IMAGE_BITMAP,LR_SHARED); - SetHandle(hd); - end - function GetHotSpot();virtual; - begin - return array(0,0); - end - function Recycling();override; - begin - DestroyHandle(); - FOnChange := nil; - inherited; - end - function destroy();override; - begin - inherited; - end - function SetSysImageListHandle(h); - begin - {** - @ignore 忽略 %% - @explan(说明) 设置构造好的iamgelist 到对象,默认不销毁 %% - **} - if h <> FHandle then - begin - SetHandle(H); - FAutoDestroy := false; - end - end - property Handle read HandleNeeded write SetHandle; - property AutoDestroy read FAutoDestroy write FAutoDestroy; - property ImageCount read FimageCount; - property Height:integer read FHeight write Setheight; - property Width:integer read FWidth write SetWidth; - property imgHeight:integer read FHeight write Setheight; - property imgWidth:integer read FWidth write SetWidth; - property OnChange read FOnChange write FOnChange; - property BkColor:COLORREF read FBKColor write setbkcolor; - property Images:imagesdata read GetImages write SetImages; - property DrawBimpFirst read FDrawBimpFirst write FDrawBimpFirst; - function publishs();override; - begin - return array("name","images","imgwidth","imgheight","bkcolor"); - end - {** - @param(Handle)(HIMAGELIS) imagelist句柄 %% - @param(AutoDestroy)(bool) 是否销毁句柄 %% - @param(ImageCount)(integer) 图标数量 %% - @param(OnChange)(function[TCustomImageList]) 改变时的回调 %% - **} -end - -type TControlImageList=class(TCustomImageList) +type tcontrolimagelist=class(tcustomcontrolimagelist) {** @explan(说明) 控件imagleit %% **} - private - FImageControls; - public - function HandleChanged();virtual; - begin - {** - @explan(说明) 句柄发生变化 %% - **} - for i := 0 to FImageControls.Count-1 do - begin - FImageControls[i].ImageChanged(); - end - end function create(AOwner);override; begin inherited; - FImageControls := new TFpList(); - OnChange := thisfunction(HandleChanged); - end - function addControl(v); - begin - id := FImageControls.indexof(v); - if id=-1 then - begin - FImageControls.append(v); - end - end - function deleteControl(v); - begin - {** - @explan(说明) 删除控件 %% - **} - id := FImageControls.indexof(v); - if id >= 0 then - begin - v.ImageList := nil; //设置为空 - FImageControls.deli(id); - end - end - function Recycling();override; - begin - {** - @explan(说明) 回收空间%% - **} - while FImageControls.Count>0 do - begin - deleteControl(FImageControls[0]); - end - inherited; - end -end + end +end + type TDragImageList=class(TCustomImageList) {** @@ -24965,2793 +6847,70 @@ type TDragImageList=class(TCustomImageList) property Dragging:Boolean read FDragging; property ImageIndex read FImageIndex write FImageIndex; end -type TImage=class(TSLUIBASE) - {** - @explan(说明)image类采用gdiflat封装 %% - **} - private - FHandle; - FGdi; - Static FImageTypes; - class function GetFileType(t_); - begin - if not(t_ and ifstring(t_))then t := "png"; - else t := lowercase(t_); - if not(t in array("png","jpeg","bmp","gif","tiff"))then exit; - vp := FImageTypes[t]; - if vp then return vp; - vp := tslcstructure(array((0,"byte[20]",array()))); //原本16; - //messagebox("image/"+t,"123",0); - nt := _wapi.AnsiToWidChar("image/"+t); - vvp := _wapi.GetEncoderClsid(nt,vp._getptr_); - if vvp <>-1 then - begin - FImageTypes[t]:= vp; - end - return vp; - end - function IFhandle(h); - begin - return ifnumber(h)and h; - end - private - function ImageToStream(t); - begin - {** - @ignore(忽略) %% - @explan(说明) image 转换为stream %% - **} - if not FHandle then exit; - vp := GetFileType(t); - _wapi.CreateStreamOnHGlobal(0,true,st); - r := gdi.GdipSaveImageToStream(FHandle,st,vp._getptr_,0); - if r <> 0 then exit; - return st; - end - public - class function sinit();override; - begin - inherited; - if not ifarray(FImageTypes)then - begin - //return ; - FImageTypes := array(); - for i,v in array("png","jpeg","bmp","gif","tiff") do - begin - GetFileType(v); - end - end - end +type TImage = class(tcustomimage) function create(); begin inherited; - FHandle := 0; - FGdi := new TGdiplusflat(); - end - function DestroyHandle(); - begin - {** - @explan(说明) 销毁句柄 %% - **} - if IFhandle(FHandle)then - begin - gdi.GdipDisposeImage(FHandle); - end - FHandle := 0; - end - function Recycling();override; - begin - {** - @explan(说明) 回收 %% - **} - DestroyHandle(); - inherited; - end - function Destroy();override; - begin - inherited; - end - function LoadFromFile(path); - begin - {** - @explan(说明)打开文件 %% - @param(path)(string) 路径 %% - **} - if not ifstring(path)then exit; - size := filesize("",path); //获取文件大小 - r :=-1; - if readFile(rwraw(),"",path,0,size,data)then - begin - r := StringToImage(data); - end - return r; - //***********GdipLoadImageFromFile 报错**************** - fn := _wapi.AnsiToWidChar(path); - r := gdi.GdipLoadImageFromFile(fn,hd); - if hd then - begin - DestroyHandle(); - FHandle := hd; - end - return r; - end - function SavetoFile(p,t); - begin - {** - @explan(说明) 保存到文件%% - @param(p)(string)路径 %% - @param(t)(string)类型 ,"png" "bmp" "gif" - **} - if not ifstring(p)then return-1; - if not ifstring(t)then t := "png"; - if not FHandle then return-1; - vp := GetFileType(t); - fn := _wapi.AnsiToWidChar(p); - return Gdi.GdipSaveImageToFile(FHandle,fn,vp._getptr_(),0); - end - function ImageToString(t); - begin - {** - @explan(说明) 得到图片内存%% - @param(t)(string) png bmp %% - **} - if not FHandle then exit; - /////////整理imagetostring////////// - vp := GetFileType(t); - s := gdi.imagetostring(FHandle,vp); - return s; - end - function StringToImage(b); - begin - {** - @explan(说明) 从字符串到图片 %% - @param(b)(string) 内存 %% - **} - if not(b and ifstring(b))then return 3; - ////////整理////////////////////// - r := gdi.stringtoimage(b,hd); - if hd then - begin - DestroyHandle(); - FHandle := hd; - end - return r; - end - function ToHbitmap(); - begin - {** - @explan(说明) 转换为bitmap %% - @return(pointer) - **} - if not FHandle then exit; - gdi.GdipCreateHBITMAPFromBitmap(FHandle,fhbmp,rgb(255,255,255)); - return fhbmp; - end - function FromHBitmap(bmp); - begin - {** - @explan(说明) 从bitmap得到图片 %% - @param(bmp)(pointer) hbitmap - **} - if not(IFhandle(bmp))then exit; - if bmp=FHandle then exit; - gdi.GdipCreateBitmapFromHBITMAP(bmp,0,hd); - if hd then - begin - DestroyHandle(); - FHandle := hd; - end - end - function FromHIcon(ico); - begin - {** - @explan(说明) 从hicon得到图片 %% - @param(ico)(pointer) hicon %% - **} - if not(ifnumber(ico)and ico)then exit; - if bmp=ico then exit; - gdi.GdipCreateBitmapFromHICON(ico,hd); - if hd then - begin - DestroyHandle(); - FHandle := hd; - end - end - function tohicon(); - begin - {** - @explan(说明) 得到hcion %% - @return(pointer)hicon - **} - if not FHandle then exit; - gdi.GdipCreateHICONFromBitmap(FHandle,hd); - return hd; - end - property Gdi read FGdi; - property Handle Read FHandle; - {** - @param(gdi)(TGdiplusflat) gdi对象 %% - @param(handle)(pointer) 句柄 %% - **} -end - -type TPicturebase=class(TSLUIBASE) - {** - @explan(说明)bitmap,ico基类 %% - **} - private - FImage; - public - function Create();override; - begin - inherited; - try - FImage := new timage(); - except - raise "^~^ gdi support err!"; - FImage := 0; - end; - end - function Recycling();override; - begin - FImage := nil; - inherited; - end - property Image read FImage; -end -type TBitmap = class(TPicturebase) - {** - @explan(说明) bitmap 类 %% - **} - private - FHandle; - FId; - FDestroy; - FBytes; - FDIBites; - FBitmap; - static FsysBitmaps; - static FSHDC; - static FSHDC2; - class function sinitdc(); - begin - if not FSHDC then - begin - FSHDC := _wapi.CreateCompatibleDC(0); - FSHDC2 := _wapi.CreateCompatibleDC(0); - end - end - function getvalue(n); - begin - case n of - "bmtype":return FBitmap.bmtype; - "bmwidth":return FBitmap.bmwidth; - "bmheight":return FBitmap.bmheight; - "bmwidthbytes":return FBitmap.bmwidthbytes; - "bmplanes":return FBitmap.bmplanes; - "bmbitspixel":return FBitmap.bmbitspixel; - end - end - - function setvalue(n,v); - begin - case n of - "bmtype" : FBitmap.bmtype :=v ; - "bmwidth" : FBitmap.bmwidth :=v ; - "bmheight" : FBitmap.bmheight :=v ; - "bmwidthbytes" : FBitmap.bmwidthbytes:=v ; - "bmplanes" : FBitmap.bmplanes :=v ; - "bmbitspixel" : FBitmap.bmbitspixel :=v ; - end ; end - function SetHandle(h); - begin - {** - @explan(说明) 设置句柄 %% - **} - if h=FHandle then exit; - if HandleAllocated()then DestroyHandle(); - FDIBites := FBytes := ""; - FHandle := h; - ReadhInfo(); - end - Function ReadhInfo(); - begin - {** - @explan(说明) 获取信息 %% - **} - if HandleAllocated()and FBitmap then - begin - _wapi.GetObjectA(FHandle,FBitmap._size_(),FBitmap._getptr_()); - end - end - function setid(id);virtual; - begin - {** - @explan(说明) 设置id %%; - **} - if id <> FId then - begin - Fid := id; - DestroyHandle(); - if ifnumber(id)then h := loadsysbmp(id); - if h then - begin - AutoDestroy := false; //不删除 - end else - begin - h := getresourcebyid(id,array("type":"bmp")); - if not h then - begin - if Image then - begin - //echo "\r\nloadok:", - Image.LoadFromFile(id); - //echo "\r\n=================readhandle:",Image.Handle; - h := Image.ToHbitmap(); - end - end - AutoDestroy := true; //删除 - end - if h then - begin - SetHandle(H); - end - end - end - protected - class function loadsysbmp(id);virtual; - begin - {** - @explan(说明) 获取系统的bitmap句柄 %% - @param(id)(menuber of TSystemBitmap) id %% - @return(hbitmap) 句柄 %% - **} - if not ifarray(FsysBitmaps)then FsysBitmaps := array(); - r := FsysBitmaps[id]; - if r then return r; - else - begin - r := _wapi.LoadBitmapA2(nil,id); - FsysBitmaps[id]:= r; - end - return r; - end - function DestroyHandle();virtual; - begin - {** - @explan(说明) 析构句柄 %% - **} - if HandleAllocated()and FDestroy then _wapi.DeleteObject(FHandle); - FHandle := 0; - FBytes := ""; - end - public - function HandleAllocated(); - begin - {** - @explan(说明) 判断是有句柄 %% - @return(bool) - **} - return ifnumber(FHandle)and(FHandle <> 0); - end +end +type TBitmap = class(tcustombitmap) + function create();override; begin inherited; - FBitmap := new TSHBMP(nil); - FDestroy := true; - end - function draw(dc,x,y,flag,rect); - begin - {** - @explan(说明) 粘贴到hdc %% - @param(dc)(tcanvas) canvas 对象%% - @param(x)(integer) canvas 中的x位置%% - @param(y)(integer) canvas 中的y位置%% - @param(rect)(array) bimap 的范围 array(左上右下)%% - @param(flag)(member of TRasterOperationConst) 光栅操作码 %% - **} - if(dc is class(tcanvas))and dc.HandleAllocated()and HandleAllocated()then - begin - sinitdc(); - bw1 := FBitmap.bmwidth; - bh1 := FBitmap.bmheight; - rc := array(0,0,bw1,bh1); - if ifarray(rect)then - begin - if intersectrect(rc,rect,irect)then rc := irect; - end - return _wapi.drawbitmaptodc(FHandle,dc.Handle,x,y,rc,flag,FSHDC); - oldmp := _wapi.SelectObject(FSHDC,FHandle); - if not flag then flag := SRCCOPY; - r := _wapi.BitBlt(dc.handle,x,y,rc[2]-rc[0],rc[3]-rc[1],FSHDC,rc[0],rc[1],flag); - if oldmp then _wapi.SelectObject(FSHDC,oldmp); - return r; - end - end - function StretchDraw(dc,drect,flag,brect); - begin - {** - @explan(说明) 粘贴到hdc %% - @param(dc)(tcanvas) canvas 对象%% - @param(drect)(array) canvas 的范围 array(左上右下)%% - @param(brect)(array) bimap 的范围 array(左上右下)%% - @param(flag)(member of TRasterOperationConst) 光栅操作码 %% - **} - if not(ifarray(drect))then return-1; - if(dc is class(tcanvas))and dc.HandleAllocated()and HandleAllocated()then - begin - sinitdc(); - bw1 := FBitmap.bmwidth; - bh1 := FBitmap.bmheight; - rc := array(0,0,bw1,bh1); - if ifarray(brect)then if intersectrect(rc,brect,irect)then rc := irect; - return _wapi.drawbitmapstretchtodc(FHandle,dc.Handle,drect,rc,flag,FSHDC); - oldmp := _wapi.SelectObject(FSHDC,FHandle); - if not flag then flag := SRCCOPY; - r := _wapi.StretchBlt(dc.handle,drect[0],drect[1],drect[2]-drect[0],drect[3]-drect[1],FSHDC,rc[0],rc[1],rc[2]-rc[0],rc[3]-rc[1],flag); - if oldmp then _wapi.SelectObject(FSHDC,oldmp); - end - return r; - end - function Readvcon(d);override; - begin - {** - @expaln(说明)读取二进制信息 %% - **} - if Image and ifarray(d)and d["type"]="img" then - begin - Image.StringToImage(d["data"]); - bthandle := Image.ToHbitmap(); - SetHandle(bthandle); - AutoDestroy := true; - return; - end - end - function tovcon();override; - begin - {** - @expaln(说明)转换为数据 %% - **} - r := nil; - if Image and HandleAllocated()then - begin - r := array(); - r["type"]:= "bmp"; - Image.FromHBitmap(FHandle); - r["type"]:= "img"; - r["data"]:= Image.ImageToString("png"); - end - return r; - end - function CopyRect(x,y,w,h); - begin - {** - @explan(说明) 拷贝位图 %% - **} - r := nil; - if HandleAllocated()then - begin - if x<0 or y<0 or w<0 or h<0 then return r; - if x+wd>FBitmap.bmwidth then return r; - if y+h>FBitmap.bmheight then return r; - wd1 := FBitmap.bmwidthbytes/FBitmap.bmwidth; - r := array(); - r["type"]:= "bmp"; - r["width"]:= w; - r["bmwidthbytes"]:= wd1 * w; - r["bmplanes"]:= FBitmap.bmplanes; - r["bmbitspixel"]:= FBitmap.bmbitspixel; - r["height"]:= h; - sbt := BmpBits; - sbt2 := ""; - setlength(sbt2,wd1 * w * h * 2); - hr := FBitmap.bmwidthbytes; - jj := 1; - sx := x * wd1; - ex := sx+w * wd1-1; //(x+w)*wd1-1; - for ri := y to y+h-1 do - begin - for ci := sx to ex do - begin - if ri * hr+ci+1>length(sbt)then break; - v := sbt[ri * hr+ci+1]; - sbt2[jj++]:= v; - end - end - r["bytes"]:= sbt2[1:(wd1 * w * h)]; - rt := new tbitmap(); - rt.readvcon(r); - return rt; - end - return r; - end - function ToBMPFileString(); - begin - if Image and HandleAllocated()then - begin - r := array(); - Image.FromHBitmap(FHandle); - return Image.ImageToString("bmp"); - end - return ""; - end - function ToIcon(); - begin - {** - @explan(说明)将位图转换为icon %% - @return(ticon|nil) 成功返回图标 %% - **} - if HandleAllocated()then - begin - Image.FromHBitmap(FHandle); - thandle := Image.tohicon(); //采用gdi+ - if not thandle then return 0; - r := new ticon(); - r.Handle := tHandle; - return r; - end - return nil; - end - function Recycling();override; - begin - DestroyHandle(); - FBitmap := nil; - inherited; - end - property id read FId write SetID; - property Handle:pointer read FHandle write SetHandle; - property AutoDestroy:bool read FDestroy write FDestroy; - //property BmpBits read GetBits; - //property DIBits read GetDIBits; - property bmtype index "bmtype" read getvalue write setvalue ; - property bmwidth index "bmwidth" read getvalue write setvalue; - property bmheight index "bmheight" read getvalue write setvalue; - property bmwidthbytes index "bmwidthbytes" read getvalue write setvalue; - property bmplanes index "bmplanes" read getvalue write setvalue; - property bmbitspixel index "bmbitspixel" read getvalue write setvalue; - {** - @param(id)() 资源id %% - @param(Handle)() 句柄 %% - @param(AutoDestroy)() 析构时销毁句柄 %% - **} + end end -type TIcon = class(TPicturebase) - private - {** - @explan(说明) 图标对象类 %% - **} - FHandle; - FId; - FMask; - FDestroy; - FMaskBMP; - FColorBMP; - FHICON; - FHandleChanged; - static FSystemIcons; - function getvalue(n); - begin - if not FHICON then return 0; - if FHandleChanged then ReadhInfo(); - case n of - "ficon": return FHICON.ficon; - "xhotspot": return FHICON.xhotspot; - "yhotspot": return FHICON.yhotspot; - "hbmmask": return FHICON.yhotspot; - "hbmcolor": return FHICON.hbmcolor; - end - end - function setvalue(n,v); - begin - if not FHICON then return 0; - if FHandleChanged then ReadhInfo(); - case n of - "ficon": return FHICON.ficon := v; - "xhotspot": return FHICON.xhotspot := v; - "yhotspot": return FHICON.yhotspot := v; - "hbmmask": return FHICON.yhotspot := v; - "hbmcolor": return FHICON.hbmcolor := v; - end - end - function SetHandle(h); - begin - {** - @explan(说明) 设置句柄 %% - **} - if HandleAllocated()then DestroyHandle(); - FHandle := h; - FHandleChanged := true; - end - function GetMaskBitMap(); - begin - if FHandleChanged then ReadhInfo(); - return FMaskBMP; - end - function GetColorBitMap(); - begin - if FHandleChanged then ReadhInfo(); - return FColorBMP; - end - Function ReadhInfo(); - begin - {** - @explan(说明) 获取信息 %% - **} - if FHandleChanged and HandleAllocated()and FHICON then - begin - _wapi.GetIconInfo(FHandle,FHICON._getptr_()); - FHandleChanged := false; - if hbmcolor then - begin - FColorBMP := new tbitmap(); - FColorBMP.AutoDestroy := true; - FColorBMP.Handle := hbmcolor; - end - if hbmmask then - begin - FMaskBMP := new tbitmap(); - FMaskBMP.AutoDestroy := true; - FMaskBMP.handle := hbmmask; - end - end - FHandleChanged := false; - end - function setid(r); - begin - {** - @explan(说明) 设置id %%; - **} - if r <> FId then - begin - Fid := r; - DestroyHandle(); - if ifnumber(r)then h := loadsysico(r); - if h then - begin - FDestroy := false; - end else - begin - h := getresourcebyid(r,array("type":"ico")); - if not h then - begin - if Image then - begin - Image.LoadFromFile(r); - h := Image.tohicon(); - end - end - FDestroy := true; - end - if H then SetHandle(H); - end - end - protected - class function loadsysico(id);virtual; - begin - if not ifarray(FSystemIcons)then FSystemIcons := array(); - r := FSystemIcons[id]; - if r then return r; - r := _wapi.LoadIconA2(nil,id); - FSystemIcons[id]:= r; - return r; - end - function DestroyHandle();virtual; - begin - {** - @explan(说明) 析构句柄 %% - @return(bool) - **} - if HandleAllocated()and FDestroy then _wapi.DestroyIcon(FHandle); - FBitmap := nil; - FMaskBMP := nil; - FColorBMP := nil; - FHandle := 0; - end - public - function HandleAllocated(); - begin - {** - @explan(说明) 判断是有句柄 %% - **} - return ifnumber(FHandle)and(FHandle <> 0); - end - function create(); - begin - inherited; - FHICON := new TSHICON(nil); - FDestroy := true; - end - function Recycling();override; - begin - DestroyHandle(); - FHICON := nil; - inherited; - end - function destroy();override; - begin - inherited; - end - function Tobitmap(); - begin - {** - @explan(说明) 将ico转换为bitmap %% - @return(nil|TBitmap) - **} - if HandleAllocated()and FImage then - begin - FImage.FromHIcon(FHandle); - Hbm := FImage.ToHbitmap(); - if hbm then - begin - r := new TBitmap(); - TBitmap.Handle := Hbm; - return r; - end - end - return nil; - end - function readvcon(d);override; - begin - if Image and ifarray(d)and d["type"]="img" then - begin - Image.StringToImage(d["data"]); - bthandle := Image.tohicon(); - SetHandle(bthandle); - AutoDestroy := true; - end - end - function tovcon();override; - begin - r := nil; - if Image and HandleAllocated()then - begin - r := array("type":"ico"); - r["ficon"]:= ficon; - r["type"]:= "img"; - Image.FromHIcon(FHandle); - r["data"]:= Image.ImageToString("png"); - end - return r; - end - property id read FId write SetID; - property Handle read FHandle write SetHandle; - property MaskBMP:tbitmap read GetMaskBitMap; - property ColorBMP:tbitmap read GetColorBitMap; - property AutoDestroy read FDestroy write FDestroy; - property ficon index "ficon" read getvalue write setvalue; - property xhotspot index "xhotspot" read getvalue write setvalue; - property yhotspot index "yhotspot" read getvalue write setvalue; - property hbmmask index "hbmmask" read getvalue write setvalue; - property hbmcolor index "hbmcolor" read getvalue write setvalue; - {** - @param(id)(integer|string) 资源id %% - @param(Handle)(intptr) 句柄 %% - @param(MaskBMP)(tbitmap) mask位图 %% - @param(ColorBMP)(tbitmap) color位图 %% - @param(AutoDestroy)(bool) 是否自动是否资源 %% - **} -end - -type TCursor=class(ticon) - {** - @explan(说明)光标类 %% - **} - private - static FSystemCursors; - protected - class function loadsysico(id);override; - begin - {** - @param(id)(member of TSystemCursor) cursor id %% - @return(pointer) 句柄 %% - **} - if not ifarray(FSystemCursors)then FSystemCursors := array(); - r := FSystemCursors[id]; - if r then return r; - r := _wapi.LoadCursorA2(nil,id); - if r then FSystemCursors[id]:= r; - return r; - end - public +type TIcon = class(tcustomicon) function create();override; begin inherited; - end - function show();override; - begin - {** - @explan(说明) 显示光标 - **} - if HandleAllocated()then - begin - //hd := _wapi.SetCursor(_wapi.LoadCursorA2(0,IDC_WAIT)); - hd := _wapi.SetCursor(self.Handle); - return hd; - end - end - function Recycling();override; - begin - inherited; - end -end - -type TGdi = class(TSLUIBASE) - private - static GDICache; - FCanvas; - function SetCanvas(c); - begin - FCanvas := c; - Onchange(); - end - protected FHandle; //gdi句柄 - FGdistate; - FGDIstruct; - class function sinit();override; - begin - inherited; - if not GDICache then GDICache := new TResourcescache(); - end - public - function HandleAllocated();virtual; - begin - return FHandle <> 0 and ifnumber(FHandle); - end - function HandleNeeded();virtual; - begin - return FHandle; - end - function DestroyHandle();virtual; - begin - if HandleAllocated()then - begin - unreference(); - FHandle := 0; - end - end - function GetGDIinfo();virtual; - begin - if not FGDIstruct then - begin - FGDIstruct := 1; - end - //return array(); - end - function Onchange();virtual; - begin - end - function GetFormatGdiStr(); - begin - v := gdiformatstr(); - if ifstring(v)then return getmsgd_Crc32(v); - return ""; - end - function reference();virtual; - begin - return GDICache.reference(GetFormatGdiStr()); - end - function addsource(v);virtual; - begin - GDICache.addsource(GetFormatGdiStr(),v); - end - function unreference();virtual; - begin - GDICache.unreference(GetFormatGdiStr()); - end - - function destroyresource();virtual; - begin - GDICache.destroyresource(GetFormatGdiStr()); - end - function gdiformatstr();virtual; - begin - return 0; - end - function create();override; - begin - inherited; - FGdistate := array(); - end - function Recycling();override; - begin - FCanvas := nil; - DestroyHandle(); - inherited; - end - property Canvas read FCanvas write SetCanvas; - property Handle read HandleNeeded; -end -type TRgn = class(TSLUIBASE) - {** - @explan(说明) 区域 %% - **} - private - FHandle; - function GetHandle(); - begin - if not HandleAllocated()then FHandle := CreateRgn(); - return FHandle; - end - function SetHandle(v); - begin - if v <> FHandle then - begin - DestroyHandle(); - if ifnumber(v)and v then FHandle := v; - end - end - public - function Create();override; - begin - inherited; - end - function HandleAllocated(); - begin - return FHandle and ifnumber(FHandle); - end - function DestroyHandle(); - begin - if HandleAllocated()then _wapi.DeleteObject(FHandle); - FHandle := 0; - end - function CreateRgn();virtual; - begin - return _wapi.createrectrgn(0,0,0,0); - end - class function CombineRgn(rgn1,rgn2,f,rgn); - begin - {** - @explan(说明)rgn合并%% - @param(rgn1)(trgn) 区域1 %% - @param(rgn2)(trgn) 区域2 %% - @param(rgn)(trgn) 返回合并后的区域 %% - @param(f)(integer) 合并方式 RGN_AND RGN_COPY RGN_DIFF RGN_OR RGN_XOR %% - @param(integer) 返回 NULLREGION COMPLEXREGION SIMPLEREGION ERROR - **} - if(rgn1 is class(TRGN))and(rgn2 is class(TRGN))then - begin - rgn := new TRgn(); - return _wapi.CombineRgn(rgn.Handle,s1.Handle,rgn2.Handle,f); - end - end - function Recycling();override; - begin - DestroyHandle(); - inherited; - end - property Handle read GetHandle write SetHandle; -end -type TRGNELLIP=class(TRGN) //椭圆 - {** - @explan(说明)椭圆rgn - **} - private - FRect; - function SetRect(v); - begin - if v <> FRect and ifarray(v) and ifnumber(v[0])and ifnumber(v[1])and v[2]>v[0]and v[3]>v[1] then - begin - FRect := v; - DestroyHandle(); - end - end - public - function create();override; - begin - inherited; - FRect := array(0,0,0,0); - end - function CreateRgn();override; - begin - return _wapi.CreateEllipticRgn(FRect[0],FRect[1],FRect[2],FRect[3]); - end - property Rect read FRect write SetRect; -end -type TRGNRECT=class(TRGNELLIP) - {** - @explan(说明)矩形区域%% - - **} - function create();override; - begin - inherited; - end - function CreateRgn();override; - begin - rec := Rect; - return _wapi.CreateRectRgn(rec[0],rec[1],rec[2],rec[3]); - end -end -type TRGNRoundRect=class(TRGNELLIP) - {** - @explan(说明) RoundRect rgn %% - **} - private - FEllipseWidth; - FEllipseHeight; - function SetEllipseWidth(v); - begin - if v >= 0 and v <> FEllipseWidth then - begin - FEllipseWidth := v; - DestroyHandle(); - end - end - function SetEllipseHeight(); - begin - if v >= 0 and v <> FEllipseHeight then - begin - FEllipseHeight := v; - DestroyHandle(); - end - end - public - function Create(AOwner);override; - begin - inherited; - FEllipseHeight := 1; - FEllipseWidth := 1; - end - function CreateRgn();override; - begin - rec := Rect; - return _wapi.CreateRoundRectRgn(rec[0],rec[1],rec[2],rec[3],FEllipseWidth,FEllipseHeight); - end - property EllipseWidth:integer read FEllipseWidth write SetEllipseWidth; - property EllipseHeight:integer read FEllipseHeight write SetEllipseHeight; -end -type TRGNPOLY=class(TRGN) //多边形 - {** - @explan(说明)多边形区域%% - **} - private - FPoints; - FImode; - function SetImode(v); - begin - if(v in array(1,2))and v <> FImode then - begin - FImode := v; - DestroyHandle(); - end - end - function SetPoints(v); - begin - if v <> FPoints then - begin - FPoints := v; - DestroyHandle(); - end - end - public - function create(); //点 和填充模式 - begin - inherited; - FImode := ALTERNATE; - end - function CreateRgn();override; - begin - t := pointtovector(FPoints); - len := length(t); - if len>5 then return _wapi.CreatePolygonRgn(t,len/2,FImode); - end - property Points read FPoints write SetPoints; - property Imode read FImode write SetImode; -end - -type TFont = class(tgdi) - private - FHeight; - FWidth; - Fescapement; - Forientation; - Fweight; - Fitalic; - Funderline; - Fstrikeout; - Fcharset; - Foutprecision; - Fclipprecision; - Fquality; - Fpitchandfamily; - Ffacename; - FColor; - FBKColor; - FBkmode; - static LOGSTRUCT; - static LOGSTRUCTarray; - class function sinit();override; - begin - inherited; - if not LOGSTRUCTarray then - begin - LOGSTRUCTarray := array( - ("height","int",15), - ("width","int",0), - ("escapement","int",0), - ("orientation","int",0), - ("weight","int",400), - ("italic","byte",0), - ("underline","byte",0), - ("strikeout","byte",0), - ("charset","byte",134), - ("outprecision","byte",3), - ("clipprecision","byte",2), - ("quality","byte",1), - ("pitchandfamily","byte",FIXED_PITCH), - ("facename","char[32]","新宋体")); - LOGSTRUCT := tslcstructure(LOGSTRUCTarray); - end - end - function SetColor(c); - begin - if ifnumber(c)and c <> FColor then - begin - FColor := c; - if Canvas then Canvas.OnFontColorChange(); - end - end - function SetbkColor(c); - begin - if ifnumber(c)and c <> FBKColor then - begin - FBKColor := c; - if Canvas then Canvas.OnFontbkColorChange(); - end - end - function SetbkMode(c); - begin - nc :=(c=OPAQUE)?OPAQUE:TRANSPARENT; - if FBkmode <> nc then - begin - FBkmode := nc; - if Canvas then Canvas.OnFontbkmodeChange(); - end - end - function Setheight(v) - begin - if ifnumber(v)and v <> Fheight then - begin - Fheight := v; - onchange(); - end - end - function Setwidth(v) - begin - if ifnumber(v)and v <> Fwidth then - begin - Fwidth := v; - onchange(); - end - end - function Setescapement(v) - begin - if ifnumber(v)and v <> Fescapement then - begin - Fescapement := v; - onchange(); - end - end - function Setorientation(v) - begin - if ifnumber(v)and v <> Forientation then - begin - Forientation := v; - onchange(); - end - end - function Setweight(v) - begin - if not(v=400 or v=700)then return; - if v <> Fweight then - begin - Fweight := v; - onchange(); - end - end - function Setitalic(v) - begin - nv := v?true:false; - if nv <> Fitalic then - begin - Fitalic := nv; - onchange(); - end - end - function Setunderline(v) - begin - nv := v?true:false; - if nv <> Funderline then - begin - Funderline := nv; - onchange(); - end - end - function Setstrikeout(v) - begin - nv := v?true:false; - if nv <> Fstrikeout then - begin - Fstrikeout := nv; - onchange(); - end - end - function Setcharset(v) - begin - if ifnumber(v)and v <> Fcharset then - begin - Fcharset := v; - onchange(); - end - end - function Setoutprecision(v) - begin - if not(v in array(OUT_DEFAULT_PRECIS,OUT_DEVICE_PRECIS,OUT_OUTLINE_PRCIS,OUT_RASTER_PRECIS, - OUT_STRING_PRECIS,OUT_STROKE_PRECIS,OUT_TT_ONLY_PRECIS,OUT_TT_PRECIS))then return; - if v <> Foutprecision then - begin - Foutprecision := v; - onchange(); - end - end - function Setclipprecision(v) - begin - if not ifnumber(v)then return; - if(v .&(CLIP_DEFAULT_PRECIS .| CLIP_STROKE_PRECIS .| CLIP_MASK .| CLIP_LH_ANGLES .| CLIP_TT_ALWAYS))and v <> Fclipprecision then - begin - Fclipprecision := v; - onchange(); - end - end - function Setquality(v) - begin - if not(v in array(DEFAULT_QUALITY,DRAFT_QUALITY,PROOF_QUALITY))then return; - if v <> Fquality then - begin - Fquality := v; - onchange(); - end - end - function Setpitchandfamily(v) - begin - if not(v in array(DEFAULT_PITCH,FIXED_PITCH,VARIABLE_PITCH, - FF_DECORATIVE,FF_MODERN,FF_ROMAN,FF_SCRIPT,FF_SWISS))then return; - if v <> Fpitchandfamily then - begin - Fpitchandfamily := v; - onchange(); - end - end - function Setfacename(v) - begin - if ifstring(v)and v <> Ffacename and length(v)<= 32 then - begin - Ffacename := v; - onchange(); - end - end - protected - function gdiformatstr();override; - begin - s := ""; - for i,v in LOGSTRUCTarray do - begin - v0 := v[0]; - s += v0; - s += ":"; - if v0="facename" then - begin - s += invoke(self,"f"+v0); - end else - vvi := invoke(self,"f"+v0); - if ifnumber(vvi)then s += inttostr(vvi); - else s += "0"; - s += ";"; - end - r := "class:font;"+s; - return r; - end - public - function HandleNeeded();override; - begin - if not HandleAllocated()then - begin - hp := reference(); - if not hp then - begin - for i,v in LOGSTRUCTarray do - begin - v0 := v[0]; - LOGSTRUCT._setvalue_(v0,invoke(self,"f"+v0)); - end - hp := _wapi.CreateFontIndirectA(LOGSTRUCT._getptr_); - addsource(hp); - end - FHandle := hp; - end - return FHandle; - end - function fontinfo(); - begin - {** - @explan(说明) 获得字体信息 %% - **} - r := array(); - for i,v in LOGSTRUCTarray do - begin - r[v[0]]:= invoke(self,v[0]); - end - r["color"]:= color; - r["bkcolor"]:= bkcolor; - return r; - end - function create();override; - begin - inherited; - fheight := 15; - fwidth := 7; - fescapement := 0; - forientation := 0; - fweight := 400; - fitalic := 0; - funderline := 0; - fstrikeout := 0; - fcharset := 134; - foutprecision := 3; - fclipprecision := 2; - fquality := 1; - fpitchandfamily := FIXED_PITCH; - ffacename := "新宋体"; - FColor := 0; - Onchange(); - end - function Onchange();override; - begin - if Canvas then Canvas.OnFontChange(); - DestroyHandle(); - end - function copyfont(f);virtual; - begin - {** - @explan(说明) 字体信息拷贝 %% - @param(f)(tfont) - **} - if not(f is class(tfont))then exit; - return SetValues(f.fontinfo()); - val := array(); - for i,v in LOGSTRUCTarray do - begin - v0 := v[0]; - fvi := invoke(f,v0); - val[v0]:= fvi; - end - val["color"]:= f.color; - val["bkcolor"]:= f.bkcolor; - return SetValues(val); - end - function SetValues(vs);virtual; - begin - {** - @explan(说明) 通过数组设置字体属性 %% - @param(vs)(array)字体信息数据 %% - **} - if not ifarray(vs)then exit; - for i,v in LOGSTRUCTarray do - begin - v0 := v[0]; - vsv := vs[v0]; - if not ifnil(vsv)then - begin - ovi := invoke(self,"f"+v0); - if ovi <> vsv then - begin - invoke(self,"f"+v0,1,vsv); - cg := true; - end - end - end - if ifnumber(vs["color"])then - begin - cg := true; - SetColor(vs["color"]); - end - if cg then Onchange(); - return cg; - end - function GetFontWidth(); - begin - if FWidth>0 then return FWidth; - return abs(FHeight)/2; - end - property height read Fheight write Setheight; - property width read Fwidth write Setwidth; - property escapement read Fescapement write Setescapement; - property orientation read Forientation write Setorientation; - property weight read Fweight write Setweight; - property italic read Fitalic write Setitalic; - property underline read Funderline write Setunderline; - property strikeout read Fstrikeout write Setstrikeout; - property charset read Fcharset write Setcharset; - property outprecision read Foutprecision write Setoutprecision; - property clipprecision read Fclipprecision write Setclipprecision; - property quality read Fquality write Setquality; - property pitchandfamily read Fpitchandfamily write Setpitchandfamily; - property facename read Ffacename write Setfacename; - property Color read FColor write SetColor; - property bkColor read FBKColor Write SetBkColor; - property bkmode read FBkmode Write SetBkMode; -end - -type TFontControl=class(tfont) - {** - @explan(说明) 控件字体 %% - **} - private - FControl; - Function SetControl(v); - begin - if(v <> FControl)and(v is class(tcontrol))then - begin - FControl := v; - end - end - protected - function Onchange();override; - begin - inherited; - if FControl then - begin - FControl.FontChanged(); - end - end - public - function create();override; - begin - inherited; - end - function Recycling();override; - begin - FControl := nil; - inherited; - end - property Control read FControl write SetControl; -end -type TPen=class(tgdi) - private - FStyle; - FColor; - FWidth; - static LOGSTRUCT; - class function sinit();override; - begin - inherited; - if not LOGSTRUCT then LOGSTRUCT := tslcstructure(array(("lopenstyle","int",0), - ("lopnwidth","int",1), - ("lopnwidth2","int",0), - ("lopncolor","int",0))); - end - function HandleNeeded();override; - begin - if not HandleAllocated()then - begin - hp := reference(); - if not hp then - begin - if fStyle in array(PS_NULL,PS_SOLID,PS_INSIDEFRAME)then - begin - w := FWidth; - end else - w := 0; - hp := _wapi.CreatePen(FStyle,w,FColor); - addsource(hp); - end - FHandle := hp; - end - return FHandle; - end - function gdiformatstr();override; - begin - return format("class:pen;style:%d;color:%d;width:%d",FStyle,FColor,FWidth); - end - function Onchange();override; - begin - if Canvas then Canvas.OnPenChange(); - DestroyHandle(); - end - function SetColor(c); - begin - if ifnumber(c)and c <> FColor then - begin - Onchange(); - FColor := c; - end - end - function SetStyle(s); - begin - if(s in array(0,1,2,3,4,5,6)) and s <> FStyle then - begin - Onchange(); - FStyle := s; - end - end - function SetWidth(w); - begin - if w >= 0 and w<20 and c <> FWidth then - begin - Onchange(); - FWidth := w; - end - end - function copypen(p); - begin - {** - @explan(说明)拷贝pen属性 %% - @param(p)(tpen) 源 %% - **} - if p is class(tpen)then - begin - ps := p.style; - wd := p.width; - cl := p.color; - if ps <> FStyle or wd <> FWidth or cl <> FColor then - begin - Onchange(); - FStyle := ps; - FWidth := wd; - FColor := cl; - end - end - end - public - function create(); - begin - inherited; - FStyle := PS_SOLID; - FWidth := 1; - FColor := 0; - end - property Color read FColor write SetColor; - property Width read FWidth write SetWidth; - property Style read FStyle write SetStyle; -end - -type TBrush=class(tgdi) - private - FStyle; - FColor; - FHatch; - static LOGSTRUCT; - function SetColor(c); - begin - if ifnumber(c)and c <> FColor then - begin - onchange(); - FColor := c; - end - end - public - class function sinit();override; - begin - inherited; - if not LOGSTRUCT then - begin - LOGSTRUCT := tslcstructure(array(("lbstyle","int",BS_SOLID), - ("lbcolor","int",0), - ("lbhatch","intptr",0))); - end - end - function onchange();override; - begin - if Canvas then Canvas.OnBrushChange(); - DestroyHandle(); - end - function HandleNeeded();override; - begin - if not HandleAllocated()then - begin - hp := reference(); - if not hp then - begin - //LOGSTRUCT._setvalue_("lbstyle",FStyle); - //LOGSTRUCT._setvalue_("lbcolor",FColor); - //LOGSTRUCT._setvalue_("lbhatch",FHatch); - //hp := _wapi.CreateBrushIndirect(LOGSTRUCT._getptr_); - hp := _wapi.CreateSolidBrush(FColor); - addsource(hp); - end - FHandle := hp; - end - return FHandle; - end - function gdiformatstr();override; - begin - return format("class:brush;style:%d;color:%d;hatch:%d",FStyle,FColor,FHatch); - end - function create();override; - begin - inherited create(); - sinit(); - FStyle := BS_SOLID; - FHatch := 0; - FColor := 0; - end - function copybrush(b); - begin - if b is class(tbrush)then - begin - if FColor <> b.color then - begin - onchange(); - FColor := b.color; - end - end - end - //property Style read FStyle write SetStyle; - property Color read FColor write SetColor; - //property Hatch read FHatch write SetHatch; -end -type TCanvsRgnClipAutoSave=class - {** - @expan(说明) 裁剪canvas区域,销毁时还原 %% - **} - function Create(cvs,rec); - begin - {** - @explan(说明)构造裁剪对象 %% - @param(cvs)(tcanvas) canvas 对象 %% - @param(rec)(array(左上右下))区域 %% - **} - if(cvs is class(TCanvas))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 -type TControlCanvs=class(TCanvas) - function Create(); - begin - inherited; - end - property ClipRect read FClipRect write SetClipRect; - private - Function SetClipRect(v); - begin - if ifarray(v)and v[0]0 then FCurrentId--; - end - property CurrenId read FCurrentId; - end - function SetTextTabLen(v); - begin - nv := integer(v); - if nv <> FTabLength then - begin - FTabLength := nv; - if not FTabLenParam then FTabLenParam := new Ttagdrawtextparams(); - FTabLenParam.itablength := nv; - end - end - function SetPen(p); - begin - FPen.copypen(p); - end - function SetFont(f); - begin - if ifarray(f)then - begin - FFont.SetValues(f); - end else - FFont.copyfont(f); - end - function SetBrush(b); - begin - FBrush.copybrush(b); - end - function SelectObject(hgdi); - begin - if HandleAllocated()then - begin - return _wapi.SelectObject(FHandle,hgdi); - end - end - function SetHandle(h); - begin - if ifnumber(h)then - begin - flashhandle(); - if FHandle <> h then - begin - FCounter.clean(); - end - FHandle := h; - if h then - begin - _wapi.GetTextMetricsA(FHandle,FTEXTMETRICA._getptr_); - end - end - end - function flashhandle(); - begin - FState := 1+2+4+8+16+32+64; - end - function ifrect(rect); - begin - return ifarray(rect)and ifnumber(rect[0])and ifnumber(rect[1])and ifnumber(rect[2])and ifnumber(rect[3]); - end - public - function GetTextExtent(s,mul); - begin - {** - @explan(说明) 获得 字符串绘制宽度和高度 %% - @param(s)(string) 字符串 %% - @param(mul)(bool) 多行 默认多行true%% - **} - r := array(0,0); - if ifstring(s)and HandleAllocated()then - begin - requiregdi(); - if ifnil(mul)then mul := true; - if mul then - begin - ss := str2array(s,"\n"); - if length(ss)then - begin - for i,v in ss do - begin - ri := array(0,0); - vi := trim(v); - if not vi then vi := "\r"; - _wapi.GetTextExtentPoint32A2(FHandle,vi,length(v),ri); - r[0]:= max(r[0],ri[0]); - r[1]+= ri[1]; - end - end - end else - _wapi.GetTextExtentPoint32A2(FHandle,s,length(s),r); - end - return r; - end - function SelectClipRgn(rgn); - begin - {** - @explan(说明) 设置区域 %% - @param(rgn)(TRgn) 选择区域 %% - **} - if rgn=FRgn then exit; - r := FRgn; - FRgn := rgn; - if not HandleAllocated()then exit; - if FRgn is class(TRgn)then - begin - r1 := _wapi.SelectClipRgn(FHandle,FRgn.Handle); - end else - begin - r1 := _wapi.SelectClipRgn(FHandle,nil); - end - if r is class(trgn)then return r; - return r1; - end - function create();override; - begin - inherited; - FTabLength := 0; - FCounter := new TCounter(); - FHandle := 0; - FState := 0; - FPen := new tpen(); - FPen.Canvas := self; - FBrush := new tbrush(); - FBrush.Canvas := self; - FFont := new tfont(); - FFont.Canvas := self; - FTEXTMETRICA := new ttagTEXTMETRICA(); - end - function Recycling();override; - begin - {** - @explan(说明)资源回收 %% - **} - FBrush.Recycling(); - FPen.Recycling(); - FBrush := nil; - FPen := nil; - FState := nil; - inherited; - end - function destroy();override; - begin - inherited; - end - function HandleAllocated(); - begin - {** - @explan(说明) 判断canvas句柄是否构造 %% - @return(bool) - **} - return ifnumber(FHandle)and(FHandle <> 0); - end; - procedure requiregdi(rq); - begin - {** - @explan(说明) 初始化gdi对象 如画刷 画笔 等 %% - **} - if HandleAllocated()then - begin - if FState .& 1 then - begin - SelectObject(FPen.Handle); - end - if FState .& 2 then - begin - SelectObject(FBrush.Handle); - end - if FState .& 4 then - begin - SelectObject(FFont.Handle); - end - if FState .& 8 then - begin - _wapi.SetTextColor(FHandle,FFont.Color); - end - if FState .& 16 then - begin - _wapi.SetBkColor(FHandle,FFont.bkColor); - end - if FState .& 32 then - begin - _wapi.SetbkMode(FHandle,(FFont.bkmode=OPAQUE)?OPAQUE:TRANSPARENT); //OPAQUE - end - if FRgn is class(trgn)then - begin - _wapi.SelectClipRgn(FHandle,FRgn.Handle); - end - FState := 0; - end - end - function OnFontbkmodeChange(); - begin - FState .|= 32; - end - function OnPenChange(); - begin - FState .|= 1; - end - function OnBrushChange(); - begin - FState .|= 2; - end - function OnFontChange(); - begin - FState .|= 4; - end - function OnFontColorChange(); - begin - FState .|= 8; - end - function OnFontbkColorChange(); - begin - FState .|= 16; - end - function SetViewportOrg(xy); - begin - {** - @explan(说明)设置选择基准点 %% - @param(xy)(array) array(x,y)%% - @return(integer) %% - **} - if HandleAllocated()then - begin - if not ifarray(xy)then return 0; - return _wapi.SetViewportOrgEx(FHandle,xy[0],xy[1],nil); - end - end - function SetPixel(xy,colr); - begin - {** - @explan(说明) 画一个像素 %% - @param(xy)(array) array(x,y)%% - @param(colr)(integer) 颜色rgb值 %% - @return(integer) %% - **} - if HandleAllocated()then return _wapi.SetPixel(FHandle,xy[0],xy[1],colr); - end - function fillrgn(rgn); - begin - {** - @explan(说明)区域填充 %% - @param(rgn)(trgn) 区域 %% - **} - if not HandleAllocated()then exit; - if not(rgn is class(TRgn))then exit; - _wapi.FillRgn(FHandle,rgn.Handle,FBrush.Handle); - end - function FillRect(rec); //填充 - begin - {** - @explan(说明)填充rect %% - @param(rec)(array) 区域 array(左,上,右,下)%% - @param(br)(tbrush) 画刷 %% - **} - if HandleAllocated()then - begin - return _wapi.FillRect(FHandle,(ifrect(rec)?rec:zeros(4)),FBrush.Handle); - end - end - function InvertRect(rec); //反向填充,rec区域,br画刷 - begin - {** - @explan(说明)反向填充区域 %% - @param(rec)(array) 区域 array(左,上,右,下)%% - **} - if not HandleAllocated()then exit; - return _wapi.InvertRect(FHandle,rec,FBrush.Handle); - end - function moveto(pos); - begin - {** - @explan(说明)移动当前点%% - @param(pos)(array) 位置array(x,y) %% - @return(array) 原来位置 %% - **} - ret := array(0,0); - if not ifarray(pos)then return-1; - if HandleAllocated()then - begin - _wapi.MoveToEx(FHandle,pos[0],pos[1],ret); - end - return ret; - end - function lineto(pos); //画线 - begin - {** - @explan(说明)画线到点%% - @param(pos)(array) 位置array(x,y) %% - **} - if not ifarray(pos)then return-1; - if HandleAllocated()then - begin - requiregdi(); - return _wapi.LineTo(FHandle,pos[0],pos[1]); - end - end - function textout(str,pos); //输出文字,str文字,pos开始位置 - begin - {** - @explan(说明)输出文本%% - @param(str)(string) 字符串 %% - @param(pos)(array) 位置array(x,y) %% - **} - if not ifstring(str)then return 0; - if not ifarray(pos)then pos := array(0,0); - if HandleAllocated()then - begin - requiregdi(); - return _wapi.TextOutA(FHandle,pos[0],pos[1],str,length(str)); - end - end - function drawtext(str,rec,uft); //在区域中绘制文字 - begin - {** - @explan(说明)在指定区域上输出文本%% - @param(str)(string) 绘制的文字 %% - @param(rec)(array) array(left,top,right,bottom) %% - @param(uft)(integer) DT_CALCRECT：这个参数比较重要，可以使DrawText函数计算出输出文本的尺寸。如果输出文本有多行，DrawText函数使用lpRect定义的矩形的宽度，并扩展矩形的底部以容纳输出文本的最后一行。如果输出文本只有一行，则DrawText函数改变矩形的右边界，以容纳下正文行的最后一个字符。出现上述任何一种情况，DrawText函数将返回格式化文本的高度，而不是绘制文本。 - DT_CENTER：指定文本水平居中显示。 - DT_VCENTER：指定文本垂直居中显示。该标记只在单行文本输出时有效，所以它必须与DT_SINGLELINE结合使用。 - DT_SINGLELINE：单行显示文本，回车和换行符都不断行。 - %% - **} - if not ifstring(str)then return-1; - if not ifnumber(uft)then uft := DT_NOPREFIX; //默认忽略 &占位符 - if not ifarray(rec)then rec := nil; - if HandleAllocated()then - begin - requiregdi(); - if FTabLength then - begin - return _wapi.DrawTextExA(FHandle,str,length(str),rec,uft .| DT_EXPANDTABS .| DT_TABSTOP,FTabLenParam._getptr_()); - end else - return _wapi.DrawTextA(FHandle,str,length(str),rec,uft); - // - end - end - function StretchDraw(rec,bmp); - begin - {** - @explan(说明) 绘制bitmap %% - @param(rec)(array of integer) array(左,上,右,下) %% - @param(bmp)(tbitmap) 位图 %% - **} - if not(bmp is class(tbitmap))then exit; - bmp.StretchDraw(self,rec); - end - function DrawBitmap(bmp,p); - begin - {** - @explan(说明)绘制bitmap %% - @param(bmp)(tbitmap) 图标 %% - @param(p)( array of integer) 位置 array(x,y) - **} - if not(bmp is class(tbitmap))then return-1; - if not ifarray(p)then p := array(0,0); - bmp.draw(self,p[0],p[1]); - end - function DrawIcon(ico,p); - begin - {** - @explan(说明)绘制icon %% - @param(ico)(ticon) 图标 %% - @param(p)( array of integer) 位置 array(x,y) - **} - if HandleAllocated()then - begin - if not(ifarray(p)and ifnumber(p[1])and ifnumber(p[0]))then p := array(0,0); - if(ico is class(ticon))and ico.Handle then return _wapi.DrawIcon(FHandle,p[0],p[1],ico.Handle); - end - end - function draw(name_,points,f,m); - begin - {** - @explan(说明)gdi画图函数%% - @param(name_)(string) 图形名称, rectangle 矩形 ;ellipse 椭圆;roundrect 圆角矩形;chord 弧线 ;pie 饼 ;polybezier 贝塞尔 ;polygon多条直线 %% - @param(points)(array) 点数组 例如 array((0,0),(1,2)) 表述两个点的数组,点的多少根据name_参数确定 %% - @param(f)(integer) 作图辅助参数 在画弧线的时候会用到的方向 %% - @param(m)(integer) 在polypolyline 使用表示绘图样式 %% - **} - if not HandleAllocated()then return 0; - requiregdi(); - if not ifstring(name_)then return 0; - _name_1 := lowercase(name_); - r := length(points); - c := mcols(points); - if not(r>1 and c=2)then return 0; - if "framecontrol"=_name_1 then - begin - if r<2 then return 0; - nrc := array(points[0][0],points[0][1],points[1][0],points[1][1]); - ret := _wapi.DrawFrameControl(FHandle,nrc,(f 4 then return 0; - if not ifnil(f)then SetArcDirection(FHandle,f); - ret := _wapi.Arc(FHandle,points[0,0],points[0,1],points[1,0],points[1,1],points[2,0],points[2,1],points[3,0],points[3,1]); - end else - if(("polygon"=_name_1)or("polyline"=_name_1))then - begin - if r<2 then return 0; - pt := pointtovector(points); - if "polygon"=_name_1 then - begin - if r<3 then return 0; - ret := _wapi.Polygon(FHandle,pt,r); - end else - ret := _wapi.polyline(FHandle,pt,r); - end else - if "polypolyline"=_name_1 then - begin - if ifarray(f)and(sum(f)=length(points))then - begin - pt := pointtovector(points); - ret := _wapi.polypolyline(FHandle,pt,f,m); - end - end else - if("polybezier"=_name_1)then - begin - if r<3 then return 0; - pt := pointtovector(points); - ret := _wapi.PolyBezier(FHandle,pt,r); - end - return ret; - end - - function CopyBitmap(rect); - begin - {** - @explan(说明) 获取canvas区域到位图 %% - @param(array of integer) 区域 array(左,上,右,下); - @return(tbitmap|nil) 成功返回位图 %% - **} - r := nil; - if not(ifarray(rect)and rect[2]>rect[0]and rect[3]>rect[1])then return r; - if not HandleAllocated()then return r; - if not FHDC then FHDC := _wapi.CreateCompatibleDC(0); - if not FHDC then return r; - bthandle := _wapi.CreateCompatibleBitmap(FSHDC2,w,h); - if not bthandle then return r; - oldb := _wapi.SelectObject(FHDC,bthandle); - _wapi.BitBlt(FHDC,0,0,rect[2]-rect[0],rect[3]-rect[1],FHandle,rect[0],rect[1],SRCCOPY); - if oldb then _wapi.SelectObject(FHDC,oldb); - R := new tbitmap(); - R.handle := bthandle; - return r; - end - function SetWorldTransform(trans); - begin - {** - @explan(说明)文本旋转%% - @param(trans)(array) array(cos,-sin,sin,cos,x,y)%% - **} - _xformobj._setvalue_("em11",trans[0]); - _xformobj._setvalue_("em12",trans[1]); - _xformobj._setvalue_("em21",trans[2]); - _xformobj._setvalue_("em22",trans[3]); - _xformobj._setvalue_("edx",trans[4]); - _xformobj._setvalue_("edy",trans[5]); - return _wapi.SetWorldTransform(FHandle,_xformobj._getptr_); - end - function SetPolyFillMode(md); //设置填充样式 - begin - {** - @explan(说明)设置填充模式 %% - @param(md)(integer) 填充模式 ALTERNA WINDING %% - **} - if HandleAllocated()then if ifnumber(md)then return _wapi.SetPolyFillMode(FHandle,md); - return-1; - end - function SetBkMode(m); - begin - {** - @explan(说明)文本背景样式%% - @param(m)(integer) 背景样式OPAQUE or TRANSPARENT %% - **} - if HandleAllocated()then return _wapi.SetBkMode(FHandle,m); - end - function GetBkMode(); - begin - {** - @explan(说明)文本背景样式%% - @return(integer) 背景样式%% - **} - if HandleAllocated()then return _wapi.GetBkMode(FHandle); - end - function SetTextAlign(fmt); - begin - {** - @explan(说明)文字对其方式%% - @param(fmt)(integer) 对其方式TA_LEFT; - TA_RIGHT; - TA_CENTER; - TA_TOP; - TA_BOTTOM;默认左对齐 %% - **} - if not ifnumber(fmt)then fmt := _wapi.TA_LEFT; - if HandleAllocated()then return _wapi.SetTextAlign(FHandle,fmt); - end - function ReleaseDC();virtual; - begin - //if HandleAllocated() then _wapi.ReleaseDC(FHandle); - end - - {function BeginPath(); - begin - if HandleAllocated() then return _wapi.BeginPath(FHandle); end - function EndPath(); - begin - if HandleAllocated() then return _wapi.EndPath(FHandle); - end - function StrokePath(); - begin - requiregdi(); - if HandleAllocated() then return _wapi.StrokePath(FHandle); - end - function FillPath(); - begin - requiregdi(); - if HandleAllocated() then return _wapi.FillPath(FHandle); - end - function StrokeAndFillPath(); - begin - requiregdi(); - if HandleAllocated() then return _wapi.StrokeAndFillPath(FHandle); - end} - function DeleteDC(); - begin - if HandleAllocated()then _wapi.DeleteDC(FHandle); - FHandle := 0; - end - function SaveDC(); - begin - {** - @explan(说明) 保存当前的dc %% - **} - if HandleAllocated()then - begin - FCounter.InCrease(); - _wapi.SaveDC(FHandle); - end - end - function RestoreDC(); - begin - {** - @explan(说明) 还原dc %% - **} - if HandleAllocated()then - begin - if FCounter.CurrenId>0 then - begin - FCounter.DeCrease(); - _wapi.RestoreDC(FHandle,-1); - end - end - end - property Handle read FHandle write SetHandle; - property pen read FPen write SetPen; - property font read FFont write SetFont; - property brush read FBrush write SetBrush; - property bkmode write SetBkMode; - property TextMetric read FTEXTMETRICA; - property TextTabLength read FTabLength write SetTextTabLen; - {** - @param(pen)(tpen) 画笔 %% - @param(brush)(TBRUSH) 画刷 %% - @param(font)(tfont) 字体 %% - @param(bkmode)(integer) 背景样式 OPAQUE or TRANSPARENT 默认 TRANSPARENT %% - @param(TextMetric)(ttagTEXTMETRICA) 文本样式信息 %% - **} -end -type TTimer = class(tcomponent)//定时器类 - {** - @explan(说明)定时器类,间隔是以毫秒为最小单位 %% - **} - {** - @example(范例--定时器) - //构造计算器,第一个参数为间隔(毫秒),第二个为函数指针 - tm := new ttimer(1000,function(o,e)begin echo now(); end ); - tm.start();//启动定时器 - tm.stop();//停止 - **} - private - static _STIMERS; //TIMER对象 - static FSIDC; //id 构造器 - class function Sgettimer(id); +end +type tcursor = class(tcustomcursor) + function create();override; begin - {** - @explan(说明) 通过id获得定时器对象 %% - @param(id)(integer) 定时器id %% - **} - return _STIMERS[id]; - end - class function Ssettimer(tm); + inherited; + end +end + +type TFont = class(tcustomfont) + function create();override; begin - {** - @explan(说明)存储定时器 %% - @param(tm)(ttimer) 定时器对象%% - **} - _STIMERS[tm.id]:= tm; + inherited; end - class function Sdeltimer(tid); +end + +type tpen = class(tcustompen) + function create();override; begin - {** - @explan(说明) 删除定时器 %% - @param(tid)(integer) id%% - **} - if tid and(ifnumber(tid))then reindex(_STIMERS,array(tid:nil)); - end - protected FOntimeout; - private - FOntimer; - Fid; - FInterval; - FStart; - _kill0; //标记 - function SetEnabled(f); + inherited; + end + +end + +type TBrush = class(tcustombrush) + function create();override; begin - if f then start(); - else stop(); - end - function SetInterval(intv); //设置间隔 + inherited; + end +end +type TCanvas = class(TCustomcanvas) + function create();override; begin - {** - @explan(说明)设置间隔 %% - @param(intv)(integer) 间隔,毫秒 %% - **} - if not(ifnumber(intv))then return FInterval; - if FStart then - begin - ndstart := 1; - stop(); - end - if intv <> FInterval and ifnumber(intv)and intv>0 then //时间不等 - begin - FInterval := intv; - end - if ndstart then start(); - end - public - {** - @param(FSIDC)(tidcreater) id构造器%% - @param(_STIMERS)(array) 全局存储%% - @param(FOntimer)(fpointer) timeout执行对象%% - @param(_kill0)(bool) 标记%% - **} + inherited; + end +end +type TTimer = class(TCustomTimer) function create(AOwner);override; begin inherited; - FID := FSIDC.createid(); - FStart := false; - FInterval := 1000; - end - function timeout(cmd,t); //一次性事件 - begin - {** - @explan(说明) 一次性事件 %% - @param(cmd)(fpointer) 执行回调 %% - @param(t)(integer) t毫秒后执行 %% - **} - FOntimeout := cmd; - if ifnumber(t)then SetInterval(t); - FOntimer := function(o,e) - begin - try - stop(); - calldatafunction(FOntimeout,o,e); - finally - FOntimeout := nil; - end; - end; - start(); - end - function start(); //开始 - begin - {** - @explan(说明)启动 %% - **} - if not(dataisfunction(FOntimer)and FInterval)>0 then return-1; - if FStart then return FStart; - ret := _wapi.SetTimer(nil,Fid,FInterval,getwinprocptr(2)); - _kill0 := ret; - Ssettimer(self(true)); - FStart := ret <> 0; - return FStart; - end - function stop(); //停止 - begin - {** - @explan(说明)停止 %% - **} - if FStart then - begin - if _kill0 then - begin - FStart := not((_wapi.KillTimer(nil,_kill0))<> 0); - if FStart=false then _kill0 := 0; - end - Sdeltimer(FID); - end - return not FStart; - end - function Recycling();override; - begin - {** - @explan(说明)析构预备 %% - **} - stop(); - FSIDC.deleteid(FID); - FOntimer := nil; - FOntimeout := nil; - FTimerStrc := nil; - inherited; - end - function destroy();override; - begin - inherited; - end - class function _timeproc_(hwnd,message,wparam,lparam); - begin - {** - @explan(说明) 定时回调入接口 %% - @param(hwnd)(integer) 窗口句柄 %% - @param(message)(integer) 消息id %% - @param(lparam)(integer) 消息参数2 %% - @param(wparam)(integer) 消息参数1 %% - **} - e := new tuieventbase(message,wparam,lparam,hwnd); - for i,iv in mrows(_STIMERS,1) do - begin - v := _STIMERS[iv]; - if v is class(ttimer)then if v.tproc(e)then return; - end - //return _twinproc_(hwnd,message,wparam,lparam); - end - class function Sinit();override; - begin - {** - @explan(说明)初始化定时器全局 %% - **} - if not FSIDC then - begin - _STIMERS := array(); - FSIDC := new tidcreater(); - end - inherited; - end - function tproc(e);virtual; - begin - if e.wparam and(e.wparam=_kill0)then - begin - CallMessgeFunction(FOntimer,self(true),e); - return 1; - end - end - property Interval:integer read FInterval write SetInterval; - property Ontimer:eventhandler read FOntimer write FOntimer; - property Enabled:bool read FStart Write SetEnabled; - property id read FID; - function publishs();override; - begin - return array("name","interval","ontimer"); - end - {** - @param(Interval)(integer) 设置运行间隔 %% - @param(Ontimer)(funtion[self,tuieventbase]) 定时调度 %% - @param(Enabled)(bool) 是否已经启动 %% - **} -end + end +end + //******action 相关***************************************** -type TBasicAction=class(TComponent) - private - FActionComponent:TComponent; //执行的tcomponent - FOnChange:TNotifyEvent; - FOnExecute:TNotifyEvent; - FOnUpdate:TNotifyEvent; - FParent; - function SetParent(p); - begin - if FParent <> p then - begin - if FParent is class(TActionList)then - begin - FParent.DeleteAction(self); - end - if p is class(TActionList)then - begin - p.AddAction(self); - end - Fparent := p; - end - end - protected FClients; - {** - @param(FClients)( TFpList of TActionLink) 关联的组件 %% - **} - procedure Change;virtual; - begin - calldatafunction(FOnChange,self); - end - procedure SetOnExecute(Value:TNotifyEvent);virtual; - begin - for i := 0 to FClients.count-1 do - begin - FClients[i].SetOnExecute(value); - end - FOnExecute := Value; - Change(); - end - public - function Create(AOwner:TComponent);override; - begin - inherited; - FClients := new TFpList(); - end - function Recycling();override; - begin - if FActionComponent then - begin - FActionComponent.RemoveFreeNotification(self); - end - while FClients.Count>0 do - begin - UnRegisterChanges(FClients.Last()); - end - inherited; - end - function Destroy();override; - begin - inherited; - end - function HandlesTarget(Target:TObject):Boolean;virtual; - begin - return false; - end - procedure UpdateTarget(Target:TObject);virtual; - begin - end - procedure ExecuteTarget(Target:TObject);virtual; - begin - end - function Execute():Boolean;virtual; - begin - if csDesigning in ComponentState then return ; - if FOnExecute then - begin - e := new tuieventbase(0,0,0,0); - calldatafunction(FOnExecute,self(true),e); - return true; - end - return false; - end - procedure RegisterChanges(Value:TBasicActionLink); - begin - Value.FAction := Self(true); - FClients.add(Value); - end - procedure UnRegisterChanges(Value:TBasicActionLink); - begin - for i := 0 to FClients.count-1 do - begin - if FClients[i]=Value then - begin - Value.FAction := nil; - FClients.deli(i); - break; - end - end - end - {function Update(): Boolean; virtual; - begin - if FOnUpdate then - begin - calldatafunction(FOnUpdate,self); - return true; - end - return false; - end } - function Notification(AComponent,Operation);override; - begin - inherited; - if Operation=opRemove and AComponent=FActionComponent then - begin - FActionComponent := nil; - if FParent is class(TActionList)then - begin - FParent.DeleteAction(self); - end - end - end - function SetActionComponent(Value); - begin - if FActionComponent <> Value then - begin - if FActionComponent is class(TComponent)then FActionComponent.RemoveFreeNotification(self); - FActionComponent := Value; - if FActionComponent is class(TComponent)then FActionComponent.FreeNotification(self); - end - end - property ActionComponent:TComponent read FActionComponent write SetActionComponent; - property onexecute:eventhandler read FOnExecute write SetOnExecute; - property OnUpdate:TNotifyEvent read FOnUpdate write FOnUpdate; - property OnChange:TNotifyEvent read FOnChange write FOnChange; - property parent read FParent Write SetParent; - {** - @param(OnExecute)(fpointer) 执行回调 %% - @param(OnUpdate)(fpointer) 更新回调 %% - @param(OnChange)(fpointer) 改变回调 %% - **} -end; -type TContainedAction=class(TBasicAction) - function create(AOwner);override; - begin - inherited; - end - function Destroy();override; - begin - inherited; - end -end -type TCustomAction=class(TContainedAction) - {** - @explan(说明) action类 %% - **} - private - FCaption:string; - FChecked:Boolean; - FChecking:Boolean; - FEnabled:Boolean; - FGroupIndex:Integer; - FHint:string; - FVisible:Boolean; - FShortCut; - procedure SetCaption(const Value:string); - begin - if Value=FCaption then exit; - for I := 0 to FClients.Count-1 do - begin - FClients[I].SetCaption(Value); - end - FCaption := Value; - Change(); - end - procedure SetChecked(Value:Boolean); - begin - if Value=FChecked then exit; - for I := 0 to FClients.Count-1 do - begin - FClients[I].SetChecked(Value); - end - FChecked := Value; - Change(); - end - procedure SetEnabled(Value:Boolean); - begin - nValue := Value?true:false; - if nValue=FEnabled then exit; - for I := 0 to FClients.Count-1 do FClients[I].SetEnabled(nValue); - FEnabled := nValue; - Change(); - end - procedure SetVisible(Value:Boolean); - begin - nValue := Value?true:false; - if nValue=FVisible then exit; - for I := 0 to FClients.Count-1 do FClients[I].SetVisible(nValue); - FVisible := nValue; - Change(); - end - function getShortCut(); - begin - return formatshortcut(FShortCut); - end - - function SetShortCut(v); - begin - if v and ifstring(v) then - begin - nst := parsershortcutstr(v); - end else nst := nil; - if nst <> FShortCut then - begin - FShortCut := nst; - - for I := 0 to FClients.Count-1 do - begin - FClients[I].SetShortCut(v); - end - Change(); - end - end - protected - procedure AssignTo(Dest:TPersistent);override; - begin - {** - @explan(说明) 赋值 %% - **} - if Dest=Self then exit; - if Dest is class(TCustomAction)then - begin - ps := array("checked","caption","visible","enabled","shortcut"); - for i,v in ps do invoke(Dest,v,1,invoke(self,v)); - end else - inherited; - end - public - function Create(AOwner:TComponent);override; - begin - {** - @explan(说明) 构造 %% - **} - inherited; - FEnabled := True; - FVisible := True; - end - function Recycling();override; - begin - inherited; - end - function Destroy;override; - begin - inherited; - end - function ExecuteCommand(cmd,p);override; - begin - if csDesigning in ComponentState then return ; - if cmd="doshortcut" then - begin - if (FClients and FClients.Count>0) and Enabled and Visible and ShortCut = p then - begin - if Execute() then return "havedoshortcut"; - end - end - end - function Execute():Boolean;override; - begin - Result := False; - Result := Enabled and inherited Execute(); - return Result; - end - published - property Caption:string read FCaption write SetCaption; - property Checked:bool read FChecked write SetChecked; - property Enabled:bool read FEnabled write SetEnabled; - property Visible:bool read FVisible write SetVisible; - property ShortCut read getshortcut write SetShortCut; -end; type TAction=class(TCustomAction) {** @explan(说明) action / command 类 对外接口,参考 TCustomAction 类 %% @@ -27760,10 +6919,7 @@ type TAction=class(TCustomAction) begin inherited; end - function destroy();override; - begin - inherited; - end + function publishs();override; begin r := array("name","caption","enabled","onexecute"); @@ -27771,340 +6927,7 @@ type TAction=class(TCustomAction) end end -type TBasicActionLink=class(TSLUIBASE) - {** - @explan(说明) 基础action component关联类 %% - **} - private - FOnChange; - protected - procedure AssignClient(AClient:TObject);virtual; - begin - end - procedure Change;virtual; - begin - calldatafunction(OnChange,FAction); - end - function IsOnExecuteLinked():Boolean;virtual; - begin - return true; - end - procedure SetAction(Value:TBasicAction);virtual; - begin - if Value <> FAction then - begin - if FAction then FAction.UnRegisterChanges(Self(true)); - FAction := Value; - if Value then Value.RegisterChanges(Self(true)); - end; - end - procedure SetOnExecute(Value:TNotifyEvent);virtual; - begin - end - public - FAction:TBasicAction; - function Create(AClient:TObject);override; - begin - inherited create(); - AssignClient(AClient); - end - Function Recycling();override; - begin - if FAction is class(TBasicAction)then FAction.UnRegisterChanges(self); - inherited; - end - function Destroy;override; - begin - inherited; - end - function Execute(AComponent:TComponent):Boolean;virtual; - begin - {** - @explan(说明) 执行 %% - **} - if not(FAction is class(TBasicAction))then exit; - FAction.ActionComponent := AComponent; - try - r := FAction.Execute(); - finally - FAction.ActionComponent := nil; - end; - return r; - end - {function Update(): Boolean; virtual; - begin - if FAction is class(TBasicAction) then return FAction.Update(); - end } - property Action:TBasicAction read FAction write SetAction; - property OnChange:TNotifyEvent read FOnChange write FOnChange; - {** - @param(OnChange)(function[sender:tcomponent]) 改变的回调 %% - @param(Action)(taction) action对象 %% - **} -end; -type TActionLink=class(TBasicActionLink) - {** - @explan(说明) action与控件连接类 %% - **} - public - procedure SetShortCut(const Value:String);virtual; - begin - end - procedure SetCaption(const Value:string);virtual; - begin - end - procedure SetChecked(Value:Boolean);virtual; - begin - end - procedure SetEnabled(Value:Boolean);virtual; - begin - end - procedure SetVisible(Value:Boolean);virtual; - begin - end - function create(AClient);override; - begin - inherited; - end - protected - function IsshortcutLinked():Boolean;virtual; - begin - return Action is CLASS(TCustomAction); - end - function IsCheckedLinked():Boolean;virtual; - begin - return Action is CLASS(TCustomAction); - end - function IsEnabledLinked():Boolean;virtual; - begin - return Action is CLASS(TCustomAction); - end - function IsCaptionLinked():Boolean;virtual; - begin - return Action is CLASS(TCustomAction); - end - function IsOnExecuteLinked():Boolean;virtual; - begin - return Action is CLASS(TCustomAction); - end - function IsVisibleLinked: - Boolean; - virtual; - begin - return Action is CLASS(TCustomAction); - end -end; -type TControlActionLink=class(TActionLink) - {** - @explan(说明)关联tcontrol 和 taction 类 %% - **} - protected - FClient:TControl; - function IsshortcutLinked():Boolean;virtual; - begin - return false; - end - procedure AssignClient(AClient);override; - begin - {** - @explan(说明)赋值control %% - @param(AClient)(tcontrol) %% - **} - if AClient is class(tcontrol)then FClient := AClient; - end - function IsCaptionLinked():Boolean;override; - begin - return FClient and inherited; - end - function IsEnabledLinked():Boolean;override; - begin - return FClient and inherited; - end - function IsVisibleLinked():Boolean;override; - begin - return FClient and inherited; - end - function IsOnExecuteLinked():Boolean;override; - begin - return FClient and inherited; - end - function IsCheckedLinked():Boolean;virtual; - begin - return false; - end - public - function create(AClient);override; - begin - inherited; - end - function destroy();override; - begin - inherited; - end - function Recycling();override; - begin - FClient := nil; - inherited; - end - procedure SetCaption(const Value:string);override; - begin - if IsCaptionLinked()then return FClient.Caption := Value; - end - procedure SetEnabled(Value:Boolean);override; - begin - if IsEnabledLinked()then return FClient.Enabled := Value; - end - procedure SetVisible(Value:Boolean);override; - begin - if IsVisibleLinked()then return FClient.Visible := Value; - end - procedure SetOnExecute(Value:TNotifyEvent);override; - begin - return inherited; - end -end; -type TMenuActionLink=class(TControlActionLink) - {** - @explan(说明) 菜单actionlink %% - **} - protected - procedure AssignClient(AClient);override; - begin - {** - @explan(说明)赋值control %% - @param(AClient)(tcontrol) %% - **} - if AClient is class(tmenu)then FClient := AClient; - end - function IsshortcutLinked();override; - begin - return FClient and(Action is CLASS(TCustomAction)); - end - function IsVisibleLinked():Boolean;override; - begin - return false; - end - function IsCheckedLinked():Boolean;override; - begin - return FClient and(Action is CLASS(TCustomAction)); - end - public - procedure SetShortCut(const Value:String);override; - begin - if IsshortcutLinked() then - begin - return FClient.ShortCut := Value; - end - end - function create(AOwner);override; - begin - inherited; - end - procedure SetChecked(Value:Boolean);override; - begin - if IsCheckedLinked()then return FClient.Checked := Value; - end -end -type TtoolbuttonActionLink=class(TControlActionLink) - {** - @explan(说明) 工具条按钮actionlink %% - **} - protected - procedure AssignClient(AClient);override; - begin - {** - @explan(说明)赋值control %% - @param(AClient)(TToolButton) %% - **} - if AClient is class(TToolButton)then FClient := AClient; - end - function IsshortcutLinked();override; - begin - return FClient and(Action is CLASS(TCustomAction)); - end - function IsCheckedLinked():Boolean;override; - begin - return false; - end - public - procedure SetShortCut(const Value:String);override; - begin - if IsshortcutLinked() then return FClient.ShortCut := Value; - end - function create(AOwner);override; - begin - inherited; - end - -end -type TActionList=class(TComponent) - {** - @explan(说明) actionlist %% - **} - private - FActionList; - function DeleteAllActions(); - begin - while FActionList.Count>0 do - begin - it := FActionList[0]; - if it is class(TBasicAction)then - begin - it.parent := nil; - end else - FActionList.deli(0); - end - end - public - function create(AOwner);override; - begin - inherited; - FActionList := new TFpList(); - end - function DeleteAction(v); - begin - {** - @explan(说明) 删除 %% - @param(v)(TBasicAction) - **} - if not(v is class(TBasicAction))then return 0; - idx := FActionList.indexof(v); - if not(idx >= 0)then return 0; - FActionList.deli(idx); - v.parent := nil; - end - function AddAction(V); - begin - {** - @explan(说明) 删除Action %% - @param(v)(TBasicAction) - **} - if v is class(TBasicAction)then - begin - if FActionList.indexof(v)>= 0 then return 0; - FActionList.add(v); - v.parent := self; - end - end - function Notification(AComponent,Operation);override; - begin - inherited; - if Operation=opRemove and AComponent=FActionComponent then - begin - DeleteAllActions(); - end - end - function Recycling();override; - begin - DeleteAllActions(); - inherited; - end - function publishs();override; - begin - return array("name"); - end -end //***************************** type TCommDlg=class(tcomponent) {** @@ -28689,893 +7512,13 @@ type TFolderChooseADlg=class(TCommDlg) end //菜单 -type TMenu = class(tcomponent) - {** - @explan(说明) 菜单类 %% - **} -private -#!begin - static FSIDC; //command 计数器 - FActionLink:TMenuActionLink; - Fhandle:hmenu; - FCaption:string; - FParent:tmenu; - FItems; - FAutoChecked:bool; - FChecked :bool; - FEnabled :bool; - FVisible :bool; - FCommand :integer; - FOnclick; - FOwnerDraw; - FOnselect; - FOnDrawItem; //绘制 - FOnMeasureItem; //测量 - FOninitmenupopup; - FOnrbuttonup; - FMtype; //样式 - FMenuitemInfo; - FOnDesignClick; - FBitmap; - FShortCut; - function modifyshowcaption(item); - begin - s := item.caption; - st := item.ShortCut; - if st then r := s+" ("+st+")"; - else r := s; - return r; - end - function SetBitmap(v); //设置bmp - begin - if v <> FBitmap then SetBitmapsub(v); - end - function SetBitmapsub(v); //子项设置bmp - begin - FBitmap := v; - if v is class(tbitmap)then - begin - if FBitmap.HandleAllocated()then - begin - if Parent then - begin - if not(Parent is class(tmainmenu))then - begin - return parent.setmenuiteminfo(indexof(),MIIM_BITMAP,"hbmpitem",v.Handle); - end - end - end - end else - begin - if Parent then - begin - if not(Parent is class(tmainmenu))then - begin - parent.setmenuiteminfo(indexof(),MIIM_BITMAP,"hbmpitem",-1); - end - end - end - end - function ancestor(); - begin - if parent then return parent.ancestor(); - else return self(true); - end - function ancestorof(item); - begin - {** - @explan(说明) 判断item是否为子节点 %% - @param(item)(tmenu) 判断的节点 %% - **} - if item is class(tmenu)then - begin - if item=self then return 1; - for i := 0 to FItems.count-1 do - begin - if FItems[i].ancestorof(item)then return 1; - end - end - return 0; - end - function inmenutree(item); - begin - ac := ancestor(); - if ac.ancestorof(item)then return true; - return 0; - end - function removehmenuitem(item,pi); - begin - {** - @explan(说明) 删除hmenu节点 %% - **} - if _wapi.RemoveMenu(FHandle,pi,MF_BYPOSITION)then menuchanged(); - end - function addhmenuitem(item,bef); - begin - {** - @explan(说明) 添加到hmenu %% - **} - mif := item.Itemstruct; - mif._setvalue_("wid",item.command); - ic := modifyshowcaption(item); - mif._setvalue_("dwtypedata",ic); - bm := item.Bitmap; - if(bm is class(tbitmap))and bm.HandleAllocated()and(not(self is class(tmainmenu)))then - begin - mif._setvalue_("hbmpitem",bm.handle); - bsk := true; - end - if item.HandleAllocated()then - begin - mif._setvalue_("hsubmenu",item.handle); - mif._setvalue_("fmask",MIIM_ID .| MIIM_STRING .| MIIM_STATE .| MIIM_FTYPE .| MIIM_SUBMENU .|(bsk?MIIM_BITMAP:0)); - end else - begin - mif._setvalue_("fmask",MIIM_ID .| MIIM_STRING .| MIIM_STATE .| MIIM_FTYPE .|(bsk?MIIM_BITMAP:0)); - end - IF item.TSeparator then - begin - mif._setvalue_("ftype",MFT_SEPARATOR); - end else - if item.TOwnerdraw then - begin - mif._setvalue_("ftype",MFT_OWNERDRAW); - end else - begin - mif._setvalue_("ftype",MFT_STRING); - end - state := 0; - if item.Checked then - begin - state .|= MFS_CHECKED; - end else - state .|= MFS_UNCHECKED; - if item.Enabled then - begin - state .|= MFS_ENABLED; - end else - state .|= MFS_DISABLED; - mif._setvalue_("fstate",state); - _wapi.InsertMenuItemA(FHandle,bef,true,mif._getptr_); - menuchanged(); - end - Function SetMenuType(nms,n); - begin - if not(n)then - begin - ms := MF_STRING; - end else - begin - ms := nms; - end - if FMtype <> ms then - begin - FMtype := ms; - if ms=MF_STRING then ft := MFT_STRING; - if ms=MF_SEPARATOR then ft := MFT_SEPARATOR; - if ms=MF_OWNERDRAW then ft := MFT_OWNERDRAW; - if parent then - begin - parent.setmenuiteminfo(indexof(),MIIM_FTYPE,"ftype",ft); - end - end - end - function getitems(); - begin - return FItems.data(); - end - function GetItemcount(); - begin - return FItems.count; - end - function GetMenuType(ms); - begin - return FMtype=ms; - end - function ifchild(item); - begin - if item is class(tmenu)then - begin - for i := 0 to FItems.count-1 do if FItems[i]=item then return 1; - end - return 0; - end - function dispatchrbuttonup(e); - begin - if e.lparam=FHandle then - begin - it := FItems[e.wparam]; - CallMessgeFunction(it.Onrbuttonup,it,e); - return 1; - end - return itemsdispatch(e); - end - function dispatchloop(e); - begin - if e.wparam=FHandle then - begin - CallMessgeFunction(Oninitmenupopup,self(true),e); - return 1; - end - return itemsdispatch(e); - end - function dispatchcommand(e); - begin - if e.lowparam=FCommand then - begin - //if FAutoChecked then checked := not(checked); - doClick(self(true),e); - return 1; - end else - begin - return itemsdispatch(e); - end - return 0; - end - function itemsdispatch(e); - begin - for i := 0 to FItems.count-1 do if FItems[i].dispatch(e)then return 1; - end - function dispatchselect(e); - begin - cmd := e.lowparam; - if cmd>1000 then - begin - if cmd=FCommand then - begin - CallMessgeFunction(FOnselect,self(true),e); - return 1; - end else - begin - return itemsdispatch(e); - end - end else - begin - if FHandle=e.lparam then - begin - it := FItems[cmd]; - if ifobj(it)then CallMessgeFunction(it.Onselect,it,e); - return 1; - end else - return itemsdispatch(e); - end - end - function dispatchbycmdid(e); - begin - if e.itemID=FCommand then - begin - case e.msg of - WM_MEASUREITEM: - begin - DoMeasureItem(self(true),e); - end - WM_DRAWITEM: - begin - DoDrawItem(self(true),e); - end - end; - return 1; - end else - begin - return itemsdispatch(e); - end - end - function itemsate(); - begin - state := 0; - if FEnabled then state .|= MF_ENABLED; - else state .|= MF_DISABLED; - if FChecked then state .|= MF_CHECKED; - else state .|= MF_UNCHECKED; - return state; - end - function doClick(o,e);virtual; - begin - if csDesigning in ComponentState then - begin - CallMessgeFunction(FOnDesignClick,o,e); - end - if Action and Action.Execute() then - begin - - end else - CallMessgeFunction(Onclick,o,e); - end - function DoMeasureItem(o,e);virtual; - begin - return CallMessgeFunction(OnMeasureItem,o,e); - end - function DoDrawItem(o,e);virtual; - begin - return CallMessgeFunction(OnDrawItem,o,e); - end - function modifyitem(item,uflags); - begin - {** - @explan(说明) 修改菜单子项的状态 %% - @param(item)(tmenu) 菜单子项 %% - @param(uflags)(integer) 状态常量 %% - **} - if HandleAllocated()then - begin - idx := indexof(item); - vv := vid := array(); - vvdx := 0; - if((uflags .& MIIM_STRING)=MIIM_STRING)then - begin - vid[vvdx]:= "dwtypedata"; - vv[vvdx++]:= modifyshowcaption(item); - end - if(uflags .& MF_POPUP)=MF_POPUP then - begin - vid[vvdx]:= "hsubmenu"; - vv[vvdx++]:= item.handle; - end - setmenuiteminfo(idx,uflags,vid,vv); - menuchanged(); - return; - end - end - function GetZorder(); - begin - r := indexof(); - return r; - end - function SetZorder(n); - begin - if not(n >= 0)then exit; - f := Parent; - if f is class(tmenu)then - begin - odn := indexof(); - if odn=n then exit; - nn := f.GetItemByIndex(n); - if nn then f.RemoveItem(self(true)); - f.insertitem(self(true),nn); - end - end - -#!end - protected - function SetAction(Value);virtual; - begin - if ifnil(Value)then - begin - if FActionLink then - begin - FActionLink.SetAction(nil); - end - excludestate(FControlStyle,csActionClient); - end else - if Value is class(TBasicAction)then - begin - includestate(FControlStyle,csActionClient); - if ifnil(FActionLink)then FActionLink := createobject(GetActionLinkClass(),self); - FActionLink.Action := Value; - FActionLink.Onchange := thisfunction(DoActionChange); - ActionChange(Value,csLoading in Value.ComponentState); - Value.FreeNotification(Self); - end - end - procedure DoActionChange(Sender:TObject); - begin - if Sender=Action then ActionChange(Sender,False); - end - function GetAction();virtual; - begin - if FActionLink then - begin - return FActionLink.Action; - end - end - function GetActionLinkClass();virtual; - begin - {** - @explan(说明) 返回actionlinkclass %% - @return(TMenuActionLink class) - **} - return class(TMenuActionLink); - end - procedure ActionChange(Sender:TObject;CheckDefaults:Boolean);virtual; - begin - if Sender is class(TCustomAction)then - begin - NewAction := Sender; - if (not CheckDefaults) or (Caption='') or (Caption=Name) then Caption := NewAction.Caption; - if (not CheckDefaults) then ShortCut := NewAction.ShortCut; - if (not CheckDefaults) or Enabled then Enabled := NewAction.Enabled; - if (not CheckDefaults) or FChecked then Checked := NewAction.Checked; - end; - end - function SetCaption(v);virtual; - begin - if not(ifstring(v)and(FCaption <> v))then exit; - FCaption := v; - if Parent then - begin - vs := modifyshowcaption(self); - parent.setmenuiteminfo(indexof(),MIIM_STRING,"dwtypedata",vs); - end - end - function SetVisible(v);virtual; - begin - nv := v?true:false; - if FVisible=nv then exit; - FVisible := nv; - TOwnerDraw := FVisible?false:true; - end - function SetChecked(v);virtual; - begin - nv := v?true:false; - if nv <> FChecked then - begin - FChecked := nv; - if parent then parent.setmenuiteminfo(indexof(),MIIM_STATE,"fstate",itemsate()); - end - end - function SetEnabled(v);virtual; - begin - nv := v?true:false; - if nv <> FEnabled then - begin - FEnabled := nv; - if parent then - begin - parent.setmenuiteminfo(indexof(),MIIM_STATE,"fstate",itemsate()); - end - end - end - function HandleNeeded(); - begin - {** - @explan(说明) 获取节点句柄,必须有子节点%% - @return(pointer) 节点句柄 %% - **} - if not HandleAllocated()then CreateHandle(); - return Fhandle; - end - //FCompStyle:integer; - public - function ExecuteCommand(cmd,d);override; - begin - if cmd = 'doshortcut' then - begin - if csDesigning in ComponentState then return ; - if Visible and Enabled and Parent and GetMenuType(0) then - begin - if d = ShortCut then - begin - DoClick(self,new tuieventbase(0,0,0,0)); - return "havedoshortcut"; - end - end - end - end - function Notification(AComponent:TComponent;Operation:TOperation);override; +type TMenu = class(TcustomMenu) + function create(AOwner);override; begin inherited; - if Operation=opRemove then - begin - if AComponent=Action then Action := nil; - end end - class function sinit();override; - begin - {** - @explan(说明) 初始化类成员 %%; - **} - inherited; - if not FSIDC then - begin - FSIDC := new tidcreater(5000); - end - end - function dispatch(e);override; //分发 - begin - {** - @explan(说明) 菜单消息分发 %% - @param(e)(tuieventbase) 消息对象 %% - **} - case e.msg of - WM_COMMAND: - begin - return dispatchcommand(e); - end - WM_MENUSELECT: - begin - return dispatchselect(e); - end - WM_INITMENUPOPUP: - begin - return dispatchloop(e); - end - WM_MENURBUTTONUP: - begin - return dispatchrbuttonup(e); - end else - return dispatchbycmdid(e); - end; - return 0; - end - Function create(AOwner:tcomponent);override; - begin - inherited; - FMtype := MF_STRING; - FParent := nil; - FChecked := False; - FVisible := True; - FEnabled := True; - FItems := new TFpList(); - FCaption := "menu"; - FCommand := FSIDC.createid(); - menustr := array( - ("cbsize","int",0), - ("fmask","int",0), - ("ftype","int",0), - ("fstate","int",0), - ("wid","int",0), - ("hsubmenu","intptr",0), - ("hbmpchecked","intptr",0), - ("hbmpunchecked","intptr",0), - ("dwitemdata","intptr",0), - ("dwtypedata","intptr",0), - ("cch","int",90), - ("hbmpitem","intptr",0)); - FMenuitemInfo := new tcstructwithcharptr(menustr,array("dwtypedata":"cch")); - FMenuitemInfo._setvalue_("cbsize",FMenuitemInfo._size_()); - end - function HandleAllocated(); - begin - {** - @explan(说明)菜单句柄是否已有效%% - **} - return ifnumber(FHandle)and FHandle; - end - function DestroyHandle(); - begin - {** - @explan(说明) 销毁菜单句柄 %% - **} - if HandleAllocated()then - begin - for i := 0 to FItems.count-1 do - begin - it := FItems[i]; - if it is class(tmenu)then it.DestroyHandle(); - end - _wapi.DestroyMenu(FHandle); - FHandle := 0; - end - end - function CreateMenu();virtual; - begin - {** - @explan(说明) 构造菜单句柄,通过overrid此函数实现不同类型菜单构造 %% - @return(pointer) 句柄 %% - **} - return _wapi.CreatePopupMenu(); - end - function CreateHandle(); - begin - {** - @explan(说明)更新节点句柄 %% - **} - if not HandleAllocated()then - begin - IF FItems.count>0 then - begin - FHandle := CreateMenu(); - end else - if self(true)is class(tmainmenu)then //修改 - begin - FHandle := CreateMenu(); - end - end - for i := 0 to FItems.count-1 do - begin - it := FItems[i]; - ch := it.handle; - addhmenuitem(it,i+1); - end - end - function Recycling();override; - begin - {** - @explan(说明) 菜单资源回收%% - **} - //DestroyHandle(); - if parent is class(tmenu)then - begin - parent.RemoveItem(self); - end - FSIDC.deleteid(FCommand); - FItems.clean(); - FOnDesignClick := nil; - FOnclick := nil; - FOwnerDraw := nil; - FOnselect := nil; - FOnDrawItem := nil; - FOnMeasureItem := nil; - FOninitmenupopup := nil; - FOnrbuttonup := nil; - inherited; - end - function removefromparent(); - begin - {** - @explan(说明) 从父节点中删除自己 %% - **} - if Fparent then - begin - Fparent.removeitem(self); - FParent := nil; - end - return self; - end - function indexof(item); - begin - {** - @explan(说明) 查看对象位置 %% - @param(item)(tmenu | nil) 如为nil 返回在自己在父节点位置,为菜单返回该菜单,在本菜单的位置 %% - **} - if ifnil(item)then - begin - if FParent then return FParent.indexof(self(true)); - return-1; - end - return FItems.indexof(item); - end - function GetItemByIndex(idx); - begin - {** - @explan(说明) 根据序号id 获得菜单%% - @param(idx)(integer) 序号id %% - @return(TMenu|nil) 如果存在返回菜单项,如果不错返回nil - **} - if ifnumber(idx)>= 0 then - begin - return FItems.geti(idx); - end - return nil; - end - function setmenuiteminfo(idx,mv,vid,vv); //设置信息 - begin - {** - @explan(说明)设置菜单信息 %% - @param(mv)(integer) mask %% - @param(vid)(string) 下标 %% - @param(vv)() 值 %% - **} - FMenuitemInfo._setvalue_("fmask",mv); - if ifstring(vid)then - begin - FMenuitemInfo._setvalue_(vid,vv); - end else - if ifarray(vid)and ifarray(vv)and(length(vid)=length(vv))then - begin - for i,v in vid do - begin - FMenuitemInfo._setvalue_(v,vv[i]); - end - end - if HandleAllocated()then return _wapi.SetMenuItemInfoA(Fhandle,idx,true,FMenuitemInfo._getptr_); - end - function insertitem(item,bef);virtual; - begin - {** - @explan(说明) 添加节点 %% - @param(item)(tmenu) 待添加的节点 %% - @param(bef)(tmenu | integer) 基准位置 %% - **} - if not(item is class(tmenu))then return-2; - if not ifchild(item)then - begin - if bef is class(tmenu)then - begin - beforid := indexof(bef); - end else - if ifnumber(bef)then - begin - beforid := bef; - end else - beforid := FItems.count(); - item.removefromparent(); - flagprant := false; - if FItems.count=0 then - begin - if Fparent then - begin - if Fparent.HandleAllocated()then - begin - flagprant := true; - end - end - end - FItems.insertbefor(item,beforid); - item.setfparent(self(true)); - if HandleAllocated()then - begin - addhmenuitem(item,beforid); - end - if flagprant then - begin - mks := MIIM_SUBMENU .| MIIM_STRING; - mksv := array("dwtypedata","hsubmenu"); - vs := modifyshowcaption(self); - mksvv := array(vs,self.handle); - if FBitmap is class(tbitmap)and FBitmap.HandleAllocated()then - begin - mks .|= MIIM_BITMAP; - mksv[2]:= "hbmpitem"; - mksvv[2]:= FBitmap.Handle; - end - Fparent.setmenuiteminfo(indexof(),mks,mksv,mksvv); - end - end - return-1; - end - function setfparent(p); - begin - {** - @ignore(忽略) %% - @explan(说明) 设置fprent %% - **} - FParent := p; - end - function removeItemByIndex(idx); - begin - {** - @explan(说明)根据序号删除子菜单 %% - @param(idx)(integer) 序号id %% - **} - it := GetItemByIndex(idx); - if it is class(tmenu)then - begin - return removeItem(it); - end - return nil; - end - function RecyclingAllItems(); - begin - {** - @explan(说明) 销毁当前节点的 所有子节点,子节点不可以再被使用 %% - **} - while FItems.count >= 1 do - begin - it := FItems[0]; - it.Recycling(); - end - end - function removeitem(item);virtual; - begin - {** - @explan(说明) 删除节点 %% - @param(item)(tmenu) 将删除的菜单项 %% - **} - pi := FItems.indexof(item); - if pi<0 then return-1; - if HandleAllocated()then removehmenuitem(item,pi); - FItems.deli(pi); - if FItems.count<1 then - begin - if Fparent then - begin - DestroyHandle(); //销毁菜单 - vs := modifyshowcaption(self); - Fparent.setmenuiteminfo(indexof(),MIIM_STRING .| MIIM_SUBMENU,array("dwtypedata","hsubmenu"),array(vs,0)); - //Fparent.modifyitem(self(true),FMtype.|MF_POPUP); //修改样式 - end - end - item.setfparent(nil); - end - private - function setparentforproperty(f); - begin - if f is class(tmenu)then - begin - f.insertitem(self); - end else - if parent is class(tmenu)then - begin - parent.removeitem(self); - end - end - public - function SetChangedPublish(n,v);virtual; - begin - {** - @explan(说明) 设计器相关函数 %% - **} - ts := array("tstring","tseparator","townerdraw"); - if(n in ts)then - begin - for i,vi in ts do DeleteChangedPublish(vi); - if v then inherited; - return; - end - inherited; - end - function menuchanged();virtual; - begin - {** - @explan(说明) 菜单改变时的回调 %% - **} - end - published - //property Visible read FVisible write SetVisible; - property Action:taction read GetAction write SetAction; - {** - @param(Action)(taction) action对象 %%; - **} - property caption:string read FCaption write SetCaption; - property Enabled:bool read FEnabled write SetEnabled; - property ItemCount read GetItemcount; - property Items read getitems; - property Handle read HandleNeeded; - property Parent read FParent write setparentforproperty; - property Command read FCommand; - property Bitmap:tbitmap read FBitmap write SetBitmap; - property Onclick:eventhandler read FOnclick write FOnclick; - {** - @param(caption)(string) 菜单显示文字 %%; - @param(ItemCount)(integer) 菜单子项个数 %% - @param(Handle)(pointer) 菜单句柄 %% - @param(Parent)(tmenu) 父节点 %% - @param(Command)(integer) 菜单id %% - @param(onclick)(function[tmenu,tuieventbase]) 菜单点击回调函数 %% - **} - //property OwnerDraw read FOwnerDraw write FOwnerDraw; - property TSeparator:bool index 0x800 read GetMenuType write SetMenuType; - property Itemstruct read FMenuitemInfo; - property TString index 0 read GetMenuType write SetMenuType; - Property TOwnerdraw:bool index 0x100 read GetMenuType write SetMenuType; - property Checked:bool read FChecked write SetChecked; - property OnDrawItem:eventhandler read FOnDrawItem write FOnDrawItem; - property OnMeasureItem:eventhandler read FOnMeasureItem write FOnMeasureItem; - property OnSelect:eventhandler read FOnselect write FOnselect; - property Oninitmenupopup read FOninitmenupopup write FOninitmenupopup; - property Onrbuttonup:eventhandler read FOnrbuttonup write FOnrbuttonup; - property Zorder read GetZorder write SetZorder; - property OnDesignClick read FOnDesignClick write FOnDesignClick; - property ShortCut read getShortCut write SetShortCut; - function publishs();override; - begin - return array("action","bitmap","caption","checked","enabled","name","townerdraw","tseparator", - "onclick","onrbuttonup","onselect"); - end - {** - @param(Parent)(tmenu|nil)添加父节点,如果非tmenu,从父节点移除 %% - @param(OnDrawItem)(function[tmenu,TMDRAWITEM]) 自绘制菜单回调函数 %% - @param(OnMeasureItem)(function[tmenu,TMMEASUREITEM]) 自绘制菜单高度宽度设置回调函数 %% - @param(Onrbuttonup)(function[tmenu,tuieventbase]) 菜单右击回调函数 %% - @param(OnSelect)(function[tmenu,TMMENUSELECT]) 菜单被鼠标选中回调函数 %% - @param(Oninitmenupopup)(function[tmenu,tuieventbase]) 进入菜单循环菜单回调函数 %% - **} - private - function getShortCut(); - begin - return formatshortcut(FShortCut); - end - - function SetShortCut(v); - begin - if v and ifstring(v) then - begin - nst := parsershortcutstr(v); - end else nst := nil; - if nst <> FShortCut then - begin - FShortCut := nst; - if Parent then - begin - vs := modifyshowcaption(self); - parent.setmenuiteminfo(indexof(),MIIM_STRING,"dwtypedata",vs); - end - end - end -end - -type TPopupmenu=class(tmenu) +end +type TPopupmenu=class(TcustomPopupmenu) {** @explan(说明) 弹出菜单 %% **} @@ -29583,78 +7526,13 @@ type TPopupmenu=class(tmenu) begin inherited; end - function publishs();override; - begin - return array("name","caption","enabled","onrbuttonup"); - end end - -type TMainmenu=class(tmenu) - {** - @explan(说明) 主菜单类 %% - **} - private - FWndHandle; - function setmenu(); - begin - if _wapi.IsWindow(FWndHandle)then - begin - _wapi.SetMenu(FWndHandle,self.handle); - end - end - function setwndhandle(v); - begin - if FWndHandle <> v then - begin - if _wapi.IsWindow(FWndHandle)then - begin - _wapi.SetMenu(FWndHandle,0); - end - FWndHandle := v; - setmenu(); - end - end - function DrawMenuBar(); - begin - if HandleAllocated()and _wapi.IsWindow(FWndHandle)then - begin - _wapi.DrawMenuBar(FWndHandle); - end - end - public - function insertitem(item,bef);override; - begin - inherited; - DrawMenuBar(); - end - function removeitem(item);override; - begin - inherited; - DrawMenuBar(); - end - function menuchanged();override; - begin - if _wapi.IsWindow(FWndHandle)then _wapi.DrawMenuBar(FWndHandle); - end +type TMainmenu = class(TcustomMainmenu) function create(AOwner);override; begin inherited; end - function CreateMenu();override; - begin - r := nil; - r := _wapi.CreateMenu(); - return r; - end - property Hwnd:pointer read FWndHandle write setwndhandle; - function publishs();override; - begin - return array("name"); - end - {** - @param(Hwnd)()窗口句柄 %%; - **} -end +end type TApplicationProperties=class(TComponent) {** @@ -30260,6 +8138,15 @@ type TSocketServer=class(TSocketInterface) "onclose","onconnected","onread","onwrite","onaccept","onerror"); end end +type TClipBoard = class(TcustomClipBoard) + {** + @explan(说明) 剪切板类 %% + **} + function create(AOwner);override; + begin + inherited; + end +end //线程 type TThreadWorker =class(TCustomThreadworker) @@ -30666,134 +8553,7 @@ type TWinEnviroment=class() end //剪切板类 -type TClipBoard=class(tcomponent) - {** - @explan(说明) 剪切板类 %% - **} - private - private - FIsopen; - function CloseClipboard(); - begin - if FIsopen then FIsopen := not _wapi.CloseClipboard(); - return not(FIsopen); - end - function OpenClipboard(); - begin - {** - @explan(说明) 打开剪切板 %% - **} - IF not(FIsopen)then FIsopen := _wapi.OpenClipboard(0); - return FIsopen; - end - function EmptyClipboard(); - begin - {** - @explan(说明) 清空剪切板 %% - **} - if FIsopen then _wapi.EmptyClipboard(); - end - function SetText(s); - begin - {** - @explan(说明) 设置字符串到剪切板 %% - @param(s)(string|nil) 字符串如果为nil则清空 %% - **} - ret :=-1; - if not(ifstring(s)and length(s)>0)then - begin - return-1; - end - OpenClipboard(); - try - EmptyClipboard(); - _wapi.setclipboardtext(0,s); - finally - CloseClipboard(); - end; - return ret; - end - function GetText(); - begin - {** - @explan(说明) 获得剪切板字符串 %% - @return(string) 字符串 %% - **} - OpenClipboard(); - try - if _wapi.IsClipboardFormatAvailable(CF_TEXT)then - begin - r := _Wapi.getclipboardtext(0); - end - finally - CloseClipboard(); - end; - return r; - end - function SetBitmap(v); - begin - if v is class(tbitmap)then - begin - if V.HandleAllocated()then - begin - OpenClipboard(); - try - EmptyClipboard(); - _wapi.setclipboardbmp(v.Handle); - finally - CloseClipboard(); - end; - return ret; - end - end - end - function Getbitmap(); - begin - OpenClipboard(); - try - if _wapi.IsClipboardFormatAvailable(CF_BITMAP)then - begin - sid := _wapi.getclipboardbmp(); - if sid then - begin - bmp := new tbitmap(); - bmp.Handle := sid; - return bmp; - end - return false; - end - finally - CloseClipboard(); - end; - return r; - end - public - function create(AOwner);override; - begin - {** - @explan(说明) 构造剪切板类对象 %% - **} - inherited; - end - function Recycling();override; - begin - CloseClipboard(); - inherited; - end - function destroy();override; - begin - inherited; - end - property Text read GetText write SetText; - property Bmp read GetBitmap write SetBitmap; - function publishs();override; - begin - return array("name","text","bmp"); - end - {** - @explan(Text)(string) 设置或者获取剪切板文本 %% - **} -end + type TQuotations=class(tcomponent) {** @explan(说明) 行情订阅以及远程执行类 %% @@ -31206,227 +8966,7 @@ type tlogincontrol=class(tpanel) **} end -type TArrayTreeClass = class - {** - @explan(说明) 树形类 %% - @param(FIdName)(integer | string) id名称 %% - @param(FPIdName)(integer | string) 父节点名称 %% - **} - {** - @example(转换范例) %% - d := array(("id":1,"pid":5,"caption":"jd1"), - ("id":4,"pid":2,"caption":"jd2"), - ("id":2,"pid":1,"caption":"jd3"), - ("id":3,"pid":2,"caption":"jd4"), - ("id":5,"pid":7,"caption":"jd5"), - ); - dt := class(TArrayTreeClass).ToTreeArray(d,array("id":"id","pid":"pid","sub":"sub")); - return dt; - **} - private - class function ClumnNameOk(id); - begin - return ifnumber(id) or ifstring(id) ; - end - static FCounter; - static FIdName; - Static FPIdName; - static FSubName; - static FSInToArray; - FRecyce; - FInToArray; - FComponents; //节点 - FId; //id - FValue; //数据 - class function initconter(); - begin - FCounter := 1; - end - class function GetCounter(); - begin - return FCounter++; - end - public - class function SetIdName(id,pid,sub); - begin - if(id <> pid)and(ifstring(id)or ifnumber(id))and(ifstring(pid)or ifnumber(pid))and(ifstring(sub)or ifnumber(sub))then - begin - FIdName := id; - FPIdName := pid; - FSubName := sub; - end - end - function create(v); - begin - {** - @explan(说明) 构造节点 %% - **} - FId := v[FIdName]; - FValue := v; - FComponents := array(); - end - function addcomponent(o); - begin - {** - @explan(说明) 添加节点 %% - **} - len := length(FComponents); - for i := 0 to len-1 do if o=FComponents[i]then exit; - FComponents[len]:= o; - end - function Recycle(); - begin - {** - @explan(说明) 出现死循环的时候的处理 %% - **} - if FRecyce then return; - FRecyce := true; - for i,v in FComponents do - begin - v.Recycle(); - end - FComponents := array(); - end - function toarray(); - begin - {** - @explan(说明) 转换为array %% - **} - if FInToArray=FSInToArray then - begin - Recycle(); - raise "节点关系出现循环"; - end - FInToArray := FSInToArray; - ret := array(); - sub := array(); - for i := 0 to length(FComponents)-1 do - begin - ret[FSubName,i]:= FComponents[i].toarray(); - end - for i,v in FValue do - begin - if i=FSubName then continue; - ret[i]:= v; - end - return ret; - end - class function SetColumnName(info); - begin - if not ifarray(info)then info := array("id":"id","pid":"pid","sub":"sub"); - if not ClumnNameOk(info["id"])then info["id"]:= "id"; - if not ClumnNameOk(info["pid"])then info["pid"]:= "pid"; - if not ClumnNameOk(info["sub"])then info["sub"]:= "sub"; - SetIdName(info["id"],info["pid"],info["sub"]); - end - class function ToTree(d,info); - begin - {** - @explan(说明) 二维表转换为树结构 %% - @param(d)(array) 数据包含 信息 %% - @param(info)(array) 字段信息 "id" 当前节点的字段,"pid" 当前节点的父节点字段,"sub" ,返回子节点的字段 - 默认值 array("id":"id","pid":"pid","sub":"sub"); %% - @return(TArrayTreeClass) - **} - SetColumnName(info); - root := new TArrayTreeClass(array(FIdName:nil,FPIdName:nil)); - oarray := array(); - oarray[-inf]:= root; - for i,v in d do //构建id - begin - id := v[FIdName]; - ido := oarray[id]; - if ifnil(ido)then - begin - ido := new TArrayTreeClass(v); - oarray[id]:= ido; - end - end - ifcycle := true; - for i,v in d do - begin - id := v[FIdName]; - ido := oarray[id]; - pid := v[FPIdName]; - pdo := oarray[pid]; - if not pdo then - begin - pdo := oarray[-inf]; - ifcycle := false; - end - pdo.addcomponent(ido); - end - if ifcycle and oarray then - begin - for i,v in oarray do - begin - v.Recycle(); - raise "节点关系出现循环"; - break; - end - end - return root; - end - class function CreateRow(d,id,r); - begin - for i,v in d do - begin - ri := array(); - if not v then continue; - ri[FIdName]:= GetCounter(); - ri[FPIdName]:= id; - for j,vi in v do - begin - if j=FSubName then - begin - call(thisfunction,vi,ri[FIdName],r); - end - {else if j=FIdName or j = FPIdName then - begin - - end}else - begin - ri[j]:= vi; - end - end - if ri then - begin - r[length(r)]:= ri; - end - end - end - class function TreeArrayToArray(d,info); - begin - {** - @explan(说明) 树结构转换为二维表 %% - @param(d)(array) 数据包含 信息 %% - @param(info)(array) 字段信息 "id" 当前节点的字段,"pid" 当前节点的父节点字段,"sub" ,返回子节点的字段 - 默认值 array("id":"id","pid":"pid","sub":"sub"); %% - @return(array) - **} - if not ifarray(d)then exit; - SetColumnName(info); - r := array(); - initconter(); - CreateRow(d,GetCounter(),r); - return r; - end - class function ToTreeArray(d,info); - begin - {** - @explan(说明) 二维表转换为树结构 %% - @param(d)(array) 数据包含 信息 %% - @param(info)(array) 字段信息 "id" 当前节点的字段,"pid" 当前节点的父节点字段,"sub" ,返回子节点的字段 - 默认值 array("id":"id","pid":"pid","sub":"sub"); %% - @return(array) 树形结构的array - **} - root := ToTree(d,info); - if not root then return; - FSInToArray := tostn(now()); - r :=(root.toarray()); - return r; - end -end + type TIniFileExta=class() {** @explan(说明) ini文件读写封装 %% @@ -32244,7 +9784,7 @@ F513681B0DD0F32ED0F92AB0E4144010231BC2E1BC5ED40ED18BCCAE4261F2D2C 00000049454E44AE42608200"; for i := 0 to length(imageData)-1 do begin - t := new tbitmap(); + t := new tcustombitmap(); t.Readvcon(HexFormatStrToTsl(imageData[i])); imageData[i]:= t; end @@ -32802,1113 +10342,36 @@ type TInPutQuerys= class(tpanel) static SFInputType; static SHashInited; end -type TVirtualListItem = class(tsluibase) - {** - @ignore(忽略) %% - @explan(说明) list 的 item项目基类 - **} - type THandleClass=class - end - function Create(List);override; - begin - {** - @explan(说明) 构造函数%% - @param(list)(TVirtualList) item的所有者,必须是TVirtualList或者其派生 %% - **} - if(List is class(TVirtualList))then - begin - FOwner := List; - end - hd := new THandleClass(); - try - FHandle := inttostr(int64(hd)); ////当前句柄唯一标识 - except - FHandle := inttostr(gettslvariableptr(hd)); - end; - inherited create(); - FWidth := 30; - end - function paint(cvs,x,y,xwidth,yheight);virtual; - begin - {** - @explan(说明) 绘制 %% - @param(cvs)(TCanvas) canvas对象 %% - @param(x)(integer) 当前x轴位置 %% - @param(y)(integer) 当前y轴位置 %% - @param(xwidth)(integer) 最大项的宽度 %% - @param(yheight)(integer) 高度 %% - **} - end - property Width read FWidth write SetWidth; - property Handle read FHandle; - property Owner read FOwner; - {** - @param(width)(integer) 宽度 %% - @param(Owner)(TVirtualList) 所有者 %% - **} - function Recycling();override; - begin - FOwner := nil; - inherited; - end - private - FHandle; - function SetWidth(w);virtual; - begin - if w>0 and w <> FWidth then - begin - if Owner and(Owner.ItemMaxWidth=FWidth)or(Owner.ItemMaxWidth= 0 then - begin - rc := ClientRect; - yp := GetYPos(); - rc[1]:=(idx-yp)* FItemHeight; - rc[3]:= rc[1]+FItemHeight; - return rc; - end - end - function GetIndexRect(idx);virtual; - begin - {** - @explan(说明) 通过id获得item区域 %% - @param(idx)(integer) 序号 %% - @return(array) array(左,上,右,下) %% - **} - r := GetIndexClientRect(idx); - if r then - begin - r[0]:= FColWidth *(0-GetXpos()); - end - return r; - end - function GetClientItemIndexs();virtual; - begin - rc := ClientRect; - r := GetRectItemIndexs(rc); - return r[0]-> r[1]; - end - function doControlALign();override; - begin - if(IsUpDating())then - begin - FScroolChanged := true; - end else - begin - InitialScroll(); - end - end - property ItemCount read GetItemCount write SetItemCount; - property ItemHeight read FItemHeight write SetItemHeight; - property ColCount read FColCount write SetColCount; - property ColWidth read FColWidth write SetColWidth; - private - FValidateRect; - FItemCount; //项数量 - FItemHeight; //项高 - FColCount; //列数 - FColWidth; //列宽 - FScroolChanged; //滚动条修改 - function GetRectItemIndexs(rc); - begin - yp := GetYPos(); - tp := rc[1]; - bo := rc[3]; - FirstLine := integer(tp/GetYScrollDelta())+yp; - LastLine := integer((bo)/GetYScrollDelta())+yp; - return array(FirstLine,LastLine); - end - function SetColWidth(h); - begin - if FColWidth <> h and h>5 then - begin - FColWidth := h; - UpDateScrollBar(); - end - end - function SetColCount(v); - begin - nv := GZNumber(v); - if nv >= 0 and nv <> FColCount then - begin - FColCount := nv; - UpDateScrollBar(); - end - end - function GetItemCount();virtual; - begin - return FItemCount; - end - function SetItemCount(v);virtual; - begin - nv := GZNumber(v); - if nv >= 0 and nv <> FItemCount then - begin - FItemCount := nv; - UpDateScrollBar(); - end - end - function SetItemHeight(v); - begin - nv := GZNumber(v); - if FItemHeight <> nv then - begin - FItemHeight := nv; - UpDateScrollBar(); - end - end - function GZNumber(v); - begin - return v>0?integer(v):0; - end -end -type TVirtualList = class(TVirtualListFixed) - {** - @ignore(忽略) %% - @explan(说明) 虚拟的list - **} - function GetClientYCount();override; //高度项 - begin - return FItems.Count; - end - function GetClientXCount();override; //宽度间隔 - begin - return integer(FxClientMax/ColWidth); - end - function Create(AOwner);override; - begin - inherited; - FxClientMax := ColWidth; - FItemMinWidth := FxClientMax; - FHashItems := array(); - FItems := new TFpList(); - end - function GetItemByIndex(idx); - begin - {** - @explan(说明) 通过id获得序号 %% - @param(idx)(integer) 序号 %% - @return(TVirtualListItem) 项 %% - **} - if idx >= 0 and IdxFItems.Count-1 then idx :=-1; - return idx; - end - Function GetItemByYPos(y); - begin - {** - @explan(说明) 通过y轴位置获得item %% - @param(y)(integer) y轴位置 %% - @return(TVirtualListItem) 项 %% - **} - idx := GetItemIndexByYpos(y); - if idx >= 0 then return FItems[idx]; - end - function GetItemIndex(item,guess); - begin - {** - @explan(说明) 获得item序号 %% - @param(item)(TVirtualListItem) item %% - @return(integer) 序号 %% - **} - for i :=(guess>0?guess:0)to FItems.Count-1 do - begin - if item=FItems[i]then return i; - end - return-1; - return FItems.Indexof(item); - end - function GetItemRect(item); - begin - {** - @explan(说明) 获得item区域 %% - @param(item)(TVirtualListItem) item %% - @return(array) array(左,上,右,下) %% - **} - idx := GetItemIndex(item); - if idx >= 0 then return GetItemRectByIndex(idx); - return array(); - end - function GetItemRectByIndex(idx);virtual; - begin - {** - @explan(说明) 通过id获得item区域 %% - @param(idx)(integer) 序号 %% - @return(array) array(左,上,右,下) %% - **} - if idx >= 0 and idx= 0 and idx= 0 and idxFxClientMax then - begin - FItemMaxItemIndex := idx0; - FxClientMax := it.Width; - end else - begin - if FItemMaxItemIndex >= idx0 then FItemMaxItemIndex++; - end - FItems.InsertBefor(it,idx0); - idx0++; - FHashItems[it.handle]:= it; - end - end - ItemUpDated(); - finally - DecPaintLock(); - end; - end - function InsertItem(it,idx);virtual; - begin - {** - @explan(说明) 在位置出入项 %% - @param(it)(TVirtualListItem) item %% - @param(idx)(integer) 位置 %% - **} - //idx0 := FItems.Count; - try - IncPaintLock(); - idx0 :=(idx >= 0 and idxFxClientMax then - begin - FItemMaxItemIndex := idx0; - FxClientMax := it.Width; - end else - begin - if FItemMaxItemIndex >= idx0 then FItemMaxItemIndex++; - end - FItems.InsertBefor(it,idx0); - FHashItems[it.handle]:= it; - r := true; - end - end - ItemUpDated(); - finally - DecPaintLock(); - end; - return r; - end - function DeleteItemByBounds(b,e);virtual; - begin - idx := b; - ei := e; - if not(idx >= 0 and idx)then return false; - Try - IncPaintLock(); - while idx <= ei do - begin - ei--; - if FItemMaxItemIndex>idx then FItemMaxItemIndex -= 1; - else if FItemMaxItemIndex=idx then FItemMaxItemIndex := nil; - it := FItems[idx]; - if it then reindex(FHashItems,array(it.Handle:nil)); - FItems.Deli(idx); - end - ItemUpDated(); - finally - DecPaintLock(); - end - end - function DeleteItemByIndex(idx);virtual; - begin - {** - @explan(说明) 删除位置的项 %% - @param(idx)(integer) 位置 %% - **} - if idx >= 0 and idxidx then FItemMaxItemIndex -= 1; - else if FItemMaxItemIndex=idx then FItemMaxItemIndex := nil; - it := FItems[idx]; - if it then reindex(FHashItems,array(it.Handle:nil)); - FItems.Deli(idx); - ItemUpDated(); - finally - DecPaintLock(); - end; - return true; - end - return false; - end - function AppendItem(v);virtual; - begin - {** - @explan(说明) 追加项 %% - @param(v)(TVirtualListItem) item %% - **} - return InsertItem(v,FItems.Count); - end - function AppendItems(vs);virtual; - begin - {** - @explan(说明) 批量追加项 %% - @param(v)(array of TVirtualListItem) 项集 %% - **} - //O := new TPAINTCOUNT(self); - id := FItems.count; - try - IncPaintLock(); - for i,v in vs do - begin - if v is class(TVirtualListItem)then - begin - if FHashItems[v.handle]then continue; - wd := v.width; - if not(FItemMaxItemIndex >= 0)then - begin - FxClientMax := CalcMaxItemWidth(); - owd := FxClientMax; - end - if FxClientMax mx)then - begin - FxClientMax := mx; - end - UpDateScrollBar(); - DecPaintLock(); - end - function PaintRect(cvs,yPos,ht,FirstLine,LastLine,xPos,wd,FirstCol,LastCol);override; - begin - x := wd *(0-xPos); - rc := ClientRect; - PrevPaint(FirstLine,LastLine); - for i := FirstLine to LastLine do - begin - nrc := GetIndexRect(i); - //ri GetItemRectByIndex(i); - it := FItems[i]; - //y := ht * (i - yPos)+100; - it.paint(cvs,x,nrc[1],rc[2]-rc[1]-x,ht); - end - end - function SetTopLine(idx);override; - begin - {** - @explan(说明) 将idx行放入client区域 %% - @param(idx)(integer) 行号 %% - **} - if idx >= 0 and idx5 and FItemMinWidth <> w then - begin - FItemMinWidth := w; - if FItemMinWidth>FxClientMax then - begin - FxClientMax := FItemMinWidth; - ColCount := integer(FxClientMax/ColWidth+0.5); - end - end - end - function CalcMaxItemWidth();virtual; - begin - {** - @explan(说明)计算最大的item宽度 %% - **} - mx := FItemMinWidth; - if ifnil(FItemMaxItemIndex)then - begin - FItemMaxItemIndex := 0; - for i := 0 to FItems.Count-1 do - begin - nwd := FItems[i].Width; - if nwd>mx then - begin - mx := nwd; - FItemMaxItemIndex := i; - end - end - end else - begin - return FxClientMax; - end - return mx; - end - - private - FHashItems; - function PrevPaint(begid,endid);virtual; - begin - end - function GetItemCount();override; - begin - return FItems.Count; - end - function SetColWidth();override; - begin - end - function SetItemCount();override; - begin - end - function GetItems(); - begin - r := array(); - for i := 0 to FItems.Count-1 do r[i]:= FItems[i]; - return r; - end - FItemMinWidth; - FItemMaxItemIndex; - FItems; //项目 - FxClientMax; //水平宽度 -end - -type TNode = class() - {** - @explan(说明) 树结点 %% - **} - private - FItems; //子项 - FParent; //父节点 - public - function Create();virtual; - begin - inherited; - FExpanded := true; - FItems := new TFpList(); //子项 - end - function CreateNode();virtual; - begin - return CreateObject(self(true).Classinfo(1)); - end - function CreateNodeAndAppend();virtual; //构造并追加 - begin - nd := CreateNode(); - AppendNode(nd); - return nd; - end - function GetNodeByIndex(idx); - begin - {** - @explan(说明) 通过序号获得子节点%% - @param(idx)(TNode) %% - **} - if idx >= 0 then return FItems[idx]; - return nil; - end - function indexof(v); //获得序号 - begin - return FItems.indexof(v); - end - function GetIndex();virtual; - begin - {** - @explan(说明) 获得在父节点中的序号 %% - @return(integer) 序号 %% - **} - if Parent then Parent.indexof(self); - end - function AppendNode(it);virtual; - begin - {** - @explan(说明) 插入一个节点 %% - @param(it)(TNode) 节点 %% - @return(bool) 是否成功 %% - **} - return InsertNode(it,FItems.Count); - end - function HasNode(nd);virtual; - begin - {** - @explan(说明) 是否为某个节点的祖先节点 %% - @param(nd)(TNode) 子节点 %% - @return(TNode|0) 如果为祖先节点,就返回查询节点的父节点 %% - **} - if not(nd is class(TNode))then return 0; - p1 := nd.Parent; - p := p1; - while p do - begin - if p=self then return p1; - if p is class(TNode)then p := p.Parent; - end - return 0; - end - function DeleteNode(nd);virtual; - begin - {** - @explan(说明) 删除节点 %% - @param(nd)(TNode) 待删除节点 %% - **} - if nd=self then return 0; - pn := HasNode(nd); - if not pn then return; - return pn.DeleteChildNode(nd); - end - function DeleteChildNode(nd); - begin - {** - @explan(说明) 删除子节点%% - @param(nd)(TNode) 节点 %% - **} - idx :=-1; - idx := indexof(nd); - if idx=-1 then return 0; - return DeleteNodeByIndex(idx); - end - function DeleteNodeByIndex(idx); - begin - {** - @explan(说明) 根据位置删除节点%% - @param(idx)(integer) 序号 %% - **} - nd := FItems[idx]; - if not nd then return; - //是否显示处理 - FItems.Deli(idx); - CurrentDeleteNode := nd; - nd.parent := self(true); - CurrentDeleteNode := nil; - return true; - end - function DeleteChildren();virtual; // - begin - {** - @explan(说明) 删除所有的子节点%% - **} - while NodeCount>0 do - begin - idx := 0; - it := FItems[idx]; - CurrentDeleteNode := it; - it.parent := self(true); - CurrentDeleteNode := nil; - FItems.Deli(idx); - end - end - function InsertNodes(its,idx);virtual; - begin - {** - @explan(说明) 插入一个节点 %% - @param(it)( array of TNode) 字符串 %% - @param(idx)(integer) 序号 默认为0 %% - **} - idx0 := idx; - if idx<0 then idx0 := 0; - if idx>FItems.Count then idx0 := FItems.Count; - bidx := idx0; - for i,it in its do - begin - if(it is class(TNode))and(not it.Parent)then - begin - FItems.InsertBefor(it,idx0); - CurrentAddNode := it; - it.Parent := self(true); - CurrentAddNode := nil; - idx0++; - end - end - end - function InsertNode(it,idx);virtual; - begin - {** - @explan(说明) 插入一个节点 %% - @param(it)(TNode) 字符串 %% - @param(idx)(integer) 序号 默认为0 %% - **} - if(it is class(TNode))and(not it.Parent)then - begin - if idx<0 then idx := 0; - if idx>FItems.Count then idx := FItems.Count; - if not(idx >= 0)then idx := 0; - FItems.InsertBefor(it,idx); - CurrentAddNode := it; - it.Parent := self(true); - CurrentAddNode := nil; - return true; - end - end - function Expand();virtual; //展开 - begin - FExpanded := true; - end - function UnExpand();virtual; //折叠 - begin - FExpanded := false; - end - function RecyclingChildren();virtual; - begin - while NodeCount>0 do - begin - it := FItems[0]; - it.Recycling(); - end - end - function Recycling();virtual; - begin - p := FParent; - if p then - begin - p.DeleteNode(self); - end - while NodeCount>0 do - begin - it := FItems[0]; - it.Recycling(); - end - //inherited; - end - property NodeCount read GetNodeCount; //节点数 - property Expanded read FExpanded write SetExpand; //展开 - property Parent read FParent write SetParent; //父节点 - property LastChild read GetLstChild; - {** - @param(NodeCount)(integer) 子节点数量 %% - @param(Expanded)(bool) 是否展开 %% - @param(Parent)(TNode) 父节点 %% - **} - protected property CurrentDeleteNode read FCurrentDeleteNode write FCurrentDeleteNode; - property CurrentAddNode read FCurrentAddNode write FCurrentAddNode; - {** - @ignoremembers(CurrentDeleteNode,CurrentAddNode) - **} - function SetParent(V);virtual; - begin - tp := Parent; - if v=tp then return; - if(v is class(TNode))then - begin - if v.CurrentAddNode=self then - begin - FParent := v; //新节点 - end else - if v.CurrentDeleteNode=self then //从节点移除 - begin - FParent := nil; - end else - begin - if tp=v then return; - if tp then - begin - tp.DeleteNode(self(true)); - end - v.InsertNode(self(true),v.NodeCount); - end - end else - begin - if tp then tp.DeleteNode(self(true)); - end - end - private - function GetLstChild(); - begin - return FItems[FItems.Count-1]; - end - FCurrentDeleteNode; - FCurrentAddNode; - FExpanded; - function SetExpand(v);virtual; //已经展开 - begin - if v then Expanded(); - else UnExpand(); - end - function GetNodeCount(); //子节点数 - begin - return FItems.Count; - end -end implementation -type Ttagprocessentry32=class(tslcstructureobj) +type TDragManager=class(TComponent) private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(("dwsize","int",0) - ,("cntusage","int",0) - ,("th32processid","int",0) - ,("th32defaultheapid","intptr",0) - ,("th32moduleid","int",0) - ,("cntthreads","int",0) - ,("th32parentprocessid","int",0) - ,("pcpriclassbase","int",0) - ,("dwflags","int",0) - ,("szexefile","char[260]",0) - )); - return SSTRUCT; - end + FDragImmediate:Boolean; + FDragThreshold:Integer; + protected //input capture + procedure KeyUp(var Key:Word;Shift:TShiftState);virtual; + procedure KeyDown(var Key:Word;Shift:TShiftState);virtual; + procedure CaptureChanged(OldCaptureControl:TControl);virtual; + procedure MouseMove(Shift:TShiftState;X,Y:Integer);virtual; + procedure MouseUp(Button:TMouseButton;Shift:TShiftState;X,Y:Integer);virtual; + procedure MouseDown(Button:TMouseButton;Shift:TShiftState;X,Y:Integer);virtual; public - function create(ptr) - begin - inherited create(getstruct(),ptr); - dwsize := _size_(); - end - property dwsize index "dwsize" read _getvalue_ write _setvalue_; - property cntusage index "cntusage" read _getvalue_ write _setvalue_; - property th32processid index "th32processid" read _getvalue_ write _setvalue_; - property th32defaultheapid index "th32defaultheapid" read _getvalue_ write _setvalue_; - property th32moduleid index "th32moduleid" read _getvalue_ write _setvalue_; - property cntthreads index "cntthreads" read _getvalue_ write _setvalue_; - property th32parentprocessid index "th32parentprocessid" read _getvalue_ write _setvalue_; - property pcpriclassbase index "pcpriclassbase" read _getvalue_ write _setvalue_; - property dwflags index "dwflags" read _getvalue_ write _setvalue_; - property szexefile index "szexefile" read _getvalue_ write _setvalue_; -end - -type Ttagmoduleentry32=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(("dwsize","int",0) - ,("th32moduleid","int",0) - ,("th32processid","int",0) - ,("glblcntusage","int",0) - ,("proccntusage","int",0) - ,("modbaseaddr","intptr",0) - ,("modbasesize","int",0) - ,("hmodule","intptr",0) - ,("szmodule","char[256]",0) - ,("szexepath","char[260]",0) - )); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - dwsize := _size_(); - end - property dwsize index "dwsize" read _getvalue_ write _setvalue_; - property th32moduleid index "th32moduleid" read _getvalue_ write _setvalue_; - property th32processid index "th32processid" read _getvalue_ write _setvalue_; - property glblcntusage index "glblcntusage" read _getvalue_ write _setvalue_; - property proccntusage index "proccntusage" read _getvalue_ write _setvalue_; - property modbaseaddr index "modbaseaddr" read _getvalue_ write _setvalue_; - property modbasesize index "modbasesize" read _getvalue_ write _setvalue_; - property hmodule index "hmodule" read _getvalue_ write _setvalue_; - property szmodule index "szmodule" read _getvalue_ write _setvalue_; - property szexepath index "szexepath" read _getvalue_ write _setvalue_; -end -type TMONITORINFO=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("cbsize","int",0), - ("rcmonitor","int[4]", - (0,0,0,0)), - ("rcwork","int[4]", - (0,0,0,0)), - ("dwflags","int",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - cbsize := _size_(); - end - property cbsize index "cbsize" read _getvalue_ write _setvalue_; - property rcmonitor index "rcmonitor" read _getvalue_ write _setvalue_; - property rcwork index "rcwork" read _getvalue_ write _setvalue_; - property dwflags index "dwflags" read _getvalue_ write _setvalue_; -end + function Create(TheOwner:TComponent);override; + function IsDragging: + boolean; + virtual; + function Dragging(AControl:TControl):boolean;virtual; + procedure RegisterDockSite(Site:TWinControl;DoRegister:Boolean);virtual; + procedure DragStart(AControl:TControl;AImmediate:Boolean;AThreshold:Integer);virtual; + procedure DragMove(APosition:TPoint);virtual; + procedure DragStop(ADrop:Boolean);virtual; + property DragImmediate:Boolean read FDragImmediate write FDragImmediate; // default True; + property DragThreshold:Integer read FDragThreshold write FDragThreshold; // default 5; +end; + + + -function getmonthdates(y,m); -begin - if m = 2 then return (not(y mod 4) and ( (y mod 100)))+ 28; - if m in array(1,3,5,7,8,10,12) then return 31; - return 30; -end function GetPathFromFullName(fullname,fname,ftype); begin {** @@ -34026,106 +10489,7 @@ begin class(Ttfm2Component).RegisterComponentType(n,typ); end -function HexHash(); -begin - c := array("A","B","C","D","E","F"); - idxs := inttostr(0 -> 9)union c union lowercase(c); - r := array(); - for i,v in idxs do - begin - if i<16 then r[v]:= i; - else r[v]:= i-6; - end - return r; -end -function TslToHexStr(t); -begin - {** - @explan(说明) 将tsl数据转换为16进制字符串 %% - @param(t)(any) 任意的tsl数据 %%; - @return(string) 16进制字符串 %% - **} - r := ""; - str := tostm(t); - ky := static(inttostr(0 -> 9)union array("A","B","C","D","E","F")); - idx := 1; - setlength(r,length(str)* 2); - for i := 0 to length(str)-1 do - begin - vi := ord(str[i]); - //r += ky[_shr(vi,4) .& 0xf]; - //r += ky[vi .& 0xf] ; - r[idx]:= ky[_shr(vi,4).& 0xf]; - r[idx+1]:= ky[vi .& 0xf]; - idx += 2; - end - return r; -end -function HexFormatStrToTsl(hex); -begin - {** - @explan(说明)将带有换行符的16进制字符串转换为tsl数据 %% - @param(hex)(string) 16进制字符串 %% - @return(any) tsl数据类型 %% - **} - r := ""; - hs := static HexHash(); - //rs := inttostr(0 -> 9)union array("A","B","C","D","E","F","a","b","c","d","e","f"); - for i := 1 to length(hex) do - begin - ri := hex[i]; - if hs[ri]>=0 then - begin - r += ri; - end - end - return HexStrToTsl(r); -end -function TslToHexFormatStr(tsl); -begin - s := TslToHexStr(tsl); - r := ""; - n := length(s); - i := 1; - bc := 64; - while true do - begin - if i>n then break; - ij := i+bc; - if ij>n and i <= n then - begin - r += s[i:n]; - break; - end else - r += s[i:ij]; - if ij>n then break; - r += "\r\n"; - i := ij+1; - end - return r; -end -function HexStrToTsl(hex); -begin - {** - @explan(说明)16进制字符串转换为tsl数据 %% - @param(hex)(string) 16进制字符串 %% - @return(any) tsl数据类型 %% - **} - if not(hex and ifstring(hex)) then return nil; - r := tostm(nil); - setlength(r,Integer(length(hex)/2)); - hs := static HexHash(); - idx := 0; - for i := 1 to length(hex)-1 step 2 do - begin - vi := hs[hex[i]]; - vi1 := hs[hex[i+1]]; - r[idx]:= _shl(vi,4).| vi1; - idx++; - end - return stm(r); -end function initializeapplication(); begin {** @@ -34134,128 +10498,17 @@ begin **} return getapplication(); end -function includestate(u,s); -begin - {** - @explan(说明) 状态扩展 %% - **} - if not ifarray(u)then u := array(); - if ifarray(s)then u union2= s; - else u union2= array(s); - return u; -end -function excludestate(u,s); -begin - {** - @explan(说明) 状态缩减%% - **} - if not ifarray(u)then u := array(); - if ifarray(s)then u minus= s; - else u minus= array(s); - return u; -end -function signedtounsigned(v,n); -begin - {** - @explan(说明) 符号数转换为无符号数 %% - @param(v)(integer) 数字 %% - @param(n)(integer) 有效位数 %% - @return(integer) - **} - if not ifnumber(n)then n := 16; - if n>64 then n := 64; - mkv2 := 1; - ret := mkv2 .& v; - for i := 1 to n-1 do - begin - mkv2 := _shl(mkv2,1); - ret +=(mkv2 .& v); - end - mkv2 := _shl(mkv2,1); - if v<0 then - begin - ret .|= mkv2; - end else - begin - ret .&=(.! mkv2); - end - return ret; -end -function getbitsfrominteger(n,b,e); -begin - {** - @explan(说明) 获取数字的位数并转换为整数 %% - @param(b)(integer) 开始位 %% - @param(e)(integer) 截止位 %% - @param(n)(integer) 数字 %% - @return(integer) - **} - r := 0; - if b<0 then return 0; - mk := 2^(b); - for i := b to e do - begin - if(mk .& n)>0 then r += _shr(mk,b); - mk := _shl(mk,1); - end - return r; -end - -function unsignedtosigned2(v,n); -begin - {** - @explan(说明) 无符号数转换为符号数 %% - @param(v)(integer) 数字 %% - @param(n)(integer) 有效位数 %% - @return(integer) - **} - if not ifnumber(n)then n := 16; - if n>64 then n := 64; - vv := 1 .& v; - for i := 1 to n-1 do vv +=(v .& _shr(1,i)); - mkv := _shr(1,n); - if(v .& mkv)then - begin - return 0-((_not(vv) .& mkv2)+1); - end - return vv; -end -function unsignedtosigned(v,n); -begin - {** - @explan(说明) 无符号数转换为符号数 %% - @param(v)(integer) 数字 %% - @param(n)(integer) 有效位数 %% - @return(integer) - **} - if not ifnumber(n)then n := 16; - if n>64 then n := 64; - mkv := 0; - mkv := _shl(1,n-1); - mkv2 := 1; - for i := 1 to n-1 do - begin - mkv2 := _shl(mkv2,1); - mkv2 += 1; - end - vv := v .& mkv2; - if(v .& mkv)then - begin - return 0-((_not(vv) .& mkv2)+1); - end - return vv; -end function getapplication(); begin {** @explan(说明) 返回application对象%% @return(tapplication) 应用对象 %% **} - r := class(UIglobalData).uigetdata("tuiapplication"); + r := class(tUIglobalData).uigetdata("tuiapplication"); if not(r)then begin r := new tapplication(); - class(UIglobalData).uisetdata("tuiapplication",r); + class(tUIglobalData).uisetdata("tuiapplication",r); end return r; //return static new tapplication(); @@ -34265,7 +10518,9 @@ begin {** @explan(说明) 返回win32api对象 **} - return static new tswin32api(); + global G_O_TSWIN32API_; + if not G_O_TSWIN32API_ then G_O_TSWIN32API_ := new tswin32api(); + return G_O_TSWIN32API_; end Function tslcstructure(data,dsize,pack,ptr); Begin @@ -34293,69 +10548,6 @@ begin return tslarraytocstructcalc(data,pack,0,ssize); end - //*************makelong***************************** -function ShowErrorMessage(msg); -begin - {** - @explan(说明) 错误信息提示 %% - @param(msg)(string) 提示信息 %% - **} - if ifstring(msg)then getapplication().ShowErrorMessage(msg); -end -function makeposition(x,y); -begin - {** - @explan(说明)将x,y构造为一个int类型 %% - @return(integer) - **} - if ifnumber(x)and ifnumber(y)then return makelong(signedtounsigned(x),signedtounsigned(y)); - return 0; -end -function intasposition(i); -begin - if ifnumber(i)then - begin - return lowuperdword(i); - end - return array(0,0); -end - -function makelong(low,high,ptrl); -begin - {** - @explan(说明) 合并高低为 %% - @return(integer) 整数 %% - @param(low)(integer) 低位 %% - @param(high)(integer) 高位 %% - @param(ptrl)(integer) 长度 默认为 8 %% - **} - if not ifnumber(ptrl)then ptrl := 16; - mask := 2^(ptrl)-1; - low1 := low .& mask; - high1 := high .& mask; - return _shl(high1,ptrl).| low1; -end -function lowuperdword(value_,lvalue,uvalue,ptrl); -begin - {** - @explan(说明) 高低位获取 %% - @param(value_)(integer) 整数 %% - @param(lvalue)(integer) 低位 %% - @param(uvalue)(integer) 高位 %% - @param(ptrl)(integer) 长度 默认为 8 %% - **} - lvalue := uvalue := 0; - if not ifnumber(value_)then return array(0,0); - if not ifnumber(ptrl)then ptrl := 16; - value :=(value_); - mask := 2^(ptrl)-1; - uvalue := _shr(value,ptrl).& mask; - //t := _shl(value,ptrl); - //lvalue := _shr(t,ptrl) .& mask; - lvalue := value .& mask; - return array(lvalue,uvalue); -end; - function remotetslcallback(data); begin {** @@ -34364,304 +10556,9 @@ begin class(TQuotations).Dispatch(data); //return class(TQuotations)._SWINDOWS._send_(0X4400,0,data,1); end -function formatshortcut(d); -begin - r := ""; - if d then - begin - if d["c"] then r +=(r)?"+Ctrl":"Ctrl"; - if d["s"] then r +=(r)?"+Shift":"Shift"; - if d["a"] then r +=(r)?"+Alt":"Alt"; - if d["f"] then r +=(r)?("+"+d["f"]):d["f"]; - if d["w"] then r +=(r)?("+"+d["w"]):d["w"]; - end - return r; -end -function dispatchshortcut(c,st); //快捷键分发 -begin - if not st then return 0; - if c then - begin - if (c is class(TMenu)) or (c is class(TToolButton)) or (c is class(TCustomAction)) then - begin - if c.ExecuteCommand("doshortcut",st)="havedoshortcut" then return "havedoshortcut"; - end - cc := c.Components ; - for i:= 0 to cc.count-1 do - begin - if dispatchshortcut(cc[i],st) then return "havedoshortcut"; - end - end - return 0; -end -function dispatchctlshortcut(o,st); //控件分发热键 -begin - if o is class(tcontrol) then - begin - if dispatchmenushortcut(o.Action,st) then return "havedoshortcut"; - if dispatchmenushortcut(o.PopupMenu,st) then return "havedoshortcut"; - end - if o is class(tform) then - begin - if dispatchmenushortcut(o.MainMenu,st) then return "havedoshortcut"; - end - -end -function dispatchmenushortcut(mu,st); //菜单分发热键 -begin - if mu is class(TMenu) then - begin - if mu.ItemCount>0 then - begin - for i := 0 to mu.ItemCount-1 do - begin - if dispatchmenushortcut(mu.GetItemByIndex(i),st)="havedoshortcut" then return "havedoshortcut"; - end - end else - begin - if mu.ExecuteCommand("doshortcut",st)="havedoshortcut" then return "havedoshortcut"; - end - //if mu.ItemCount - end else - if mu is class(TAction) then - begin - if mu.ExecuteCommand("doshortcut",st)="havedoshortcut" then return "havedoshortcut"; - end -end -function parsershortcutstr(s_); //快捷键解析 -begin - s := uppercase(s_); - ls := length(s); - zmb := array(); - fb := array(); - for i := 65 to 90 do zmb[chr(i)] := true; - for i:= 1 to 12 do fb["F"+inttostr(i)] := true; - cword :=""; - i := 1; - r := array(); - while(i<=ls) do - begin - vi := s[i]; - vio := ord(vi); - case vio of - 65 to 90 ,48 to 57: - begin - cword +=vi; - end - else - begin - if cword then - begin - case cword of - "SHIFT": - begin - r["s"] := true; - end - "CTRL": - begin - r["c"] := true; - end - "ALT": - begin - r["a"] := true; - end - else - begin - - if fb[cword] and not(r["w"]) then - begin - r["f"] := cword; - end else - if r and not(r["f"]) then - begin - if zmb[cword] then r["w"] := cword; - end - end - - end ; - end - cword := ""; - end - - end; - i++; - end - if cword then - begin - case cword of - "SHIFT": - begin - r["s"] := true; - end - "CTRL": - begin - r["c"] := true; - end - "ALT": - begin - r["a"] := true; - end - else - begin - if fb[cword] and not(r["w"]) then - begin - r["f"] := cword; - end else - if r and not(r["f"]) then - begin - if zmb[cword] then r["w"] := cword; - end - end - - end ; - end - if not(r["w"] or r["f"]) then r := array(); - return r; -end - -type TTipWnd = class( TCustomControl) //tip窗口 -{** - @ignore(忽略) %% -**} - function Create(AOwner);override; - begin - inherited; - Visible := false; - WsPopUp:= true; - Enabled := false; - color := rgb(244,246,224); - border := false; - FTip := ""; - end - function ShowTip(); - begin - if FTip then - begin - if Visible then return ; - xy := array(0,0); - _wapi.GetCursorPos(xy); - //left := xy[0]+10; - //top := xy[1]+10; - show( SW_SHOWNOACTIVATE);// - SetBounds(xy[0]+10,xy[1]+10,FSize[0],FSize[1]); - end - else Visible := false; - end - Function Paint();override; - begin - dc := Canvas; - dc.DrawText(FTip,self.ClientRect,DT_LEFT .|DT_NOPREFIX); - end - property Tip read FTip write SetTip; - private - FTip; - function SetTip(s); - begin - if ifstring(s) and s<>FTip then - begin - FTip := s; - wh := GetTextWidthAndHeightWidthFont(s,seLF.font,1); - //width := wh[0]+5; - //height := wh[1]+5; - FSize := array(wh[0]+5,wh[1]+5); - end - end - private - FSize; -end - -type TPAINTCOUNT=class - {** - @explan(说明) 绘制计数 %% - **} - function create(v); - begin - if v is class(TControl)then - begin - FPainter := v; - v.BeginUpDate(); - end - end - function Destroy(); - begin - if FPainter then FPainter.EndUpDate(); - FPainter := nil; - end - FPainter; -end -type tmacroconst=class(_commctrldef_,_tvclmsageid_,_shellapi_) - class function sinit();virtual; - begin - class(_commctrldef_).sinit(); - class(_tvclmsageid_).sinit(); - class(_shellapi_).sinit(); - end -end -type TSLUICONST=class(tmacroconst,tconstant) - {** - @explan(说明) 界面库常量类 %% - **} - static WM_TRAY; - class function sinit();override; - begin - class(tmacroconst).sinit(); - WM_TRAY := WM_USER+100; - end -end //*********字符串相关对象************************************** -function FormatTslData(d,sj,tn); -begin - {** - @explan(说明) 格式化tsl数据 %% - @param(d)(any) tsl数据 %% - @param(sj)(string) 空格距离 %% - @param(tn)(nil) 空参数 %% - @return(string) 格式化后的字符串 %% - **} - r := ""; - if not(sj and ifstring(sj))then sj := " "; - if ifarray(d)then - begin - r := "(\r\n"; - if ifnil(tn)then - begin - tn := 0; - r := "array(\r\n"; - end - di := 0; - len := length(d); - for i,v in d do - begin - bt := sj; - if di <> i then - begin - bt += tostn(i)+":"; - end - di++; - vr := FormatTslData(v,sj,1); - if len>di then vr += ","; - r += bt; - if ifarray(v)then - begin - vrs := str2array(vr,"\r\n"); - dii := 0; - for j,vj in vrs do - begin - if dii<1 then r += vj; - else r += sj+vj; - r += "\r\n"; - dii++; - end - end else - r += vr+"\r\n"; - end - r += ")"; - return r; - end else - return tostn(d); -end function calldatafunction(); begin @@ -34692,14 +10589,6 @@ begin end else return callinarray(f,pms[0:lpt-1]); end -function dataisfunction(f); -begin - {** - @explan(说明) 判断数据是否为函数指针%% - @return(bool) - **} - return datatype(f)=7; -end function NotifyComponent(Acomponent,Act,AOwner); begin {** @@ -34744,10 +10633,15 @@ type tglobalabc=class end function controlisCustomPaint(id); begin - wd := class(UIglobalData).uigetdata("TGlobalValues").getvalue(id); + wd := class(tUIglobalData).uigetdata("TGlobalValues").getvalue(id); if wd then return wd.isCustomPaint(); return false; end +function tslvclfindclass(n); +begin + r := findclass(n); + return r; +end function _twinproc_(hwnd,message,wparam,lparam); //消息分发 begin {** @@ -34762,7 +10656,7 @@ begin //echo format("\r\n%x\t%x\t%x\t%x",hwnd,message,wparam,lparam); //wdobj := class(TGlobalComponentcache).getwndbyhwnd(hwnd); //wdobj := uigetdata("TGlobalComponentcache").getwndbyhwnd(hwnd); - wdobj := class(TGlobalComponentcache).getwndbyhwnd(hwnd); + wdobj := class(tUIglobalData).uigetdata("TGlobalComponentcache").getwndbyhwnd(hwnd); if ifnil(wdobj)then //没有注册 begin if message=0x81 then //如果为 WM_CREATE WM_NCCREATE 就注册 @@ -34770,8 +10664,7 @@ begin cpm := new tslcstructureobj(MemoryAlignmentCalculate(array( ("lpcreateparams","intptr",0))),lparam); cid := cpm._getvalue_("lpcreateparams"); - wdobj := class(UIglobalData).uigetdata("TGlobalValues").getvalue(cid); - //wdobj := class(TGlobalValues).getvalue(cid); + wdobj := class(tUIglobalData).uigetdata("TGlobalValues").getvalue(cid); {if wdobj is class(TWincontrol) then begin //return wdobj.MainWndProc(hwnd,message,wparam,lparam); @@ -34789,7 +10682,7 @@ begin end if message=0x82 then begin - class(TGlobalComponentcache).unregisterhandle(hwnd); + class(tUIglobalData).uigetdata("TGlobalComponentcache").unregisterhandle(hwnd); end return r; if message in array(1,0x81)then @@ -34845,356 +10738,38 @@ begin d := new TtagOFNA(lparam); end end -function sinitgidplus(); -begin - FGDI := new TGdiplusflat(); - vot := array( - ("gdiplusversion","int",1), - ("debugeventcallback","int",0), - ("suppressbackgroundthread","int",0), - ("suppressexternalcodecs","int",0)); - og := new ctslctrans(tslarraytocstructcalc(vot)); - ftoken :=-1; - ig :=-1; - FGDI.GdiplusStartup(ftoken,og._getptr_,ig); -end - -type TGlobalValues=class - private - static FValues; - FId; - class function sinit(); - begin - if not ifarray(FValues)then FValues := array(); - end - public - class function getvalue(id); - begin - sinit(); - r := FValues[inttostr(id)]; - //if r then reindex(FValues,id); - return r; - end - function Create(id,value); - begin - sinit(); - tid := inttostr(id); - FOld := FValues[tid]; - if not ifnil(FOld)then raise "全局变量冲突!"; - FId := tid; - FValues[tid]:= value; - end - function destroy(); - begin - reindex(FValues,array(FId:nil)); - end -end - -type UIglobalData=class - static UIData; - class Function uisetdata(n,d); - begin - InitUiData(); - UIData[n]:= d; - end - class function uigetdata(n); - begin - InitUiData(); - //UIData[n] := d; - return UIData[n]; - end - private - class function InitUiData(); - begin - if not ifarray(UIData)then UIData := array(); - end -end function initallib(); begin //ClearScriptCache(); //global tuiapplication; - //tuiapplication := getapplication(); - class(TSLUICONST).sinit(); - class(tenumeration).initenumeration(new tconstant()); - class(UIglobalData).uisetdata("TGlobalComponentcache",class(TGlobalComponentcache)); - class(UIglobalData).uisetdata("TGlobalValues",class(TGlobalValues)); - sinitgidplus(); - class(timage).sinit(); + //tuiapplication := getapplication(); + global G_F_CONTROL_IS_CUSTOMPAINT; + global G_F_TSLVCL_FINDCLASS; + global G_F_TWIN_PROC_; + global G_F_TIME_PROC_; + + global G_T_TTFM2COMPONET_; + global G_T_TVCFORM_; + + G_F_CONTROL_IS_CUSTOMPAINT := thisfunction(controlisCustomPaint); + G_F_TSLVCL_FINDCLASS := thisfunction(tslvclfindclass); + G_F_TWIN_PROC_ := thisfunction(_twinproc_); + G_F_TIME_PROC_ := thisfunction(_timeproc_); + G_T_TTFM2COMPONET_ := class(Ttfm2Component); + G_T_TVCFORM_ := class(TVCForm); + class(tUIglobalData).uisetdata("TGlobalComponentcache",class(TGlobalComponentcache)); + class(tUIglobalData).uisetdata("TGlobalValues",class(TGlobalValues)); class(TRegKey).sinit(); //初始化reg注册表 end -function WriteExLog(n); -begin - sz := filesize("",%% C:\Program Files\Tinysoft\Analyse.NETplug\log\nn.log%%); - writefile(rwraw(),"",%% C:\Program Files\Tinysoft\Analyse.NETplug\log\nn.log%%,sz,length(n)+2,n+"\r\n"); -end - -Function getmsgd_Crc32(s); -Begin - {** - @explan(说明) 获得字符串的信息指纹%% - @param(s)(string) 字符串 %% - @return(string) 8位长度的信息指纹%% - **} - {$ifdef linux} - G_CRC32TABLE:=array( - 0x00000000, 0x77073096, 0xEE0E612C, 0x990951BA, - 0x076DC419, 0x706AF48F, 0xE963A535, 0x9E6495A3, - 0x0EDB8832, 0x79DCB8A4, 0xE0D5E91E, 0x97D2D988, - 0x09B64C2B, 0x7EB17CBD, 0xE7B82D07, 0x90BF1D91, - 0x1DB71064, 0x6AB020F2, 0xF3B97148, 0x84BE41DE, - 0x1ADAD47D, 0x6DDDE4EB, 0xF4D4B551, 0x83D385C7, - 0x136C9856, 0x646BA8C0, 0xFD62F97A, 0x8A65C9EC, - 0x14015C4F, 0x63066CD9, 0xFA0F3D63, 0x8D080DF5, - 0x3B6E20C8, 0x4C69105E, 0xD56041E4, 0xA2677172, - 0x3C03E4D1, 0x4B04D447, 0xD20D85FD, 0xA50AB56B, - 0x35B5A8FA, 0x42B2986C, 0xDBBBC9D6, 0xACBCF940, - 0x32D86CE3, 0x45DF5C75, 0xDCD60DCF, 0xABD13D59, - 0x26D930AC, 0x51DE003A, 0xC8D75180, 0xBFD06116, - 0x21B4F4B5, 0x56B3C423, 0xCFBA9599, 0xB8BDA50F, - 0x2802B89E, 0x5F058808, 0xC60CD9B2, 0xB10BE924, - 0x2F6F7C87, 0x58684C11, 0xC1611DAB, 0xB6662D3D, - - 0x76DC4190, 0x01DB7106, 0x98D220BC, 0xEFD5102A, - 0x71B18589, 0x06B6B51F, 0x9FBFE4A5, 0xE8B8D433, - 0x7807C9A2, 0x0F00F934, 0x9609A88E, 0xE10E9818, - 0x7F6A0DBB, 0x086D3D2D, 0x91646C97, 0xE6635C01, - 0x6B6B51F4, 0x1C6C6162, 0x856530D8, 0xF262004E, - 0x6C0695ED, 0x1B01A57B, 0x8208F4C1, 0xF50FC457, - 0x65B0D9C6, 0x12B7E950, 0x8BBEB8EA, 0xFCB9887C, - 0x62DD1DDF, 0x15DA2D49, 0x8CD37CF3, 0xFBD44C65, - 0x4DB26158, 0x3AB551CE, 0xA3BC0074, 0xD4BB30E2, - 0x4ADFA541, 0x3DD895D7, 0xA4D1C46D, 0xD3D6F4FB, - 0x4369E96A, 0x346ED9FC, 0xAD678846, 0xDA60B8D0, - 0x44042D73, 0x33031DE5, 0xAA0A4C5F, 0xDD0D7CC9, - 0x5005713C, 0x270241AA, 0xBE0B1010, 0xC90C2086, - 0x5768B525, 0x206F85B3, 0xB966D409, 0xCE61E49F, - 0x5EDEF90E, 0x29D9C998, 0xB0D09822, 0xC7D7A8B4, - 0x59B33D17, 0x2EB40D81, 0xB7BD5C3B, 0xC0BA6CAD, - - 0xEDB88320, 0x9ABFB3B6, 0x03B6E20C, 0x74B1D29A, - 0xEAD54739, 0x9DD277AF, 0x04DB2615, 0x73DC1683, - 0xE3630B12, 0x94643B84, 0x0D6D6A3E, 0x7A6A5AA8, - 0xE40ECF0B, 0x9309FF9D, 0x0A00AE27, 0x7D079EB1, - 0xF00F9344, 0x8708A3D2, 0x1E01F268, 0x6906C2FE, - 0xF762575D, 0x806567CB, 0x196C3671, 0x6E6B06E7, - 0xFED41B76, 0x89D32BE0, 0x10DA7A5A, 0x67DD4ACC, - 0xF9B9DF6F, 0x8EBEEFF9, 0x17B7BE43, 0x60B08ED5, - 0xD6D6A3E8, 0xA1D1937E, 0x38D8C2C4, 0x4FDFF252, - 0xD1BB67F1, 0xA6BC5767, 0x3FB506DD, 0x48B2364B, - 0xD80D2BDA, 0xAF0A1B4C, 0x36034AF6, 0x41047A60, - 0xDF60EFC3, 0xA867DF55, 0x316E8EEF, 0x4669BE79, - 0xCB61B38C, 0xBC66831A, 0x256FD2A0, 0x5268E236, - 0xCC0C7795, 0xBB0B4703, 0x220216B9, 0x5505262F, - 0xC5BA3BBE, 0xB2BD0B28, 0x2BB45A92, 0x5CB36A04, - 0xC2D7FFA7, 0xB5D0CF31, 0x2CD99E8B, 0x5BDEAE1D, - - 0x9B64C2B0, 0xEC63F226, 0x756AA39C, 0x026D930A, - 0x9C0906A9, 0xEB0E363F, 0x72076785, 0x05005713, - 0x95BF4A82, 0xE2B87A14, 0x7BB12BAE, 0x0CB61B38, - 0x92D28E9B, 0xE5D5BE0D, 0x7CDCEFB7, 0x0BDBDF21, - 0x86D3D2D4, 0xF1D4E242, 0x68DDB3F8, 0x1FDA836E, - 0x81BE16CD, 0xF6B9265B, 0x6FB077E1, 0x18B74777, - 0x88085AE6, 0xFF0F6A70, 0x66063BCA, 0x11010B5C, - 0x8F659EFF, 0xF862AE69, 0x616BFFD3, 0x166CCF45, - 0xA00AE278, 0xD70DD2EE, 0x4E048354, 0x3903B3C2, - 0xA7672661, 0xD06016F7, 0x4969474D, 0x3E6E77DB, - 0xAED16A4A, 0xD9D65ADC, 0x40DF0B66, 0x37D83BF0, - 0xA9BCAE53, 0xDEBB9EC5, 0x47B2CF7F, 0x30B5FFE9, - 0xBDBDF21C, 0xCABAC28A, 0x53B39330, 0x24B4A3A6, - 0xBAD03605, 0xCDD70693, 0x54DE5729, 0x23D967BF, - 0xB3667A2E, 0xC4614AB8, 0x5D681B02, 0x2A6F2B94, - 0xB40BBE37, 0xC30C8EA1, 0x5A05DF1B, 0x2D02EF8D); - result :=0xFFFFFFFF; - bs := binary(s); - for i:=0 to length(bs)-1 do - begin - ebx:=G_CRC32TABLE[(result .& 0xff) .^ord(bs[i]) ]; - result shr=8; - result .^= ebx; - end; - result:=_not(result); - return inttohex(result,8); - {$endif} - return GetMsgDigest(s,0); -End; -function getresourcebyid(id,options); -begin - {** - @explan(说明)获得resource信息%% - @param(id)(obj) id 对象 %% - @param(options)(array) 额外参数 %% - **} - w32 := gettswin32api(); - if not ifarray(options)then return 0; - h := 0; - if options["type"]="bmp" then - begin - if ifnumber(id)then h := w32.LoadBitmapA2(nil,id); - else if ifstring(id)then - begin - //h := w32.LoadImageA(0,id,0,100,100,0x10 .| 0x40);// - h := w32.LoadImageA(0,id,0,0,0,0x10 .| 0x40); // - //h := w32.LoadBitmapA(nil,id); - end - end else - if options["type"]="ico" then - begin - if ifnumber(id)then h := w32.LoadIconA2(nil,id); - else if ifstring(id)then h := w32.LoadImageA(0,id,0x1,0,0,0x10); - end - return h; -end - -function CheckArrayIsNumbers(Value,n); -begin - if not(ifnumber(n)and n >= 1)then n := 4; - if ifarray(Value)then - begin - for i := 0 to n-1 do - begin - if not(ifnumber(Value[i]))then return 1; - end - return 0; - end - return 1; -end -function CheckArrayIsControlRect(Value); -begin - {** - @explan(说明) 检查数组是否可以作为control的rect %%; - **} - if not(CheckArrayIsNumbers(Value,4))then - begin - return Value[3]>0 and Value[2]>0; - end -end -function CheckArrayIsControlBounds(Value); -begin - {** - @explan(说明) 检查数组是否可以作为control 的 bounds - **} - if not(CheckArrayIsNumbers(Value,4))then - begin - return(Value[3]>Value[1])and(Value[2]>Value[0]); - end -end - -function intersectrect(rec1,rec2,irec); -begin - {** - @explan(说明) 计算矩形的交集 %% - @param(rec1)(array of integer) 矩形区域 %% - @param(rec2)(array of integer) 矩形区域 %% - @param(irec)(var array of integer) 重叠的区域 %% - @return(bool) - **} - if lineintersect(array(rec1[0],rec1[2]),array(rec2[0],rec2[2]),d1)and lineintersect(array(rec1[1],rec1[3]),array(rec2[1],rec2[3]),d2)then - begin - irec := array(d1[0],d2[0],d1[1],d2[1]); - return true; - end - return 0; -end - -function pointtovector(pts); //点转换为数组 -begin - {** - @explan(说明) 将两列的二维数组转换为一维数组 %% - @param(pts)(array) 一维的数组%% - @return(array) 两列数组 %% - **} - {** - @example(点数组转换为一维数组) - // array((x1,y1),(x2,y2),(x3,y3)...) => array(x1,y1,x2,y2,x3,y3,...) - a := array((1,2),(3,4)); - return pointtovector(a);//array(1,2,3,4); - **} - t := array(); - lt := 0; - if not ifarray(pts)then return array(); - for i,v in pts do - begin - if ifarray(v)and ifnumber(v[0])and ifnumber(v[1])then - begin - t[lt++]:= v[0]; - t[lt++]:= v[1]; - end - end - return t; -end -function pointinrect(p,rec); -begin - {** - @explan(说明) 判断点是否在矩形中 %% - @param(rec)(array of integer) 矩形区域 %% - @param(p)(array of integer) 点 array(x,y) %% - @return(bool) - - **} - x := p[0]; - y := p[1]; - return x>rec[0]and y>rec[1]and xxx2[0]and xx1[0]>xx2[1])or(xx2[0]>xx1[1]and xx2[1]>xx1[0])then return 0; - xx := array(max(xx1[0],xx2[0]),min(xx1[1],xx2[1])); - return 1; -end -function CompareRect(orect,nrect); -begin - return orect=nrect; -end - -function ParserCommandLine(s); //解析命令行参数 -begin - r := array(); - if not ifstring(s) then return r; - len := length(s); - p := ""; - while idx= 0?flag:0); end -function CallMessgeFunction(f,o,e); -begin - {** - @ignore(忽略) - **} - if datatype(f)=7 then return call(f,o,e); -end -function GetTextWidthAndHeightWidthFont(s,f,mul); -begin - {** - @explan(说明) 获得文本在给定字体f下的绘制宽高 %% - @param(s)(string) 文本 %% - @param(f)(tfont) 给定字体 %% - @param(mul)(bool) 是否多行文本 %% - **} - if ifstring(s)and s then - begin - cv := static GetOneCanvas(); - if f is class(tfont)then cv.font := f; - if ifarray(f)and f then cv.font.SetValues(f); - return cv.GetTextExtent(s,mul); - end - return array(0,0); -end -function GetOneCanvas(); -begin - cv := new TCanvas(getapplication()); - cv.handle := cv._wapi.CreateCompatibleDC(0); - return cv; -end - function GetCurrentTslDir(); //获得tsl目录以\结尾 begin p := pluginpath();iofp := ioFileseparator(); @@ -35607,504 +11089,17 @@ begin npre := bpre; return true; end +function xor(a,b); +begin + {** + @explan(说明) 异或 运算 %% + @return(bool) + **} + return(a and not(b))or(b and not(a)); +end + Initialization initlib(); Finalization end. -//////////////////////暂时没用到的类型/////////////////////////////////////// -(* - -type TFileLocker=class() - {** - @ignore(忽略) %% - @explan(说明) 文件锁定 %% - **} - private - FHandle; - FLocked; - FApi; - function GetFileOpen(); - begin - return FHandle <> 0; - end - function GetFileLocked(); - begin - return FLocked <> 0; - end - public - function Create(F); - begin - {** - @explan(说明)对文件加锁,防止其他进程读写 %% - @param(f)(string) 文件名 %% - **} - FHandle := 0; - FLocked := 0; - if not FileExists("",f)then exit; - FApi := gettswin32api(); - FHandle := FApi.CreateFileA(F,0x40000000L,0,0,3,0x00000080,0); - if not FHandle then exit; - FLocked := FApi.LockFile(FHandle,0,0,0,0); - end - function Destroy(); - begin - if FLocked then - begin - FApi.UnlockFile(FHandle,0,0,0,0); - end - if FHandle then - begin - FApi.CloseHandle(FHandle); - end - end - property FileOpend read GetFileOpen; - property FileLocked read GetFileLocked; - {** - @param(FileOpend)(bool) 是否有效%% - @param(FileLocked)(bool) 是否已经锁定%% - **} -end - - -type Ttagaccel=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("fvirt","byte",0), - ("key","short",0), - ("cmd","short",0))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property fvirt index "fvirt" read _getvalue_ write _setvalue_; - property key index "key" read _getvalue_ write _setvalue_; - property cmd index "cmd" read _getvalue_ write _setvalue_; -end -type TBITMAPINFOHEADER=class(tslcstructureobj) - private - static SSTRUCT; - class function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("bisize","int",40), - ("biwidth","int",0), - ("biheight","int",0), - ("biplanes","short",0), - ("bibitcount","short",0), - ("bicompression","int",0), - ("bisizeimage","int",0), - ("bixpelspermeter","int",0), - ("biypelspermeter","int",0), - ("biclrused","int",0), - ("biclrimportant","int",0) - )); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - bisize := _size_(); - end - property bisize index "bisize" read _getvalue_ write _setvalue_; - property biwidth index "biwidth" read _getvalue_ write _setvalue_; - property biheight index "biheight" read _getvalue_ write _setvalue_; - property biplanes index "biplanes" read _getvalue_ write _setvalue_; - property bibitcount index "bibitcount" read _getvalue_ write _setvalue_; - property bicompression index "bicompression" read _getvalue_ write _setvalue_; - property bisizeimage index "bisizeimage" read _getvalue_ write _setvalue_; - property bixpelspermeter index "bixpelspermeter" read _getvalue_ write _setvalue_; - property biypelspermeter index "biypelspermeter" read _getvalue_ write _setvalue_; - property biclrused index "biclrused" read _getvalue_ write _setvalue_; - property biclrimportant index "biclrimportant" read _getvalue_ write _setvalue_; -end -type TTBBUTTONINFOA=class(tcstructwithcharptr) - {** - @explan(说明) 工具条项内存对象 %% - **} - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := array( - ("cbsize","int",0), - ("dwmask","int",0), - ("idcommand","int",0), - ("iimage","int",0), - ("fsstate","byte",0), - ("fsstyle","byte",0), - ("cx","short",0), - ("lparam","intptr",0), - ("psztext","char*",0), - ("cchtext","int",100)); - return SSTRUCT; - end - public - function create();override; - begin - inherited create(getstruct(),array("psztext":"cchtext"),nil); - cbsize := _size_(); - end - property cbsize index "cbsize" read _getvalue_ write _setvalue_; - property dwmask index "dwmask" read _getvalue_ write _setvalue_; - property idcommand index "idcommand" read _getvalue_ write _setvalue_; - property iimage index "iimage" read _getvalue_ write _setvalue_; - property fsstate index "fsstate" read _getvalue_ write _setvalue_; - property fsstyle index "fsstyle" read _getvalue_ write _setvalue_; - property cx index "cx" read _getvalue_ write _setvalue_; - property lparam index "lparam" read _getvalue_ write _setvalue_; - property psztext index "psztext" read _getvalue_ write _setvalue_; - property cchtext index "cchtext" read _getvalue_ write _setvalue_; -end - -type TTBBUTTON=class(tslcstructureobj) - {** - @explan(说明) 工具栏按钮内存对象 %% - **} - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( - ("ibitmap","int",0), - ("idcommand","int",0), - ("fsstate","byte",0), - ("fsstyle","byte",0), - ("dwdata","intptr",0), - ("istring","char*",128))); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - function _setvalue_(id,v); - begin - if id="istring" then - begin - if ifstring(v)and length(v)<127 then - begin - return inherited; - end - return; - end - return inherited; - end - property ibitmap index "ibitmap" read _getvalue_ write _setvalue_; - property idcommand index "idcommand" read _getvalue_ write _setvalue_; - property fsstate index "fsstate" read _getvalue_ write _setvalue_; - property fsstyle index "fsstyle" read _getvalue_ write _setvalue_; - property dwdata index "dwdata" read _getvalue_ write _setvalue_; - property istring index "istring" read _getvalue_ write _setvalue_; -end -type TScrollBarKind=class(tenumeration) - static sbHorizontal; - static sbVertical; -end - -type TToolTipsFlags=class - {** - @ignore(忽略) %% - @explan() tooltips flags 常量 %% - **} - static TTF_IDISHWND; - static TTF_CENTERTIP; - static TTF_RTLREADING; - static TTF_SUBCLASS; - static TTF_TRACK; - static TTF_ABSOLUTE; - static TTF_TRANSPARENT; - static TTF_PARSELINKS; - static TTF_DI_SETITEM; -end - - type TIMAGEINFO = class(tslcstructureobj) - {** - @ignore 忽略 %% - @explan(说明) imgelist中image的信息 %% - **} - private - static SSTRUCT; - function getstruct() - begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate( - array( - ("hbmimage","intptr",0), - ("hbmmask","intptr",0), - ("unused1","int",0), - ("unused2","int",0), - ("rcimage","int[4]", - (0,0,0,0)))); - return SSTRUCT; - end - function getbmp(v); - begin - {** - @explan(说明)构造tbitmap对象 %% - **} - hm := _getvalue_(v); - if hm then - begin - r := new tbitmap(); - r.handle := hm; - r.AutoDestroy := false; - return r; - end - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end - property bmimage:tbitmap index "hbmimage" read getbmp write getbmp; - property bmmask:tbitmap index "hbmmask" read getbmp write getbmp; - property hbmimage index "hbmimage" read _getvalue_ write _setvalue_; - property hbmmask index "hbmmask" read _getvalue_ write _setvalue_; - property unused1 index "unused1" read _getvalue_ write _setvalue_; - property unused2 index "unused2" read _getvalue_ write _setvalue_; - property rcimage index "rcimage" read _getvalue_ write _setvalue_; - {** - @param(bmimage)(tbitmap) 位图 %% - @param(bmmask)(tbitmap) mask %% - @param(rcimage)(array) 左上右下 %% - **} - end - -*) - - -//////////////twincontrol 中移除的函数 -(* - function CreateDrawItemEvent();virtual; - begin - {** - @explan(说明) 主动构造drawitem消息,可以自行填写信息在DoDrawItem中使用,与DestroyDrawItemEvent成对出现 %% - @return(TMDRAWITEM|nil) item绘制对象 %% - **} - e := nil; - if HandleAllocated() then - begin - hd := self.Handle; - itptr := FTtageDrawItem._getptr_; - e := new TMDRAWITEM(WM_DRAWITEM,0,itptr,hd); - e.canvas := canvas; - canvas.handle := _wapi.GetDC(self.Handle); - end - return e; - end - function DestroyDrawItemEvent(e);virtual; - begin - {** - @explan(说明) 与CreateDrawItemEvent配合使用 %% - @param(e)(TMDRAWITEM) CreateDrawItemEvent 构造的消息对象 %% - **} - if HandleAllocated() and ( e is class(TMDRAWITEM)) and (e.lparam = FTtageDrawItem._getptr_()) then - begin - dc := canvas.Handle; - if dc then - begin - canvas.handle := 0; - return _wapi.ReleaseDC(self.Handle,dc); - end - end - end -*) - -(* - //tcontrol 移除代码 - function GetDeviceContext(var WindowHandle:HWND);virtual; //type_tcontrol - begin - {** - @explan(说明) 获取设备hdc %% - @param(WindowHandle)(pointer) 窗口句柄 %% - @return(pointer) dc 句柄 %% - **} - if Parent is class(TWinControl)then - begin - Result := Parent.GetDeviceContext(WindowHandle); - MoveWindowOrgEx(Result,Left,Top); - IntersectClipRect(Result,0,0,Width,Height); - end else - raise "错误"; - return Result; - end; - - function IntersectClipRect(hdc, x0, y0, x1, y1);virtual; //type_tcontrol - begin - _wapi.IntersectClipRect(hdc, x0, y0, x1, y1); - end - function MoveWindowOrgEx(hdc;x:integer;y:integer);virtual; //type_tcontrol - begin - {** - @explan(说明) 移动dc原点 %% - @param(hdc)(pointer) dc 句柄 %% - **} - return _wapi.SetViewportOrgEx(hdc,x,y,nil); - end - - function WMXButtonDown(o,e): LM_XBUTTONDOWN;virtual; - begin - end - function WMMButtonDBLCLK(o,e): LM_MBUTTONDBLCLK;virtual; - begin - - end - function WMXButtonDBLCLK(o,e): LM_XBUTTONDBLCLK;virtual; - begin - - end - function WMLButtonTripleCLK(o,e): LM_LBUTTONTRIPLECLK;virtual; - begin - - end - function WMRButtonTripleCLK(o,e): LM_RBUTTONTRIPLECLK;virtual; - begin - - end - function WMMButtonTripleCLK(o,e): LM_MBUTTONTRIPLECLK;virtual; - begin - - end - function WMXButtonTripleCLK(o,e): LM_XBUTTONTRIPLECLK;virtual; - begin - - end - function WMXButtonUp(o,e): LM_XBUTTONUP;virtual; - begin - - end - function WMLButtonQuadCLK(): LM_LBUTTONQUADCLK;virtual; - function WMRButtonQuadCLK(): LM_RBUTTONQUADCLK;virtual; - function WMMButtonQuadCLK(): LM_MBUTTONQUADCLK;virtual; - function WMXButtonQuadCLK(): LM_XBUTTONQUADCLK;virtual; -*) -(* - - function SetMainMenubk(mu); - begin - if csDesigning in ComponentState then - begin - if FMainMenu and mu then //已经存在 %% - begin - return ; - end - if (not FMainMenu) and mu then - begin - mu := new TMainmenu(self); //构造一个假的菜单 - tm := new TMenu(mu); - tm.caption := "menu"; - tm.parent := mu; - end - end - if FMainMenu<>mu then - begin - OM := FMainMenu; - if OM is class(tmainmenu) then - begin - OM.DestroyHandle(); //删除句柄 %% - OM.Hwnd := 0; - //if HandleAllocated() then _wapi.SetMenu(self.Handle,0); //删除窗口上面的菜单句柄 - end - if (mu is class(tmainmenu)) then - begin - if HandleAllocated() then - begin - mu.Hwnd := handle; - //_wapi.SetMenu(self.Handle,mu.handle); - end - end - FMainMenu := mu; - end - end - - type TTempFile = class - function Create(dt); - begin - if not ifarray(FFiles) then FFiles := array(); - bp :=gettemppath()+"tinysoft"+ioFileseparator()+"tslvcl"+ioFileseparator(); - {if not fileexists("",bp) then - begin - for i:=2 to length(bp) do - begin - if bp[i]=ioFileseparator() then - begin - if fileexists("",bp[1:i-1]) then - begin - createdir("",bp[1:i-1]) - end - end - end - end } - for i,v in mrows( FFiles,1) do - begin - if not(FFiles[v]) then - begin - FFiles[v] := true; - FPath := v; - break; - end - end - while not FPath do - begin - i := 0; - while true do - begin - subdir := tostn( rand(3)[1]); - p := bp+subdir[3]+ioFileseparator()+subdir[4]+".png"; - echo p,"\r\n"; - if not(FFiles[p]) then - begin - FFiles[p] := true; - FPath := p; - //writefile(rwraw(),"",FPath,0,1,"0") ; - break; - end - end - end - if ifstring(dt) then - begin - //if FileExists("",FPath) then filedelete("",FPath); - writefile(rwraw(),"",FPath,0,length(dt),dt) ; - end - end - function GetData(buf);//获得数据 - begin - if FPath then - begin - sz := filesize("",FPath); - return readfile(rwraw(),"",FPath,0,sz,buf); - end - end - function Destroy(); - begin - //FFiles[FPath] := false; - if FileExists("",FPath) then echo "\r\ndeletefile:",filedelete("",FPath); - FPath := ""; - end - property path read FPath ; - private - FPath; - static FFiles; -end - -*) -//暂时不用的函数 -{function chartoint(c); -begin - v := ord(c); - case v of - 48 to 57:vk := v-48; - 65 to 70:vk := v-65+10; - 97 to 102:vk := v-97+10; - else raise "非16进制字符串"; - end - return vk; -end} \ No newline at end of file diff --git a/funcext/tvclib/tuieventbase.tsf b/funcext/tvclib/tuieventbase.tsf new file mode 100644 index 0000000..bb5f1a3 --- /dev/null +++ b/funcext/tvclib/tuieventbase.tsf @@ -0,0 +1,155 @@ +type tuieventbase=class(TSLUICONST) + {** + @explan(说明) 消息基类 %% + **} + uses utslvclauxiliary,utslvclconstant; + public + Message:integer; + Wparam:pointer; + Lparam:pointer; + Hwnd:pointer; + _tag; + {** + @param(Message)(integer) 消息id %% + @param(Wparam)(pointer) 消息wparam %% + @param(Lparam)(pointer) 消息lparam %% + @param(Hwnd)(pointer) 窗口句柄 %% + **} + private + Fhwparam; + Flwparam; + Fhlparam; + Fllparam; + //有符号数 + Fuhwparam; + Fulwparam; + Fuhlparam; + Fullparam; + //结果 + FSkip; + Fresult; + FSender; + function setSkip(v); + begin + if v then + begin + FSkip := true; + end else + begin + FSkip := false; + end + end + function GetSender(); + begin + return FSender; + end + Function SetSender(v); + begin + return FSender := v; + end + public + //FLparamdata; + //FWparamdata; + function create(m,w,l,h);virtual; + begin + {** + @explan(说明) 消息构造 %% + @param(m)(integer) 消息id %% + @param(w)(pointer) 消息wparam %% + @param(l)(pointer) 消息lparam %% + @param(h)(pointer) 窗口句柄 %% + **} + Message := m; + Wparam := w; + Lparam := l; + Hwnd := h; + end + function hilparam(); + begin + {** + @explan(说明) 高字节 %% + **} + if ifnil(Fhlparam)then + begin + lowuperdword(Lparam,Fllparam,Fhlparam); + end + return Fhlparam; + end + function lolparam(); + begin + {** + @explan(说明) 低字节 %% + **} + if ifnil(Fllparam)then + begin + lowuperdword(Lparam,Fllparam,Fhlparam); + end + return Fllparam; + end + function hiwparam(); + begin + {** + @explan(说明) 高字节 %% + **} + if ifnil(Fhwparam)then + begin + lowuperdword(Wparam,Flwparam,Fhwparam); + end + return Fhwparam; + end + function lowparam(); + begin + {** + @explan(说明) 低字节 %% + **} + if ifnil(Flwparam)then + begin + lowuperdword(Wparam,Flwparam,Fhwparam); + end + return Flwparam; + end + function hilparamsigned(); + begin + {** + @explan(说明) 高字作为符号数 + **} + if ifnil(Fuhlparam)then Fuhlparam := unsignedtosigned(hilparam()); + return Fuhlparam; + end + function lolparamsigned(); + begin + {** + @explan(说明) 低字作为符号数 + **} + if ifnil(Fullparam)then Fullparam := unsignedtosigned(lolparam()); + return Fullparam; + end + function hiwparamsigned(); + begin + {** + @explan(说明) 高字作为符号数 + **} + if ifnil(Fuhwparam)then Fuhwparam := unsignedtosigned(hiwparam()); + return Fuhwparam; + end + function lowparamsigned(); + begin + {** + @explan(说明) 低字作为符号数 + **} + if ifnil(Fulwparam)then Fulwparam := unsignedtosigned(lowparam()); + return Fulwparam; + end + property msg read Message; + property skip read FSkip write setSkip; + property Result read Fresult write Fresult; + property Handle read Hwnd write Hwnd; + property Sender read GetSender write SetSender; + {** + @param(msg)(integer) 消息id %% + @param(skip)(bool) 是否忽略底层消息处理函数 %% + @param(Result)(integer) 消息处理返回 %% + @param(Handle)(pointer) 窗口句柄 %% + @param(sender)(TControl) 发送消息的控件,如菜单消息的触发窗口 %% + **} +end diff --git a/funcext/tvclib/twincontrol.tsf b/funcext/tvclib/twincontrol.tsf new file mode 100644 index 0000000..cc6b63f --- /dev/null +++ b/funcext/tvclib/twincontrol.tsf @@ -0,0 +1,2464 @@ +type TWinControl = class(tcontrol) +///////////平台判断//////// +{$ifdef linux} + {$define gtkpaint} + {$define linuxgtk} +{$else} + {$define gdipaint} +{$endif} + uses utslvclauxiliary,utslvclmemstruct,utslvclbase,utslvclevent,utslvclgdi,uvclthreadworker,utslvclaction,utslvclmenu,utslvclstdctl; + {** + @explan(说明) 窗口控件 %% + **} + private //成员变量 + __wstyle; //窗口样式 + __wexstyle; //窗口扩展样式 + __wstylestruct; //样式消息结构体 + __clientsize; //客户区大小 + __oldclientsize; //旧客户区大小 + FClientleft; + FClientTop; + FClientWdith; + FClientHeight; + FWsPopUp; + //FTtageDrawItem; //已经移除 + FWMNCHITTEST; + FImageList; + //FTRACKMOUSEEVENT; + FHandle:HWND; //窗口句柄 + private //窗口相关 + FBorderStyle; + FParentWindow:HWND; //父窗口句柄 + static FDefaultProc; //windows默认句柄处理 + FWndproc; //消息句柄 + protected //消息 + FDefWndproc; //默认消息句柄 + private //时间指针 + FonKillFocus; + FonSetFocus; + FControlStyle; //控件样式 + FOnClose; + FOnDesinedsel; + FOnDesigDBLClick; + FOnDesinedRclick; + FOnActivate; + FOnKeyDown; + FOnKeyPress; + FOnKeyUp; + FTabStop; + FWsCaption; + FWsSizeBox; + FWsSysMenu; + FWsDlgModalFrame; + private //模态相关 + //*******showmodal****************** + FModaling; + FModalCode; + FMinWidth; + FMinHeigt; + //Ftagminmaxinfo; + FMaxWidth; + FMaxHeight; + FGtkEventOjbect; //gtkobject + private //窗口属性 + function SetMaxWidth(v); + begin + if v>0 and FMaxWidth <> V then + begin + FMaxWidth := v; + end + end + function SetMaxHeight(v); + begin + if v>0 and FMaxHeight <> v then + begin + FMaxHeight := v; + end + end + function SetMinWidth(v); + begin + if v>0 and FMinWidth <> v then + begin + FMinWidth := v; + if FMinWidth>width then width := FMinWidth; + end + end + function SetMinHeight(v); + begin + if v>0 and FMinHeigt <> v then + begin + FMinHeigt := v; + if FMinHeigt>height then height := FMinHeigt; + end + end + function DoModal() + begin + //标识处于模态状态中 + if not WsPopUp then + begin + exit; + end +{$ifdef gtkpaint} + if FModaling then exit; + if _wapi.gtk_window_showmodal(self(true))then + begin + FModaling := true; + app := class(tUIglobalData).uigetdata("tuiapplication"); + if app then app.run(); + end + return FModalCode; + exit; +{$endif} + modp := parent; + {if not(modp is class(TWinControl)) then + begin + return -1; + end } + hWnd := Handle; + FModaling := TRUE; + FMSG := new TTagMSG(); + msg := FMSG._getptr_; + //显示自己 + _wapi.ShowWindow(hWnd,SW_SHOW); + _wapi.BringWindowToTop(hWnd); + //disable掉父窗口 + FModalRootWnd := 0; + if(modp is class(TWinControl))and modp.HandleAllocated()then + begin + hParentWnd := modp.Handle; + while(hParentWnd) do + begin + _wapi.EnableWindow(hParentWnd,FALSE); + wdobj := class(tUIglobalData).uigetdata("TGlobalComponentcache").getwndbyhwnd(hParentWnd); + if wdobj and wdobj.Modaling then + begin + FModalRootWnd := hParentWnd; + break; + end + hParentWnd := _wapi.GetParent(hParentWnd); + end + end + //接管消息循环 + while(FModaling) do + begin + ///////////////////////////////////////////// + if(_wapi.PeekMessageA(msg,0,0,0,0x1))then + begin + if FMSG.message=0x12 then + begin + return 1; + end else + begin + _wapi.TranslateMessage(msg); + _wapi.DispatchMessageA(msg); + end + end else + begin + tslprocessmessages(false); + sleep(10); + class(TCustomThreadworker).dispatch(); + end + ////////////////////////////////////////// + {if (not _wapi.GetMessageA(msg, 0, 0, 0)) then break; + _wapi.TranslateMessage(msg); + _wapi.DispatchMessageA(msg);} + end + //模态已经退出 + //恢复父窗口的enable状态 + if(modp is class(TWinControl))and modp.HandleAllocated()then + begin + hParentWnd := modp.Handle; + while(hParentWnd) do + begin + _wapi.EnableWindow(hParentWnd,TRUE); + if FModalRootWnd=hParentWnd then break; + hParentWnd := _wapi.GetParent(hParentWnd); + end + end + //将自己隐藏 + _wapi.ShowWindow(hWnd,SW_HIDE); + return FModalCode; + end + private //窗口样式 + function SetWSsizeBox(v); + begin + nv := v?true:false; + if nv <> FWsSizeBox then + begin + FWsSizeBox := nv; + if HandleAllocated()then RecreateWnd(); + end + end + function GetWsSysMenu();virtual; + begin + return FWsSysMenu; + end + function SetWsSysMenu(v);virtual; + begin + nv := v?true:false; + if nv <> FWsSysMenu then + begin + FWsSysMenu := nv; + if HandleAllocated()then RecreateWnd(); + end + end + function SetWsDlgModalFrame(v);virtual; + begin + nv := v?true:false; + if nv <> FWsDlgModalFrame then + begin + FWsDlgModalFrame := nv; + if HandleAllocated()then + begin + RecreateWnd(); + end + end + end + protected + function SetWsPopUp(v);virtual; + begin + nv := v?true:false; + if nv <> FWsPopUp then + begin + FWsPopUp := nv; + if HandleAllocated()then RecreateWnd(); + end + end + function GetWsPopUp();virtual; + begin + return FWsPopUp; + end + private + + function CompareRect(orect,nrect); + begin + return orect=nrect; + end + + function GetWsCaption(v);virtual; + begin + return FWsCaption; + end + function SetWsCaption(v);virtual; + begin + nv := v?true:false; + if nv <> FWsCaption then + begin + FWsCaption := nv; + if HandleAllocated()then RecreateWnd(); + end + end + function GetHandle(); //type_twinctrol + begin + //if not HandleAllocated then DebugLn('TWinControl.GetHandle Creating handle on the fly: ',DbgSName(Self)); + HandleNeeded(); + return FHandle; + end; + procedure SetHandle(NewHandle); //type_twinctrol + begin + if {NewHandle and}not(FHandle)then FHandle := NewHandle; + //if (NewHandle=0) and (AnsiCompareText(ClassName,'TPAGE')=0) then + // RaiseGDBException('TWincontrol.SetHandle'); + //FHandle:=NewHandle; + //InvalidatePreferredSize(); + end; + function SetTabStop(v); + begin + nv := V?true:false; + if nv <> FTabStop then + begin + FTabStop := nv; + if HandleAllocated()then + begin + if nv then appendwstyle(WS_TABSTOP); + else minuswstyle(WS_TABSTOP); + end + end + end + function GetControlCount():Integer; //type_twinctrol + begin + return FControls.Count(); + end; + procedure SetParentWindow(const AValue:HWND); //type_twinctrol + begin + {** + @ignore(忽略) %% + **} + if(ParentWindow=AValue)or Assigned(Parent)then Exit; + FParentWindow := AValue; + if HandleAllocated()then + begin + if(AValue <> 0)then //LCLIntf.SetParent(Handle, AValue) + else DestroyHandle(); + end + UpdateControlState(); + end + protected + function SetImageList(v); + begin + if FImageList=v then exit; + if FImageList is class(tcustomcontrolimagelist) then + begin + ti := FImageList; + FImageList := nil; + ti.deleteControl(self); + end + FImageList := v; + if v is class(tcustomcontrolimagelist) then v.addControl(self); + ImageChanged(); + end + class function getwndbyhwnd(hwnd); //type_twinctrol + begin + return class(tUIglobalData).uigetdata("TGlobalComponentcache").getwndbyhwnd(hwnd); + end + class function registerhandle(handle,o); //type_twinctrol + begin + //注册对象 %% + return class(tUIglobalData).uigetdata("TGlobalComponentcache").registerhandle(handle,o); + end + class function unregisterhandle(handle); //type_twinctrol + begin + //删除对象 %% + return class(tUIglobalData).uigetdata("TGlobalComponentcache").unregisterhandle(handle); + end + class function sinit();override; + begin + {** + @explan(说明)初始化 %% + **} + if ifnil(FDefaultProc)then FDefaultProc := getwinprocptr(1); + end + function SetBorder(v);override; //type_twinctrol + begin + nv := v?true:false; + if nv <> Border then + begin + inherited; + if nv then appendwstyle(WS_BORDER); + else minuswstyle(WS_BORDER); + Refresh(); + end + end + procedure CreateHandle();virtual; //type_twinctrol + begin + if csCreating in ControlState then return; + if(not HandleAllocated())then + begin + includestate(ControlState,csCreating); + CreateWnd(); + excludestate(ControlState,csCreating); + end + end; + procedure InitializeWnd();virtual; //type_twinctrol + begin + {** + @explan(说明) 窗口句柄初始化,在该函数设置窗口句柄的一些信息 %% + **} + //背景这些处理 + if HandleAllocated()then + begin + //Canvas.Handle := _wapi.GetDC(self.Handle); + if(Parent is class(TWinControl))and Parent.HandleAllocated()then + begin + //if Align<>alNone then + Parent.DoControlAlign(); + end + if ParentFont then + begin + hd := GetParentFontHandle(); + end else + hd := Font.Handle; + if hd then + begin + _send_(WM_SETFONT,hd,1,1); //send 修改为 post + end + ImageChanged(); + // "id:",self.caption,_wapi.GetWindowLongPtrA(FHandle,GWLP_ID); + end + end + function GetBorderStyle(); + begin + return FBorderStyle; + end + function SetBorderStyle(NewStyle);virtual; + begin + if FBorderStyle=NewStyle then exit; + if FBorderStyle in array(bsNone,bsSingle)then + begin + FBorderStyle := NewStyle; + if FBorderStyle=bsNone then + begin + minuswexstyle(WS_EX_CLIENTEDGE); + end else + appendwexstyle(WS_EX_CLIENTEDGE); + end + end + function CreateParams(p);virtual; //type_twinctrol + begin + {** + @explan(说明)构架窗口句柄使用 %% + @param(p)(var TCreateParams) 变参返回 %% + **} + if not(p is class(TCreateParams))then p := new TCreateParams(); + p.Caption := Caption; + //p.Style := WS_CHILD .| WS_CLIPSIBLINGS .| WS_CLIPCHILDREN ; + p.Style := WS_CHILD; + if FWsPopUp then + begin + p.Style := WS_POPUP; + end else + begin + p.Style := WS_CHILD; + end + //p.style .|= WS_CAPTION; //WS_SYSMENU .| + if WsCaption then p.style .|= WS_CAPTION; + if FWsSysMenu then P.Style .|= WS_CAPTION .| WS_SYSMENU; + if FWsSizeBox then p.style .|= WS_SIZEBOX; + if Border then p.Style := p.Style .| WS_BORDER; + if csAcceptsControls in FControlStyle then p.ExStyle := p.ExStyle .| WS_EX_CONTROLPARENT; + if BorderStyle=bsSingle then p.ExStyle := p.ExStyle .| WS_EX_CLIENTEDGE; + if WSDlgModalFrame then + begin + p.ExStyle .|= WS_EX_DLGMODALFRAME; + end + if TabStop then p.Style .|= WS_TABSTOP; + //op := parent; + if not(Enabled)then p.Style .|= WS_DISABLED; + if Visible then p.Style .|= WS_VISIBLE; + if Parent is class(TWinControl)then //if Parent.HandleAllocated() then + p.WndParent := Parent.Handle; + else p.WndParent := ParentWindow; + p.X := Left; + p.Y := Top; + p.Width := Width; + p.Height := Height; + p.happ := happ; + p.Style .|= WS_CLIPSIBLINGS .| WS_CLIPCHILDREN; + p.cstyle := CS_HREDRAW .| CS_VREDRAW .| CS_OWNDC .| CS_DBLCLKS; + end + procedure RealSetText(Value:TCaption);override; //type_twinctrol + begin + {** + @explan(说明) 设置标题 %% + @param(value)(string) 标题 %% + **} + if ifstring(Value)and(Caption <> Value)then + begin + inherited; + if HandleAllocated()then + begin + _wapi.SetWindowTextA(self.handle,self.Caption); + end + end + end + function createwndclass(p); //type_twinctrol + begin + {** + @param(p)(TCreateParams) 注册窗口类 %% + @explan(说明)注册窗口类 %% + **} + classobj := p.winclass; //new tagWNDCLASSA(); + subclass := p.subclass; + uiproc := getwinprocptr(); + dfproc := getwinprocptr(1); + p.subclasswndproc := dfproc; + tclass := new tagWNDCLASSA(); + classobj._setvalue_("lpszclassname",p.WinClassName); + for i,v in classobj._getdata_() do + begin + if i="lpfnwndproc" then tclass._setvalue_(i,uiproc); + else tclass._setvalue_(i,v); + end + regptr := _wapi.GetClassInfoExA(p.happ,p.WinClassName,classobj._getptr_); + if not regptr then + begin + for i,v in tclass._getdata_() do + begin + classobj._setvalue_(i,v); + end + end + if ifstring(p.SubClassName)and p.SubClassName then //存在subclass + begin + tcn := p.SubClassName; + subregptr := _wapi.GetClassInfoExA(p.Happ,tcn,subclass._getptr_); + if subregptr then + begin + p.subclasswndproc := subclass._getvalue_("lpfnwndproc"); + if p.subclasswndproc=uiproc then + begin + p.subclasswndproc := dfproc; + end + if not regptr then //窗口没有注册 + begin + for i,v in subclass._getdata_() do //填充子窗口信息 + begin + if i="lpfnwndproc" then + begin + classobj._setvalue_(i,uiproc); + end else + if i="lpszclassname" then + begin + tcn := p.WinClassName; + classobj._setvalue_(i,tcn); + end else + begin + classobj._setvalue_(i,v); + end + end + end + end + end else //不存在subclass 默认回调为 defaultproc + begin + if p.cstyle then classobj.style := p.cstyle; + p.subclasswndproc := dfproc; + end + if regptr then + begin + if uiproc <> classobj._getvalue_("lpfnwndproc")then + begin + messageboxA("窗口类注册冲突!","错误",1); + end + end else + begin + regptr := _wapi.RegisterClassExA(classobj._getptr_); + end + end + function UpdateControlState(); ////type_twinctrol + begin + end + procedure ChangeBounds(ALeft,ATop,AWidth,AHeight:integer;KeepBase:boolean);override; //type_twinctrol + begin + if HandleAllocated()then + begin + //_wapi.MoveWindow(self.Handle,ALeft,ATop,AWidth,AHeight,true); + _wapi.SetWindowPos(self.Handle,0,integer(ALeft),integer(ATop),integer(AWidth),integer(AHeight),SWP_NOZORDER .| SWP_NOACTIVATE); //.| SWP_NOACTIVATE + end else + begin + inherited; + //class(tcontrol).ChangeBounds(ALeft, ATop, AWidth, AHeight,KeepBase); + end + end + function SetEnabled(v);override; + begin + inherited; + if HandleAllocated()then _wapi.EnableWindow(FHandle,v?true:false); + end + function SetVisible(v);override; + begin + inherited; + if HandleAllocated()then + begin + _wapi.ShowWindow(FHandle,v?SW_SHOW:SW_HIDE); + if(Parent is class(TWinControl))and parent.HandleAllocated()then + begin + if Align <> alNone then Parent.DoControlAlign(); + end + {if V then + begin + DoControlAlign(); + end } + end + end + function Hitcontrol(p); + begin + {** + @explan(说明) 命中控件 %% + **} + for i := ControlCount-1 downto 0 do + begin + it := Controls[i]; + if it is class(TGraphicControl)then + begin + if it.Enabled and it.Visible and pointinrect(p,it.GetBoundsRect)then + begin + return it; + end + end + end + end + function MouseHover(O,e);override; + begin + inself := true; + initem := 0; + for i := ControlCount-1 downto 0 do + begin + it := FControls[i]; + if(it is class(TGraphicControl))and it.visible then + begin + if inself and pointinrect(array(e.lolparamsigned,e.hilparamsigned),it.GetBoundsRect)and it.Enabled then + begin + initem := it; + inself := false; + end else + begin + it.Perform(messagecreater(nil,WM_MOUSELEAVE,0,0)); + end + end + end + if inself then return inherited; + else self.Perform(messagecreater(nil,WM_MOUSELEAVE,0,0)); + if initem then initem.Perform(messagecreater(nil,WM_MOUSEHOVER,0,0)); + end + function GetParentFontHandle();override; + begin + {** + @explan(说明) 获取字体的句柄 %% + @return(pointer) + **} + if ParentFont and Parent then return Parent.GetParentFontHandle(); + if HandleAllocated()then + begin + return _send_(WM_GETFONT,0,0); + end else + return inherited; + end + public //消息绑定函数 + function WMMouseMove(o,e):LM_MOUSEMOVE;override; + begin + it := Hitcontrol(e.pos); + if it then + begin + return it.WMMouseMove(it,new TMMouse(LM_MOUSEMOVE,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); + //return it.Perform(new TMMouse(LM_MOUSEMOVE,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); + end + inherited; + end + function WMLButtonUp(o,e):LM_LBUTTONUP;override; + begin + it := Hitcontrol(e.pos); + if it then + begin + return it.WMLButtonUp(it,new TMMouse(LM_LBUTTONUP,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); + end + inherited; + end + function WMRButtonUp(o,e):LM_RBUTTONUP;override; + begin + it := Hitcontrol(e.pos); + if it then + begin + return it.WMRButtonUp(it,new TMMouse(LM_RBUTTONUP,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); + end + inherited; + end + function WMMButtonUp(o,e):LM_MBUTTONUP;override; + begin + it := Hitcontrol(e.pos); + if it then + begin + return it.WMMButtonUp(it,new TMMouse(LM_MBUTTONUP,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); + end + inherited; + end + function WMContextMenu(o,e):LM_CONTEXTMENU;override; + begin + ps := array(e.lolparamsigned,e.hilparamsigned); + _wapi.ScreenToClient(Handle,ps); + it := Hitcontrol(ps); + if it then + begin + ev := new TMMouse(e.msg,e.wparam,e.lparam); + return it.Perform(ev); + end + return inherited; + end + function WMLButtonDown(o,e):LM_LBUTTONDOWN;override; + begin + it := Hitcontrol(e.pos); + if it then + begin + return it.WMLButtonDown(it,new TMMouse(LM_LBUTTONDOWN,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); + end + inherited; + end + function WMRButtonDown(o,e):LM_RBUTTONDOWN;override; + begin + it := Hitcontrol(e.pos); + if it then + begin + return it.WMRButtonDown(it,new TMMouse(LM_RBUTTONDOWN,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); + //return it.Perform(new TMMouse(LM_MOUSEMOVE,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); + end + inherited; + end + function WMMButtonDown(o,e):LM_MBUTTONDOWN;override; + begin + it := Hitcontrol(e.pos); + if it then + begin + return it.WMMButtonDown(it,new TMMouse(LM_MBUTTONDOWN,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); + end + inherited; + end + function WMLButtonDBLCLK(o,e):LM_LBUTTONDBLCLK;override; + begin + it := Hitcontrol(e.pos); + if it then + begin + return it.WMLButtonDBLCLK(it,new TMMouse(LM_LBUTTONDBLCLK,e.wparam,makelong(e.xpos-it.left,e.ypos-it.top))); + end + inherited; + end + public //设计器相关杂项 + class function CaptionHeight(); + begin + {** + @explan(说明) caption的高度 %% + @return(integer) 高度 %% + **} + return _wapi.GetSystemMetrics(SM_CYCAPTION); + end + function DesigningSelect(v); + begin + if ifnil(FDesignSelect)then FDesignSelect := false; + if ifnil(v)then return FDesignSelect; + if WsPopUp then return; + if not(csDesigning in ComponentState)then return; + nv := v?true:false; + if nv=FDesignSelect then return; + FDesignSelect := nv; + {$ifdef linux} + return InvalidateRect(nil,false); + {$endif} + rec := array(left,top,left+width,top+height); + rec[2:3]+= 1; + SetBoundsRect(rec); + rec[2:3]-= 1; + SetBoundsRect(rec); + end + private + FDesignSelect; + public //消息绑定函数 + function ImageChanged();virtual; + begin + end + + function WMNCPAINT(o,e):LM_NCPAINT;virtual; + begin + if (csDesigning in ComponentState) and FDesignSelect then + begin + hWnd := Handle; + rec := zeros(4); + {$ifdef linux} + + cvs := Canvas; + cvs.Handle := e.lparam;; + pc := cvs.pen.Color; + cvs.Pen.Color := rgb(224,0,0); + ps := cvs.Pen.Style; + pw := cvs.Pen.width; + cvs.Pen.Style := PS_SOLID; + cvs.Pen.width := 2; + _wapi.gtk_widget_get_allocation(hWnd,rec); + rec[0]:=0; + rec[1] := 0; + //rec[2]-=2; + //rec[3]-=2; + //cvs.FillRect(array(0,0,width,height)); //array(0,0,width,height) + cvs.Draw("Polyline",array((0,0),(rec[2]-rec[0]-1,0),(rec[2]-rec[0]-1,rec[3]-rec[1]-1),(0,rec[3]-rec[1]-1),(0,0))); + cvs.Pen.Color := pc; + cvs.Pen.width := pw; + cvs.Pen.Style := ps; + cvs.Handle := 0; + return ; + {$endif} + _wapi.GetWindowRect(hwnd,rec); + rect := array(0,0,0,0); + _wapi.GetClientRect(self.Handle,rect); + region := new TRGNRECT(); + region.Rect := rec; + if e.wparam =1 then + begin + end else + begin + _wapi.CombineRgn(region.Handle,e.wparam,nil,RGN_COPY); + end + hdc := _wapi.GetDCEx(hWnd, region.Handle, DCX_WINDOW .| DCX_CACHE .| DCX_INTERSECTRGN .| DCX_LOCKWINDOWUPDATE); + if hdc=0 then return ; + cvs := Canvas; + cvs.Handle := hdc; + cvs.Pen.Color := rgb(224,0,0); + cvs.Pen.Style := PS_SOLID; + cvs.Pen.width := 2; + defaulthandler(e); + //cvs.FillRect(array(0,0,width,height)); //array(0,0,width,height) + cvs.Draw("Polyline",array((0,0),(rec[2]-rec[0]-1,0),(rec[2]-rec[0]-1,rec[3]-rec[1]-1),(0,rec[3]-rec[1]-1),(0,0))); + _wapi.ReleaseDC(hWnd,hdc); + e.skip := true; + e.Result := 0; + end + end + procedure FontChanged(Sender:TObject);override; + begin + if(HandleAllocated()and not(ParentFont))then + begin + _send_(WM_SETFONT,Font.Handle,1); + end + end + function CMPARENTFONTCHANGED(o,e):CM_PARENTFONTCHANGED;virtual; + begin + if ParentFont then + begin + _send_(WM_SETFONT,e.wparam,1); + end + end + function WMGETMINMAXINFO(o,e):WM_GETMINMAXINFO;virtual; + begin + {** + @explan(说明) 最小窗口设置 %% + **} + k := 0; + if FMinWidth>0 then + begin + k .|= 1; + end + if FMinHeigt>0 then + begin + k .|= 2; + end + if FMaxHeight>0 then + begin + k .|= 4; + end + if FMaxWidth>0 then + begin + k .|= 8; + end + if k then + begin + d := new Ttagminmaxinfo(e.lparam); + ts := d.ptmintracksize; + case k of + 1:ts[0]:= FMinWidth; + 2:ts[1]:= FMinHeigt; + 3:ts := array(FMinWidth,FMinHeigt); + end; + d.ptmintracksize := ts; + end + end + function CMFONTCHANGED(o,e):CM_FONTCHANGED;virtual; + begin + hd := e.wparam; + for i := 0 to ControlCount-1 do + begin + it := Controls[i]; + it.Perform(new tuieventbase(CM_PARENTFONTCHANGED,hd,1,0)); + end + end + function WMSETFONT(o,e):WM_SETFONT;virtual; + begin + defaulthandler(e); + Perform(new tuieventbase(CM_FONTCHANGED,e.wparam,e.lparam,0)); + end + function WMACTIVATE(o,e):WM_ACTIVATE;virtual; + begin + CallMessgeFunction(OnActivate,o,e); + end + function GetClientRect();override; + begin + {** + @explan(说明)获得客户区大小 %% + @return(array of integer) 客户区矩形 %% + **} + ret := inherited; + if HandleAllocated()then + begin + if ifnumber(FClientWdith)and ifnumber(FClientHeight)then + begin + ret := array(0,0,FClientWdith,FClientHeight); + end else + _wapi.GetClientRect(self.Handle,ret); + end + //else ret := array(0,0,FClientWdith,FClientHeight); + return ret; + end + +#!begin //消息 + function DoCNALIGN(o,e);override; + begin + if(wstyle().& WS_POPUP)=WS_POPUP then exit; + inherited; + end + function DoWMCLOSE(o,e);virtual; + begin + EndModal(); + end + function WMCLOSE(o,e):WM_CLOSE;virtual; + begin + CallMessgeFunction(OnClose,o,e); + DoWMCLOSE(o,e); + end + function WMCREATE(o,e):WM_CREATE;virtual; + begin + if e.lparam then + begin + co := new TCREATESTRUCT(e.lparam); + __wstyle := co.style; + __wexstyle := co.dwexstyle; + end + end + function WMSETCURSOR(o,e):WM_SETCURSOR;virtual; + begin + if e.lolparam=HTCLIENT then + begin + ne := new tuieventbase(CM_CURSORCHANGED,0,0); + Perform(ne); + if ne.skip then + begin + e.skip := true; + e.result := true; + end + end + end + function WMSTYLECHANGING(o,e):WM_STYLECHANGING;virtual; + begin + end + function WMNCDESTROY(o,e):WM_NCDESTROY;virtual; + begin + FHandle := nil; + for i := 0 to FControls.count-1 do + begin + item := FControls.geti(i); + if(item is class(TWinControl))and item.WsPopUp then + begin + item.DestroyHandle(); + end + end + end + function WMSTYLECHANGED(o,e):WM_STYLECHANGED;virtual; + begin + end + function WMNCCALCSIZE(o,e):WM_NCCALCSIZE;virtual; + begin + if(csDesigning in ComponentState)and FDesignSelect then + begin + wd := 1; + hwd := wd; + rc := new TCRect(e.lparam); + rc.top += hwd; + rc.left += wd; + rc.bottom -= wd; + rc.right -= wd; + end + end + function WMMOUSEHOVER(o,e):WM_MOUSEHOVER;virtual; + begin + MouseHover(o,e); + end + function WMMOUSELEAVE(o,e):WM_MOUSELEAVE;virtual; + begin + MouseLeave(o,e); + end + function WMMENURBUTTONUP(o,e):WM_MENURBUTTONUP;virtual; + begin + if PopupMenu is class(TcustomPopupmenu)then PopupMenu.dispatch(e); + end + function WMMENUSELECT(o,e):WM_MENUSELECT;virtual; + begin + if PopupMenu is class(TcustomPopupmenu)then PopupMenu.dispatch(e); + end + function WMINITMENUPOPUP(o,e):WM_INITMENUPOPUP;virtual; + begin + if PopupMenu is class(TcustomPopupmenu)then PopupMenu.dispatch(e); + end + function WMERASEBKGND(o,e):WM_ERASEBKGND;override; + begin + {** + @explan(说明) 背景绘制 %% + **} + if not HandleAllocated()then return; + mtic; + //if not(csCustomPaint in ControlState) and not(e.lparam) then return ; + dc := e.wparam; + if dc {and e.lparam}then + begin + cl := Color; + rect := array(0,0,0,0); + if e.lparam=2 then + begin + rect := PAINTSTRUCT().rcpaint(); + end + _wapi.GetClientRect(self.Handle,rect); + if ifnumber(cl)then + begin + Canvas.Brush.Color := cl; + Canvas.Handle := dc; + Canvas.FillRect(rect); + end else + begin + cl := _wapi.GetStockObject(WHITE_BRUSH); + _wapi.FillRect(dc,rect,cl); + end + if(BKBitmap is class(tcustombitmap))and BKBitmap.HandleAllocated()then + begin + Canvas.Handle := dc; + //Canvas.StretchDraw(rect,BKBitmap); + Canvas.DrawBitmap(self.BKBitmap,rect); + end + e.skip := true; + e.Result := 1; + end + end + Function WMDRAWITEM(o,e):WM_DRAWITEM;virtual; //type_twinctrol + begin + {** + @ignore(忽略) %% + @explan(说明) 自绘制消息处理 %% + @param(o)(TWincontrol) 窗口控件 %% + @param(e)(TMDRAWITEM) 消息 %% + **} + e.canvas := canvas; + dc := e.hdc; + //dc := _wapi.GetDC(SELF.hANDLE); + //dcid := _wapi.SaveDC(dc); + canvas.handle := dc; + if(e.wparam=0)and(PopupMenu is class(TcustomPopupmenu))then + begin + r := PopupMenu.dispatch(e); + if r then + begin + e.canvas := nil; + exit; + end + end + ctrl := getwndbyhwnd(e.hwndItem); + if ctrl then + begin + e.message := CN_DRAWITEM; + h := e.hwnd; + try + ctrl.Perform(const e); + except + end; + e.hwnd := h; + e.message := WM_DRAWITEM; + end + //if dcid then + // "\r\nrestor:",_wapi.RestoreDC(dc,-1); + e.canvas := nil; + // _wapi.ReleaseDC(Handle,Canvas.handle); + end + function WMMEASUREITEM(o,e):WM_MEASUREITEM;virtual; + begin + {** + @ignore(忽略) %% + @explan(说明) 测量消息处理 %% + @param(o)()控件本身 %% + @param(e)(TMMEASUREITEM)测量消息 %% + **} + if(e.wparam=0 and e.ctltype=ODT_MENU)and(PopupMenu is class(TcustomPopupmenu))and PopupMenu.Dispatch(e)then exit; + for i := 0 to FControls.count-1 do + begin + it := FControls[i]; + if it and it.getid=e.ctlid then + begin + h := e.hwnd; + e.message := CN_MEASUREITEM; + it.Perform(e); + e.message := WM_MEASUREITEM; + e.hwnd := h; + return; + end + end + end + function WMNOTIFY(o,e):WM_NOTIFY;virtual; + begin + {** + @explan(说明) 子控件通知父控件 %% + @param(e)(TMNOTIFY) 通知消息 %% + **} + hd := e.hwndfrom; + if hd then + begin + ctrl := getwndbyhwnd(hd); + if ctrl then + begin + nr := new tuieventbase(CN_NOTIFY,e.code,e.lparam); + ctrl.Perform(nr); + e.skip := nr.skip; + end + end + end + function WMCTLCOLORBTN(o,e):WM_CTLCOLORBTN;virtual; + begin + hd := e.lparam; + if hd then + begin + ctrl := getwndbyhwnd(hd); + if ctrl then + begin + ce := new tuieventbase(CN_CTLCOLORBTN,e.wparam,e.lparam,e.lparam); + ctrl.Canvas.handle := e.lparam; + ctrl.Perform(ce); + if ce.Result then + begin + e.result := ce.result; + e.skip := true; + end + end + end + end + function WMSYSCOMMAND(o,e):WM_SYSCOMMAND;virtual; + begin + //sysmenu.dispatch(); + end + function WMCOMMAND(o,e):WM_COMMAND;virtual; + begin + if(popupmenu is class(TcustomPopupmenu))and popupmenu.dispatch(e)then exit; + hd := e.lparam; + if hd then + begin + ctrl := getwndbyhwnd(hd); + if ctrl then + begin + wp := e.wparam; + ctrl.Perform(new tuieventbase(CN_COMMAND,wp,0)); + end + end + end + function WMKEYDOWN(o,e):WM_KEYDOWN;virtual; + begin + CallMessgeFunction(FOnkeyDown,o,e); + if e.skip then return; + if HandleAllocated()and(e.wParam=VK_TAB)then + begin + cfoc := _wapi.GetFocus(); + if Handle=cfoc then + begin + if TabStop then //发送给父控件 + begin + if Parent then Parent._Send_(WM_KEYDOWN,VK_TAB,e.lparam,nil); + end + end else //遍历子控件 设置下一个focus + begin + cts := Controls; + Thec := false; + pc := 0; + for i := 0 to cts.Count-1 do + begin + ci := cts[i]; + if(ci is class(TWinControl))and ci.Enabled and ci.Visible and ci.TabStop and ci.HandleAllocated()then + begin + if ci.Handle=cfoc then //找到了当前 + begin + Thec := true; + if pc and(ssShift in e.shiftstate)then + begin + pc.SetFocus(); + break; + end + continue; + end + pc := ci; + if Thec then + begin + ci.SetFocus(); + break; + end + end + end + end + end + return KeyDown(o,e); + end + function WMKEYUP(o,e):WM_KEYUP;virtual; + begin + CallMessgeFunction(FOnKeyUp,o,e); + keyup(o,e); + end + function WMCHAR(o,e):WM_CHAR;virtual; + begin + CallMessgeFunction(FOnKeyPress,o,e); + return keypress(o,e); + end + function WMSETFOCUS(o,e):WM_SETFOCUS;virtual; + begin + CallMessgeFunction(FonSetFocus,o,e); + dosetfocus(o,e); + end + function WMKILLFOCUS(o,e):WM_KILLFOCUS;virtual; + begin + CallMessgeFunction(FonKillFocus,o,e); + dokillfocus(o,e); + end + function WMPAINT(O,e):LM_PAINT;virtual; + begin + hd := e.hwnd; + if e.wparam then + begin + PaintHandler(e); + end else + if csCustomPaint in ControlState then + begin + ps := PaintStruct(); + DC := _wapi.BeginPaint(hd,ps._getptr_); + if DC=0 then exit; + try + c := ClientRect; + memdc := dc; +{$ifdef gdipaint} + mdc := _wapi.GetDC(0); + if not mdc then exit; + mbit := _wapi.CreateCompatibleBitmap(mdc,c[2],c[3]); + if not mbit then exit; + memdc := _wapi.CreateCompatibleDC(0); + if not memdc then exit; + oldmp := _wapi.SelectObject(memdc,mbit); +{$endif} + e.wparam := memdc; + if Color then + begin + Dispatch(o,new tuieventbase(LM_ERASEBKGND,memdc,2)); + end + Dispatch(o,e); + e.wparam := 0; + rc := ps.rcpaint; +{$ifdef gdipaint} + _wapi.BitBlt(dc,rc[0],rc[1],rc[2]-rc[0],rc[3]-rc[1],memdc,rc[0],rc[1],SRCCOPY); //_wapi.BitBlt(dc,c[0],c[1],c[2],c[3],memdc,0,0,SRCCOPY); +{$endif} + finally + _wapi.EndPaint(hd,ps._getptr_); +{$ifdef gdipaint} + _wapi.ReleaseDC(0,mdc); + _wapi.SelectObject(memdc,oldmp); + _wapi.DeleteDC(memdc); + _wapi.DeleteObject(mbit); +{$endif} + end + end else + begin +{$ifdef gdipaint} + ctls := Controls; + if not ctls then return; // e.skip := false; + if ctls.Count<1 then return; // e.skip := false ; + flag := true; + for i := 0 to ctls.Count-1 do + begin + ci := ctls[i]; + if ci is class(TGraphicControl)then + begin + flag := false; + break; + end + end + if flag then + begin + return; + end + rec := zeros(4); + _wapi.GetUpdateRect(hd,rec,false); + defaulthandler(e); + dc := _wapi.GetDC(hd); + if not dc then + begin + return e.skip := true; + end + e.wparam := dc; + try + pts := PaintStruct(); + pts._setvalue_("rcpaint",rec); + pts._setvalue_("hdc",dc); + //Perform(e); + Dispatch(o,e); + finally + _wapi.ReleaseDC(hd,dc); + e.wparam := 0; + e.skip := true; + end +{$endif} + end + e.skip := true; + e.result := true; + end + +#!end + function KeyUp(o,e);virtual; + begin + {** + @explan(说明) key 松开 %% + @param(o)(TWinControl) 控件自身 %% + @Param(e)(TMKEY) 消息对象 %% + **} + end + function KeyDown(o,e);virtual; + begin + {** + @explan(说明) key 按下 %% + @param(o)(TWinControl) 控件自身 %% + @Param(e)(TMKEY) 消息对象 %% + **} + end + function keypress(o,e);virtual; + begin + {** + @explan(说明) char 消息处理 %% + @param(o)(TWinControl) 控件自身 %% + @Param(e)(TMKEY) 消息对象 %% + **} + end + function dosetfocus(o,e);virtual; + begin + {** + @explan(说明) 控件获得焦点 %% + @param(o)(TWinControl) 控件自身 %% + @Param(e)(tuieventbase) 消息对象 %% + **} + end + function dokillfocus(o,e);virtual; + begin + {** + @explan(说明) 控件失去焦点 %% + @param(o)(TWinControl) 控件自身 %% + @Param(e)(tuieventbase) 消息对象 %% + **} + end + protected //样式相关 + function SetColor(v);override; + begin + oc := color; + if oc <> v and ifnumber(v)then + begin + inherited; + if HandleAllocated()then invalidaterect(nil,false); + end + end + function SetBitmap(v);override; + begin + if v <> BKBitmap then + begin + inherited; + if HandleAllocated()then invalidaterect(nil,false); + end + end + function Refresh(); + begin + if HandleAllocated()then + begin + _wapi.SetWindowPos(self.Handle,0,0,0,0,0,SWP_DEFERERASE .| SWP_NOMOVE .| SWP_NOSIZE .| SWP_NOZORDER .| SWP_NOSENDCHANGING .| SWP_NOACTIVATE .| SWP_DRAWFRAME); + end + end + procedure PaintControls(DC:HDC;First:TControl); //type_twinctrol + begin + end + procedure PaintHandler(var TheMessage:TLMPaint); //type_twinctrol + begin + PaintWindow(TheMessage.wparam); + //c := ClientRect; + c := array(0,0); //设置基准点,为00 20201112 修改 + rcpaint := PaintStruct().rcpaint; + if sum(rcpaint)<4 then exit; + rgC := _wapi.CreateRectRgn(0,0,10,10); + rga := _wapi.CreateRectRgn(rcpaint[0],rcpaint[1],rcpaint[2],rcpaint[3]); + try + for i := 0 to ControlCount-1 do + begin + it := FControls[i]; + if it is class(TGraphicControl)then + begin + if not(it.Visible)then continue; + itbounds := it.GetBoundsRect(); + if not(intersectrect(itbounds,rcpaint,outrect))then + begin + continue; + end + //rgb := _wapi.CreateRectRgn(itbounds[0],itbounds[1],itbounds[2],itbounds[3]); //控件区域 + rgb := _wapi.CreateRectRgn(outrect[0],outrect[1],outrect[2],outrect[3]); //控件区域 + _wapi.CombineRgn(rgC,rga,rgb,RGN_AND); //控件绘画区域 + bkrg := _wapi.SelectClipRgn(TheMessage.wparam,rgc); //裁剪区域 + try + pts := it.PaintStruct(); + pts._setvalue_("rcpaint",array(outrect[0]-itbounds[0],outrect[1]-itbounds[1],outrect[2]-itbounds[0],outrect[3]-itbounds[1])); + pts._setvalue_("hdc",TheMessage.wparam); + ne := new tuieventbase(LM_PAINT,TheMessage.wparam,TheMessage.lparam,TheMessage.hwnd); + it.Perform(ne); + _wapi.SetViewportOrgEx(TheMessage.wparam,c[0],c[1],nil); //恢复基准点 + finally + _wapi.SelectClipRgn(TheMessage.wparam,bkrg); //恢复区域 + _wapi.DeleteObject(rgb); //销毁区域 + end; + end + end + finally + _wapi.DeleteObject(rga); + _wapi.DeleteObject(rgc); + end; + end + procedure PaintWindow(DC:HDC);virtual; + begin + end + function SetTempCursor(Value);override; + begin + if(Value is class(tcustomcursor))and Value.HandleAllocated()and HandleAllocated()and Enabled and Visible then + begin + return Value.Show(); + end + end + //public + function wstyle(v); + begin + { + @explan(说明)设置或者获取样式 %% + @param(v)(integer)为空获取样式,为整数 设置样式%% + @return(integer)当前样式 + } + if v and ifnumber(v)then + begin + if(v <> __wstyle)and HandleAllocated()then _wapi.SetWindowLongPtrA(FHandle,GWL_STYLE,v); + end else + return __wstyle; + end + function wexstyle(v); + begin + { + @explan(说明)设置或者获取扩展样式 %% + @param(v)(integer)为空获取样式,为整数 设置样式%% + @return(integer)当前扩展样式 + } + if v and ifnumber(v)then + begin + if(v <> __wexstyle)and HandleAllocated()then _wapi.SetWindowLongPtrA(FHandle,GWL_EXSTYLE,v); + end else + return __wexstyle; + end + function minuswstyle(v); + begin + { + @explan(说明)剔除样式 %% + @param(v)(integer) 剔除的样式 %% + } + if ifnumber(v)then + begin + s := wstyle(); + ns := bitcombination(s,v,2); + if ns <> s then + begin + wstyle(ns); + end + end + end + function appendwstyle(v); + begin + { + @explan(说明)在原有样式中追加 样式%% + @param(v)(integer) 追加的样式 %% + } + if ifnumber(v)then + begin + s := wstyle(); + ns := bitcombination(s,v,0); + if ns <> s then + begin + wstyle(ns); + end + end + end + function minuswexstyle(v); + begin + { + @explan(说明)剔除扩展样式 %% + @param(v)(integer) 剔除的样式 %% + } + if ifnumber(v)then + begin + s := wexstyle(); + ns := bitcombination(s,v,2); + if ns <> s then + begin + wexstyle(ns); + end + end + end + function appendminuswstyple(ap,mi); + begin + { + @explan(说明)添加and剔除样式 %% + @param(ap)(integer) 添加的样式 %% + @param(mi)(integer) 剔除的样式 %% + } + if ifnumber(ap)or ifnumber(mi)then + begin + s := wstyle(); + ns := s; + if ifnumber(ap)then ns := bitcombination(ns,ap,0); + if ifnumber(mi)then ns := bitcombination(ns,mi,2); + if ns <> s then + begin + wstyle(ns); + end + end + end + + function appendminuswexstyple(ap,mi); + begin + { + @explan(说明)添加and剔除样式 %% + @param(ap)(integer) 添加的样式 %% + @param(mi)(integer) 剔除的样式 %% + } + if ifnumber(ap)or ifnumber(mi)then + begin + s := wexstyle(); + ns := s; + if ifnumber(ap)then ns := bitcombination(ns,ap,0); + if ifnumber(mi)then ns := bitcombination(ns,mi,2); + if ns <> s then + begin + wexstyle(ns); + end + end + end + function appendwexstyle(v); + begin + { + @explan(说明)在原有扩展样式中追加 样式%% + @param(v)(integer) 追加的样式 %% + } + if ifnumber(v)then + begin + s := wexstyle(); + ns := bitcombination(s,v,0); + if ns <> s then + begin + wexstyle(ns); + end + end + end + public //常用接口 + function MonitorHandle(); + begin + if HandleAllocated()then + begin + return _wapi.MonitorFromWindow(self.Handle,MONITOR_DEFAULTTONEAREST); + end + return 0; + end + function clienttowindow(x,y); + begin + {** + @explan(说明) 客户区坐标到窗口坐标的转换%% + **} + if WsPopUp and HandleAllocated()then + begin + xy := clienttoscreen(0,0); + rect := zeros(4); + _wapi.GetWindowRect(self.Handle,rect); + nxy := xy-rect[0:1]; + r := array(x,y)+nxy; + return r; + end + return array(x,y); + end + function ClientToScreen(x,y);override; + begin + ps := array(x,y); + if HandleAllocated()then + begin + _wapi.ClientToScreen(self.Handle,ps); + end + return ps; + end + function ScreenToClient(x,y);override; + begin + ps := array(x,y); + if HandleAllocated()then + begin + _wapi.ScreenToClient(self.Handle,ps); + end + return ps; + end + function show(sw); + begin + {** + @explan(说明) 显示窗口 %% + @param(sw)(nil) 空 %% + **} + if ifnil(sw)then sw := SW_SHOW; + if not(sw >= 0)then return; + h := self.Handle; + if SW=SW_SHOW then return Visible := true; + if SW=SW_HIDE then return Visible := false; + _wapi.ShowWindow(h,sw); + class(TControl).Visible := true; + end +function showmodal();virtual; +begin + return DoModal(); +end + function EndModal(endc);virtual; + begin + {** + @explan(说明)关闭模态窗口 %% + @param(endc)(any) 为非nil 将作为EndModalCode %% + **} + if not ifnil(endc)then EndModalCode := endc; +{$ifdef gtkpaint} + if FModaling then + begin + if HandleAllocated()then _wapi.gtk_window_endmodal(self(true)); + FModaling := false; + global G_O_TSWIN32API_; + if G_O_TSWIN32API_ then G_O_TSWIN32API_.PostQuitMessage(0); + end + return EndModalCode; +{$endif} + if not FModaling then return EndModalCode; + FModaling := FALSE; + if not HandleAllocated()then return EndModalCode; + _wapi.PostMessageA(0,0,0,0); + if Parent and Parent.HandleAllocated()then + begin + hParentWndt := parent.Handle; + hParentWnd := hParentWndt; + while(hParentWnd) do + begin + hParentWndt := _wapi.GetParent(hParentWnd); + if not hParentWndt then + begin + _wapi.BringWindowToTop(hParentWnd); + end + hParentWnd := hParentWndt; + end + end + return EndModalCode; + end + function UpdateWindow(); + begin + {** + @explan(说明) 刷新窗口客户区 %% + @return(integer) 非0 成功 %% + **} + if HandleAllocated()then return _wapi.UpdateWindow(self.Handle); + end + function SetFocus(); + begin + if HandleAllocated()then + begin + _wapi.SetFocus(self.Handle); + end + end + function DescendantHwnd(hwnd); + begin + { + @explan(说明)判断窗口句柄是否为当前窗口句柄的子窗口 %% + } + if not _wapi.IsWindow(hwnd)then return 0; + if not HandleAllocated()then return 0; + shd := self.Handle; + wnd := hwnd; + while wnd do + begin + if wnd=shd then return true; + nwnd := _wapi.GetParent(wnd); + wnd := nwnd; + end + return false; + end + function MoveControlOrder(Acomponent,n); + begin + {** + + @explan(说明) 移动控件的层 %% + @param(Acomponent)(tcontrol) 控件 %% + @param(n)(integer) 次序 %% + **} + dqid := FControls.IndexOf(Acomponent); + odp := FControls[n]; + if n <> dqid and n >= 0 then + begin + FControls.setorder(dqid,n); + end + if odp is class(TWincontrol)and Acomponent is class(TWincontrol)and(Acomponent.HandleAllocated())and(odp.HandleAllocated())then + begin + _wapi.SetWindowPos(Acomponent.Handle,odp.Handle,0,0,0,0,SWP_NOMOVE .| SWP_NOSIZE); + end + if HandleAllocated()and(Acomponent.Align <> alNone)then + begin + DoControlAlign(); + end + end + function BeginUpDate(); + begin + FUpDateCount++; + end + function IsUpDating(); + begin + return FUpDateCount; + end + function EndUpDate(); + begin + if FUpDateCount>0 then + begin + FUpDateCount--; + DoEndUpDate(); + end + end + function DoEndUpDate();virtual; + begin + if FUpDateCount=0 then + begin + if FPaintRects then + begin + if HandleAllocated()then + begin + ValidFlag := true; + for i,v in FPaintRects do + begin + if ifnil(v)then + begin + _wapi.InvalidateRect2(FHandle,nil,0); + ValidFlag := false; + break; + end + end + if ValidFlag then + begin + for i,v in FPaintRects do + begin + _wapi.InvalidateRect(FHandle,v,f); + end + end + end + FPaintRects := array(); + end + end + end + function InvalidateRect(rec,f);virtual; + begin + {** + @explan(说明)设置窗口区域无效 %% + @param(rec)(array) 无效区域,nil表示窗口整体无效,array(左上右下) %% + @param(f)(bool) 是否重画 %% + **} + if HandleAllocated()then + begin + if IsUpDating()then + begin + if not ifarray(FPaintRects)then FPaintRects := array(); + FPaintRects[length(FPaintRects)]:= rec; + return; + end + if not(ifarray(rec)and rec)then r := _wapi.InvalidateRect2(FHandle,nil,f); + else r := _wapi.InvalidateRect(FHandle,rec,f); + return r; + end + end + function ContainsControl(Control:TControl):bool; + begin + while(Control <> nil)and(Control <> Self) do Control := Control.Parent; + return Control=Self; + end + function create(owner);override; //type_twinctrol + begin + inherited; + FUpDateCount := 0; + FTabStop := false; + FControls := new TFpList(); + FBorderStyle := bsNone; + //FTRACKMOUSEEVENT := NEW TTRACKMOUSEEVENT(); + FWsPopUp := false; + FWsSysMenu := false; + FWsCapton := false; + WSSizebox := FALSE; + __wstyle := 0; //窗口样式 + __wexstyle := 0; //窗口扩展样式 + FWsDlgModalFrame := false; + //FTtageDrawItem := new TtageDrawItem(); //移除了 + FWMNCHITTEST := new TWMNCHITTEST(); + FMinWidth := 1; //添加最小限制 + FMinHeigt := 1; + end + function destroy();override; //type_twinctrol + begin + inherited; + end + function Recycling();override; + begin + DestroyHandle(); + //FTtageDrawItem := nil; + FOnClose := nil; + FOnDesinedsel := nil; + FOnDesigDBLClick := nil; + FOnDesinedRclick := nil; + FOnDesignBeginMove := nil; + FOnDesignEndMove := nil; + FOnActivate := nil; + FOnKeyDown := nil; + FOnKeyPress := nil; + FOnKeyUp := nil; + ImageList := nil; + FonSetFocus := nil; + FonKillFocus := nil; + inherited; + end + function RecreateWnd();virtual; + begin + if csDestroying in ComponentState then exit; + if HandleAllocated()then + begin + DestroyHandle(); + HandleNeeded(); + end + end + function CreateWnd();virtual; //type_twinctrol + begin + {** + @explan(说明)构建窗口句柄 %% + **} + //if not(Parent and Parent.HandleAllocated or (self(true) is class(tapplicationwindow))) then exit; + CreateParams(p); + //_wapi.GetSystemMetrics(SM_CXSCREEN) DIV 2; + //此处处理构造句柄 + id := 0; + if p.style .& WS_CHILD then id := getid(); + tcc := p.Caption; + stl := p.style; + x := p.x; + y := p.y; + sx := p.width; + sy := p.height; + try + selfid := int64(self(true)); + except + selfid := gettslvariableptr(self(true)); + end; + saveobj := new TGlobalValues(selfid,self(true)); + createwndclass(p); + FDefWndproc := p.subclasswndproc; + tcn := P.WinClassName; + f := _wapi.CreateWindowExA(p.ExStyle,tcn,tcc,stl,x,y,sx,sy,p.WndParent,id,p.happ,selfid); + InitializeWnd(); + if HandleAllocated()then ControlCreateWnd(); + end + protected + function ControlCreateWnd(); + begin + for i := 0 to FControls.count-1 do + begin + item := FControls.geti(i); + if(item is class(TWinControl))then + begin + item.HandleNeeded(); + end + end + end + public + function HandleAllocated(); //type_twinctrol + begin + {** + @explan(说明)构建窗口句柄是否构造 %% + @param(bool) + **} + //return ifnumber(FHandle) and _wapi.IsWindow(FHandle); + return ifnumber(FHandle)and(FHandle <> 0); + end; + function DestroyHandle();virtual; + begin + {** + @explan(说明)析构窗口句柄 %% + **} + EndModal(); + if HandleAllocated()then + begin + {FTRACKMOUSEEVENT.hwndtrack := handle; + if OnMouseEnter or OnMouseLeave then + begin + FTRACKMOUSEEVENT.dwflags := TME_CANCEL .| TME_HOVER .| TME_LEAVE; + _wapi.TrackMouseEvent(FTRACKMOUSEEVENT._getptr_); + end } + _wapi.DestroyWindow(self.Handle); + end + FHandle := 0; + end + procedure HandleNeeded();virtual; //type_twinctrol + begin + {** + @explan(说明)构建窗口句柄,以及子控件句柄 %% + @return(pointer) 窗口句柄 + **} + {if (not HandleAllocated()) then + begin + if self.Parent = Self then + begin + + end + else begin + if (Parent is class(TWinControl)) then + begin + Parent.HandleNeeded(); + if HandleAllocated() then exit; + end; + end; + CreateHandle(); + end; } + if(not HandleAllocated())and(not(csDestroying in ComponentState))then + begin + if self.Parent=Self then + begin + end else + begin + if {(Parent <> nil)}(Parent is class(TWinControl))then + begin + Parent.HandleNeeded(); + if HandleAllocated()then exit; + end; + end; + CreateHandle(); + end; + end + function SetParent(NewParent);override; //type_twinctrol + begin + if(NewParent=parent)and(NewParent is class(TWinControl))then //避免wrapcontrol句柄发生改变的问题 + begin + if HandleAllocated()and NewParent.HandleAllocated()then + begin + if _wapi.GetParent(self.Handle)=NewParent.Handle then return; + end + end + if NewParent is class(TWinControl)then + begin + //if not CheckNewParent(NewParent) then return ; + //都有句柄 + callparent := false; + callalocate := false; + if HandleAllocated()and NewParent.HandleAllocated()then + begin + if WsPopUp then + begin + DestroyHandle(); + callalocate := true; + end else + if _wapi.SetParent(FHandle,NewParent.handle)then callparent := true; + end else + if HandleAllocated()and not(NewParent.HandleAllocated())then + begin + DestroyHandle(); + callparent := true; + end else + if not(HandleAllocated())and NewParent.HandleAllocated()then + begin + callparent := true; + callalocate := true; + end else + begin + callparent := true; + end + if callparent then + begin + class(tcontrol).SetParent(NewParent); + if Align <> alNone then + begin + NewParent.DoControlAlign(); + end + end + if callalocate then HandleNeeded(); + end else + begin + if HandleAllocated()then DestroyHandle(); + inherited SetParent(NewParent); + end + end + procedure SetBounds(ALeft,ATop,AWidth,AHeight:integer);override; //type_twinctrol + begin + {** + @explan(说明)设置窗口矩形区域 %% + **} + //设置bonds + OldBounds := BoundsRect; + OldBounds := array(OldBounds[0],OldBounds[1],OldBounds[2]-OldBounds[0],OldBounds[3]-OldBounds[1]); + newbounds := array(ALeft,ATop,AWidth,AHeight); + if not(CompareRect(OldBounds,newbounds))then + begin + inherited; + //class(tcontrol).SetBounds(ALeft, ATop, AWidth, AHeight); + end + end + private //绘制相关成员 + FPaintRects; + FUpDateCount; + public + function gethitstyle(x,y); + begin + return FWMNCHITTEST.hitstyle2(self(true),x,y); + end + public //消息分发 + function MainWndProc(hwnd,message,wparam,lparam);virtual; //type_twinctrol + begin + {** + @explan(说明)窗口主循环 %% + **} + //if message=0x85 and not( WsCaption or border or WsDlgModalFrame) then return ; + e := messagecreater(hwnd,message,wparam,lparam); + e.sender := self(true); + if message = WM_SYSKEYDOWN or message = WM_KEYDOWN then //快捷键实现 + begin + WndProc(const e); + if e.skip then return 1; + ////////////解析热键///////////////////// + ec := e.CharCode; + sa := array(); + if ec>=65 and ec<=90 then + begin + sa["w"] := chr(ec); + end + if ec>=0x70 and ec<=0x7b then + begin + sa["f"] := "F"+inttostr(ec-0x6F); + end + st := e.shiftstate; + if ssCtrl in st then sa["c"] := 1; + if ssAlt in st then sa["a"] := 1; + if ssShift in st then sa["s"] := 1; + if sa["w"] and (sa["c"] or sa["a"] or sa["s"]) then + begin + st := sa; + end else + if sa["f"] then + begin + st := sa; + end else + st := array(); + + if st then + begin + st := formatshortcut(st); + if st then + begin + if dispatchctlshortcut(self(true),st)= "havedoshortcut" then return 1; //执行本控件 + if dispatchshortcut(class(tUIglobalData).uigetdata("tuiapplication"),st) = "havedoshortcut" then + begin + return 1; + end + end + end + //热键处理完成 + return defaulthandler(e); + end + if message=WM_NCCREATE then + begin + FHandle := hwnd; + //echo "\r\nsethandle:",hwnd; + class(tUIglobalData).uigetdata("TGlobalComponentcache").registerhandle(hwnd,self(true)); + end else + if message=WM_SIZE then + begin + x := e.lolparamsigned(); + if x <> 0 then + begin + //dxsize := x-FClientWdith; + cc := 0; + if FClientWdith <> x then + begin + FClientWdith := x; + cc := true; + end + y := e.hilparamsigned(); + //dysize := y-FClientHeight; + if FClientHeight <> y then + begin + FClientHeight := y; + //cc := true; + end + if true then + begin + DoControlAnchor(); + DoControlAlign(); + end + end + end else + if message=WM_MOVE then + begin + x := e.lolparamsigned(); + if FClientLeft <> x then FClientLeft := x; + y := e.hilparamsigned(); + if FClientTop <> y then FClientTop := y; + end else + //if message = WM_MOUSEMOVE then + if message=WM_NCHITTEST then // + begin + {if OnMouseEnter or OnMouseLeave then + begin + FTRACKMOUSEEVENT.hwndtrack := hwnd; + FTRACKMOUSEEVENT.dwflags := TME_HOVER .| TME_LEAVE; + FTRACKMOUSEEVENT.dwhovertime := 600; + _wapi.TrackMouseEvent(FTRACKMOUSEEVENT._getptr_); + end } + end else + if message=WM_STYLECHANGED then + begin + if e.wparam=GWL_EXSTYLE then + begin + __wexstyle := e.stylenew; + end else + begin + __wstyle := e.stylenew; + end + end + (**else + if message = WM_NCCALCSIZE then + begin + if e.wparam=1 then + begin + dt := new tNCCALCSIZE_PARAMS(e.lparam)._getvalue_("rgrc"); + if dt[0]=-32000 then + begin + //echo "\r\n隐藏到工具栏"; + end + else if dt[4] = -32000 then + begin + //echo "\r\n从工具栏弹出"; + end + else + begin + //rect1 := dt[0:3]; + //rect2 := dt[4:7]; + //rect3 := dt[8:]; + {dx := dt[2]-dt[0]-(dt[6]-dt[4]); + dy := dt[3]-dt[1]-(dt[7]-dt[5]); + __clientsize := array(dt[10]-dt[8]+dx,dt[11]-dt[9]+dy); + x := __clientsize[0]; + dxsize := x-FClientWdith; + if FClientWdith<> x then FClientWdith := x; + y := __clientsize[1]; + dysize := y-FClientHeight; + if FClientHeight <> y then FClientHeight := y; + DoControlAnchor(array(dxsize,dysize)); + DoControlAlign(array(0,0,x,y));} + //__oldclientsize := array(dt[10]-dt[8],dt[11]-dt[9]); + end + + end + else + begin + //echo "\r\n++++calc:",caption,tostn(new tcrect(e.lparam)._getdata_); + end + //echo "\r\ncalcsize:",o.caption,"****",e.wparam; + //echo "\r\nleft:", new tcrect(e.lparam).left; + end + **) + WndProc(const e); + if not(e.skip)then + begin + ret := defaulthandler(e); + end else + begin + {$ifdef linuxgtk} + if WM_NCHITTEST=e.msg then return e.Result; + return true; + {$endif} + ret := e.Result; + end + return ret; + end + function DesigningSizer();virtual; + begin + {** + @explan(说明) 设计模式下面是否可以调整大小 %% + @return(bool) + **} + return true; + end + function DesigningClick();virtual; + begin + {** + @explan(说明) 设计模式下面是否可以响应原有的点击消息 %% + @return(bool) + **} + return false; + end + function DesigningMove();virtual; + begin + {** + @explan(说明) 设计模式下面是否可以移动 %% + @return(bool) + **} + return true; + end + function HitWindowborder(o,e,hit);virtual; + begin + if not(WsSizeBox)and DesigningSizer()and(Align=alNone)then + begin + e.Result := hit; + e.skip := true; + end + end + private //设计器相关,消息 + FClickTime; + FClickPos; + public //消息分发 + procedure WndProc(e);override; //type_twinctrol + begin + //WM_NCHITTEST + if (csDesigning in ComponentState) then + begin + msg := e.msg; + if msg = WM_NCHITTEST then + begin + + r := FWMNCHITTEST.hitstyle(self(true),e); + if r<>HTCLIENT then + begin + HitWindowborder(self(true),e,r); + end else + begin + return e.Result := Wnddefaulthandler(e); + end + end else + if msg= WM_LBUTTONDOWN then + begin + if not(WsCaption) and DesigningMove() and (Align=alNone) then + begin + _Send_(WM_NCLBUTTONDOWN,HTCAPTION,0,0); + e.skip := true; + end + CallMessgeFunction(OnDesignClick,self(true),e); + //保留原有的点击消息 + {if DesigningClick() then + begin + CallMessgeFunction(FOnMouseUp,self(true),e); + end } + end else + if msg = WM_LBUTTONDBLCLK then + begin + CallMessgeFunction(OnDesignDBLClick,self(true),e); + end else + if msg = WM_RBUTTONDOWN then + begin + CallMessgeFunction(OnDesignRClick,self(true),e); + end + end + inherited; + end; + procedure DoControlAlign({rect});override; + begin + {** + @explan(说明) 控件对齐 %% + **} + if not HandleAllocated()then exit; + if not ifarray(rect)then + begin + rect := ClientRect; + {$ifdef linuxgtk} + if Border or WSSizebox or WSDlgModalFrame then //处理gtk的情况 + begin + rect[0]+=1; + rect[1]+=1; + rect[2]-=1; + rect[3]-=1; + end + {$endif} + end + e := new TMALIGN(CN_ALIGN,0,0,0); + E.left := rect[0]; + e.top := rect[1]; + e.width := rect[2]; + e.height := rect[3]; + for i := 0 to ControlCount-1 do + begin + it := Controls[i]; + if it is class(tcontrol)then + begin + //if it.Align=alNone then continue; + it.Dispatch(it,e); + //it.Perform(e); + end + end + end + procedure DoControlAnchor();override; + begin + {** + @explan(说明) 控件锚定调整 %% + **} + if not HandleAllocated()then exit; + e := new TMANCHOR(CN_ANCHOR,0,0,0); + c := ClientRect; + for i := 0 to ControlCount-1 do + begin + it := Controls[i]; + if not it then continue; + if it.Align <> alNone then continue; + if not ifarray(it.Anchors)then continue; + if it is class(TWinControl)then + begin + if it.WsPopUp then continue; + end + e.prec := c; + it.Dispatch(it,e); + end + end + function Wnddefaulthandler(e); //type_twinctrol + begin + {** + @explan(说明)win32默认消息处理函数 %% + @param(e)(tuieventbase) + **} + r := _wapi.CallWindowProcA(FDefaultProc,e.Hwnd,e.msg,e.wparam,e.lparam); + e.skip := true; + return r; + end + function defaulthandler(e);override; + begin + {** + @explan(说明) 执行默认句柄 %% + @param(e)(tuieventbase) + **} + r := _wapi.CallWindowProcA(FDefWndproc,e.Hwnd,e.msg,e.wparam,e.lparam); + e.skip := true; + return r; + end + procedure BroadCast(e); + begin + {** + @explan(说明) 广播消息 %% + @param(e)(tuieventbase) + **} + for I := 0 to ControlCount-1 do + begin + Controls[I].WindowProc(e); + if e.skip then Exit; + if not ifnil(e.Result)then Exit; + end; + end; + procedure NotifyControls(Msg); //type_twinctrol + begin + ToAllMessage := new tuieventbase(msg,0,0,0); + Broadcast(ToAllMessage); + end + function _send_(msg,wparam,lparam,f,d);virtual; //type_twinctrol + begin + {** + @explan(说明) 发送消息给窗口 %% + @param(msg)(integer)消息号 %% + @param(wparam)(integer)wparam %% + @param(lparam)(integer)lparam %% + @param(param)(bool) true 采用post false 采用send %% + @return(pointer) + + **} + if not(ifnumber(msg)and ifnumber(wparam)and ifnumber(lparam))then + begin + //messagebox("参数必须为数字,如果字符串参数,请用tslcstructre构造然后传入指针!","提示",1); + exit; + end + if HandleAllocated()then + begin + if f then + begin + return _wapi.PostMessageA(FHandle,msg,wparam,lparam {$ifdef linux},d {$endif}); + end else + begin + return _wapi.SendMessageA(FHandle,msg,wparam,lparam); + end + end else + begin + e := messagecreater(nil,msg,wparam,lparam); + Perform(e); + return e.result; + end + end + function setwndhandle(h); + begin + {** + @ignore 忽略 %% + **} + DestroyHandle(); + if _wapi.IsWindow(h)then + begin + ph := _wapi.SetWindowLongPtrA(h,_wapi.GWLP_WNDPROC,getwinprocptr()); + FDefWndproc := ph; + MainWndProc(h,WM_NCCREATE,0,0); + end + end + public //对外property + property MinWidth:natural read FMinWidth write SetMinWidth; + property MinHeight:natural read FMinHeigt write SetMinHeight; + //property MaxWidth:integer read FMaxWidth write SetMaxWidth; + //property MaxHeight:integer read FMaXHeight write SetMaxHeight; + property BorderStyle read GetBorderStyle write SetBorderStyle; + //property ParentWindow read FParentWindow write SetParentWindow; + property Handle read GetHandle write SetHandle; + property TabStop:bool read FTabStop write SetTabStop; + property ControlCount read GetControlCount; + property OnActivate:eventhandler read FOnActivate write FOnActivate; + property OnClose:eventhandler read FOnClose write FOnClose; + property OnKeyDown:eventhandler read FOnKeyDown write FOnKeyDown; + property OnKeyUp:eventhandler read FOnKeyUp write FOnKeyUp; + property OnKeyPress:eventhandler read FOnKeyPress write FOnKeyPress; + property OnDesignClick read FOnDesinedsel write FOnDesinedsel; + property OnDesignDBLClick read FOnDesigDBLClick write FOnDesigDBLClick; + property OnDesignRClick read FOnDesinedRclick write FOnDesinedRclick; + property WsPopUp:bool read GetWsPopUp write SetWsPopUp; + property WsDlgModalFrame:bool read FWsDlgModalFrame write SetWsDlgModalFrame; + property WsCaption:bool read GetWsCaption write SetWsCaption; + Property WSSizebox:bool read FWsSizeBox Write SetWSsizeBox; + property WSsysMenu:bool read FWsSysMenu write SetWsSysMenu; + property EndModalCode read FModalCode write FModalCode; + property ImageList:tcontrolimagelist read FImageList write SetImageList; + property onKillFocus:eventhandler read FonKillFocus write FonKillFocus; + property onSetFocus:eventhandler read FonSetFocus write fonSetFocus; + private //模态相关 + property Modaling read FModaling; + {** + @param(BorderStyle)(bsNone|bsSingle) 边框样式 %% + @param(Handle)(pointer) 窗口句柄 %% + @param(WsDlgModalFrame)(bool) dlg边框效果 %% + @param(ControlCount)(integer) 子控件数量 %% + @param(OnClose)(function[TWincontrol,tuieventbase]) 窗口关闭消息回调 %% + @param(OnKeyDown)(function[TWincontrol,TMKEY]) 按键按下回调 %% + @param(OnKeyUp)(function[TWincontrol,TMKEY]) 按键松开 %% + @param(OnKeyPress)(function[TWincontrol,TMKEY]) 字符消息 %% + **} + private //ShortCut + function dispatchshortcut(c,st); //快捷键分发 + begin + if not st then return 0; + if c then + begin + if (c is class(TcustomMenu)) or (c is class(tcustomtoolbar)) or (c is class(TCustomAction)) then + begin + if c.ExecuteCommand("doshortcut",st)="havedoshortcut" then return "havedoshortcut"; + end + cc := c.Components ; + for i:= 0 to cc.count-1 do + begin + if dispatchshortcut(cc[i],st) then return "havedoshortcut"; + end + end + return 0; + end + function dispatchctlshortcut(o,st); //控件分发热键 + begin + if o is class(tcontrol) then + begin + if dispatchmenushortcut(o.Action,st) then return "havedoshortcut"; + if dispatchmenushortcut(o.PopupMenu,st) then return "havedoshortcut"; + end + global G_T_TVCFORM_; + if G_T_TVCFORM_ and (o is G_T_TVCFORM_ ) then + begin + if dispatchmenushortcut(o.MainMenu,st) then return "havedoshortcut"; + end + + end + function dispatchmenushortcut(mu,st); //菜单分发热键 + begin + if mu is class(TcustomMenu) then + begin + if mu.ItemCount>0 then + begin + for i := 0 to mu.ItemCount-1 do + begin + if dispatchmenushortcut(mu.GetItemByIndex(i),st)="havedoshortcut" then return "havedoshortcut"; + end + end else + begin + if mu.ExecuteCommand("doshortcut",st)="havedoshortcut" then return "havedoshortcut"; + end + //if mu.ItemCount + end else + if mu is class(TCustomAction) then + begin + if mu.ExecuteCommand("doshortcut",st)="havedoshortcut" then return "havedoshortcut"; + end + end + +end \ No newline at end of file diff --git a/funcext/tvclib/ugtkinterface.tsf b/funcext/tvclib/ugtkinterface.tsf index c46559a..7dd5b79 100644 --- a/funcext/tvclib/ugtkinterface.tsf +++ b/funcext/tvclib/ugtkinterface.tsf @@ -4,27 +4,2643 @@ interface 20220128-0900 稳定接口 20210902-0308 稍微整理 } -uses cstructurelib,utslvclmemstruct; +uses utslvclconstant,cstructurelib,utslvclauxiliary,utslvclmemstruct; function _gtkeventcall_();//gtk消息分发 function _gtkidledo_(); //gtk idle消息分发 function _gtk_add_time_msg_(h,m,w,l); function GetGtkEventNameOrId(n); //gtk 事件名称 -function AddMessageToGtkMessageQueue(FHandle,msg,wparam,lparam,d);//添加事件 -function FeachMessageFromGtkMessageQueue();//获取最后的事件 -function clearMessageFromGtkMessageQueue(h,m);//清除消息 -function hasMessageFromGtkMessageQueue(h,m);//是否存在消息 -type TGtkList = class( _gslist) //gtk链表类 - function create(ptr); - begin - inherited; - end -end type tgtkeventobject =class(tgtk_ctl_object) //gtk对象消息类(测试用) function create(h); begin inherited; end end + +type tsgtkapi = class(tgtkapis) + class function AnsiToWidChar(c); + begin + if not ifstring(c) then return ""; + return c; + end + function GetModuleFileNameExA(); + begin + end + function Comctl32DllGetVersion(); + begin + end + function shell32DllGetVersion(); + begin + end + function GetCursorInfo_(); + begin + end + function GetMonitorInfoA(); + begin + end + function CreateToolhelp32Snapshot()begin return -1; end; + function EnumProcesses_();begin end + function ShowWindow(hwd :pointer;f:integer); + begin + {SW_HIDE := 0x0;SW_SHOWNORMAL := 0x1;SW_NORMAL := 0x1; + SW_SHOWMINIMIZED := 0x2;SW_SHOWMAXIMIZED := 0x3;SW_MAXIMIZE := 0x3; + SW_SHOWNOACTIVATE := 0x4;SW_SHOW := 0x5;SW_MINIMIZE := 0x6; + SW_SHOWMINNOACTIVE := 0x7;SW_SHOWNA := 0x8;SW_RESTORE := 0x9; + SW_SHOWDEFAULT := 0xA;SW_FORCEMINIMIZE := 0xB;SW_MAX := 0xB;} + global G_GTK_WINDOW_ACTIVATE; + if not hwd then return ; + if not GTK_WIDGET(hwd) then return ; + if f =0 then + begin + + if gtk_widget_is_toplevel(hwd) then + begin + p := GetParent(hwd); + if p then gtk_window_set_transient_for(hwd,0); + end + gtk_widget_hide(hwd); + end else + if f=0xc then + begin + if gtk_widget_is_toplevel(hwd) then + begin + p := GetParent(hwd); + if p and GTK_WIDGET(p) then + begin + if gtk_widget_is_toplevel(p) then pp := p; + else + pp := gtk_widget_get_toplevel(p); + if pp then gtk_window_set_transient_for(hwd,pp); + end + end + gtk_widget_show_all(hwd); + end else + begin + if gtk_widget_is_toplevel(hwd) then + begin + global g_current_get_focus_widget; + cf := g_current_get_focus_widget; + p := GetParent(hwd); + if p and GTK_WIDGET(p) then + begin + if gtk_widget_is_toplevel(p) then pp := p; + else + pp := gtk_widget_get_toplevel(p); + if pp then gtk_window_set_transient_for(hwd,pp); + end + if 2 =g_object_get_data(hwd,"gtk_popwp") then + begin + x := g_object_get_data(hwd,"gtk_layout_x"); + y := g_object_get_data(hwd,"gtk_layout_y"); + w := g_object_get_data(hwd,"gtk_layout_width"); + h := g_object_get_data(hwd,"gtk_layout_height"); + gtk_window_move(hwd,x,y); + if w>=0 and h>=0 then + gtk_widget_set_size_request(hwd,w,h); + end + if f=0x4 then + begin + if not gtk_window_get_decorated(hwd) then + gtk_window_set_type_hint((hwd),3); + if cf and cf<>g_current_get_focus_widget then //设置一下focus + begin + tplev := gtk_widget_get_toplevel(cf); + if tplev then gtk_window_set_focus(tplev,cf); + end + end + end + gtk_widget_show(hwd); + if f<>0x4 and G_GTK_WINDOW_ACTIVATE<>hwd then + begin + if G_GTK_WINDOW_ACTIVATE then + gtk_addMessageQueue(G_GTK_WINDOW_ACTIVATE,0x6,0,0,0); + G_GTK_WINDOW_ACTIVATE := hwd; + gtk_addMessageQueue(hwd,0x6,1,0,0); + end + end + return true; + end + function MessageBoxA(hwnd :pointer;txt:string;cap:string;flag:integer); + begin + return gtk_MessageBoxA(hwnd,txt,cap,flag); + end + function IsWindow(h); + begin + wt := static gtk_widget_get_type(); + r := g_type_check_instance_is_a(h,wt); + return r; + end + function GetWindowTextA(h,s,l); + begin + if not(h>0 or h<0) then return ; + if not ifstring(s) then return ; + wt := static gtk_window_get_type(); + if g_type_check_instance_is_a(h,wt) then + begin + rs := GtkStringToTsl(gtk_window_get_title(h)); + end else + begin + lbl := g_object_get_data(h,"gtk_layout_label"); + if lbl then + begin + rs := GtkStringToTsl(gtk_label_get_text(lbl)); + end else + begin + et := g_object_get_Data(h,"gtk_layout_editer"); + if et then + begin + rs := GtkStringToTsl( gtk_entry_get_text(h)); + end else + begin + et := g_object_get_Data(h,"gtk_layout_memo"); + if et then + begin + rs := gtk_executeMessageA(h,0xd,0,0); + end + end + end + end + if rs then + begin + for i:= 1 to min(length(s),min(length(rs),l)) do + begin + s[i] := rs[i]; + end + return i; + end + end + function SetWindowTextA(h,s); + begin + if not(h>0 or h<0) then return ; + if not ifstring(s) then return ; + wt := static gtk_window_get_type(); + us := TslStringToGtk(s); + if g_type_check_instance_is_a(h,wt) then + begin + gtk_window_set_title(h,us); + end else + begin + return ; + lbl := g_object_get_data(h,"gtk_layout_label"); + if lbl then + begin + return gtk_label_set_text(lbl,us); + end + et := g_object_get_Data(h,"gtk_layout_editer"); + if et then + begin + return gtk_entry_set_text(h,us); + end + et := g_object_get_Data(h,"gtk_layout_memo"); + if et then + begin + gtk_executeMessageA(h,0xc,0,us); + end + + //et := g_object_get_Data(h,"gtk_layout_memo"); + //if et then return gtk_entry_set_text(et,us); + end + end + function GetScrollInfo(hWnd:pointer;x:integer;info:pointer) + begin + return gtk_GetScrollInfo(hwnd,x,info); + end + function SetScrollInfo(hwnd:pointer; nBar:integer; lpsi:pointer;redraw:integer) + begin + return gtk_SetScrollInfo(hwnd,nBar,lpsi,redraw); + end + function SystemParametersInfoA(uiAction:integer;uiParam:integer; pvParam:pointer; fWinIni:integer); + begin + if (uiAction = 0x30) and (pvParam>0 or pvParam<0) then + begin + w := static gdk_screen_width(); + h := static gdk_screen_height(); + rc := new tcrect(pvParam); + rc._setvalue_(0,0); + rc._setvalue_(1,0); + rc._setvalue_(2,w); + rc._setvalue_(3,h); + end + end + function GetClientRect(h :pointer;var rec:array of integer); + begin + if h then + begin + x0 := g_object_get_data(h,"gtk_layout_width"); + y0 := g_object_get_data(h,"gtk_layout_height"); + end + rec := array(0,0,x0, y0); + return true; + end + function GetWindowRect(hwnd :pointer;var rec:array of integer):integer; + begin + xy := array(0,0); + ClientToScreen(hwnd,xy); + h := g_object_get_data(hwnd,"gtk_layout_height"); + w := g_object_get_data(hwnd,"gtk_layout_width"); + rec := array(xy[0],xy[1],xy[0]+w,xy[1]+h); + end + function GetWindowInfo(hwnd :pointer;f:pointer):integer; + begin + if not(f>0 or f<0 ) then return 0; + //info := new TWINDOWINFO(f); + end + function SetWindowPos(h:pointer;hWndInsertAfter:pointer; X:integer; Y:integer; cx:integer;cy:integer; uFlags:integer); + begin + if 0x400 .& uFlags then + begin + //echo "border set \r\n"; + InvalidateRect(h,nil,false); + return ; + end + if not(h>0 or h<0) then return ; + flg := 0; + wt := static gtk_window_get_type(); + if g_type_check_instance_is_a(h,wt) then //主窗口 + begin + x0 := g_object_get_data(h,"gtk_layout_x"); + y0 := g_object_get_data(h,"gtk_layout_y"); + if (x>=0 and y>=0) and (x<>x0 or y<>y0) then //窗口位置 + begin + gtk_window_move(h,x,y); + g_object_set_data(h,"gtk_layout_x",x); + g_object_set_data(h,"gtk_layout_y",y); + flg .|=2; + end + w0 := g_object_get_data(h,"gtk_layout_width"); + h0 := g_object_get_data(h,"gtk_layout_height"); + if (cx>=0 and cy>=0) and ( cx<>w0 or cy<>h0) then + begin + if gtk_window_get_resizable(h) then + begin + gtk_widget_get_size_request(h,cx0,cy0); //改小一点 + if cx0>cx or cy0>cy then + begin + gtk_widget_set_size_request(h,cx,cy); + end + gtk_window_resize(h,cx,cy); + end + else + begin + //gtk_widget_get_size_request(h,cx0,cy0); + //echo "\r\noldsize:",cx0,"====",cy0; + //gtk_window_resize(wh,cx,cy); + gtk_widget_set_size_request(h,cx,cy); + //gtk_window_set_decorated(h,true); + //gtk_window_set_resizable(h,true); + + //gtk_window_resize(h,cx,cy); + //gtk_window_set_decorated(h,false); + //gtk_window_resize_to_geometry(h,cx,cy); + end + g_object_set_data(h,"gtk_layout_width",cx); + g_object_set_data(h,"gtk_layout_height",cy); + flg .|=1; + end + if flg then //多发送一次消息 + begin + Gtk_TrigMoveSizeEvent(h,x,y,cx,cy,flg); + end + end else + if isGtkWidget(h) then + begin + lot := gtk_widget_get_parent(h); + //flg := 0; + if lot then + begin + x0 := g_object_get_data(h,"gtk_layout_x"); + y0 := g_object_get_data(h,"gtk_layout_y"); + if x<>x0 or y<>y0 then + begin + gtk_layout_move(lot,h,x,y); + g_object_set_data(h,"gtk_layout_x",x); + g_object_set_data(h,"gtk_layout_y",y); + flg .|=2; + end + end + w0 := g_object_get_data(h,"gtk_layout_width"); + h0 := g_object_get_data(h,"gtk_layout_height"); + if (cx>=0 and cy>=0) and ( cx<>w0 or cy<>h0) then + begin + gtk_widget_set_size_request(h,cx,cy); + g_object_set_data(h,"gtk_layout_width",cx); + g_object_set_data(h,"gtk_layout_height",cy); + //lbl := g_object_get_data(h,"gtk_layout_lable"); + //if lbl then gtk_widget_set_size_request(lbl,cx-5,cy-5); + flg .|=1; + end + if flg then + begin + Gtk_TrigMoveSizeEvent(h,x,y,cx,cy,flg); + end + + end + end + function IsGtkWidget(h); + begin + wt := static gtk_widget_get_type(); + return g_type_check_instance_is_a(h,wt); + end + function gtk_window_showmodal(w); //shomodal + begin + dialog := w.handle; + pt := GetParent(dialog); + if (pt) and GTK_WIDGET(pt) then + begin + if (not gtk_widget_is_toplevel(pt)) then + begin + pt := gtk_widget_get_toplevel(pt); + end + w.Visible := true; + gtk_window_set_type_hint((dialog),0); + //gtk_window_set_modal(GTK_WINDOW( dialog),TRUE); //屏蔽掉showmodal + gtk_window_set_transient_for( GTK_WINDOW(dialog),GTK_WINDOW(pt)); + + return true; + end + end + function gtk_window_endmodal(w); //shomodal + begin + dialog := w.handle; + pt := GetParent(dialog); + if (pt) then + begin + if (not gtk_widget_is_toplevel(pt)) then + begin + pt := gtk_widget_get_toplevel(pt); + end + //gtk_window_set_modal(GTK_WINDOW( dialog),false); //屏蔽掉showmodal + gtk_window_set_transient_for( GTK_WINDOW(dialog),0); + w.Visible := false; + end + end + function GetParent(h); //获得父窗口 + begin + if not IsGtkWidget(h) then return 0; + if gtk_widget_is_toplevel(h) then return g_object_get_data(h,"gtk_layout_parent"); + p := gtk_widget_get_parent(h); + if p then + return g_object_get_data(p,"gtk_layout_owner"); + return 0; + end + function SetParent(h :pointer;phwnd:pointer); //设置gtk父窗口 + begin + if h=phwnd then return 0; + if not IsGtkWidget(h) then return 0; + if gtk_widget_is_toplevel(h) then + begin + r := g_object_get_data(h,"gtk_layout_parent"); + if r=phwnd then return ; + g_object_set_data(h,"gtk_layout_parent",IsGtkWidget(phwnd)?phwnd:0); + + if gtk_widget_is_visible(h) then //显示的子窗口处理 + begin + if GTK_WIDGET(phwnd) then + begin + if gtk_widget_is_toplevel(phwnd) then pp := phwnd; + else + pp := gtk_widget_get_toplevel(phwnd); + gtk_window_set_transient_for(h,pp); + end + end else + begin + gtk_window_set_transient_for(h,0); //处理20211020 + end + return r; + end + lot :=gtk_widget_get_parent(h); ;//g_object_get_data(h,"gtk_layout_parent");// //原有layout + if lot then + begin + r := g_object_get_data(lot,"gtk_layout_owner"); + if r=phwnd then return 0; + gtk_container_remove(lot,h); + end + if not phwnd then return r; + lot := g_object_get_data(phwnd,"gtk_layout"); + if lot then + begin + x := g_object_get_data(h,"gtk_layout_x"); + y := g_object_get_data(h,"gtk_layout_y"); + gtk_layout_put(lot,h,x,y); + + end + return r; + end + function hittestwidget(h,x,y); + begin + wd := class(tUIglobalData).uigetdata("TGlobalComponentcache").getwndbyhwnd(h); + if wd then return wd.gethitstyle(x,y); + return 0; + end + function GetTopWidgetList(h,x,y,r); + begin + wd := class(tUIglobalData).uigetdata("TGlobalComponentcache").getwndbyhwnd(h); + if wd and wd.Visible and wd.Enabled then + begin + xy := wd.ScreenToClient(x,y); + if xy[0]>0 and xy[1]>0 and wd.width>xy[0] and wd.height>xy[1] then + begin + r[length(r)] := array(h,xy); + ctls := wd.Controls; + for i:= 0 to ctls.count-1 do + begin + ci := ctls[i]; + if (ci is class(TWinControl)) and ci.HandleAllocated() and (not ci.WsPopUp) then + begin + GetTopWidgetList(ci.Handle,x,y,r); + end + end + end + end + end + // class(tUIglobalData).uigetdata("TGlobalComponentcache").getwndbyhwnd(hwnd); + function Gtk_TrigMoveSizeEvent(h,aleft,atop,AWidth,AHeight,flg); + begin + global G_F_TWIN_PROC_; + SWP_NOMOVE := 2; + SWP_NOSIZE := 1; + WM_WINDOWPOSCHANGED := 0x47; + d := new tvclwindowpos_class(0); + SizeChanged := flg .& 1; + PosChanged := flg .& 2; + + if SizeChanged then + begin + vb := g_object_get_data(h,"gtk_window_vscroll_bar"); + hb := g_object_get_data(h,"gtk_window_hscroll_bar"); + if vb and gtk_widget_is_visible(vb) then + begin + d.cx := max(AWidth-10,0); + end + else d.cx := AWidth; + if hb and gtk_widget_is_visible(hb) then + begin + d.cy := max(AHeight-10,0); + end + else + d.cy := AHeight; + D.flags := SWP_NOMOVE; + if G_F_TWIN_PROC_ then call(G_F_TWIN_PROC_,h,WM_WINDOWPOSCHANGED,0,d._getptr_); + end + if PosChanged then + begin + d.x := ALeft; + d.y := ATop; + d.flags := SWP_NOSIZE; + if G_F_TWIN_PROC_ then call(G_F_TWIN_PROC_,h,WM_WINDOWPOSCHANGED,0,d._getptr_); + end + if SizeChanged then //这个是不是应该放前面 + begin + gtk_widgetsizechanged(h,AHeight,AWidth); + end + {if SizeChanged then + begin + _twinproc_(h,0x5,0,makeposition(AWidth,AHeight)); + end} + if PosChanged then + begin + if G_F_TWIN_PROC_ then + begin + call(G_F_TWIN_PROC_,h,0x3,0,makeposition(ALeft,ATop)); + end + + end + + end + function GetCursorPos(var p:array of integer); + begin + gdk_display_get_pointer(gdk_display_get_default(), nil, x, y, nil) ; + p := array(x,y); + return true; + end + function PostQuitMessage(c); + begin + gtk_main_quit(); + return c; + end + ///////////////////////////////////////// + + ///////////////////////////////////////// + + Function LoadCursorA2(hd:pointer;n:pointer) + begin + rn := array(0x7F01:152,0x7F8A:126,0x7F89:24,0x7F88:0,0x7F87:0, + 0x7F86:58,0x7F85:138,0x7F84:70,0x7F83:12,0x7F82:14,0x7F80:58,0x7F04:6, + 0x7F03:30,0x7F02:150)[n]; + if ifnil(rn) then rn := 2; + return gdk_cursor_new(rn); + end + function RegisterClassExA(wc:pointer); + begin + return gtk_RegisterClassExA(wc); + end + function GetClassInfoExA(HH:pointer;lpszClass:string;lpwcx:pointer); + begin + return gtk_GetClassInfoExtA(hh,lpszClass,lpwcx); + end + function CreateWindowExA(dwExStyle:integer; lpClassName:string; lpWindowName:string; + dwStyle:integer;x:integer;y:integer;nWidth:integer;nHeight:integer; + hWndParent:pointer;hMenu:pointer; hInstance:pointer;lpParam:pointer); + begin + return gtk_createwindowexa(dwExStyle,lpClassName,lpWindowName,dwStyle,x,y,nwidth,nheight,hwndparent,hmenu,hinstance,lpParam); + end + ///////////////////////空接口 + + class function GetModuleHandleA(name:pointer)begin return 1; end; + + function SetClassLongPtrA(HH:pointer;idx:integer;dwNewLong:pointer)begin end; + function GetClassLongPtrA(HH:pointer;idx:integer)begin end; + //////////////////////////////////////// + function CallWindowProcA(lpPrevWndFunc:pointer;hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer) + begin + //默认处理程序 + //echo "call defalt handler\r\n"; + end + function GetKeyState(key); + begin + return gtk_GetKeyState(key); + end + function GetAsyncKeyState(key); + begin + return gtk_GetAsyncKeyState(key); + end + function GetSysColor(idx:integer):integer; + begin + if idx = 0x5 then + begin + return 0xffffff; + end + return 0xf0f0f0; + end + function SendMessageA(h,msg,w,l); + begin + return gtk_sendmessagea(h,msg,w,l); + end + function PostMessageA(h,msg,w,l,d); + begin + return gtk_postmessagea(h,msg,w,l,d); + end + function SetWindowLongPtrA(h,n,v); + begin + if not(h>0 or h<0) then return 0; + return gtk_SetWindowLongPtrA(h,n,v); + end + function GetWindowLongPtrA(h,idx); + begin + if not(h>0 or h<0) then return 0; + return gtk_GetWindowLongPtrA(h,idx); + end + function DestroyWindow(h:pointer); + begin + if h>0 or h<0 then + begin + SetParent(h,0); + if IsGtkWidget(h) then + begin + gtk_widget_destroy(h); + end + end + end + class function MultiByteToWideChar_a(CodePage:integer;dwFlags:integer;lpMultiByteStr:string;cbMultiByte:integer;var lpWideCharStr:string;cchWideChar:integer):integer; + begin + + end + class function GetEncoderClsid(n:String;ed:pointer):integer; + begin + WriteStringToPtr(ed,n); //保存 + return -1; + end + function EnableWindow(w,c); + begin + //可能还有其他处理 + if not(w>0 or w<0) then return false; + r := gtk_widget_get_sensitive(w); + nc := c?true:false; + issetfc := false; + if r<>nc then + begin + if not nc then //似乎还是有点问题 + begin + cf := GetFocus(); + pcf := cf; + while pcf do //查找上层窗口 + begin + if pcf = w then + begin + g_object_set_data(w,"gtk_focus_widget_handle",cf); + issetfc := true; + break; + end + pcf := gtk_widget_get_parent(pcf); + end + if not issetfc then //保存当前消失的窗口 + begin + g_object_set_data(w,"gtk_focus_widget_handle",0); + end + end + gtk_widget_set_sensitive(w,nc); + global g_current_get_focus_widget; + if nc and 0=g_current_get_focus_widget then + begin + fh := g_object_get_data(w,"gtk_focus_widget_handle") ; + if fh and GTK_WIDGET(fh) then + begin + SetFocus(fh); + end + end + end + return r; + end + function CreateStreamOnHGlobal(hGlobal:pointer;fDeleteOnRelease:integer; var ppstm:pointer):pointer; + begin + ppstm := ""; + return true; + end + function GetHGlobalFromStream(pstm:string; var phglobal:string):pointer; + begin + // + phglobal := pstm; + end + function memcpy2(var dst:string;src:string;size_t:integer):pointer; + begin + //字符串 + dst := src; + return ;// + end + function GlobalUnlock(mem :string):integer; + begin + return mem; + end + function GlobalSize(menm:pointer):integer; + begin + return 0;// + end + function InvalidateRect(hwnd :pointer;rec:array of integer;f:integer):integer; + begin + h := g_object_get_data(hwnd,"gtk_clientwideget"); + if h then + begin + //return gtk_widget_queue_draw(h); + if ifarray(rec) and ifnumber(rec[0]) and ifnumber(rec[1]) and ifnumber(rec[2]) and ifnumber(rec[3]) then + begin + + gtk_widget_queue_draw_area(h,rec[0],rec[1],rec[2]-rec[0],rec[3]-rec[1]); + end + else + begin + gtk_widget_queue_draw(h); + + end + end + end + function InvalidateRect2(hwnd :pointer;rec:pointer;f:integer):integer; + begin + InvalidateRect(hwnd,0,f); + end + + //////////////////////////////gdi/////////////////////////////////////////// + function SelectObject(hdc :pointer;gdiobj:pointer); + begin + // + if not hdc then return 0; + if not(gdiobj>0 or gdiobj<0) then return 0; + global gtk_gdi_object_globals; + if not ifarray(gtk_gdi_object_globals) then return 0; + obj := gtk_gdi_object_globals[inttostr(gdiobj)]; + if not obj then return 0; + t := obj[1]; + o := obj[0]; + case obj[1] of + "pen": + begin + r := gtk_object_get_data(hdc,"pen"); + gtk_object_set_data(hdc,"pen",gdiobj); + gtk_object_set_data(hdc,"pen.color",o.color); + gtk_object_set_data(hdc,"pen.width",o.width); + gtk_object_set_data(hdc,"pen.style",o.style); + end + "brush": + begin + r := gtk_object_get_data(hdc,"brush"); + gtk_object_set_data(hdc,"brush",gdiobj); + gtk_object_set_data(hdc,"brush.color",o.color); + end + "font": + begin + r := gtk_object_get_data(hdc,"font"); + gtk_object_set_data(hdc,"font",gdiobj); + end + "rgn": + begin + r := gtk_object_get_data(hdc,"rgn"); + gtk_object_set_data(hdc,"rgn",gdiobj); + end + end ; + return r; + end + Function TextOutA(hdc :pointer;X:integer;y:integer;txt:string;len:integer):integer; + begin + cl := gtk_object_get_data(hdc,"text.color"); + // gtk_rgb_color_rgb(cl,r,g,b); + // cairo_set_source_rgb(hdc, r, g, b); + xb := gtk_object_get_data(hdc,"viewport.x"); + yb := gtk_object_get_data(hdc,"viewport.y"); + ft := gtk_object_get_data(hdc,"font"); + global gtk_gdi_object_globals; + if ft and ifarray(gtk_gdi_object_globals) then + begin + fto := gtk_gdi_object_globals[inttostr(ft)]; + if fto then fto := fto[0]; + if fto then //文字处理 + begin + fc := fto._getvalue_("facename"); + ht := fto._getvalue_("height"); + wd := fto._getvalue_("width"); + it := fto._getvalue_("italic"); + wt := fto._getvalue_("weight")=700; + udl := fto._getvalue_("underline"); + fnotset := false; + {fns := static pango_font_family_get_names(); + for i,v in fns do + begin + if v=fc then + begin + fnotset := true; + break; + end + end } + cft := (fnotset?fc:"AR PL UKai CN"); + global g_gtk_font_get_size ; + if not ifarray(g_gtk_font_get_size) then g_gtk_font_get_size := array(); + cfinfo := g_gtk_font_get_size[cft,ht,wd,it,wt]; + if cfinfo then + begin + wd := cfinfo["width"]; + dkzt := cfinfo["zczw"]; + iwd2 := cfinfo["iwd2"]; + cairo_select_font_face(hdc,cft,it,wt); + cairo_set_font_size(hdc,cfinfo["iwd2"]); + end else + begin + cairo_select_font_face(hdc,cft,it,wt); + ext := new _cairo_text_extents_t(nil); + brk := 0; + wd2 := wd*2-2-wt; //稍微缩小一点 + iwd2 := wd2; + brk_Ct := 0; + dkzt := false; + while not brk do + begin + brk_Ct++; + cairo_set_font_size(hdc,iwd2); + cairo_text_extents(hdc, U"国", ext._getptr_()); + nwd := ext.width; + if brk_Ct = 1 then + begin + cairo_text_extents(hdc, U"i", ext._getptr_()); + nwd2 := ext.width; + dkzt := (nwd2/nwd)>0.6; + //echo "\r\n*********************",(nwd2/nwd); + if dkzt then //不支持中文,稍微放大一点 + begin + wd2 := wd+1+it-wt; + iwd2 := wd+1+it-wt; + end + end + if nwd>(wd2+0.4) then + begin + iwd2-=0.25; + end else + if nwd<(wd2) then + begin + iwd2+=0.25; + end else + begin + brk := true; + end + if brk_Ct>50 then break; + end + g_gtk_font_get_size[cft,ht,wd,it,wt] := array("width":wd,"zczw":dkzt,"iwd2":iwd2); + end + end + + end + + wid := wd; + idx := 1 ; + tlen := (len<0)?length(txt):(min(len,length(txt))); + xp := x+xb; + yp := y+yb+ht; + ///////////////////背景///////////////////////////////////////// + if gtk_object_get_data(hdc,"font.bkmode") = 2 then + begin + gtk_rgb_color_rgb(gtk_object_get_data(hdc,"font.bkcolor"),r,g,b); + //cairo_fill + cairo_move_to(hdc,xp,yp); + cairo_line_to(hdc,xp+wid*tlen,yp); + cairo_line_to(hdc,xp+wid*tlen,yp-ht); + cairo_line_to(hdc,xp,yp-ht); + cairo_line_to(hdc,xp,yp); + cairo_set_source_rgb(hdc, r, g, b); + cairo_fill(hdc); + end + gtk_rgb_color_rgb(cl,r,g,b); + cairo_set_source_rgb(hdc, r, g, b); + //////////////////////////////////////////////////////// + if udl then + begin + cairo_set_line_width(hdc,0.5); + end + while idx<=tlen do + begin + if udl then bxp := xp; + ci := GetChar(txt,idx); + {if ci=13 then // \n + begin + idx++; + yp+=ht; + continue; + end else // \r + if ci = 10 then + begin + idx++; + xp := x+xb; + continue; + end } + cairo_move_to(hdc,xp,yp); + if (ci .& 0x80) then + begin + if idx14 then + cairo_show_text(hdc,TslStringToGtk2( txt[idx])); + end + xp+=wid; + idx++; + if udl then + begin + cairo_move_to(hdc,bxp,yp); + cairo_line_to(hdc,xp,yp); + end + //cairo_move_to(hdc,xp,yp); + end + cairo_stroke(hdc); + return 1; + end + Function DrawTextA(hdc :pointer;txt:string;len:integer;rec:array of integer;fmt:integer):integer; + begin + //输出字符数 + //方位 + return DrawTextExA(hdc,txt,len,rec,fmt,0); + end + Function DrawTextExA(hdc :pointer;txt:string;len:integer;rec:array of integer;fmt:integer;lpdtp:pointer):integer; + begin + slen := length( txt); + if slen<1 then return ; + ft := gtk_object_get_data(hdc,"font"); + global gtk_gdi_object_globals; + if ft and ifarray(gtk_gdi_object_globals) then + begin + fto := gtk_gdi_object_globals[inttostr(ft)]; + if fto then fto := fto[0]; + wd := fto._getvalue_("width"); + ht := fto._getvalue_("height"); + end + //DT_LEFT := 0; + DT_RIGHT := 0x2; + //DT_TOP := 0; + DT_BOTTOM:= 0x8; + DT_CENTER := 0x1; + DT_VCENTER:= 0x4; + //DT_SINGLELINE:= 0x20; + //DT_TABSTOP:= 0x80; + rw := rec[2]-rec[0]; + nlen := min(len, min(integer(rw/wd),slen)); + sx := rec[0]; + rh := rec[3]-rec[1]; + sy := rec[1]; + if fmt=0 or not(fmt>0 or fmt<0 ) then + begin + + end + if (fmt .& DT_CENTER)=DT_CENTER then //处理 + begin + if nlen = slen then + begin + sx +=(rw-(nlen*wd))/2; + end + + end + if (fmt .& DT_VCENTER)=DT_VCENTER then //处理 + begin + if rh>ht then + begin + sy+=(rh-ht)/2; + end + end + if (fmt .& DT_RIGHT)=DT_RIGHT then //不处理 + begin + if rw>(nlen*wd) then + begin + sx := rec[2]-((nlen*wd)); + end + end + if (fmt .& DT_BOTTOM)=DT_BOTTOM then //不处理 + begin + sy := rec[3]-3-ht; + end + r := TextOutA(hdc,sx,sy,txt,nlen); + return r; + rr := gtk_object_get_data(hdc,"rgn"); + if rr then + begin + p := new TCRect(gdiobj); + rc := p._getdata_(); + cairo_reset_clip(hdc); + cairo_rectangle(hdc,rc[0],rc[1],rc[2]-rc[0],rc[3]-rc[1]); + cairo_clip(hdc); + end else + begin + cairo_reset_clip(hdc); + end + return r; + end + Function SetTextColor(hdc :pointer;col:integer):integer; + begin + gtk_object_set_data(hdc,"text.color",col); + return true; + end + Function FillRect(dc:pointer;rec:array of integer;br:pointer):integer; + begin + if not dc then return ; + if ifarray(rec) then + begin + global gtk_gdi_object_globals; + if not ifarray(gtk_gdi_object_globals) then gtk_gdi_object_globals := array(); + brs := gtk_gdi_object_globals[inttostr(br)]; + if not brs then return 0; + cl := brs[0].Color; + x := gtk_object_get_data(dc,"viewport.x"); + y := gtk_object_get_data(dc,"viewport.y"); + cairo_rectangle(dc, x+rec[0], y+rec[1], rec[2]-rec[0], rec[3]-rec[1]); + gtk_rgb_color_rgb(cl,r,g,b); + cairo_set_source_rgb(dc,r,g,b); + cairo_fill(dc); + end + end + Function InvertRect(dc:pointer;rec:array of integer;br:pointer):integer; + begin + if not dc then return ; + if ifarray(rec) then + begin + global gtk_gdi_object_globals; + if not ifarray(gtk_gdi_object_globals) then gtk_gdi_object_globals := array(); + brs := gtk_gdi_object_globals[inttostr(br)]; + if not brs then return 0; + cl := brs[0].Color; + x := gtk_object_get_data(dc,"viewport.x"); + y := gtk_object_get_data(dc,"viewport.y"); + cairo_rectangle(dc, x+rec[0], y+rec[1], rec[2]-rec[0], rec[3]-rec[1]); + gtk_rgb_color_rgb(cl,r,g,b); + cairo_set_source_rgb(dc,1-r,1-g,1-b); + cairo_fill(dc); + end + end + function ReleaseDC(hwd :pointer;hdc:pointer):integer; + begin + + end + function SelectClipRgn(hdc :pointer;gdiobj:pointer); + begin + + r := SelectObject(hdc,gdiobj); + if not(gdiobj) then + begin + gtk_object_set_data(hdc,"rgn",nil); + cairo_reset_clip(hdc); + end + else + begin + rr := gtk_object_get_data(hdc,"rgn"); + if rr <> gdiobj then return ; + p := new TCRect(gdiobj); + rc := p._getdata_(); + cairo_reset_clip(hdc); + x := gtk_object_get_data(dc,"viewport.x"); //控制基准位置 + y := gtk_object_get_data(dc,"viewport.y"); + cairo_rectangle(hdc,rc[0]+x,rc[1]+y,rc[2]-rc[0],rc[3]-rc[1]); + cairo_clip(hdc); + //gtk_object_set_data(hdc,"rgn",gdiobj); + end + return r; + end + function CreateRectRgn(nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer):pointer; + begin + global gtk_gdi_object_globals; + if not ifarray(gtk_gdi_object_globals) then gtk_gdi_object_globals := array(); + p := new TCRect(); + p.left := nLeftRect; + p.top := nTopRect; + p.right := nRightRect; + p.bottom := nBottomRect; + ptr := p._getptr_(); + gtk_gdi_object_globals[inttostr(ptr)] := array(p,"rgn"); + return ptr; + end + function CombineRgn(hrgnDest:pointer;hrgnSrc1:pointer;hrgnSrc2:pointer; fnCombineMode:integer):integer; + begin + //RGN_ERROR := 0x0;RGN_AND := 0x1;RGN_OR := 0x2;RGN_XOR := 0x3;RGN_DIFF := 0x4;RGN_COPY := 0x5; + rd := new TCRect(hrgnDest); + rs1 := new TCRect(hrgnSrc1); + if fnCombineMode=0x1 then + begin + rs2 := new TCRect(hrgnSrc2); + rd.left := max(rs1.left,rs2.left); + rd.top := max(rs1.top,rs2.top); + rd.right := min(rs1.right,rs2.right); + rd.bottom := min(rs1.bottom,rs2.bottom); + end else + if fnCombineMode=0x5 then + begin + rd.left := rs1.left ; + rd.top := rs1.top ; + rd.right := rs1.right ; + rd.bottom := rs1.bottom ; + end + return ret; + end + + function SetViewportOrgEx(dc:pointer;x:integer;y:integer;var pt:array of integer):integer; + begin + if not dc then return 0; + gtk_object_set_data(dc,"viewport.x",x); + gtk_object_set_data(dc,"viewport.y",y); + return 1; + end + + function DeleteObject(gdiobj :pointer);//删除gdi对象 + begin + global gtk_gdi_object_globals; + if not ifarray(gtk_gdi_object_globals) then return 0; + r := gtk_gdi_object_globals[inttostr( gdiobj)]; + if r then + begin + reindex(gtk_gdi_object_globals,array(inttostr(gdiobj):nil)); + return true; + end + class(TGdiplusflat).GdipDisposeImage(gdiobj); + return 0; + end + function DestroyIcon(icon:pointer):integer; + begin + return DeleteObject(icon); + end + function DestroyCursor(cursor:pointer):integer; + begin + return DeleteObject(cursor); + end + function CreatePen(FS,w,FC); //gtk 模拟 pen + begin + global gtk_gdi_object_globals; + if not ifarray(gtk_gdi_object_globals) then gtk_gdi_object_globals := array(); + p := new ttgtk_pen(); + p.width := w; + p.color := FC; + p.style := fs; + ptr := p._getptr_(); + gtk_gdi_object_globals[inttostr(ptr)] := array(p,"pen"); + return ptr; + //构造画笔 + end + function CreateSolidBrush(crColor:integer); + begin + global gtk_gdi_object_globals; + if not ifarray(gtk_gdi_object_globals) then gtk_gdi_object_globals := array(); + p := new ttgtk_brush(); + p.color := crColor; + ptr := p._getptr_(); + gtk_gdi_object_globals[inttostr(ptr)] := array(p,"brush"); + return ptr; + end + function CreateFontIndirectA(lplf:pointer); + begin + + global gtk_gdi_object_globals; + if not ifarray(gtk_gdi_object_globals) then gtk_gdi_object_globals := array(); + p := new ttgtk_font(); + p2 := new ttgtk_font(lplf); + for i,v in array("height","width","escapement","orientation","weight","italic","underline","strikeout","charset","outprecision","clipprecision","quality","pitchandfamily","facename") do + p._setvalue_(v,p2._getvalue_(v)); + ptr := p._getptr_(); + gtk_gdi_object_globals[inttostr(ptr)] := array(p,"font"); + return ptr; + end + Function GetTextMetricsA(hdc :pointer;TM:pointer):integer; + begin + + end + Function MoveToEx(hdc :pointer;x:integer;y:integer;var point:array of integer):integer; + begin + xb := gtk_object_get_data(hdc,"viewport.x"); + yb := gtk_object_get_data(hdc,"viewport.y"); + //cairo_move_to(hdc,x+xb,y+yb); + xy := gtk_object_get_data(hdc,"movepointto"); + if xy then + begin + point := xy; + end else point := array(0,0); + gtk_object_set_data(hdc,"movepointto",array(x,y)); + end + Function LineTo(dc :pointer;x:integer;y:integer):integer; + begin + xb := gtk_object_get_data(dc,"viewport.x"); + yb := gtk_object_get_data(dc,"viewport.y"); + pc := gtk_object_get_data(dc,"pen.color"); + pw := gtk_object_get_data(dc,"pen.width"); + pt := gtk_object_get_data(dc,"pen.style"); + if pw>0 then cairo_set_line_width(dc,pw); + else cairo_set_line_width(dc,1); + if pc=0 then + begin + cairo_set_source_rgb(dc,0,0,0); + end else + begin + gtk_rgb_color_rgb(pc,rc,gc,bc); + cairo_set_source_rgb(dc,rc,gc,bc); + end + cairo_applay_pen_style(dc); + xy := gtk_object_get_data(dc,"movepointto"); + if xy then + begin + cairo_move_to(dc,xy[0]+xb,xy[1]+yb); + end + gtk_object_set_data(dc,"movepointto",array(x,y)); + cairo_line_to(dc,x+xb,y+yb); + cairo_stroke(dc); + + end + + //////////////////////////gtk 菜单////////////////// + Function CreateMenu():pointer; + begin + r := gtk_menu_bar_new(); + gtk_widget_show(r); + return r; + end + Function CreatePopupMenu():pointer; + begin + //弹出菜单 + r := gtk_menu_new(); + gtk_widget_show(r); + g_object_set_data(r,"popmenubar",true); + return r; + end + Function DestroyMenu(hMenu:pointer):integer; + begin + return gtk_widget_destroy(hMenu); + end + Function DrawMenuBar(hwd:pointer):integer; //处理菜单栏 + begin + h :=g_object_get_data(hwd,"gtk_layout_height"); + w :=g_object_get_data(hwd,"gtk_layout_width"); + gtk_widgetsizechanged(hwd,h,w); + end + Function SetMenu(hwd:pointer;hmenu:pointer):integer; //设置菜单栏 + begin + vb := g_object_get_data(hwd,"gtk_vbox"); + if not vb then return ; + mb := g_object_get_data(hwd,"menubar"); + if mb = hmenu then return ; + if mb then + begin + gist := gtk_container_get_children(mb); + ridx := 0; + while gist do + begin + og := new _gslist(gist); + dt := og.data; + if dt then + gtk_container_remove(mb,dt); + ridx++; + gist := og.next; + end + gtk_widget_destroy(mb); + end + if hmenu then + begin + g_object_set_data(hwd,"menubar",hmenu); + g_object_set_data(hmenu,"menubarwindow",hwd); + gtk_box_pack_start(vb,hmenu,0,0,0); + gtk_widget_realize(hmenu); + //gtk_widget_show_all(hmenu); + end + else + begin + g_object_set_data(hwd,"menubar",0); + end + h :=g_object_get_data(hwd,"gtk_layout_height"); + w :=g_object_get_data(hwd,"gtk_layout_width"); + gtk_widgetsizechanged(hwd,h,w); + //移除原有窗口 + //menubar 添加到窗口 + end + Function RemoveMenu( hMenu:pointer; uPosition:integer;uFlags:integer):integer; + begin + mi := gtk_menu_shell_get_by_positon(hmenu,uPosition); + if mi then + begin + g_object_ref(mi); + gtk_container_remove(hMenu,mi); + return true; + end + + //移除菜单项目 + end + Function SetMenuItemInfoA( hMenu:pointer; uItem:integer;fByPosition:integer;lpmii:pointer):integer; + begin + return gtk_SetMenuItemInfoA(hMenu,uitem,fbyposition,lpmii); + //添加菜单 + end + Function InsertMenuItemA( hMenu:pointer;uItem:integer;fByPosition:integer;lpmii:pointer):integer; + begin + return gtk_insertmenuitema(hMenu,uitem,fbyposition,lpmii); + //添加菜单 + end + Function TrackPopupMenu( hMenu:pointer;uFlags:integer; x:integer; y:integer; nReserved:integer;hWnd:pointer; prcRect: array of integer):integer; + begin + //echo "\r\n===trackmenu:",hmenu,"===",x,"===",y,"===",nReserved,"===hwnd:",hwnd,"===rect:",tostn(prcRect); + if g_object_get_data(hMenu,"popmenubar") then + begin + g_object_set_data(hMenu,"popmenubarwindow",hWnd); + gtk_menu_popup(hmenu,0,0,0,0,3,0);//弹出 + return 1; + end else + begin + + end + //弹出菜单 + end + + function ClientToScreen(hwnd :pointer;var p:array of integer):integer; // 继续努力 + begin + if not hwnd then return ; + if not GTK_WIDGET(hwnd) then return ; + x := g_object_get_data(hwnd,"gtk_layout_x"); + y := g_object_get_data(hwnd,"gtk_layout_y"); + p[0]+=x; + p[1]+=y; + if not gtk_widget_is_toplevel(hwnd) then + begin + phwnd := GetParent(hwnd); + return ClientToScreen(phwnd,p); + end else + begin + mb := g_object_get_data(hwnd,"menubar"); + if mb and gtk_widget_is_visible(mb) then + begin + rec := zeros(4); + gtk_widget_get_allocation(mb,rec); + if rec[3]>1 then + begin + p[1]+= rec[3] ;//max(rec[3],25); + end + + end + end + return true; + end + function ScreenToClient(hwnd :pointer;var p:array of integer):integer;// 继续努力 + begin + p1 := array(0,0); + ClientToScreen(hwnd,p1); + p[0]-=p1[0]; + p[1]-=p1[1]; + return true; + end + function BeginPaint(hwd :pointer;strc:pointer):pointer; + begin + psc := new TPAINTSTRUCT(strc); + dc := g_object_get_data(hwd,"paint_dc"); + h := g_object_get_data(hwd,"paint_height"); + w := g_object_get_data(hwd,"paint_width"); + psc._setvalue_("hdc",dc); + psc._setvalue_("rcpaint",array(0,0,w,h)); + return dc; + end + function EndPaint(hwd :pointer;strc:pointer):integer; + begin + return 0; + end + function SaveDC(hdc :pointer):integer; + begin + if not(hdc>0 or hdc<0) then return ; + cairo_save(hdc); //需要处理 + end + function RestoreDC(hdc :pointer;nSavedDC:integer):integer; + begin + if not(hdc>0 or hdc<0) then return ; + cairo_restore(hdc); //需要处理 + end + function DeleteDC(hdc :pointer):integer; + begin + if not(hdc>0 or hdc<0) then return ; + gtk_object_set_data(hdc); //清空 + cairo_destroy(hdc); //需要处理 + end + function GetTextExtentPoint32A(hdc:pointer;lpString:string;c:integer; psizl:pointer):integer; + begin + end + function GetTextExtentPoint32A2(hdc:pointer;lpString:string;c:integer; var psizl:array of integer):integer; + begin + psizl := array(0,0); + if not(hdc>0 or hdc<0) then return 0; + if not( ifstring(lpString) and c>0 and c>=length(lpString)) then return 0; + ft := gtk_object_get_data(hdc,"font"); + global gtk_gdi_object_globals; + wd := 8; + ht := 16; + if ft and ifarray(gtk_gdi_object_globals) then + begin + fto := gtk_gdi_object_globals[inttostr(ft)]; + if fto then fto := fto[0]; + if fto then //文字处理 + begin + fc := fto._getvalue_("facename"); + ht := fto._getvalue_("height"); + wd := fto._getvalue_("width"); + end + end + psizl[0] := wd*length(lpString); + psizl[1] := ht; + return 1; + + end + function GetCharWidthA(hdc:pointer;iFirst:integer;iLast:integer;var lpBuffer:array of integer):integer; + begin + + + end + Function Rectangle(dc :pointer;l:integer;t:integer;r:integer;b:integer):integer; + begin + x := gtk_object_get_data(dc,"viewport.x"); + y := gtk_object_get_data(dc,"viewport.y"); + pc := gtk_object_get_data(dc,"pen.color"); + pw := gtk_object_get_data(dc,"pen.width"); + if pw>0 then cairo_set_line_width(dc,pw); + else cairo_set_line_width(dc,1); + if pc=0 then + begin + cairo_set_source_rgb(dc,0,0,0); + end else + begin + gtk_rgb_color_rgb(pc,rc,gc,bc); + cairo_set_source_rgb(dc,rc,gc,bc); + end + cairo_applay_pen_style(dc); + cairo_move_to(dc,l+x,t+y); + cairo_line_to(dc,r+x,t+y); + cairo_line_to(dc,r+x,b+y); + cairo_line_to(dc,l+x,b+y); + cairo_line_to(dc,l+x,t+y); + cairo_stroke(dc); + //return + cairo_stroke_preserve(dc); + bsh := gtk_object_get_data(dc,"brush.color"); + gtk_rgb_color_rgb(bsh,rc,gc,bc); + cairo_set_source_rgb(dc,rc,gc,bc); + cairo_fill(dc); + end + Function Ellipse(dc :pointer;l:integer;t:integer;r:integer;b:integer):integer; + begin + //圆心 + //长度 + x := gtk_object_get_data(dc,"viewport.x"); + y := gtk_object_get_data(dc,"viewport.y"); + pc := gtk_object_get_data(dc,"pen.color"); + pw := gtk_object_get_data(dc,"pen.width"); + brc := gtk_object_get_data(dc,"brush.color"); + if pw>0 then cairo_set_line_width(dc,pw); + else cairo_set_line_width(dc,1); + + mx := (l+r)/2+x; + my := (b+t)/2+y; + cairo_translate(dc,mx,my); + rx := (r-l)/2; + ry := (b-t)/2; + cairo_scale(dc,1,ry/rx); + cairo_applay_pen_style(dc); + cairo_arc(dc, 0, 0, rx, 0, 2 * 3.14); + if brc=0 then + begin + cairo_set_source_rgb(dc,0,0,0); + end else + begin + gtk_rgb_color_rgb(brc,rc,gc,bc); + cairo_set_source_rgb(dc,rc,gc,bc); + end + cairo_fill_preserve(dc); + if pc=0 then + begin + cairo_set_source_rgb(dc,0,0,0); + end else + begin + gtk_rgb_color_rgb(pc,rc,gc,bc); + cairo_set_source_rgb(dc,rc,gc,bc); + end + cairo_stroke(dc); + cairo_scale(dc,1,rx/ry); + cairo_translate(dc,0-mx,0-my); + end + Function RoundRect(dc :pointer;l:integer;t:integer;r:integer;b:integer;wid:integer;ht:integer):integer; + begin + xb := gtk_object_get_data(dc,"viewport.x"); + yb := gtk_object_get_data(dc,"viewport.y"); + pc := gtk_object_get_data(dc,"pen.color"); + pw := gtk_object_get_data(dc,"pen.width"); + + if pw>0 then cairo_set_line_width(dc,pw); + else cairo_set_line_width(dc,1); + cairo_applay_pen_style(dc); + cairo_draw_round_rectangle(dc,l,t,r-l,b-t,wid); + + bsh := gtk_object_get_data(dc,"brush.color"); + gtk_rgb_color_rgb(bsh,rc,gc,bc); + cairo_set_source_rgb(dc,rc,gc,bc); + cairo_fill_preserve(dc); //绘制底色 + if pc=0 then + begin + cairo_set_source_rgb(dc,0,0,0); + end else + begin + gtk_rgb_color_rgb(pc,rc,gc,bc); + cairo_set_source_rgb(dc,rc,gc,bc); + end + cairo_stroke(dc);//绘制边框 + return ; + end + Function Chord(hdc :pointer;l:integer;t:integer;r:integer;b:integer;wid:integer;ht:integer):integer; + begin + + end + Function Pie(hdc :pointer;nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer;nXRadial1:integer;nYRadial1:integer;nXRadial2:integer;nYRadial2:integer):integer; + begin + + end + Function SetArcDirection(hdc :pointer;direct:integer):integer; + begin + + end + Function Arc(hdc :pointer;nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer;nXRadial1:integer;nYRadial1:integer;nXRadial2:integer;nYRadial2:integer):integer; + begin + + end + Function Polygon(hdc :pointer;points:array of integer;n:integer):integer; + begin + + end + Function PolyBezier(hdc :pointer;points:array of integer;n:integer):integer; + begin + + end + Function SetPolyFillMode(hdc :pointer;md:integer):integer; + begin + + end + Function Polyline(dc :pointer;points:array of integer;n:integer):integer; + begin + if n<2 then return ; + x := gtk_object_get_data(dc,"viewport.x"); + y := gtk_object_get_data(dc,"viewport.y"); + pc := gtk_object_get_data(dc,"pen.color"); + pw := gtk_object_get_data(dc,"pen.width"); + if pw>0 then cairo_set_line_width(dc,pw); + else cairo_set_line_width(dc,1); + if pc=0 then + begin + cairo_set_source_rgb(dc,0,0,0); + end else + begin + gtk_rgb_color_rgb(pc,rc,gc,bc); + cairo_set_source_rgb(dc,rc,gc,bc); + end + cairo_move_to(dc,points[0]+x,Points[1]+y); + cairo_applay_pen_style(dc); + for i := 1 to n-1 do + begin + cairo_line_to(dc,Points[i*2]+x,Points[i*2+1]+y); + end + cairo_stroke(dc); + end + Function PolyPolyline(hdc :pointer;points:array of integer;pc:array of integer;n:integer):integer; + begin + + end + Function DrawFrameControl(DC:pointer; var LPRECT: array of integer ; dr1 :integer;dr2:integer):integer; + begin + { + DFC_SCROLL := 0x3;DFC_BUTTON := 0x4;DFC_POPUPMENU := 0x5; + DFCS_CAPTIONCLOSE := 0x0;DFCS_CAPTIONMIN := 0x1;DFCS_CAPTIONMAX := 0x2; + DFCS_CAPTIONRESTORE := 0x3;DFCS_CAPTIONHELP := 0x4;DFCS_MENUARROW := 0x0; + DFCS_MENUCHECK := 0x1;DFCS_MENUBULLET := 0x2;DFCS_MENUARROWRIGHT := 0x4; + DFCS_SCROLLUP := 0x0;DFCS_SCROLLDOWN := 0x1;DFCS_SCROLLLEFT := 0x2; + DFCS_SCROLLRIGHT := 0x3;DFCS_SCROLLCOMBOBOX := 0x5;DFCS_SCROLLSIZEGRIP := 0x8; + DFCS_SCROLLSIZEGRIPRIGHT := 0x10;DFCS_BUTTONCHECK := 0x0;DFCS_BUTTONRADIOIMAGE := 0x1; + DFCS_BUTTONRADIOMASK := 0x2;DFCS_BUTTONRADIO := 0x4;DFCS_BUTTON3STATE := 0x8; + DFCS_BUTTONPUSH := 0x10;DFCS_INACTIVE := 0x100;DFCS_PUSHED := 0x200; + DFCS_CHECKED := 0x400;DFCS_TRANSPARENT := 0x800;DFCS_HOT := 0x1000; + DFCS_ADJUSTRECT := 0x2000;DFCS_FLAT := 0x4000;DFCS_MONO := 0x8000; + + } + x := gtk_object_get_data(dc,"viewport.x"); + y := gtk_object_get_data(dc,"viewport.y"); + case dr1 of + 0x4 : //DFC_BUTTON + begin + //if dr2 = 0x10 then // DFCS_BUTTONPUSH + //begin + + //end else + cairo_applay_pen_style(dc); + if dr2 = 0 then // DFCS_BUTTONCHECK + begin + cairo_set_source_rgb(dc,135/255,135/255,135/255); + cairo_set_line_width(dc,5); + + cairo_rectangle (dc, LPRECT[0]+x, LPRECT[1]+y, LPRECT[2]-LPRECT[0], LPRECT[3]-LPRECT[1]); + cairo_stroke_preserve(dc); + cairo_set_source_rgb(dc,1,1,1); + cairo_fill(dc); + end else + if dr2 = 0x400 then // DFCS_CHECKED + begin + cairo_set_source_rgb(dc,135/255,135/255,135/255); + cairo_set_line_width(dc,5); + + cairo_rectangle (dc, LPRECT[0]+x, LPRECT[1]+y, LPRECT[2]-LPRECT[0], LPRECT[3]-LPRECT[1]); + cairo_stroke_preserve(dc); + cairo_set_source_rgb(dc,1,1,1); + cairo_fill(dc); + + cairo_move_to(dc,LPRECT[0]+x+2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/3); + cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])/3,LPRECT[3]-2); + cairo_line_to(dc,LPRECT[2]-2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/4); + cairo_set_source_rgb(dc,100/255,100/255,100/255); + cairo_set_line_width(dc,4); + cairo_stroke(dc); + end else + if dr2 = 0x1 then // DFCS_BUTTONRADIOIMAGE + begin + cairo_set_source_rgb(dc,135/255,135/255,135/255); + cairo_set_line_width(dc,5); + l := LPRECT[0]; + r := LPRECT[2]; + t := LPRECT[1]; + b := LPRECT[3]; + mx := (l+r)/2+x; + my := (b+t)/2+y; + cairo_translate(dc,mx,my); + rx := (r-l)/2; + ry := (b-t)/2; + cairo_scale(dc,1,ry/rx); + + cairo_arc(dc, 0, 0, rx, 0, 2 * 3.14); + cairo_stroke_preserve(dc); + cairo_set_source_rgb(dc,1,1,1); + cairo_fill(dc); + cairo_set_line_width(dc,1); + cairo_arc(dc, 0, 0, max(rx-5,3), 0, 2 * 3.14); + cairo_set_source_rgb(dc,100/255,100/255,100/255); + cairo_fill(dc); + cairo_scale(dc,1,rx/ry); + cairo_translate(dc,0-mx,0-my); + end else + if dr2 = 0x4 then // DFCS_BUTTONRADIO + begin + cairo_set_source_rgb(dc,135/255,135/255,135/255); + cairo_set_line_width(dc,5); + l := LPRECT[0]; + r := LPRECT[2]; + t := LPRECT[1]; + b := LPRECT[3]; + mx := (l+r)/2+x; + my := (b+t)/2+y; + cairo_translate(dc,mx,my); + rx := (r-l)/2; + ry := (b-t)/2; + cairo_scale(dc,1,ry/rx); + + cairo_arc(dc, 0, 0, rx, 0, 2 * 3.14); + cairo_stroke_preserve(dc); + cairo_set_source_rgb(dc,1,1,1); + cairo_fill(dc); + cairo_scale(dc,1,rx/ry); + cairo_translate(dc,0-mx,0-my); + end else + begin + cairo_set_line_width(dc,4); + + cairo_rectangle(dc, LPRECT[0]+x, LPRECT[1]+y, LPRECT[2]-LPRECT[0], LPRECT[3]-LPRECT[1]); + {cairo_move_to(dc,LPRECT[0]+x,LPRECT[1]+y); + cairo_line_to(dc,LPRECT[2]+x,LPRECT[1]+y); + cairo_line_to(dc,LPRECT[2]+x,LPRECT[3]+y); + cairo_line_to(dc,LPRECT[0]+x,LPRECT[3]+y); + cairo_line_to(dc,LPRECT[0]+x,LPRECT[1]+y); + cairo_set_source_rgb(dc,200/255,200/255,200/255); + cairo_stroke_preserve(dc); + cairo_set_source_rgb(dc,221/255,221/255,221/255); + cairo_fill(dc);} + + cairo_set_source_rgb(dc,221/255,221/255,221/255); + cairo_fill_preserve(dc); + cairo_set_source_rgb(dc,210/255,207/255,205/255); + cairo_stroke(dc); + end + end + 0x3 : // DFC_SCROLL + begin + cairo_set_source_rgb(dc,221/255,221/255,221/255); + cairo_set_line_width(dc,0.1); + cairo_applay_pen_style(dc); + cairo_rectangle(dc, LPRECT[0]+x, LPRECT[1]+y, LPRECT[2]-LPRECT[0], LPRECT[3]-LPRECT[1]); + cairo_fill(dc); + + if dr2 = 0 then // DFCS_SCROLLUP + begin + cairo_move_to(dc,LPRECT[0]+x+2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/1.5); + cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])/2,LPRECT[1]+3); + cairo_line_to(dc,LPRECT[2]-2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/1.5); + cairo_line_to(dc,LPRECT[0]+x+2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/1.5); + cairo_set_source_rgb(dc,10/255,10/255,10/255); + cairo_fill(dc); + end else + if dr2 = 1 then // DFCS_SCROLLDOWN + begin + cairo_move_to(dc,LPRECT[0]+x+2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/3); + cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])/2,LPRECT[3]-3); + cairo_line_to(dc,LPRECT[2]-2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/3); + cairo_line_to(dc,LPRECT[0]+x+2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/3); + cairo_set_source_rgb(dc,10/255,10/255,10/255); + cairo_fill(dc); + end + if dr2 = 2 then //DFCS_SCROLLLEFT; + begin + cairo_move_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])*2/3,LPRECT[1]+y+2); + cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])*2/3,LPRECT[3]+y-2); + cairo_line_to(dc,LPRECT[0]+x+2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/2); + cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])*2/3,LPRECT[1]+y+2); + + cairo_set_source_rgb(dc,10/255,10/255,10/255); + cairo_fill(dc); + end else + if dr2 = 3 then //DFCS_SCROLLRIGHT; + begin + cairo_move_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])/3,LPRECT[1]+y+2); + cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])/3,LPRECT[3]+y-2); + cairo_line_to(dc,LPRECT[2]+x-2,LPRECT[1]+y+(LPRECT[3]-LPRECT[1])/2); + cairo_line_to(dc,LPRECT[0]+x+(LPRECT[2]-LPRECT[0])/3,LPRECT[1]+y+2); + + cairo_set_source_rgb(dc,10/255,10/255,10/255); + cairo_fill(dc); + end + end + end + + end + Function SetBkColor(dc:pointer;clrref:integer):integer; + begin + //font背景色 + gtk_object_set_data(dc,"font.bkcolor",clrref); + end + Function GetBkColor(dc:pointer):integer; + begin + return gtk_object_get_data(dc,"font.bkcolor"); + end + Function SetBkMode(dc:pointer;clrref:integer):integer; + begin + gtk_object_set_data(dc,"font.bkmode",clrref); + end + Function GetBkMode(dc:pointer):integer; + begin + return gtk_object_get_data(dc,"font.bkmode"); + end + Function FillRgn(dc:pointer;rgn:pointer;br:pointer):integer; + begin + + end + Function SetTextAlign(dc:pointer;fMode:integer):integer; + begin + + end + Function SetWorldTransform(dc:pointer;lpXform:pointer):integer; + begin + + end + + function UpdateWindow(hwnd :pointer):integer; + begin + w :=g_object_get_data(hwnd,"gtk_layout_width"); + h := g_object_get_data(hwnd,"gtk_layout_height"); + gtk_widgetsizechanged(hwnd,h,w); + return true; + end + function ClipCursor(rec:array of integer):integer; + begin + + end + function SetFocus(hwnd :pointer):pointer; + begin + cfcs := GetFocus(); + if cfcs = hwnd then return 0; + if not(hwnd>0 or hwnd<0) then return 0; + ph := hwnd; + if not GTK_WIDGET(hwnd) then return 0; + if not gtk_widget_is_toplevel(hwnd) then + begin + ph := gtk_widget_get_toplevel(hwnd); + end + //if not lot then + //lot := hwnd; + //gtk_widget_grab_focus(lot); + //echo "\r\n+++setfocus>>>",ph,">>>",hwnd; + gtk_window_set_focus(ph,hwnd); + return 0; + + end + function GetFocus():pointer; + begin + global g_current_get_focus_widget; + if g_current_get_focus_widget then return g_current_get_focus_widget; + return 0; + end + Function LoadImageA(hinst:pointer;lpszName:string; uType:integer; cxDesired:integer;cyDesired:integer;fuLoad:integer):pointer; + begin + + end + function LoadBitmapA(hin:pointer;lpsz:string):pointer; + begin + + end + function LoadBitmapA2(hin:pointer;lpsz:pointer):pointer; + begin + + end + Function GetObjectA(hgdiobj:pointer;cbBuffer:integer;lpvObject:pointer):integer; + begin + bmpobj := new TSHBMP(lpvObject); + bmpobj.bmwidth := gdk_pixbuf_get_width(hgdiobj); + bmpobj.bmheight := gdk_pixbuf_get_height(hgdiobj); + return ; + end + function GetIconInfo(hIcon:pointer; piconinfo:pointer):integer; + begin + //icoobj := new TSHICON(lpvObject); + //icoobj.bmwidth := gdk_pixbuf_get_width(hgdiobj); + //icoobj.bmheight := gdk_pixbuf_get_height(hgdiobj); + return ; + end + function CreateCompatibleDC(hdc :pointer):pointer; + begin + sf := cairo_image_surface_create(0,100,100); + r := cairo_create(sf); + return r; + return 0; + end + Function SetCursor(hd:pointer):pointer; + begin + global g_show_cursor_window; + if g_show_cursor_window and hd<>0 then + gdk_window_set_cursor(g_show_cursor_window,hd); + end + function drawbitmaptodc(bm,hdc,x,y,rc,flag,thdc); + begin + if not hdc then return ; + xb := gtk_object_get_data(hdc,"viewport.x"); + yb := gtk_object_get_data(hdc,"viewport.y"); + img := class(TGdiplusflat).GdipGetbmpSurface(bm); + //cairo_set_source(hdc, img); + //cairo_pattern_set_extend(cairo_get_source(hdc),1); + cairo_set_source_surface(hdc, img, x-rc[0], y-rc[1]); + cairo_rectangle(hdc,xb+x,yb+y,rc[2]-rc[0],rc[3]-rc[1]); + if flag = 0x8800c6 or flag = 0x4 then + begin + //echo "\r\nset alopha***********"; + //cairo_paint_with_alpha(hdc,0.5); + //cairo_set_source_rgba(hdc, 0.6, 0.6, 0.6, 0.5); + end else + begin + //cairo_paint_with_alpha(hdc,0); + //cairo_paint_with_alpha(hdc,1); + //cairo_set_source_rgba(hdc, 1.0, 1.0, 1.0, 0); + //cairo_fill(hdc); + end + cairo_fill(hdc); + //cairo_set_source_surface(hdc, img, x-rc[0], y-rc[1]); + end + function drawbitmapstretchtodc(bm,hdc,drect,rc,flag,thdc); + begin + if not hdc then return ; + xb := gtk_object_get_data(hdc,"viewport.x"); + yb := gtk_object_get_data(hdc,"viewport.y"); + img := class(TGdiplusflat).GdipGetbmpSurface(bm); + if not img then return ; + x := drect[0]; + y := drect[1]; + p1 := (drect[2]-drect[0])/(rc[2]-rc[0]); + p2 := (drect[3]-drect[1])/(rc[3]-rc[1]); + if p1<0 or p2<0 then return 0; + cairo_translate(hdc,xb+x,yb+y); + cairo_scale(hdc,p1,p2); + cairo_set_source_surface(hdc, img, 0, 0); + cairo_rectangle(hdc,0,0,rc[2]-rc[0],rc[3]-rc[1]); + if flag = 0x8800c6 or flag = 0x4 then + begin + //echo "\r\nset alopha*******+++****************"; + //cairo_paint_with_alpha(hdc,0.5); + //cairo_set_source_rgba(hdc, 0.6, 0.6, 0.6, 0.5); + end else + begin + //cairo_paint_with_alpha(hdc,0); + //cairo_paint_with_alpha(hdc,1); + //cairo_set_source_rgba(hdc, 1.0, 1.0, 1.0, 0); + + end + cairo_fill(hdc); + cairo_scale(hdc,1/p1,1/p2); + cairo_translate(hdc,0-xb-x,0-yb-y); + end + function DrawIcon(hDC:pointer;X:integer;Y:integer;hIcon:pointer):integer; + begin + if not hdc then return ; + xb := gtk_object_get_data(hdc,"viewport.x"); + yb := gtk_object_get_data(hdc,"viewport.y"); + img := class(TGdiplusflat).GdipGetbmpSurface(hIcon); + if not img then return 0; + cairo_set_source_surface(hdc, img, x+xb, y+yb); + cairo_paint(hdc); + return true; + end + //////////////////////imagelist///////////////////////////////////////////////////////////////////////// + function ImageList_Add(himl:pointer;hbmImage:pointer; hbmMask:pointer):integer; + begin + if not(himl>0 or himl<0) then return 0; + if not(hbmImage>0 or hbmImage<0) then return 0; + global g_image_list_caches ; + if not ifarray(g_image_list_caches) then g_image_list_caches := array(); + sptr := inttostr(himl); + obj := g_image_list_caches[sptr,"imglist"] ; + if not obj then return ; + class(TGdiplusflat).GdipCreateBitmapFromHBITMAP(hbmImage,r1,0); + global G_T_BITMAP_; + if G_T_BITMAP_ then + begin + bmp := createobject(G_T_BITMAP_); + bmp.Handle := r1; + obj.Push(bmp); + end + end + function ImageList_AddMasked(himl:pointer;hbmImage:pointer; crMask:integer):integer; + begin + return ImageList_Add(himl,hbmImage,crMask); + end + function ImageList_BeginDrag(himlTrack:pointer; iTrack:integer;x:integer;y:integer):integer; + begin + global g_gtk_drag_window,g_image_list_caches,g_gtk_dragxy ; + if not ifarray(g_image_list_caches) then return ; + if not(himlTrack>0 or himlTrack<0) then return ; + sptr := inttostr(himlTrack); + if not g_gtk_drag_window then + begin + g_gtk_drag_window := new tcustomcontrol(class(tUIglobalData).uigetdata("tuiapplication"));//createobject(G_T_TCUSTOMCONTROL_,class(tUIglobalData).uigetdata("tuiapplication")); + g_gtk_drag_window.color := rgb(180,180,180); + g_gtk_drag_window.Border := false; + g_gtk_drag_window.WsPopUp := true; + g_gtk_drag_window.Enabled := false; + g_gtk_drag_window.Visible := false; + end + cx := g_image_list_caches[sptr,"width"] ; + cy := g_image_list_caches[sptr,"height"] ; + obj := g_image_list_caches[sptr,"imglist"] ; + if not(cx>0 and cy>0) then return ; + if obj then + begin + g_gtk_drag_window.BKBitmap := obj[i]; + cx+=2; + cy+=2; + end + g_gtk_drag_window.SetBounds(0,0,cx,cy); + g_gtk_dragxy := array(x,y); + end + function ImageList_DragMove(x:integer;y:integer):integer; + begin + global g_gtk_drag_window,g_gtk_drag_lock_window,g_gtk_dragxy; + if not g_gtk_drag_window then return ; + xy := g_gtk_drag_lock_window.ClientToScreen(x,y); + SetWindowPos(g_gtk_drag_window.Handle,0,xy[0]-g_gtk_dragxy[0],xy[1]-g_gtk_dragxy[1],-1,-1,0); + end + function ImageList_DragEnter(hwndLock:pointer;x:integer;y:integer):integer; + begin + global g_gtk_drag_window,g_gtk_drag_lock_window; + if not g_gtk_drag_window then return ; + g_gtk_drag_lock_window := class(tUIglobalData).uigetdata("TGlobalComponentcache").getwndbyhwnd(hwndLock); + if not g_gtk_drag_lock_window then return ; + g_gtk_drag_window.Parent := g_gtk_drag_lock_window; + g_gtk_drag_window.Enabled := false; + ImageList_DragMove(x,y); + g_gtk_drag_window.show( 0x4); + end + function ImageList_DragLeave(hwndLock:pointer):integer; + begin + global g_gtk_drag_window,g_gtk_drag_lock_window; + g_gtk_drag_lock_window := nil; + if not g_gtk_drag_window then return ; + g_gtk_drag_window.show(0); + end + procedure ImageList_EndDrag(); + begin + //global g_gtk_drag_window; + //g_gtk_drag_window.show(0); + end + function ImageList_Create(cx:integer; cy:integer; flags:integer; cInitial:integer;cGrow:integer):pointer; + begin + global g_image_list_caches ; + if not ifarray(g_image_list_caches) then g_image_list_caches := array(); + ptr := new tcstring(8)._getptr_(); + sptr := inttostr(ptr); + g_image_list_caches[sptr,"width"] := cx; + g_image_list_caches[sptr,"height"] := cy; + g_image_list_caches[sptr,"flags"] := flags; + g_image_list_caches[sptr,"initial"] := cInitial; + g_image_list_caches[sptr,"grow"] := cGrow; + g_image_list_caches[sptr,"imglist"] := new tnumindexarray(); + return ptr; + end + function ImageList_Draw(himl:pointer;i:integer;hdcDst:pointer;x:integer;y:integer;fStyle:integer):integer; + begin + if not(himl>0 or himl<0) then return 0; + global g_image_list_caches ; + if not ifarray(g_image_list_caches) then return 0; + sptr := inttostr(himl); + obj := g_image_list_caches[sptr,"imglist"]; + if not obj then return ; + bmp := obj[i]; + if not bmp then return ; + cx := g_image_list_caches[sptr,"width"]; + cy := g_image_list_caches[sptr,"height"]; + drawbitmapstretchtodc(bmp.Handle,hdcDst,array(x,y,x+cx,y+cy),array(0,0,bmp.bmwidth,bmp.bmheight),fStyle,0); + end + function ImageList_Destroy(himl:pointer):integer; + begin + if not(himl>0 or himl<0) then return 0; + global g_image_list_caches ; + if not ifarray(g_image_list_caches) then return 0; + reindex(g_image_list_caches,array(inttostr(himl):nil)); + end + function ImageList_Replace(himl:pointer;id:integer;hbmImage:pointer; hbmMask:pointer):integer; + begin + if not(himl>0 or himl<0) then return 0; + if not(hbmImage>0 or hbmImage<0) then return 0; + global g_image_list_caches ; + if not ifarray(g_image_list_caches) then return 0; + obj := g_image_list_caches[inttostr(himl),"imglist"]; + if not obj then return ; + global G_T_BITMAP_; + if not G_T_BITMAP_ then return 0; + class(TGdiplusflat).GdipCreateBitmapFromHBITMAP(hbmImage,0,r1); + + bmp := createobject(G_T_BITMAP_); + bmp.Handle := r1; + if id=-1 then obj.Push(bmp); + else + obj.splice(id,1,bmp); + end + function ImageList_Remove(himl:pointer;id:integer):integer; + begin + if not(himl>0 or himl<0) then return 0; + global g_image_list_caches ; + if not ifarray(g_image_list_caches) then return 0; + obj := g_image_list_caches[inttostr(himl),"imglist"]; + if not obj then return ; + if id=-1 then obj.pop(); + else + obj.splice(id,1); + end + function ImageList_SetBkColor(himl:pointer;clrBk:integer):integer; + begin + + end + function ImageList_LoadImageA2(hi:pointer;lpbmp:pointer;cx:integer;cGrow:integer; crMask:integer;uType:integer;uFlags:integer):pointer; + begin + + end + function ImageList_GetBkColor(himl:pointer):integer; + begin + + end + function ImageList_GetDragImage(ppt:pointer;pptHotspot:pointer):pointer; + function ImageList_GetImageCount(himl:pointer):integer; + begin + if not(himl>0 or himl<0) then return 0; + global g_image_list_caches ; + if not ifarray(g_image_list_caches) then return 0; + obj := g_image_list_caches[inttostr(himl),"imglist"]; + if not obj then return 0; + return obj.length(); + end + function ImageList_SetImageCount(himl:pointer;clrBk:integer):integer; + function ImageList_Copy(himlDst:pointer;iDst:integer; himlSrc:pointer;iSrc:integer;uFlags:integer):integer; + function ImageList_Duplicate(himl:pointer):pointer; + function ImageList_Merge(himl1:pointer;i1:integer;himl2:pointer;i2:integer;dx:integer;dy:integer):pointer; + function ImageList_SetDragCursorImage(himlDrag:pointer;iDrag:integer;dxHotspot:integer;dyHotspot:integer):integer; + function ImageList_GetImageInfo(himl:pointer; i:integer;pImageInfo:pointer):integer; + begin + + end + function ImageList_ReplaceIcon(himl:pointer;i:integer;hicon:pointer):integer; + begin + return ImageList_Replace(himl,i,hicon,0); + end + function ImageList_SetIconSize(himl:pointer;cx:integer;cy:integer):integer; + function ImageList_GetIconSize(himl:pointer;var cx:integer;var cy:integer):integer; + begin + global g_image_list_caches ; + if not ifarray(g_image_list_caches) then return 0; + sptr := inttostr(himl); + cx := g_image_list_caches[sptr,"width"]; + cy := g_image_list_caches[sptr,"height"]; + return 1; + end + function ImageList_GetIcon(himl:pointer;i:integer;flags:integer):pointer; + begin + if not(himl>0 or himl<0) then return 0; + global g_image_list_caches ; + if not ifarray(g_image_list_caches) then return 0; + obj := g_image_list_caches[inttostr(himl),"imglist"]; + if not obj then return ; + r := obj[i]; + if r then return r.Handle; + return 1; + end + function ImageList_DrawIndirect(pimldp:pointer):pointer; + function ImageList_DragShowNolock(fShow:integer):integer; + ////////////////////////////////////////////////////// + ////////////////////////clipboard//////////////////////////////////////// + function OpenClipboard(h); + begin + return true; + end + function EmptyClipboard(); + begin + + end + function CloseClipboard(); + begin + return true; + end + function IsClipboardFormatAvailable(fmt); + begin + return true; + end + function getclipboardtext(clpd); + begin + c := gtk_clipboard_get(69); + r := gtk_clipboard_wait_for_text(c); + if r then r := GtkStringToTsl(r); + //echo "\r\ncop wire:",writefile(rwraw(),"","/tmp/test12.txt",0,length(r),r); + + return r; + end + function setclipboardtext(clbd,s); + begin + c := gtk_clipboard_get(69); + if ifstring(s) and s then + begin + gs := TslStringToGtk(s); + return gtk_clipboard_set_text(c,gs,length(gs)); + end else + if ifnil(s) then gtk_clipboard_set_text(c,"",0); + return 1; + end + function getclipboardbmp(); + begin + return 0; + end + function setclipboardbmp(); + begin + return false; + end +//////////////////////////////////////end clip board ////////////////////////////////// + +//////////////////////////////timmer////////////////// + class function SetTimer(hWnd:pointer; nIDEvent:pointer; uElapse:integer;lpTimerFunc:pointer):integer; + begin + global g_gtk_ttimer_cache; + if not ifarray(g_gtk_ttimer_cache) then g_gtk_ttimer_cache := array(); + + obj := new ttmstruct(nil);//tslcstructure(sc); sc := array((0,"int",0),(1,"int",0)); + rt := g_timeout_add(uElapse,lpTimerFunc,obj._getptr_() ); + g_gtk_ttimer_cache[rt] := obj; + obj._setvalue_(0,rt); + return rt; + + end + class function KillTimer(hWnd:pointer; nIDEvent:pointer):integer; + begin + global g_gtk_ttimer_cache; + if not ifarray(g_gtk_ttimer_cache) then return 0; + obj := g_gtk_ttimer_cache[nIDEvent] ; + g_source_remove(obj._getvalue_(0)); + reindex(g_gtk_ttimer_cache,array(nIDEvent:nil)); + return true; + end + //////////////////////////////////////////////////////////////////// + + function GetOpenFileNameA(LPOPENFILENAMEA:pointer):integer; + begin + + r := GetSaveFileNameA(LPOPENFILENAMEA); + + return r; + end + function GetSaveFileNameA(LPOPENFILENAMEA:pointer):integer; + begin + global g_open_file_flag; + r := false; + obj := new TtagOFNA_(LPOPENFILENAMEA); + wd := obj._getvalue_("hwndowner"); + wd := wd?:nil; + if wd then wd := gtk_widget_get_toplevel(wd); + mulsel := false; + if obj._getvalue_("flags") .& 0x200 then mulsel := true; + //echo "\r\n>>>", obj._getvalue_("nmaxfiletitle"); + if mulsel then + begin + cdlg := gtk_file_chooser_dialog_new("file selector",wd,0,"open",100,"cancel",50,nil); + gtk_file_chooser_set_select_multiple(cdlg,true); + end else + begin + cdlg := gtk_file_chooser_dialog_new("file selector",wd,1,"open",100,"cancel",50,nil); + end + dfdir := obj._getvalue_("lpstrinitialdir"); + if dfdir then //默认位置 + begin + df := ReadStringFromPtr(dfdir); + if df then + begin + gtk_file_chooser_set_filename(cdlg,TslStringToGtk( df)); + end + end + if 100=gtk_dialog_run(cdlg)then + begin + mf := obj._getvalue_("nmaxfile"); + if mulsel then + begin + gfs := gtk_file_chooser_get_filenames(cdlg); + gf := ""; + ff1 := true; + fodpos := 0; + ffd := "/"; + while gfs do + begin + if mf1 then + ffd := dts[1:fodpos-1]; + else ffd := "/"; + gf :=ffd; + gf+="\0"; + end + if fodpos 1 then + begin + bts := ReadBytesFromPtr(obj._getvalue_("lpstrfilter"),obj._getvalue_("nmaxfiletitle")); + fndx := ""; + for i ,v in bts do + begin + if bts[i]=0 and bts[i+1]=0 then break; + fndx+=chr(bts[i]); + end + stp := str2array(fndx,"\0")[fidx*2-1]; + for i := length(stp) downto 1 do + begin + if stp[i] = "." then + begin + stype := stp[i:]; + end + end + for i := length(gf) downto 1 do + begin + gfi := gf[i]; + if gfi="/" then + begin + gf+=stype; + break; + end else + if gfi = "." then + begin + break; + end + end + end + end + if gf then + begin + gf := GtkStringToTsl( gf); + fptr := obj._getvalue_("lpstrfile"); + bts := zeros(length(gf)+1); + for i := 1 to length(gf) do + begin + bts[i-1] := ord(gf[i]); + end + WriteBytesToPtr(fptr,bts); + r := true; + end + end + gtk_widget_destroy(cdlg); + return r; + end + function ChooseFontA(LOGFONTA:pointer):integer; + begin + + obj := new ttagCHOOSEFONTA(LOGFONTA); + lgobj := obj._getvalue_("lplogfont"); + ht := lgobj._getvalue_("height"); + hts := ""; + if ht>5 then hts := inttostr(ht); + ss := lgobj._getvalue_("facename")+" "+(lgobj._getvalue_("italic")?"Italic":"")+" "+((lgobj._getvalue_("weight")=700)?"Bold":"") + " "+ hts;; + cdlg := gtk_font_selection_dialog_new("font select"); + gtk_font_selection_dialog_set_preview_text(cdlg,"test fonttext"); + gtk_font_selection_dialog_set_font_name(cdlg,TslStringToGtk(ss)); + if gtk_dialog_run(cdlg)=-5 then //确定 + begin + s := GtkStringToTsl( gtk_font_selection_dialog_get_font_name(cdlg)); + fns := static pango_font_family_get_names(); + for i,v in fns do + begin + if pos(v,s)=1 then + begin + lgobj._setvalue_("facename",GtkStringToTsl(v)); + if pos("Italic",s) then + begin + lgobj._setvalue_("italic",1); + end else + begin + lgobj._setvalue_("italic",0); + end + if pos("Bold",s) then + begin + lgobj._setvalue_("weight",700); + end else + begin + lgobj._setvalue_("weight",400); + end + nms := inttostr(0->9); + for j := 1 to length(s) do + begin + if s[j] in nms then + begin + nm := s[j]; + for jj:= j+1 to length(s) do + begin + if s[jj] in nms then + begin + nm+=s[jj]; + end else break; + end + break; + end + end + if nm then + begin + ht := strtoint(nm); + lgobj._setvalue_("height",ht); + lgobj._setvalue_("width",integer(ht/2)); + end + break; + end + end + r := true; + end + gtk_widget_destroy(cdlg); + return r; + end + function ChooseColorA(LOGFONTA:pointer):integer;//颜色选择 + begin + obj := new ttagCHOOSECOLORA(LOGFONTA); + cdlg := gtk_color_selection_dialog_new("color select dialog"); + btnptr := tsl_gtk_color_selection_property(cdlg); //获得位置 + //cpbtns := tslcstructure(array((0,"intptr",0)),nil,nil,btnptr); + cpbtns := new Tintptr(btnptr); + cbtnobj := cpbtns._getvalue_(0); + color := new _GdkColor(); + rc := obj.rgbresult ; + rcs := array(getrvalue(rc),getgvalue(rc),getbvalue(rc)); + color.setrgb((_shl( rcs[0],8)),(_shl(rcs[1],8)),(_shl( rcs[2],8))); + gtk_color_selection_set_current_color(cbtnobj,color._getptr_()); + r := gtk_dialog_run(cdlg); + //rt := Gtk_dlg_get_response_name_by_id(r); + gtk_color_selection_get_current_color(cbtnobj,color._getptr_()); + obj.rgbresult := rgb( _shr(color.r,8),_shr(color.g,8),_shr(color.b,8)); + gtk_widget_destroy(cdlg); + return r=-5; + end + + function SHBrowseForFolderA(LPITEMIDLIST:pointer):pointer; + begin + obj := new TBrowseinfoA_(LPITEMIDLIST); + wd := obj._getvalue_("hwndowner"); + wd := wd?:nil; + if wd and not(gtk_widget_is_toplevel(wd)) then wd := gtk_widget_get_toplevel(wd); //top level + r := 0; + cdlg := gtk_file_chooser_dialog_new("folder selector",wd,3,"open",100,"cancel",50,nil); + dir := obj._getvalue_("pidlroot"); + if dir then //默认位置 + begin + df := ReadStringFromPtr(dir); + if df then + begin + gtk_file_chooser_set_filename(cdlg,TslStringToGtk( df)); + end + end + if 100=gtk_dialog_run(cdlg) then + begin + r := GtkStringToTsl( gtk_file_chooser_get_filename(cdlg)); + end + gtk_widget_destroy(cdlg); + return r; + + end + function SHGetPathFromIDListA(LPBROWSEINFOA:pointer;var buf:string ):integer; + begin + for i := 1 to length(LPBROWSEINFOA) do + begin + buf[i] := LPBROWSEINFOA[i]; + end + buf[i+1] := 0; + return true; + end + function ILCreateFromPathA(pszPath:string):pointer; + begin + mt := static new aefclassobj_(); + len := length(pszPath)+1; + bts := zeros(n); + for i:= 1 to len-1 do bts[i-1] :=ord(pszPath[i]); + r := mt.tmalloc(len); + WriteBytesToPtr(r,bts); + return r; + end + procedure ILFree(pidl:pointer); + begin + mt := static new aefclassobj_(); + mt.tfree(pidl); + end + //caret 插入符号 处理 + function CreateCaret(hWnd :pointer;hBitmap:pointer;nWidth:integer;nHeight:integer):integer; + begin + if not(hwnd>0 or hwnd<0) then return 0; + global g_gtk_caret_cache_timer; //缓存 + if not g_gtk_caret_cache_timer then + begin + global G_T_TTIMER_; + if not G_T_TTIMER_ then return 0; + g_gtk_caret_cache_timer := createobject(G_T_TTIMER_,nil); + g_gtk_caret_cache_timer.Interval := 680; + g_gtk_caret_cache_timer.Ontimer := function(o,e)begin + global g_current_get_focus_widget; + h := g_current_get_focus_widget; + if not h then return ; + if not g_object_get_data(h,"caretshow") then return ; + ct := g_object_get_data(h,"gtk_window_caret"); + //if not gtk_widget_is_visible(ct) then gtk_widget_show(ct); + //return ; + if gtk_widget_is_visible(ct) then gtk_widget_hide(ct); + else + gtk_widget_show(ct); + end + g_gtk_caret_cache_timer.start(); + end + h := g_object_get_data(hwnd,"gtk_window_caret"); //获得caret + if not h then + begin + h := gtk_event_box_new(); + c := new _GdkColor(nil); + c.SetRgb(0,0,0); + gtk_widget_modify_bg(h,0,c._getptr_()); + gtk_widget_hide(h); + lot := g_object_get_data(hWnd,"gtk_layout"); + g_object_set_data(hwnd,"gtk_window_caret",h); + //g_object_set_data(h,"gtk_caret_window",hwnd); //所属窗口 + gtk_layout_put(lot,h,0,0); //位置 + end + if nWidth>=0 and nHeight>=0 then + gtk_widget_set_size_request(h,nWidth,nHeight); + //g_gtk_caret_cache_caret := h; + return h; + end + function DestroyCaret():integer; + begin + global g_current_get_focus_widget; + hwnd := g_current_get_focus_widget; + if not(hwnd>0 or hwnd<0) then return ; + if not IsGtkWidget(hwnd) then return ; + g_object_set_data(hwnd,"caretshow",0); + ct := g_object_get_data(hwnd,"gtk_window_caret"); + if IsGtkWidget(ct) then + begin + gtk_widget_hide(ct); + end + return ; + // 获得focus + end + function SetCaretPos(x:integer;y:integer):integer; + begin + global g_current_get_focus_widget; + hwnd := g_current_get_focus_widget; + if IsGtkWidget(hwnd) then + begin + lot := g_object_get_data(hwnd,"gtk_layout"); + crt := g_object_get_data( hwnd,"gtk_window_caret"); + if lot and crt then + begin + gtk_layout_move(lot,crt,x,y); + gtk_object_set_data(hwnd,"caret_x_pos",x); + gtk_object_set_data(hwnd,"caret_y_pos",y); + end + + end + return ; + end + function GetCaretPos(lp:array of integer):integer; + begin + global g_current_get_focus_widget; + hwnd := g_current_get_focus_widget; + if IsGtkWidget(hwnd) then + begin + x := gtk_object_get_data(hwnd,"caret_x_pos"); + y := gtk_object_get_data(hwnd,"caret_y_pos"); + lp := array(x,y); + end + lp := array(0,0); + return ; + end + function HideCaret(hwnd :pointer):integer; + begin + // 获得focus widget + if not(hwnd>0 or hwnd<0) then return ; + if not IsGtkWidget(hwnd) then return ; + ct := g_object_get_data(hwnd,"gtk_window_caret"); + g_object_set_data(hwnd,"caretshow",0); + if IsGtkWidget(ct) then + begin + gtk_widget_hide(ct); + end + return ; + end + function ShowCaret(hwnd :pointer):integer; + begin + if not(hwnd>0 or hwnd<0) then return ; + if not IsGtkWidget(hwnd) then return ; + g_object_set_data(hwnd,"caretshow",1); + return 1; + end + function GetCaretBlinkTime():integer; + begin + end + function SetCaretBlinkTime(uMSeconds :integer):integer; + begin + end + Function WinExec(lpCmdLine:string;nCmdShow:integer):integer; + begin + + end; + function SetForegroundWindow(hwd :pointer):integer; + begin + end + function Shell_NotifyIconA(dwMessage:integer; lpData:pointer):integer; + begin + end + function BringWindowToTop(hwd :pointer); + begin + end + //socket + function socket(af:integer;tp:integer;protocol:integer):pointer;begin end + function WSAStartup(af:SHORT;DA:pointer):integer;begin end + function WSACleanup():integer;begin end + function htonl(hostlong:integer):integer;begin end + function htons(hostshort:short):short;begin end + function ntohs(hostshort:short):short;begin end + function bind(s:pointer;name:pointer;len:integer):integer;begin end + function accept(s:pointer;name:pointer;var len:integer):pointer;begin end + function send(s:pointer;bufer:string;len:integer;flag:integer):integer;begin end + function recv(s:pointer;var bufer:string;len:integer;flag:integer):integer;begin end + function listen(s:pointer;port:integer):integer;begin end + function closesocket(s:pointer):integer;begin end + function connect(s:pointer;name:pointer;len:integer):integer;begin end + function inet_addr(s:string):integer;begin end + function WSAGetLastError():integer;begin end + function inet_ntoa(ad:integer):string;begin end + function shutdown(s:pointer;how:integer):integer;begin end + function WSAAsyncSelect(s:pointer;hWnd:pointer;wMsg:integer;lEvent:integer):integer;begin end + function ioctlsocket(s:pointer;cmd:integer;var argp:integer):integer;begin end + function setsockopt(s:pointer;level:integer;optname:integer;optval:string;optlen:integer):integer;begin end + function getsockopt(s:pointer;level:integer;optname:integer;var optval:string;var optlen:integer):integer;begin end +end + + +implementation +function gettswin32api(); +begin + global G_O_TSWIN32API_; + return G_O_TSWIN32API_; +end +/////////////////////////////////////////////////////////////////////////// +type TGtkList = class( _gslist) //gtk链表类 + function create(ptr); + begin + inherited; + end +end +type ttmstruct=class(tslcstructureobj) + {** + @explan(说明)矩形区域内存分配 %% + **} + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + (0,"int",0), + (1,"int",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end +end +type Tintptr=class(tslcstructureobj) + {** + @explan(说明)矩形区域内存分配 %% + **} + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + (0,"intptr",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end +end type tmenuitemobject = class(tgtk_ctl_object) //gtk菜单对象类 function create(h); begin @@ -246,6 +2862,10 @@ type tgtkapis = class() //gtk begin return class(tgtk_ctl_object).executeMessageA(h,msg,w,l); end + function gtk_addMessageQueue(FHandle,msg,wparam,lparam,d); + begin + return AddMessageToGtkMessageQueue(FHandle,msg,wparam,lparam,d); + end function gtk_GetKeyState(key); //按键状态 begin global g_gtk_keytable; @@ -386,7 +3006,7 @@ type tgtkapis = class() //gtk begin lcl := lowercase(cl); cs := GetGtkwindowclass(lcl); - d := new taggtkWNDCLASSA(lpwcx); + d := new tagWNDCLASSA(lpwcx); if cs then begin for i,v in cs do @@ -399,7 +3019,7 @@ type tgtkapis = class() //gtk end function gtk_RegisterClassExA(lpwcx);//注册信息 begin - d := new taggtkWNDCLASSA(lpwcx); + d := new tagWNDCLASSA(lpwcx); reggtkwindowclass(d._getdata_()); return true; end @@ -1561,7 +4181,7 @@ type ttgtk_pen=class(tslcstructureobj) function create(ptr) begin inherited create(getstruct(),ptr); - _wapi := unit(tslvcl).gettswin32api(); + _wapi := gettswin32api(); end function destroy();override; begin @@ -1590,7 +4210,7 @@ type ttgtk_brush=class(tslcstructureobj) function create(ptr) begin inherited create(getstruct(),ptr); - _wapi := unit(tslvcl).gettswin32api(); + _wapi := gettswin32api(); end function destroy();override; begin @@ -1630,7 +4250,7 @@ type ttgtk_font=class(tslcstructureobj) function create(ptr) begin inherited create(getstruct(),ptr); - _wapi := unit(tslvcl).gettswin32api(); + _wapi := gettswin32api(); end function destroy();override; begin @@ -1656,9 +4276,6 @@ type ttgtk_font=class(tslcstructureobj) _wapi; end -implementation -/////////////////////////////////////////////////////////////////////////// - //////////////////////////////////////////额外定义的结构体 为了适应windows api/////////////////////////////////////////// @@ -1809,12 +4426,14 @@ type tenterouterlist = class end function create(api); begin + global G_T_TTIMER_; + if not G_T_TTIMER_ then return ; _wapi := api; FCpos := array(0,0); _wapi.GetCursorPos(FCpos); FList := array(); FIndex := -1; - FTimer := new unit(tslvcl).TTimer(); + FTimer := createobject(G_T_TTIMER_,nil); FTimer.interval := 30; //30毫秒 FTimer.Ontimer := thisfunction(MouseIsMoved); FTimer.start(); @@ -1858,7 +4477,7 @@ type tgtk_ctl_object = class(_gtkeventtype) if not _wapi then begin _const := getwin32const(); - _wapi := unit(tslvcl).gettswin32api(); + _wapi := gettswin32api(); FMousemoveernotify := new tenterouterlist(_wapi); FMousemoveernotify.Mousemovecall := thisfunction(widgetmousemovecall); FMousemoveernotify.Mousehittest := thisfunction(widgetmousehit); @@ -1917,7 +4536,11 @@ type tgtk_ctl_object = class(_gtkeventtype) return AddMessageToGtkMessageQueue(FHandle,msg,w,l,p); end else begin - r := unit(tslvcl)._twinproc_(FHandle,msg,w,l); + global G_F_TWIN_PROC_; + if G_F_TWIN_PROC_ then + begin + r := call(G_F_TWIN_PROC_,FHandle,msg,w,l); + end if msg = CM_CURSORCHANGED then begin if l<>0 and w<>0 then @@ -1954,7 +4577,7 @@ type tgtk_ctl_object = class(_gtkeventtype) rsz := _wapi.gtk_object_get_data(FHandle,"gtk_widget_resizeable"); if rsz then begin - unit(tslvcl).lowuperdword(l,lo,hi); + lowuperdword(l,lo,hi); ht := _wapi.hittestwidget(FHandle,lo,hi); FHitwidgetposition := ht; if ht=10 or ht=11 then @@ -2331,7 +4954,9 @@ type tgtk_ctl_object = class(_gtkeventtype) fcsctl := _wapi.gtk_window_get_focus(ah); if not fcsctl then begin - fcsctl := unit(tslvcl).initializeapplication().handle; //用主窗口的 + obj := class(tUIglobalData).uigetdata("tuiapplication"); + if obj then fcsctl := obj.handle; + else fcsctl := 0; if not fcsctl then return true; end fcsctl := TGtkObjects[inttostr(fcsctl)] ; @@ -3252,9 +5877,13 @@ type tgtk_ctl_scroll_window = class(tgtk_ctl_object) end; function CreateWnd(dwExStyle,lpClassName,lpWindowName,dwStyle,x,y,nwidth,nheight,hwndparent,hmenu,hinstance,lpParam);override; begin + global G_F_CONTROL_IS_CUSTOMPAINT; //echo "\r\nctl:",tostn(params),tostn(__stack_frame),datetimetostr(now()); d := new tslcstructureobj(MemoryAlignmentCalculate( array(("lpcreateparams","intptr",0))),lpParam); - isp := unit(tslvcl).controlisCustomPaint(d._getvalue_("lpcreateparams")); + if G_F_CONTROL_IS_CUSTOMPAINT then + begin + isp := call(G_F_CONTROL_IS_CUSTOMPAINT,d._getvalue_("lpcreateparams")); + end h := self.handle; {if (_const.WS_BORDER .& dwStyle)=_const.WS_BORDER then begin @@ -3953,12 +6582,12 @@ begin //定时处理 AddMessageToGtkMessageQueue(h,m,w,l,0x113); end -function hasMessageFromGtkMessageQueue(h,m); +function hasMessageFromGtkMessageQueue(h,m); //是否存在消息 begin GLobal G_GTK_MESSAGE_QUEUE_A; if G_GTK_MESSAGE_QUEUE_A then G_GTK_MESSAGE_QUEUE_A.haseasyLostMessage(h,m); end -function clearMessageFromGtkMessageQueue(h,m); +function clearMessageFromGtkMessageQueue(h,m); //清除消息 begin GLobal G_GTK_MESSAGE_QUEUE_A; if G_GTK_MESSAGE_QUEUE_A then G_GTK_MESSAGE_QUEUE_A.cleaneasyLostMessage(h,m); @@ -3972,7 +6601,7 @@ begin end G_GTK_MESSAGE_QUEUE_A.add(FHandle,msg,wparam,lparam,d); end -function FeachMessageFromGtkMessageQueue(); //获取消息 +function FeachMessageFromGtkMessageQueue(); //获取最后的事件 begin GLobal G_GTK_MESSAGE_QUEUE_A; if G_GTK_MESSAGE_QUEUE_A then @@ -4020,7 +6649,7 @@ begin end function callpaintmessage(d); begin - _wapi := unit(tslvcl).gettswin32api(); + _wapi := gettswin32api(); _const := GetWin32Const(); r := zeros(4); hd := d[0]; @@ -4068,14 +6697,15 @@ begin end } if d[4]=0x113 and d[0]=0 then //定时 begin - unit(tslvcl)._timeproc_(d[0],d[1],d[2],d[3]); + global G_F_TIME_PROC_; + if G_F_TIME_PROC_ then call(G_F_TIME_PROC_,d[0],d[1],d[2],d[3]); end else if d[0] then begin r := class(tgtk_ctl_object).CallGtkWinProc(d[0],d[1],d[2],d[3]); if r=0 and d[1]= 0x007B then //处理 contextmenu消息 begin - _wapi := unit(tslvcl).gettswin32api(); + _wapi := gettswin32api(); h := _wapi.GetParent(d[0]); if h then begin @@ -4175,34 +6805,6 @@ type tmenuStruct = class(tslcstructureobj)// property ftype:integer index "ftype" read _getvalue_ write _setvalue_; property fstate:integer index "fstate" read _getvalue_ write _setvalue_; end - type taggtkWNDCLASSA = class(tslcstructureobj)// 窗口类对象 %% - static classstruct; - class function getstruct(); - begin - if not classstruct then - begin - classstruct := MemoryAlignmentCalculate( array( - ("cbsize","int",0), - ("style","int",0), - ("lpfnwndproc","intptr",0), - ("cbclsextra","int",0), - ("cbwndextra","int",0), - ("hinstance","intptr",0), - ("hicon","intptr",0), - ("hcursor","intptr",0), - ("hbrbackground","intptr",0), - ("lpszmenuname","intptr",0),//("lpszmenuname","char*",100), - ("lpszclassname","char*",100), - ("hiconsm","intptr",0))); - end - return classstruct; - end - function create(ptr); - begin - class(tslcstructureobj).create(getstruct(),ptr); - _setvalue_("cbsize",_size_()); - end - end function GetGtkwindowclass(n);//获得窗口类 begin global G_GTK_WINDOW_CLASSINFO; @@ -4218,12 +6820,9 @@ begin end function GetWin32Const(); //获得win32常量 begin - return static new unit(tslvcl).TSLUIBASE(); -end -function makelong(l,h,p); -begin - return unit(tslvcl).makelong(l,h,p); + return static new TSLUICONST(); end + function tsl_gtk_get_thread(); begin return static systhreadid(); diff --git a/funcext/tvclib/utslmemo.tsf b/funcext/tvclib/utslmemo.tsf index 8f894fc..a33a860 100644 --- a/funcext/tvclib/utslmemo.tsf +++ b/funcext/tvclib/utslmemo.tsf @@ -3,7 +3,7 @@ unit UTslMemo; @explan(说明) 文本控件库 %% **} interface -uses TslVcl; +uses utslvclauxiliary,utslvclgdi,utslvclstdctl; type TMemoLineItem=class function Create(s); begin @@ -18,11 +18,11 @@ type TMemoLineItem=class FStr; end -TYPE TMemoLineList=class(TMyArrayB) +TYPE TMemoLineList=class(tnumindexarray) function Create(Aedit);override; begin FEdit := Aedit; - class(TMyArrayB).create(); + class(tnumindexarray).create(); FRowMaxLength := 1; Flock := true; end @@ -236,7 +236,7 @@ type TTslMenoUndoList=class() //undolist function Create(); begin fLockCount := 0; - fItems := new TMyArrayB(); + fItems := new tnumindexarray(); fMaxUndoActions := 1024; fBlockChangeNumber := 0; fNextChangeNumber := 1; @@ -1716,7 +1716,7 @@ type TCustomMemo = class(TCustomScrollControl,TCustomMemoCmd) begin if not FCopyer then begin - FCopyer := new TClipBoard(self); + FCopyer := new TcustomClipBoard(self); end FCopyer.text := r; return true; @@ -1727,7 +1727,7 @@ type TCustomMemo = class(TCustomScrollControl,TCustomMemoCmd) //if ReadOnly then return ; if not FCopyer then begin - FCopyer := new TClipBoard(self); + FCopyer := new TcustomClipBoard(self); end //s := FCopyer.Text; //echo length(s),"\r\n"; @@ -2296,7 +2296,7 @@ type TCustomMemo = class(TCustomScrollControl,TCustomMemoCmd) return array(ncy,ncx); end end -type TSynCompletionList = class(TListBox) //展示list +type TSynCompletionList = class(TcustomListBox) //展示list function Create(AOwner);override; begin inherited; @@ -2412,7 +2412,7 @@ type TSynCompletion = class(TSynCompletionList) it := GetItem(GetCurrentSelection()); if it then begin - callDatafunction(OnJumpChoosed,self.Owner,it); + CallMessgeFunction(OnJumpChoosed,self.Owner,it); end end function CancelJump(); //取消选中 @@ -2932,7 +2932,7 @@ type TSynCustomMemo = class(TCustomMemo) inherited; if e.Button() = mbRight then begin - calldatafunction(OnRClick,o,e); + CallMessgeFunction(OnRClick,o,e); end end function ExecuteCommand(cmd,data);override; @@ -3456,6 +3456,40 @@ 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. diff --git a/funcext/tvclib/utslvclaction.tsf b/funcext/tvclib/utslvclaction.tsf new file mode 100644 index 0000000..f3ed799 --- /dev/null +++ b/funcext/tvclib/utslvclaction.tsf @@ -0,0 +1,545 @@ +unit utslvclaction; +{** + @explan(说明) action 接口库 +**} +interface +uses utslvclauxiliary,utslvclbase; +type TBasicAction=class(TComponent) + private + FActionComponent:TComponent; //执行的tcomponent + FOnChange:TNotifyEvent; + FOnExecute:TNotifyEvent; + FOnUpdate:TNotifyEvent; + FParent; + function SetParent(p); + begin + if FParent <> p then + begin + if FParent is class(TActionList)then + begin + FParent.DeleteAction(self); + end + if p is class(TActionList)then + begin + p.AddAction(self); + end + Fparent := p; + end + end + protected FClients; + {** + @param(FClients)( TFpList of TActionLink) 关联的组件 %% + **} + procedure Change;virtual; + begin + if datatype(FOnChange)=7 then call(FOnChange,self); + end + procedure SetOnExecute(Value:TNotifyEvent);virtual; + begin + for i := 0 to FClients.count-1 do + begin + FClients[i].SetOnExecute(value); + end + FOnExecute := Value; + Change(); + end + public + function Create(AOwner:TComponent);override; + begin + inherited; + FClients := new TFpList(); + end + function Recycling();override; + begin + if FActionComponent then + begin + FActionComponent.RemoveFreeNotification(self); + end + while FClients.Count>0 do + begin + UnRegisterChanges(FClients.Last()); + end + inherited; + end + function Destroy();override; + begin + inherited; + end + function HandlesTarget(Target:TObject):Boolean;virtual; + begin + return false; + end + procedure UpdateTarget(Target:TObject);virtual; + begin + end + procedure ExecuteTarget(Target:TObject);virtual; + begin + end + function Execute():Boolean;virtual; + begin + if csDesigning in ComponentState then return ; + if FOnExecute then + begin + e := new tuieventbase(0,0,0,0); + if datatype(FOnExecute)=7 then call(FOnExecute,self(true),e); + return true; + end + return false; + end + procedure RegisterChanges(Value:TBasicActionLink); + begin + Value.FAction := Self(true); + FClients.add(Value); + end + procedure UnRegisterChanges(Value:TBasicActionLink); + begin + for i := 0 to FClients.count-1 do + begin + if FClients[i]=Value then + begin + Value.FAction := nil; + FClients.deli(i); + break; + end + end + end + function Notification(AComponent,Operation);override; + begin + inherited; + if Operation=opRemove and AComponent=FActionComponent then + begin + FActionComponent := nil; + if FParent is class(TActionList)then + begin + FParent.DeleteAction(self); + end + end + end + function SetActionComponent(Value); + begin + if FActionComponent <> Value then + begin + if FActionComponent is class(TComponent)then FActionComponent.RemoveFreeNotification(self); + FActionComponent := Value; + if FActionComponent is class(TComponent)then FActionComponent.FreeNotification(self); + end + end + property ActionComponent:TComponent read FActionComponent write SetActionComponent; + property onexecute:eventhandler read FOnExecute write SetOnExecute; + property OnUpdate:TNotifyEvent read FOnUpdate write FOnUpdate; + property OnChange:TNotifyEvent read FOnChange write FOnChange; + property parent read FParent Write SetParent; + {** + @param(OnExecute)(fpointer) 执行回调 %% + @param(OnUpdate)(fpointer) 更新回调 %% + @param(OnChange)(fpointer) 改变回调 %% + **} + +end; +type TContainedAction=class(TBasicAction) + function create(AOwner);override; + begin + inherited; + end + function Destroy();override; + begin + inherited; + end +end + + +type TCustomAction=class(TContainedAction) + {** + @explan(说明) action类 %% + **} + private + FCaption:string; + FChecked:Boolean; + FChecking:Boolean; + FEnabled:Boolean; + FGroupIndex:Integer; + FHint:string; + FVisible:Boolean; + FShortCut; + procedure SetCaption(const Value:string); + begin + if Value=FCaption then exit; + for I := 0 to FClients.Count-1 do + begin + FClients[I].SetCaption(Value); + end + FCaption := Value; + Change(); + end + procedure SetChecked(Value:Boolean); + begin + if Value=FChecked then exit; + for I := 0 to FClients.Count-1 do + begin + FClients[I].SetChecked(Value); + end + FChecked := Value; + Change(); + end + procedure SetEnabled(Value:Boolean); + begin + nValue := Value?true:false; + if nValue=FEnabled then exit; + for I := 0 to FClients.Count-1 do FClients[I].SetEnabled(nValue); + FEnabled := nValue; + Change(); + end + procedure SetVisible(Value:Boolean); + begin + nValue := Value?true:false; + if nValue=FVisible then exit; + for I := 0 to FClients.Count-1 do FClients[I].SetVisible(nValue); + FVisible := nValue; + Change(); + end + function getShortCut(); + begin + return formatshortcut(FShortCut); + end + + function SetShortCut(v); + begin + if v and ifstring(v) then + begin + nst := parsershortcutstr(v); + end else nst := nil; + if nst <> FShortCut then + begin + FShortCut := nst; + + for I := 0 to FClients.Count-1 do + begin + FClients[I].SetShortCut(v); + end + Change(); + end + end + protected + procedure AssignTo(Dest:TPersistent);override; + begin + {** + @explan(说明) 赋值 %% + **} + if Dest=Self then exit; + if Dest is class(TCustomAction)then + begin + ps := array("checked","caption","visible","enabled","shortcut"); + for i,v in ps do invoke(Dest,v,1,invoke(self,v)); + end else + inherited; + end + public + function Create(AOwner:TComponent);override; + begin + {** + @explan(说明) 构造 %% + **} + inherited; + FEnabled := True; + FVisible := True; + end + function Recycling();override; + begin + inherited; + end + function Destroy;override; + begin + inherited; + end + function ExecuteCommand(cmd,p);override; + begin + if csDesigning in ComponentState then return ; + if cmd="doshortcut" then + begin + if (FClients and FClients.Count>0) and Enabled and Visible and ShortCut = p then + begin + if Execute() then return "havedoshortcut"; + end + end + end + function Execute():Boolean;override; + begin + Result := False; + Result := Enabled and inherited Execute(); + return Result; + end + published + property Caption:string read FCaption write SetCaption; + property Checked:bool read FChecked write SetChecked; + property Enabled:bool read FEnabled write SetEnabled; + property Visible:bool read FVisible write SetVisible; + property ShortCut read getshortcut write SetShortCut; + function publishs();override; + begin + r := array("name","caption","enabled","onexecute"); + return r; + end +end; +type TActionList=class(TComponent) + {** + @explan(说明) actionlist %% + **} + private + FActionList; + function DeleteAllActions(); + begin + while FActionList.Count>0 do + begin + it := FActionList[0]; + if it is class(TBasicAction)then + begin + it.parent := nil; + end else + FActionList.deli(0); + end + end + public + function create(AOwner);override; + begin + inherited; + FActionList := new TFpList(); + end + function DeleteAction(v); + begin + {** + @explan(说明) 删除 %% + @param(v)(TBasicAction) + **} + if not(v is class(TBasicAction))then return 0; + idx := FActionList.indexof(v); + if not(idx >= 0)then return 0; + FActionList.deli(idx); + v.parent := nil; + end + function AddAction(V); + begin + {** + @explan(说明) 删除Action %% + @param(v)(TBasicAction) + **} + if v is class(TBasicAction)then + begin + if FActionList.indexof(v)>= 0 then return 0; + FActionList.add(v); + v.parent := self; + end + end + function Notification(AComponent,Operation);override; + begin + inherited; + if Operation=opRemove and AComponent=FActionComponent then + begin + DeleteAllActions(); + end + end + function Recycling();override; + begin + DeleteAllActions(); + inherited; + end + function publishs();override; + begin + return array("name"); + end +end +type TBasicActionLink=class(TSLUIBASE) + {** + @explan(说明) 基础action component关联类 %% + **} + private + FOnChange; + protected + procedure AssignClient(AClient:TObject);virtual; + begin + end + procedure Change;virtual; + begin + if datatype(FOnChange)=7 then call(OnChange,FAction); + end + function IsOnExecuteLinked():Boolean;virtual; + begin + return true; + end + procedure SetAction(Value:TBasicAction);virtual; + begin + if Value <> FAction then + begin + if FAction then FAction.UnRegisterChanges(Self(true)); + FAction := Value; + if Value then Value.RegisterChanges(Self(true)); + end; + end + procedure SetOnExecute(Value:TNotifyEvent);virtual; + begin + end + public + FAction:TBasicAction; + function Create(AClient:TObject);override; + begin + inherited create(); + AssignClient(AClient); + end + Function Recycling();override; + begin + if FAction is class(TBasicAction)then FAction.UnRegisterChanges(self); + inherited; + end + function Destroy;override; + begin + inherited; + end + function Execute(AComponent:TComponent):Boolean;virtual; + begin + {** + @explan(说明) 执行 %% + **} + if not(FAction is class(TBasicAction))then exit; + FAction.ActionComponent := AComponent; + try + r := FAction.Execute(); + finally + FAction.ActionComponent := nil; + end; + return r; + end + {function Update(): Boolean; virtual; + begin + if FAction is class(TBasicAction) then return FAction.Update(); + end } + property Action:TBasicAction read FAction write SetAction; + property OnChange:TNotifyEvent read FOnChange write FOnChange; + {** + @param(OnChange)(function[sender:tcomponent]) 改变的回调 %% + @param(Action)(taction) action对象 %% + **} +end; +type TActionLink=class(TBasicActionLink) + {** + @explan(说明) action与控件连接类 %% + **} + public + procedure SetShortCut(const Value:String);virtual; + begin + end + procedure SetCaption(const Value:string);virtual; + begin + end + procedure SetChecked(Value:Boolean);virtual; + begin + end + procedure SetEnabled(Value:Boolean);virtual; + begin + end + procedure SetVisible(Value:Boolean);virtual; + begin + end + function create(AClient);override; + begin + inherited; + end + protected + function IsshortcutLinked():Boolean;virtual; + begin + return Action is CLASS(TCustomAction); + end + function IsCheckedLinked():Boolean;virtual; + begin + return Action is CLASS(TCustomAction); + end + function IsEnabledLinked():Boolean;virtual; + begin + return Action is CLASS(TCustomAction); + end + function IsCaptionLinked():Boolean;virtual; + begin + return Action is CLASS(TCustomAction); + end + function IsOnExecuteLinked():Boolean;virtual; + begin + return Action is CLASS(TCustomAction); + end + function IsVisibleLinked():Boolean;virtual; + begin + return Action is CLASS(TCustomAction); + end +end; + +type TControlActionLink=class(TActionLink) + {** + @explan(说明)关联tcontrol 和 taction 类 %% + **} + protected + FClient:TControl; + function IsshortcutLinked():Boolean;virtual; + begin + return false; + end + procedure AssignClient(AClient);override; + begin + {** + @explan(说明)赋值control %% + @param(AClient)(tcontrol) %% + **} + if AClient is class(tcontrol)then FClient := AClient; + end + function IsCaptionLinked():Boolean;override; + begin + return FClient and inherited; + end + function IsEnabledLinked():Boolean;override; + begin + return FClient and inherited; + end + function IsVisibleLinked():Boolean;override; + begin + return FClient and inherited; + end + function IsOnExecuteLinked():Boolean;override; + begin + return FClient and inherited; + end + function IsCheckedLinked():Boolean;virtual; + begin + return false; + end + public + function create(AClient);override; + begin + inherited; + end + function destroy();override; + begin + inherited; + end + function Recycling();override; + begin + FClient := nil; + inherited; + end + procedure SetCaption(const Value:string);override; + begin + if IsCaptionLinked()then return FClient.Caption := Value; + end + procedure SetEnabled(Value:Boolean);override; + begin + if IsEnabledLinked()then return FClient.Enabled := Value; + end + procedure SetVisible(Value:Boolean);override; + begin + if IsVisibleLinked()then return FClient.Visible := Value; + end + procedure SetOnExecute(Value:TNotifyEvent);override; + begin + return inherited; + end +end; +implementation + +initialization + +end. \ No newline at end of file diff --git a/funcext/tvclib/utslvclauxiliary.tsf b/funcext/tvclib/utslvclauxiliary.tsf index 788de5f..dea0728 100644 --- a/funcext/tvclib/utslvclauxiliary.tsf +++ b/funcext/tvclib/utslvclauxiliary.tsf @@ -3,6 +3,54 @@ unit utslvclauxiliary; @explan(说明) tslvcl 辅助库 %% **} interface +function includestate(u,s); +function excludestate(u,s); +function makelong(low,high,ptrl); +function makeposition(x,y); +function getbitsfrominteger(n,b,e); +function unsignedtosigned(v,n); +function signedtounsigned(v,n); +function lowuperdword(value_,lvalue,uvalue,ptrl); +function FormatTslData(d,sj,tn); +function gettemppath(); +function TSL_ReservedKeys2(); //保留关键字 +function parsershortcutstr(s_); //快捷键解析 +function lineintersect(xx1,xx2,xx); +function formatshortcut(d); +function getmonthdates(y,m); +function CallMessgeFunction(f,o,e); +////////////////////点区域操作////////////////// +function pointinrect(p,rec); +function intersectrect(rec1,rec2,irec); + +function bitcombination(s,v,f); +//**************************** +/////////////////// +function ParserCommandLine(s); //解析命令行参数 +//function FormatTslData(d,sj,tn); +//function HexStrToTsl(hex); +//function TslToHexStr(d); +function TslToHexFormatStr(tsl); +function HexFormatStrToTsl(D); +type tuiglobaldata=class + static UIData; + class Function uisetdata(n,d); + begin + InitUiData(); + UIData[n]:= d; + end + class function uigetdata(n); + begin + InitUiData(); + //UIData[n] := d; + return UIData[n]; + end + private + class function InitUiData(); + begin + if not ifarray(UIData)then UIData := array(); + end +end type TCharDiscrimi=class static CD_SMA; static CD_BGA; @@ -68,6 +116,89 @@ type TCharDiscrimi=class sinit(); end end +type tidcreater=class + {** + @ignore(忽略) + **} + private + __sid; + cid; + Reuseids; + usedids; + //protected + {** + @explan(说明) 不重复整数id 生成类 %% + @param(cid)(integer) 当前id值 %% + @param(Reuseids) (array) 已经回收的id %% + + **} + public + function clean(); + begin + Reuseids := array(); + cid := __sid; + end + function create(sid); + begin + {** + @explan(说明) 构造函数 %% + @param(sid)(integer) 初始化的id值 + **} + if ifnumber(sid)then cid := sid; + else cid := 0; + __sid := cid; + usedids := Reuseids := array(); + end + function createid(); + begin + {** + @explan(说明) 构造id %% + @return(integer) id值 %% + + **} + ret := nil; + for i in Reuseids do + begin + if ifnumber(i)then + begin + ret := i; + break; + end + end + if ifnumber(ret)then + begin + reindex(Reuseids,array(ret:nil)); + usedids[ret]:= ret; + return ret; + end + cid += 1; + usedids[cid]:= cid; + return cid; + end + function deleteid(id); + begin + {** + @explan(说明) 不重复整数id 生成类 %% + @param(id)(integer) 需要回收的id值 %% + @return(bool) 是否成功 + **} + if ifnumber(id)then + begin + Reuseids[integer(id)]:= id; + reindex(usedids,array(integer(id):nil)); + return 1; + end + return 0; + end + function addid(id); + begin + if ifnumber(id)and id>0 then + begin + cid := max(cid,id); + usedids[id]:= id; + end + end +end type TByteDataOP=class() //位操作类 {** @explan(说明) 位操作封装 @@ -476,6 +607,65 @@ type tarray1dlk=class // end end end +type TFpList=class(tarray1dlk) + {** + @explan(说明) list类 %% + **} + function create(); + begin + inherited; + end + function indexof(v,f,lx); + begin + {** + @explan(说明) 查找值v在序列中的位置 %% + @param(v)(any) 任何类型 %% + @return(integer) 位置 ,等于-1 表示没查找到 %% + **} + return findvid(v,f,lx); + end + function operator[](index); + begin + {** + @explan(说明)获取序号为index的值 %% + @return(any) 数据 %% + **} + return geti(index); + end + function add(v); + begin + {** + @explan(说明)追加数据到链表 %% + @param(v)(any) 数据 %% + **} + return append(v); + end + function Remove(v); + begin + {** + @explan(说明)删除数据V %% + @param(v)(any) 数据 %% + **} + return deli(indexof(v)); + end + function last(); + begin + {** + @explan(说明)获取最后一个数据 %% + @return(any) 数据 %% + **} + return geti(self.Count()-1); + end + function Count(); + begin + {** + @explan(说明)获取数据个数 %% + @return(integer) %% + **} + return len(); + end +end + type tstrindexarray = class {** @explan(数组类型) 忽略字符串下标的大小写%% @@ -804,11 +994,1629 @@ type tnumindexarray = Class @param(Data)(array) 数据 %% **} end +type TGlobalValues=class + private + static FValues; + FId; + class function sinit(); + begin + if not ifarray(FValues)then FValues := array(); + end + public + class function getvalue(id); + begin + sinit(); + r := FValues[inttostr(id)]; + //if r then reindex(FValues,id); + return r; + end + function Create(id,value); + begin + sinit(); + tid := inttostr(id); + FOld := FValues[tid]; + if not ifnil(FOld)then raise "全局变量冲突!"; + FId := tid; + FValues[tid]:= value; + end + function destroy(); + begin + reindex(FValues,array(FId:nil)); + end +end +type TArrayTreeClass = class + {** + @explan(说明) 树形类 %% + @param(FIdName)(integer | string) id名称 %% + @param(FPIdName)(integer | string) 父节点名称 %% + **} + {** + @example(转换范例) %% + d := array(("id":1,"pid":5,"caption":"jd1"), + ("id":4,"pid":2,"caption":"jd2"), + ("id":2,"pid":1,"caption":"jd3"), + ("id":3,"pid":2,"caption":"jd4"), + ("id":5,"pid":7,"caption":"jd5"), + ); + dt := class(TArrayTreeClass).ToTreeArray(d,array("id":"id","pid":"pid","sub":"sub")); + return dt; + **} + private + class function ClumnNameOk(id); + begin + return ifnumber(id) or ifstring(id) ; + end + static FCounter; + static FIdName; + Static FPIdName; + static FSubName; + static FSInToArray; + FRecyce; + FInToArray; + FComponents; //节点 + FId; //id + FValue; //数据 + class function initconter(); + begin + FCounter := 1; + end + class function GetCounter(); + begin + return FCounter++; + end + public + class function SetIdName(id,pid,sub); + begin + if(id <> pid)and(ifstring(id)or ifnumber(id))and(ifstring(pid)or ifnumber(pid))and(ifstring(sub)or ifnumber(sub))then + begin + FIdName := id; + FPIdName := pid; + FSubName := sub; + end + end + function create(v); + begin + {** + @explan(说明) 构造节点 %% + **} + FId := v[FIdName]; + FValue := v; + FComponents := array(); + end + function addcomponent(o); + begin + {** + @explan(说明) 添加节点 %% + **} + len := length(FComponents); + for i := 0 to len-1 do if o=FComponents[i]then exit; + FComponents[len]:= o; + end + function Recycle(); + begin + {** + @explan(说明) 出现死循环的时候的处理 %% + **} + if FRecyce then return; + FRecyce := true; + for i,v in FComponents do + begin + v.Recycle(); + end + FComponents := array(); + end + function toarray(); + begin + {** + @explan(说明) 转换为array %% + **} + if FInToArray=FSInToArray then + begin + Recycle(); + raise "节点关系出现循环"; + end + FInToArray := FSInToArray; + ret := array(); + sub := array(); + for i := 0 to length(FComponents)-1 do + begin + ret[FSubName,i]:= FComponents[i].toarray(); + end + for i,v in FValue do + begin + if i=FSubName then continue; + ret[i]:= v; + end + return ret; + end + class function SetColumnName(info); + begin + if not ifarray(info)then info := array("id":"id","pid":"pid","sub":"sub"); + if not ClumnNameOk(info["id"])then info["id"]:= "id"; + if not ClumnNameOk(info["pid"])then info["pid"]:= "pid"; + if not ClumnNameOk(info["sub"])then info["sub"]:= "sub"; + SetIdName(info["id"],info["pid"],info["sub"]); + end + class function ToTree(d,info); + begin + {** + @explan(说明) 二维表转换为树结构 %% + @param(d)(array) 数据包含 信息 %% + @param(info)(array) 字段信息 "id" 当前节点的字段,"pid" 当前节点的父节点字段,"sub" ,返回子节点的字段 + 默认值 array("id":"id","pid":"pid","sub":"sub"); %% + @return(TArrayTreeClass) + **} + SetColumnName(info); + root := new TArrayTreeClass(array(FIdName:nil,FPIdName:nil)); + oarray := array(); + oarray[-inf]:= root; + for i,v in d do //构建id + begin + id := v[FIdName]; + ido := oarray[id]; + if ifnil(ido)then + begin + ido := new TArrayTreeClass(v); + oarray[id]:= ido; + end + end + ifcycle := true; + for i,v in d do + begin + id := v[FIdName]; + ido := oarray[id]; + pid := v[FPIdName]; + pdo := oarray[pid]; + if not pdo then + begin + pdo := oarray[-inf]; + ifcycle := false; + end + pdo.addcomponent(ido); + end + if ifcycle and oarray then + begin + for i,v in oarray do + begin + v.Recycle(); + raise "节点关系出现循环"; + break; + end + end + return root; + end + class function CreateRow(d,id,r); + begin + for i,v in d do + begin + ri := array(); + if not v then continue; + ri[FIdName]:= GetCounter(); + ri[FPIdName]:= id; + for j,vi in v do + begin + if j=FSubName then + begin + call(thisfunction,vi,ri[FIdName],r); + end + {else if j=FIdName or j = FPIdName then + begin + + end}else + begin + ri[j]:= vi; + end + end + if ri then + begin + r[length(r)]:= ri; + end + end + end + class function TreeArrayToArray(d,info); + begin + {** + @explan(说明) 树结构转换为二维表 %% + @param(d)(array) 数据包含 信息 %% + @param(info)(array) 字段信息 "id" 当前节点的字段,"pid" 当前节点的父节点字段,"sub" ,返回子节点的字段 + 默认值 array("id":"id","pid":"pid","sub":"sub"); %% + @return(array) + **} + if not ifarray(d)then exit; + SetColumnName(info); + r := array(); + initconter(); + CreateRow(d,GetCounter(),r); + return r; + end + class function ToTreeArray(d,info); + begin + {** + @explan(说明) 二维表转换为树结构 %% + @param(d)(array) 数据包含 信息 %% + @param(info)(array) 字段信息 "id" 当前节点的字段,"pid" 当前节点的父节点字段,"sub" ,返回子节点的字段 + 默认值 array("id":"id","pid":"pid","sub":"sub"); %% + @return(array) 树形结构的array + **} + root := ToTree(d,info); + if not root then return; + FSInToArray := tostn(now()); + r :=(root.toarray()); + return r; + end +end - +type TNode = class() + {** + @explan(说明) 树结点 %% + **} + private + FItems; //子项 + FParent; //父节点 + public + function Create();virtual; + begin + inherited; + FExpanded := true; + FItems := new TFpList(); //子项 + end + function CreateNode();virtual; + begin + return CreateObject(self(true).Classinfo(1)); + end + function CreateNodeAndAppend();virtual; //构造并追加 + begin + nd := CreateNode(); + AppendNode(nd); + return nd; + end + function GetNodeByIndex(idx); + begin + {** + @explan(说明) 通过序号获得子节点%% + @param(idx)(TNode) %% + **} + if idx >= 0 then return FItems[idx]; + return nil; + end + function indexof(v); //获得序号 + begin + return FItems.indexof(v); + end + function GetIndex();virtual; + begin + {** + @explan(说明) 获得在父节点中的序号 %% + @return(integer) 序号 %% + **} + if Parent then Parent.indexof(self); + end + function AppendNode(it);virtual; + begin + {** + @explan(说明) 插入一个节点 %% + @param(it)(TNode) 节点 %% + @return(bool) 是否成功 %% + **} + return InsertNode(it,FItems.Count); + end + function HasNode(nd);virtual; + begin + {** + @explan(说明) 是否为某个节点的祖先节点 %% + @param(nd)(TNode) 子节点 %% + @return(TNode|0) 如果为祖先节点,就返回查询节点的父节点 %% + **} + if not(nd is class(TNode))then return 0; + p1 := nd.Parent; + p := p1; + while p do + begin + if p=self then return p1; + if p is class(TNode)then p := p.Parent; + end + return 0; + end + function DeleteNode(nd);virtual; + begin + {** + @explan(说明) 删除节点 %% + @param(nd)(TNode) 待删除节点 %% + **} + if nd=self then return 0; + pn := HasNode(nd); + if not pn then return; + return pn.DeleteChildNode(nd); + end + function DeleteChildNode(nd); + begin + {** + @explan(说明) 删除子节点%% + @param(nd)(TNode) 节点 %% + **} + idx :=-1; + idx := indexof(nd); + if idx=-1 then return 0; + return DeleteNodeByIndex(idx); + end + function DeleteNodeByIndex(idx); + begin + {** + @explan(说明) 根据位置删除节点%% + @param(idx)(integer) 序号 %% + **} + nd := FItems[idx]; + if not nd then return; + //是否显示处理 + FItems.Deli(idx); + CurrentDeleteNode := nd; + nd.parent := self(true); + CurrentDeleteNode := nil; + return true; + end + function DeleteChildren();virtual; // + begin + {** + @explan(说明) 删除所有的子节点%% + **} + while NodeCount>0 do + begin + idx := 0; + it := FItems[idx]; + CurrentDeleteNode := it; + it.parent := self(true); + CurrentDeleteNode := nil; + FItems.Deli(idx); + end + end + function InsertNodes(its,idx);virtual; + begin + {** + @explan(说明) 插入一个节点 %% + @param(it)( array of TNode) 字符串 %% + @param(idx)(integer) 序号 默认为0 %% + **} + idx0 := idx; + if idx<0 then idx0 := 0; + if idx>FItems.Count then idx0 := FItems.Count; + bidx := idx0; + for i,it in its do + begin + if(it is class(TNode))and(not it.Parent)then + begin + FItems.InsertBefor(it,idx0); + CurrentAddNode := it; + it.Parent := self(true); + CurrentAddNode := nil; + idx0++; + end + end + end + function InsertNode(it,idx);virtual; + begin + {** + @explan(说明) 插入一个节点 %% + @param(it)(TNode) 字符串 %% + @param(idx)(integer) 序号 默认为0 %% + **} + if(it is class(TNode))and(not it.Parent)then + begin + if idx<0 then idx := 0; + if idx>FItems.Count then idx := FItems.Count; + if not(idx >= 0)then idx := 0; + FItems.InsertBefor(it,idx); + CurrentAddNode := it; + it.Parent := self(true); + CurrentAddNode := nil; + return true; + end + end + function Expand();virtual; //展开 + begin + FExpanded := true; + end + function UnExpand();virtual; //折叠 + begin + FExpanded := false; + end + function RecyclingChildren();virtual; + begin + while NodeCount>0 do + begin + it := FItems[0]; + it.Recycling(); + end + end + function Recycling();virtual; + begin + p := FParent; + if p then + begin + p.DeleteNode(self); + end + while NodeCount>0 do + begin + it := FItems[0]; + it.Recycling(); + end + //inherited; + end + property NodeCount read GetNodeCount; //节点数 + property Expanded read FExpanded write SetExpand; //展开 + property Parent read FParent write SetParent; //父节点 + property LastChild read GetLstChild; + {** + @param(NodeCount)(integer) 子节点数量 %% + @param(Expanded)(bool) 是否展开 %% + @param(Parent)(TNode) 父节点 %% + **} + protected property CurrentDeleteNode read FCurrentDeleteNode write FCurrentDeleteNode; + property CurrentAddNode read FCurrentAddNode write FCurrentAddNode; + {** + @ignoremembers(CurrentDeleteNode,CurrentAddNode) + **} + function SetParent(V);virtual; + begin + tp := Parent; + if v=tp then return; + if(v is class(TNode))then + begin + if v.CurrentAddNode=self then + begin + FParent := v; //新节点 + end else + if v.CurrentDeleteNode=self then //从节点移除 + begin + FParent := nil; + end else + begin + if tp=v then return; + if tp then + begin + tp.DeleteNode(self(true)); + end + v.InsertNode(self(true),v.NodeCount); + end + end else + begin + if tp then tp.DeleteNode(self(true)); + end + end + private + function GetLstChild(); + begin + return FItems[FItems.Count-1]; + end + FCurrentDeleteNode; + FCurrentAddNode; + FExpanded; + function SetExpand(v);virtual; //已经展开 + begin + if v then Expanded(); + else UnExpand(); + end + function GetNodeCount(); //子节点数 + begin + return FItems.Count; + end +end implementation +function includestate(u,s); +begin + {** + @explan(说明) 状态扩展 %% + **} + if not ifarray(u)then u := array(); + if ifarray(s)then u union2= s; + else u union2= array(s); + return u; +end +function excludestate(u,s); +begin + {** + @explan(说明) 状态缩减%% + **} + if not ifarray(u)then u := array(); + if ifarray(s)then u minus= s; + else u minus= array(s); + return u; +end + //*************makelong***************************** +function makelong(low,high,ptrl); +begin + {** + @explan(说明) 合并高低为 %% + @return(integer) 整数 %% + @param(low)(integer) 低位 %% + @param(high)(integer) 高位 %% + @param(ptrl)(integer) 长度 默认为 8 %% + **} + if not ifnumber(ptrl)then ptrl := 16; + mask := 2^(ptrl)-1; + low1 := low .& mask; + high1 := high .& mask; + return _shl(high1,ptrl).| low1; +end + +function makeposition(x,y); +begin + {** + @explan(说明)将x,y构造为一个int类型 %% + @return(integer) + **} + if ifnumber(x)and ifnumber(y)then return makelong(signedtounsigned(x),signedtounsigned(y)); + return 0; +end +function lowuperdword(value_,lvalue,uvalue,ptrl); +begin + {** + @explan(说明) 高低位获取 %% + @param(value_)(integer) 整数 %% + @param(lvalue)(integer) 低位 %% + @param(uvalue)(integer) 高位 %% + @param(ptrl)(integer) 长度 默认为 8 %% + **} + lvalue := uvalue := 0; + if not ifnumber(value_)then return array(0,0); + if not ifnumber(ptrl)then ptrl := 16; + value :=(value_); + mask := 2^(ptrl)-1; + uvalue := _shr(value,ptrl).& mask; + //t := _shl(value,ptrl); + //lvalue := _shr(t,ptrl) .& mask; + lvalue := value .& mask; + return array(lvalue,uvalue); +end +function signedtounsigned(v,n); +begin + {** + @explan(说明) 符号数转换为无符号数 %% + @param(v)(integer) 数字 %% + @param(n)(integer) 有效位数 %% + @return(integer) + **} + if not ifnumber(n)then n := 16; + if n>64 then n := 64; + mkv2 := 1; + ret := mkv2 .& v; + for i := 1 to n-1 do + begin + mkv2 := _shl(mkv2,1); + ret +=(mkv2 .& v); + end + mkv2 := _shl(mkv2,1); + if v<0 then + begin + ret .|= mkv2; + end else + begin + ret .&=(.! mkv2); + end + return ret; +end +function getbitsfrominteger(n,b,e); +begin + {** + @explan(说明) 获取数字的位数并转换为整数 %% + @param(b)(integer) 开始位 %% + @param(e)(integer) 截止位 %% + @param(n)(integer) 数字 %% + @return(integer) + **} + r := 0; + if b<0 then return 0; + mk := 2^(b); + for i := b to e do + begin + if(mk .& n)>0 then r += _shr(mk,b); + mk := _shl(mk,1); + end + return r; +end + +function unsignedtosigned(v,n); +begin + {** + @explan(说明) 无符号数转换为符号数 %% + @param(v)(integer) 数字 %% + @param(n)(integer) 有效位数 %% + @return(integer) + **} + if not ifnumber(n)then n := 16; + if n>64 then n := 64; + mkv := 0; + mkv := _shl(1,n-1); + mkv2 := 1; + for i := 1 to n-1 do + begin + mkv2 := _shl(mkv2,1); + mkv2 += 1; + end + vv := v .& mkv2; + if(v .& mkv)then + begin + return 0-((_not(vv) .& mkv2)+1); + end + return vv; +end +function bitcombination(s,v,f); +begin + {** + @explan(说明)bit位组合 %% + @param(s)(integer) 原有值 %% + @param(v)(integer) 追加或者删除 %% + @param(f)(integer) 0 为 or ,1 为 and ;2 表示 删除 v的值 %% + **} + if not(ifnumber(s)and ifnumber(v))then return 0; + case f of + 0:return s .| v; + 1:return s .& v; + 2:return(.!v).& s; + else return s; + end + hv :=((s .& v)=v); + if(hv)and f=2 then + begin + return(.!v).& s; + end else + if(f=0)and not(hv)then + begin + return s .| v; + end else + if(f=1)and not(hv)then + begin + return s .& v; + end else + return s; +end +function formatshortcut(d); +begin + r := ""; + if d then + begin + if d["c"] then r +=(r)?"+Ctrl":"Ctrl"; + if d["s"] then r +=(r)?"+Shift":"Shift"; + if d["a"] then r +=(r)?"+Alt":"Alt"; + if d["f"] then r +=(r)?("+"+d["f"]):d["f"]; + if d["w"] then r +=(r)?("+"+d["w"]):d["w"]; + end + return r; +end +function parsershortcutstr(s_); //快捷键解析 +begin + s := uppercase(s_); + ls := length(s); + zmb := array(); + fb := array(); + for i := 65 to 90 do zmb[chr(i)] := true; + for i:= 1 to 12 do fb["F"+inttostr(i)] := true; + cword :=""; + i := 1; + r := array(); + while(i<=ls) do + begin + vi := s[i]; + vio := ord(vi); + case vio of + 65 to 90 ,48 to 57: + begin + cword +=vi; + end + else + begin + if cword then + begin + case cword of + "SHIFT": + begin + r["s"] := true; + end + "CTRL": + begin + r["c"] := true; + end + "ALT": + begin + r["a"] := true; + end + else + begin + + if fb[cword] and not(r["w"]) then + begin + r["f"] := cword; + end else + if r and not(r["f"]) then + begin + if zmb[cword] then r["w"] := cword; + end + end + + end ; + end + cword := ""; + end + + end; + i++; + end + if cword then + begin + case cword of + "SHIFT": + begin + r["s"] := true; + end + "CTRL": + begin + r["c"] := true; + end + "ALT": + begin + r["a"] := true; + end + else + begin + if fb[cword] and not(r["w"]) then + begin + r["f"] := cword; + end else + if r and not(r["f"]) then + begin + if zmb[cword] then r["w"] := cword; + end + end + + end ; + end + if not(r["w"] or r["f"]) then r := array(); + return r; +end +function FormatTslData(d,sj,tn); +begin + {** + @explan(说明) 格式化tsl数据 %% + @param(d)(any) tsl数据 %% + @param(sj)(string) 空格距离 %% + @param(tn)(nil) 空参数 %% + @return(string) 格式化后的字符串 %% + **} + r := ""; + if not(sj and ifstring(sj))then sj := " "; + if ifarray(d)then + begin + r := "(\r\n"; + if ifnil(tn)then + begin + tn := 0; + r := "array(\r\n"; + end + di := 0; + len := length(d); + for i,v in d do + begin + bt := sj; + if di <> i then + begin + bt += tostn(i)+":"; + end + di++; + vr := FormatTslData(v,sj,1); + if len>di then vr += ","; + r += bt; + if ifarray(v)then + begin + vrs := str2array(vr,"\r\n"); + dii := 0; + for j,vj in vrs do + begin + if dii<1 then r += vj; + else r += sj+vj; + r += "\r\n"; + dii++; + end + end else + r += vr+"\r\n"; + end + r += ")"; + return r; + end else + return tostn(d); +end + +function DeleteItemsByIndexs(r,dxs); +begin + {** + @explan(说明) 删除数组下标, %% + @param(r)(array) 待删除下标的数组,采用字符串下标的数组,变参返回%%; + **} + if not ifarray(r)then exit; + rdx := array(); + for i,v in dxs do rdx[v]:= nil; + return reindex(r,rdx); +end +function HexHash(); +begin + c := array("A","B","C","D","E","F"); + idxs := inttostr(0 -> 9)union c union lowercase(c); + r := array(); + for i,v in idxs do + begin + if i<16 then r[v]:= i; + else r[v]:= i-6; + end + return r; +end +function TslToHexStr(t); +begin + {** + @explan(说明) 将tsl数据转换为16进制字符串 %% + @param(t)(any) 任意的tsl数据 %%; + @return(string) 16进制字符串 %% + **} + r := ""; + str := tostm(t); + ky := static(inttostr(0 -> 9)union array("A","B","C","D","E","F")); + idx := 1; + setlength(r,length(str)* 2); + for i := 0 to length(str)-1 do + begin + vi := ord(str[i]); + //r += ky[_shr(vi,4) .& 0xf]; + //r += ky[vi .& 0xf] ; + r[idx]:= ky[_shr(vi,4).& 0xf]; + r[idx+1]:= ky[vi .& 0xf]; + idx += 2; + end + return r; +end + +function HexFormatStrToTsl(hex); +begin + {** + @explan(说明)将带有换行符的16进制字符串转换为tsl数据 %% + @param(hex)(string) 16进制字符串 %% + @return(any) tsl数据类型 %% + **} + r := ""; + hs := static HexHash(); + //rs := inttostr(0 -> 9)union array("A","B","C","D","E","F","a","b","c","d","e","f"); + for i := 1 to length(hex) do + begin + ri := hex[i]; + if hs[ri]>=0 then + begin + r += ri; + end + end + return HexStrToTsl(r); +end +function TslToHexFormatStr(tsl); +begin + s := TslToHexStr(tsl); + r := ""; + n := length(s); + i := 1; + bc := 64; + while true do + begin + if i>n then break; + ij := i+bc; + if ij>n and i <= n then + begin + r += s[i:n]; + break; + end else + r += s[i:ij]; + if ij>n then break; + r += "\r\n"; + i := ij+1; + end + return r; +end +function HexStrToTsl(hex); +begin + {** + @explan(说明)16进制字符串转换为tsl数据 %% + @param(hex)(string) 16进制字符串 %% + @return(any) tsl数据类型 %% + **} + if not(hex and ifstring(hex)) then return nil; + r := tostm(nil); + setlength(r,Integer(length(hex)/2)); + hs := static HexHash(); + idx := 0; + for i := 1 to length(hex)-1 step 2 do + begin + vi := hs[hex[i]]; + vi1 := hs[hex[i+1]]; + r[idx]:= _shl(vi,4).| vi1; + idx++; + end + return stm(r); +end +function gettemppath(); +begin + {** + @explan(说明)获取windows临时目录 %% + @return(string) 目录; + **} + {$ifdef linux} + return "/var/tmp/"; + {$endif} + s := ""; + n := 1024; + setlength(s,n); + s1 := s; + GetTempPathA(n,s); + GetLongPathNameA(s,s1,n); + r := ""; + for i := 1 to n do + begin + vi := s1[i]; + if vi="\0" then + begin + return s1[1:(i-1)]; + end + end + return ""; +end +function TSL_ReservedKeys(var buf:string;buflen:integer):integer;cdecl;external{$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TSL_ReservedKeys"; +function TSL_ReservedKeys2(); +begin + ks := ""; + setlength(ks,1024 * 10); + TSL_ReservedKeys(ks,length(ks)-1); + r := array(); + rl := 0; + ki := ""; + for i := 1 to length(ks)-1 do + begin + vi := ks[i]; + if vi="\0" then break; + if vi="\n" then + begin + if ki then + begin + r[rl++]:= ki; + ki := ""; + end + end else + ki += vi; + end + return r union2 array("read","write"); //添加read write 关键字 +end +function GetLongPathNameA(var s1:string;var s:string;L:integer):integer;stdcall;external "Kernel32.dll" name "GetLongPathNameA"; +function GetTempPathA(L:integer;var s:string):integer;stdcall;external "Kernel32.dll" name "GetTempPathA"; +function ParserCommandLine(s); //解析命令行参数 +begin + r := array(); + if not ifstring(s) then return r; + len := length(s); + p := ""; + while idxrec[0]and y>rec[1]and xxx2[0]and xx1[0]>xx2[1])or(xx2[0]>xx1[1]and xx2[1]>xx1[0])then return 0; + xx := array(max(xx1[0],xx2[0]),min(xx1[1],xx2[1])); + return 1; +end +function getmonthdates(y,m); +begin + if m = 2 then return (not(y mod 4) and ( (y mod 100)))+ 28; + if m in array(1,3,5,7,8,10,12) then return 31; + return 30; +end +function CallMessgeFunction(f,o,e); +begin + {** + @ignore(忽略) + **} + if datatype(f)=7 then return call(f,o,e); +end +function CheckArrayIsNumbers(Value,n); +begin + if not(ifnumber(n)and n >= 1)then n := 4; + if ifarray(Value)then + begin + for i := 0 to n-1 do + begin + if not(ifnumber(Value[i]))then return 1; + end + return 0; + end + return 1; +end +function CheckArrayIsControlRect(Value); +begin + {** + @explan(说明) 检查数组是否可以作为control的rect %%; + **} + if not(CheckArrayIsNumbers(Value,4))then + begin + return Value[3]>0 and Value[2]>0; + end +end +function CheckArrayIsControlBounds(Value); +begin + {** + @explan(说明) 检查数组是否可以作为control 的 bounds + **} + if not(CheckArrayIsNumbers(Value,4))then + begin + return(Value[3]>Value[1])and(Value[2]>Value[0]); + end +end + +function intasposition(i); +begin + if ifnumber(i)then + begin + return lowuperdword(i); + end + return array(0,0); +end initialization +end. -end. \ No newline at end of file +//////////////////////暂时没用到的类型/////////////////////////////////////// +(* + +type TFileLocker=class() + {** + @ignore(忽略) %% + @explan(说明) 文件锁定 %% + **} + private + FHandle; + FLocked; + FApi; + function GetFileOpen(); + begin + return FHandle <> 0; + end + function GetFileLocked(); + begin + return FLocked <> 0; + end + public + function Create(F); + begin + {** + @explan(说明)对文件加锁,防止其他进程读写 %% + @param(f)(string) 文件名 %% + **} + FHandle := 0; + FLocked := 0; + if not FileExists("",f)then exit; + FApi := gettswin32api(); + FHandle := FApi.CreateFileA(F,0x40000000L,0,0,3,0x00000080,0); + if not FHandle then exit; + FLocked := FApi.LockFile(FHandle,0,0,0,0); + end + function Destroy(); + begin + if FLocked then + begin + FApi.UnlockFile(FHandle,0,0,0,0); + end + if FHandle then + begin + FApi.CloseHandle(FHandle); + end + end + property FileOpend read GetFileOpen; + property FileLocked read GetFileLocked; + {** + @param(FileOpend)(bool) 是否有效%% + @param(FileLocked)(bool) 是否已经锁定%% + **} +end + + +type Ttagaccel=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("fvirt","byte",0), + ("key","short",0), + ("cmd","short",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property fvirt index "fvirt" read _getvalue_ write _setvalue_; + property key index "key" read _getvalue_ write _setvalue_; + property cmd index "cmd" read _getvalue_ write _setvalue_; +end +type TBITMAPINFOHEADER=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("bisize","int",40), + ("biwidth","int",0), + ("biheight","int",0), + ("biplanes","short",0), + ("bibitcount","short",0), + ("bicompression","int",0), + ("bisizeimage","int",0), + ("bixpelspermeter","int",0), + ("biypelspermeter","int",0), + ("biclrused","int",0), + ("biclrimportant","int",0) + )); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + bisize := _size_(); + end + property bisize index "bisize" read _getvalue_ write _setvalue_; + property biwidth index "biwidth" read _getvalue_ write _setvalue_; + property biheight index "biheight" read _getvalue_ write _setvalue_; + property biplanes index "biplanes" read _getvalue_ write _setvalue_; + property bibitcount index "bibitcount" read _getvalue_ write _setvalue_; + property bicompression index "bicompression" read _getvalue_ write _setvalue_; + property bisizeimage index "bisizeimage" read _getvalue_ write _setvalue_; + property bixpelspermeter index "bixpelspermeter" read _getvalue_ write _setvalue_; + property biypelspermeter index "biypelspermeter" read _getvalue_ write _setvalue_; + property biclrused index "biclrused" read _getvalue_ write _setvalue_; + property biclrimportant index "biclrimportant" read _getvalue_ write _setvalue_; +end +type TTBBUTTONINFOA=class(tcstructwithcharptr) + {** + @explan(说明) 工具条项内存对象 %% + **} + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := array( + ("cbsize","int",0), + ("dwmask","int",0), + ("idcommand","int",0), + ("iimage","int",0), + ("fsstate","byte",0), + ("fsstyle","byte",0), + ("cx","short",0), + ("lparam","intptr",0), + ("psztext","char*",0), + ("cchtext","int",100)); + return SSTRUCT; + end + public + function create();override; + begin + inherited create(getstruct(),array("psztext":"cchtext"),nil); + cbsize := _size_(); + end + property cbsize index "cbsize" read _getvalue_ write _setvalue_; + property dwmask index "dwmask" read _getvalue_ write _setvalue_; + property idcommand index "idcommand" read _getvalue_ write _setvalue_; + property iimage index "iimage" read _getvalue_ write _setvalue_; + property fsstate index "fsstate" read _getvalue_ write _setvalue_; + property fsstyle index "fsstyle" read _getvalue_ write _setvalue_; + property cx index "cx" read _getvalue_ write _setvalue_; + property lparam index "lparam" read _getvalue_ write _setvalue_; + property psztext index "psztext" read _getvalue_ write _setvalue_; + property cchtext index "cchtext" read _getvalue_ write _setvalue_; +end + +type TTBBUTTON=class(tslcstructureobj) + {** + @explan(说明) 工具栏按钮内存对象 %% + **} + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("ibitmap","int",0), + ("idcommand","int",0), + ("fsstate","byte",0), + ("fsstyle","byte",0), + ("dwdata","intptr",0), + ("istring","char*",128))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + function _setvalue_(id,v); + begin + if id="istring" then + begin + if ifstring(v)and length(v)<127 then + begin + return inherited; + end + return; + end + return inherited; + end + property ibitmap index "ibitmap" read _getvalue_ write _setvalue_; + property idcommand index "idcommand" read _getvalue_ write _setvalue_; + property fsstate index "fsstate" read _getvalue_ write _setvalue_; + property fsstyle index "fsstyle" read _getvalue_ write _setvalue_; + property dwdata index "dwdata" read _getvalue_ write _setvalue_; + property istring index "istring" read _getvalue_ write _setvalue_; +end +type TScrollBarKind=class(tenumeration) + static sbHorizontal; + static sbVertical; +end + +type TToolTipsFlags=class + {** + @ignore(忽略) %% + @explan() tooltips flags 常量 %% + **} + static TTF_IDISHWND; + static TTF_CENTERTIP; + static TTF_RTLREADING; + static TTF_SUBCLASS; + static TTF_TRACK; + static TTF_ABSOLUTE; + static TTF_TRANSPARENT; + static TTF_PARSELINKS; + static TTF_DI_SETITEM; +end + + type TIMAGEINFO = class(tslcstructureobj) + {** + @ignore 忽略 %% + @explan(说明) imgelist中image的信息 %% + **} + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate( + array( + ("hbmimage","intptr",0), + ("hbmmask","intptr",0), + ("unused1","int",0), + ("unused2","int",0), + ("rcimage","int[4]", + (0,0,0,0)))); + return SSTRUCT; + end + function getbmp(v); + begin + {** + @explan(说明)构造tbitmap对象 %% + **} + hm := _getvalue_(v); + if hm then + begin + r := new tbitmap(); + r.handle := hm; + r.AutoDestroy := false; + return r; + end + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property bmimage:tbitmap index "hbmimage" read getbmp write getbmp; + property bmmask:tbitmap index "hbmmask" read getbmp write getbmp; + property hbmimage index "hbmimage" read _getvalue_ write _setvalue_; + property hbmmask index "hbmmask" read _getvalue_ write _setvalue_; + property unused1 index "unused1" read _getvalue_ write _setvalue_; + property unused2 index "unused2" read _getvalue_ write _setvalue_; + property rcimage index "rcimage" read _getvalue_ write _setvalue_; + {** + @param(bmimage)(tbitmap) 位图 %% + @param(bmmask)(tbitmap) mask %% + @param(rcimage)(array) 左上右下 %% + **} + end + +*) + + +//////////////twincontrol 中移除的函数 +(* + function CreateDrawItemEvent();virtual; + begin + {** + @explan(说明) 主动构造drawitem消息,可以自行填写信息在DoDrawItem中使用,与DestroyDrawItemEvent成对出现 %% + @return(TMDRAWITEM|nil) item绘制对象 %% + **} + e := nil; + if HandleAllocated() then + begin + hd := self.Handle; + itptr := FTtageDrawItem._getptr_; + e := new TMDRAWITEM(WM_DRAWITEM,0,itptr,hd); + e.canvas := canvas; + canvas.handle := _wapi.GetDC(self.Handle); + end + return e; + end + function DestroyDrawItemEvent(e);virtual; + begin + {** + @explan(说明) 与CreateDrawItemEvent配合使用 %% + @param(e)(TMDRAWITEM) CreateDrawItemEvent 构造的消息对象 %% + **} + if HandleAllocated() and ( e is class(TMDRAWITEM)) and (e.lparam = FTtageDrawItem._getptr_()) then + begin + dc := canvas.Handle; + if dc then + begin + canvas.handle := 0; + return _wapi.ReleaseDC(self.Handle,dc); + end + end + end +*) + +(* + //tcontrol 移除代码 + function GetDeviceContext(var WindowHandle:HWND);virtual; //type_tcontrol + begin + {** + @explan(说明) 获取设备hdc %% + @param(WindowHandle)(pointer) 窗口句柄 %% + @return(pointer) dc 句柄 %% + **} + if Parent is class(TWinControl)then + begin + Result := Parent.GetDeviceContext(WindowHandle); + MoveWindowOrgEx(Result,Left,Top); + IntersectClipRect(Result,0,0,Width,Height); + end else + raise "错误"; + return Result; + end; + + function IntersectClipRect(hdc, x0, y0, x1, y1);virtual; //type_tcontrol + begin + _wapi.IntersectClipRect(hdc, x0, y0, x1, y1); + end + function MoveWindowOrgEx(hdc;x:integer;y:integer);virtual; //type_tcontrol + begin + {** + @explan(说明) 移动dc原点 %% + @param(hdc)(pointer) dc 句柄 %% + **} + return _wapi.SetViewportOrgEx(hdc,x,y,nil); + end + + function WMXButtonDown(o,e): LM_XBUTTONDOWN;virtual; + begin + end + function WMMButtonDBLCLK(o,e): LM_MBUTTONDBLCLK;virtual; + begin + + end + function WMXButtonDBLCLK(o,e): LM_XBUTTONDBLCLK;virtual; + begin + + end + function WMLButtonTripleCLK(o,e): LM_LBUTTONTRIPLECLK;virtual; + begin + + end + function WMRButtonTripleCLK(o,e): LM_RBUTTONTRIPLECLK;virtual; + begin + + end + function WMMButtonTripleCLK(o,e): LM_MBUTTONTRIPLECLK;virtual; + begin + + end + function WMXButtonTripleCLK(o,e): LM_XBUTTONTRIPLECLK;virtual; + begin + + end + function WMXButtonUp(o,e): LM_XBUTTONUP;virtual; + begin + + end + function WMLButtonQuadCLK(): LM_LBUTTONQUADCLK;virtual; + function WMRButtonQuadCLK(): LM_RBUTTONQUADCLK;virtual; + function WMMButtonQuadCLK(): LM_MBUTTONQUADCLK;virtual; + function WMXButtonQuadCLK(): LM_XBUTTONQUADCLK;virtual; +*) +(* + + function SetMainMenubk(mu); + begin + if csDesigning in ComponentState then + begin + if FMainMenu and mu then //已经存在 %% + begin + return ; + end + if (not FMainMenu) and mu then + begin + mu := new TMainmenu(self); //构造一个假的菜单 + tm := new TMenu(mu); + tm.caption := "menu"; + tm.parent := mu; + end + end + if FMainMenu<>mu then + begin + OM := FMainMenu; + if OM is class(tmainmenu) then + begin + OM.DestroyHandle(); //删除句柄 %% + OM.Hwnd := 0; + //if HandleAllocated() then _wapi.SetMenu(self.Handle,0); //删除窗口上面的菜单句柄 + end + if (mu is class(tmainmenu)) then + begin + if HandleAllocated() then + begin + mu.Hwnd := handle; + //_wapi.SetMenu(self.Handle,mu.handle); + end + end + FMainMenu := mu; + end + end + + type TTempFile = class + function Create(dt); + begin + if not ifarray(FFiles) then FFiles := array(); + bp :=gettemppath()+"tinysoft"+ioFileseparator()+"tslvcl"+ioFileseparator(); + {if not fileexists("",bp) then + begin + for i:=2 to length(bp) do + begin + if bp[i]=ioFileseparator() then + begin + if fileexists("",bp[1:i-1]) then + begin + createdir("",bp[1:i-1]) + end + end + end + end } + for i,v in mrows( FFiles,1) do + begin + if not(FFiles[v]) then + begin + FFiles[v] := true; + FPath := v; + break; + end + end + while not FPath do + begin + i := 0; + while true do + begin + subdir := tostn( rand(3)[1]); + p := bp+subdir[3]+ioFileseparator()+subdir[4]+".png"; + echo p,"\r\n"; + if not(FFiles[p]) then + begin + FFiles[p] := true; + FPath := p; + //writefile(rwraw(),"",FPath,0,1,"0") ; + break; + end + end + end + if ifstring(dt) then + begin + //if FileExists("",FPath) then filedelete("",FPath); + writefile(rwraw(),"",FPath,0,length(dt),dt) ; + end + end + function GetData(buf);//获得数据 + begin + if FPath then + begin + sz := filesize("",FPath); + return readfile(rwraw(),"",FPath,0,sz,buf); + end + end + function Destroy(); + begin + //FFiles[FPath] := false; + if FileExists("",FPath) then echo "\r\ndeletefile:",filedelete("",FPath); + FPath := ""; + end + property path read FPath ; + private + FPath; + static FFiles; +end + +*) +//暂时不用的函数 +{function chartoint(c); +begin + v := ord(c); + case v of + 48 to 57:vk := v-48; + 65 to 70:vk := v-65+10; + 97 to 102:vk := v-97+10; + else raise "非16进制字符串"; + end + return vk; +end} \ No newline at end of file diff --git a/funcext/tvclib/utslvclbase.tsf b/funcext/tvclib/utslvclbase.tsf new file mode 100644 index 0000000..df09f08 --- /dev/null +++ b/funcext/tvclib/utslvclbase.tsf @@ -0,0 +1,395 @@ +unit utslvclbase; +interface +{$ifdef linux} + {$define gtkpaint} + {$define linuxgtk} +{$else} + {$define gdipaint} +{$endif} +uses utslvclconstant,utslvclmemstruct,utslvclauxiliary,UVCPropertyTypesPersistence; +type tswin32api = class({$ifdef linuxgtk}tsgtkapi {$else} twindowsapi {$endif} ) //windows接口 +{$ifdef linuxgtk} +uses ugtkinterface; +{$else} +uses uwindowsinterface; +{$endif} + {** + @explan(说明) win32api接口函数类 + 1. 导出了部分win32的api + 2. winuser头文件的宏定义 + 3. 添加了部分结构体定义到成员变量 + 4. 下面的external函数的win32api可以在msdn中查找具体用法 + **} + public + function GetScreenRect(); + begin + {** + @explan(说明) 获取屏幕大小%% + @return(array) 左上右下 %% + **} + rc := new tcrect(); + SystemParametersInfoA(0x30,0,rc._getptr_(),0); + return rc._getdata_(); + end + function getpathbyprocid(id); + begin + {** + @explan(说明) 获取所有进程路径 %% + @param(id)(integer) 进程id + **} + strFilePath := ""; + len := 1024; + setlength(strFilePath,len); + hd := OpenProcess(0x000F0000L .| 0x00100000L .| 0xFFFF,0,id); + GetModuleFileNameExA(hd,0,strFilePath,len); + //QueryFullProcessImageNameA(hd, 1, strFilePath, len); + r := ""; + for i := 1 to length(strFilePath) do + begin + vi := strFilePath[i]; + if vi="\0" then break; + r += vi; + end + if hd then CloseHandle(hd); + return r; + end + function EnumProcesses(); + begin + {** + @explan(说明) 获取所有进程id + **} + {** + @example(获取所有进程id,并获得路径) + t := EnumProcesses(); + for i,v in t do echo getpathbyprocid(v),"\r\n"; + **} + ret := zeros(2048); + EnumProcesses_(ret,length(ret)* 4,t); + r := ""; + if t>0 then r := ret[0:t/4]; + return r; + end + + function Toolhelp32Snapshot(); + begin + {** + @explan(说明) 获取所有进程信息 %% + @param() + @return(array) 进程信息 %% + **} + currentProcess := new Ttagprocessentry32(); + hProcess := CreateToolhelp32Snapshot(2,0); //给系统内的所有进程拍一个快照 + r := array(); + if hProcess=-1 then return r; + bMore := Process32First(hProcess,currentProcess._getptr_); //获取第一个进程信息 + countProcess := 0; + while(bMore) do + begin + r[countProcess]:= currentProcess._getdata_; + bMore := Process32Next(hProcess,currentProcess._getptr_); //遍历下一个 + countProcess++; + end + CloseHandle(hProcess); //清除hProcess句柄 + return r; + end + + function Toolhelp32Snapshotmodule(id); + begin + {** + @explan(说明) 获取所有module信息 + **} + if not(id >= 0)then id := 0; + currentProcess := new TtagMODULEENTRY32(); + hProcess := CreateToolhelp32Snapshot(8,id); //给系统内的所有进程拍一个快照 + r := array(); + if hProcess=-1 then return r; + bMore := Module32First(hProcess,currentProcess._getptr_); //获取第一个进程信息 + countProcess := 0; + while(bMore) do + begin + r[countProcess]:= currentProcess._getdata_; + bMore := Module32Next(hProcess,currentProcess._getptr_); //遍历下一个 + countProcess++; + end + CloseHandle(hProcess); //清除hProcess句柄 + return r; + end + function Comctl32version(); //获取comctl32.dll版本 + begin + o := tslcstructure(array( + ("cbsize","int",0), + ("dwmajorversion","int",0), + ("dwminorversion","int",0), + ("dwbuildnumber","int",0), + ("dwplatformid","int",0))); + o._setvalue_("cbsize",o._size_); + Comctl32DllGetVersion(o._getptr_); + return o._getdata_(); + end + function shell32Version(); //获取shell32.dll版本 + begin + o := tslcstructure(array( + ("cbsize","int",0), + ("dwmajorversion","int",0), + ("dwminorversion","int",0), + ("dwbuildnumber","int",0), + ("dwplatformid","int",0))); + o._setvalue_("cbsize",o._size_); + shell32DllGetVersion(o._getptr_); + return o._getdata_(); + end + function GetCursorInfo(); //获取cursor 信息 + begin + { + 字段: + flags 为0 表示 The cursor is hidden. + 为1 表示 The cursor is showing. + 为2 表示 The cursor is suppressed + hcursor 光标句柄 + ptscreenpos 光标位置 + } + o := new ctslctrans(array( + ("cbsize","int",0,0,4,"int",1), + ("flags","int",0,4,4,"int",1), + ("hcursor","intptr",0,8,4,"intptr",1), + ("ptscreenpos","int[2]", + (0,0),12,8,"intarray",2)),nil,nil); + o._setvalue_("cbsize",o._size_()); + if(GetCursorInfo_(o._getptr_()))then + begin + return o._getdata_(); + end + end + function GetMonitor(mhandle,r); //获得显示器信息%% + begin + r := new TMONITORINFO(); + return GetMonitorInfoA(mhandle,r._getptr_()); + end + +end +type TSLUIBASE=class(TSLUICONST) //图像库基类 + {** + @explan(说明)图像库基类,提供基本的底层操作和常量 %% + **} + private + FReCycleState; + static FTSLkeyWords; + static TSLRCS_NONE; + static TSLRCS_BEGIN; + static TSLRCS_END; + static FHAPP; + static FEditTypes; + _hashdata; + _temppath; + function Gethapp(); + begin + return FHAPP; + end + function SetHapp(v); + begin + end + public + static _wapi; //windows api; + function create();virtual; //构造 + begin + _hashdata := array(); + sinit(); + FReCycleState := TSLRCS_NONE; + end + class function sinit();virtual; + begin + {** + @explan(说明)初始化win32接口对象_wapi + **} + if not(_wapi)then + begin + global G_O_TSWIN32API_; + if not G_O_TSWIN32API_ then G_O_TSWIN32API_ := new tswin32api(); + _wapi := G_O_TSWIN32API_; + FTSLkeyWords := TSL_ReservedKeys2(); + end + if not FHAPP then + begin + FHAPP := _wapi.GetModuleHandleA(0); + TSLRCS_NONE := 0; + TSLRCS_BEGIN := 1; + TSLRCS_END := 2; + end + end + class Function isKeyWords(key); + begin + {** + @explan(说明) 判断是否为tsl关键字 %% + @param(key)(string) + **} + return ifstring(key)and ifarray(FTSLkeyWords)and(lowercase(key)in FTSLkeyWords); + return false; + end + + function destroy();virtual; + begin + if FReCycleState=TSLRCS_NONE then Recycling(); + end + function NoRecycled(); + begin + {** + @explan(说明) 是否没有被回收 %% + @return(bool) 没有回收返回true ,否则返回false; + **} + return FReCycleState=TSLRCS_NONE; + end + function Recycling();virtual; + begin + {** + @explan(说明)析构准备;为消除循环引用的销毁 + **} + if FReCycleState=TSLRCS_END then return; + _Tag := nil; + _hashdata := array(); + FReCycling := true; + FReCycleState := TSLRCS_END; + end + function hashset(i,v,f); + begin + {** + @explan(说明)设置一个哈希值 %% + @param(i)(string | integer) 下标 %% + @param(f)(bool) i=nil and f=1 and v=array 替换哈希表 %% + @param(v)() 值 + **} + if ifstring(i)or ifint(i)then + begin + _hashdata[i]:= v; + end else + if(ifnil(i)and ifarray(v)and(f=1))then _hashdata := v; + end + function hashget(i); + begin + {** + @explan(说明)获取一个哈希值 %% + @param(i)(string | integer) 下标 %% + @return() 值 + **} + if ifstring(i)or ifint(i)then + begin + return _hashdata[i]; + end else + if ifnil(i)then return _hashdata; + end + function hashdel(i,f); + begin + {** + @explan(说明)删除一个哈希值 %% + @param(i)(string | integer) 下标 %% + @param(f)(bool) i=nil and f=1 清空hash表 %% + @return(bool)是否成功 + **} + if ifstring(i)or ifint(i)then + begin + return reindex(_hashdata,array(i:nil)); + end else + if ifnil(i)and f=1 then _hashdata := array(); + end + function caption(s);virtual; + begin + return ""; + end + function temppath(); + begin + {** + @explan(说明) 获取一个可以读写的文件夹 %% + @return(string) 目录路径 %% + **} + if not(ifstring(_temppath)and _temppath)then _temppath := gettemppath()+"tinysoft"; + return _temppath; + end + class function RegPropertyType(v); //注册设计器编辑 + begin + RegComponentPropertyType(v); + end + class function GetPropertyType(n); //获得设计器编辑 + begin + return GetComponentPropertyType(n); + end + property happ read Gethapp write SetHapp; + property ReCycleState read FReCycleState; //write FReCycleState; + _Tag; //标签 + {** + @param(_wapi)(tswin32api) win32宏定义,以及api接口 %% + @param(_Tag)(any) 调用者使用的成员变量 %% + **} +end +type TWMNCHITTEST=class(TSLUICONST) // hittest消息处理类 + function hitstyle(o,e); + begin + return hitstyle2(o,e.lolparam,e.hilparam); + end + function hitstyle2(o,x,y); + begin + //rec := o.clientrect(); //客户区 + //p := o.screentoclient(e.lolparam,e.hilparam); + rec := zeros(4); + o._wapi.GetWindowRect(o.Handle,rec); + p := array(x,y); // + r := borerhittest(p,rec,4); + r := inttohit(r); + return r; + end + function inttohit(i); + begin + r := HTCLIENT; + case i of + 1:r := HTTOPLEFT; + 2:r := HTTOPRIGHT; + 3:r := HTBOTTOMRIGHT; + 4:r := HTBOTTOMLEFT; + 5:r := HTLEFT; + 6:r := HTTOP; + 7:r := HTRIGHT; + 8:r := HTBOTTOM; + end; + return r; + end + function borerhittest(p,rec,dv); + begin + rec[0]+= 1; + rec[1]+= 1; + rec[2]-= 1; + rec[3]+= 1; + ps := array(rec[0:1],(rec[2],rec[1]),(rec[2],rec[3]),(rec[0],rec[3])); + ds := array(); + for i,v in ps do + begin + ds[i]:= integer(sqrt((p[0]-v[0])^2+(p[1]-v[1])^2)); + end + minds := minvalue(ds); + if minds 0 then includestate(Result, ssShift); + if (Keys .& MK_Control) <> 0 then includestate(Result, ssCtrl); + if (Keys .& MK_LButton) <> 0 then includestate(Result, ssLeft); + if (Keys .& MK_RButton) <> 0 then includestate(Result, ssRight); + if (Keys .& MK_MButton) <> 0 then includestate(Result, ssMiddle); + if (Keys .& MK_XBUTTON1) <> 0 then includestate(Result, ssExtra1); + if (Keys .& MK_XBUTTON2) <> 0 then includestate(Result, ssExtra2); + if (Keys .& MK_DOUBLECLICK) <> 0 then includestate(Result, ssDouble); + if (Keys .& MK_TRIPLECLICK) <> 0 then includestate(Result, ssTriple); + if (Keys .& MK_QUADCLICK) <> 0 then includestate(Result, ssQuad); + global G_O_TSWIN32API_; + if G_O_TSWIN32API_ then + begin + v := G_O_TSWIN32API_.GetKeyState(VK_MENU); + end else v := 0; + if _shr(v,15) then includestate(Result, ssAlt); + //if gettswin32api().GetKeyState(VK_MENU) < 0 then includestate(Result, ssAlt); + //if (GetKeyState(VK_LWIN) < 0) or (GetKeyState(VK_RWIN) < 0) then Include(Result, ssMeta); + return Result; + end; + + end +type TMMOUSEWHEEL=class(tuieventbase) + {** + @explan(说明)鼠标滚动消息类 %% + **} + function create(m,w,l,h);override; + begin + inherited; + end + function shiftstate(); + begin + {** + @explan(说明) 按键状态 %% + @return(array of TShiftStateEnum menuber) shift 键集合 + **} + if ifnil(FKeyState)then + begin + FKeyState := class(TSIFTSTATE).KeysToShiftState(lowparam()); + end + return FKeyState; + end + property delta read hiwparamsigned; + property ypos read hilparamsigned; + property xpos read lolparamsigned; + {** + @param(ypos)(integer)鼠标的y坐标 %% + @param(xpos)(integer)鼠标的x坐标 %% + @param(delta)(integer)运动距离 %% + **} + private + FKeyState; +end +type TMMouse=class(tuieventbase) + {** + @explan(说明) 鼠标消息类 %% + **} + protected FButton; + public + function create(m,w,l,h);override; + begin + inherited; + end + {** + @param(xpos)(integer) x 位置 %% + @param(ypos)(integer) y 位置 %% + @param(FButton)(integer) 按键状态,继承时候使用 %% + **} + property xpos:integer read lolparamsigned; + property ypos:integer read hilparamsigned; + function pos(); + begin + return array(xpos(),ypos()); + end + property Dummy read Lparam; + function SetButton(v); + begin + {** + @ignore(忽略) %% + **} + if ifnumber(v)then FButton := v; + else return FButton; + end + function button(); + begin + {** + @explan(说明) 鼠标按键情况 %% + @return(member of TMouseButton) + **} + return FButton; + end + function shiftstate(); + begin + {** + @explan(说明) 按键状态 %% + @return( array of TShiftStateEnum menuber) %% + **} + if ifnil(FKeyState)then + begin + FKeyState := class(TSIFTSTATE).KeysToShiftState(Wparam); + end + return FKeyState; + end + function setshiftdouble(v); + begin + {** + @ignore(忽略) %% + **} + shiftstate(); + if ifnumber(v)then + begin + includestate(FKeyState,v); + end + end + function shiftdouble(); + begin + {** + @explan(说明) 是否双击 %% + @return(bool) 是否双击 + **} + shiftstate(); + return(ssDouble in FKeyState); + end + private + FKeyState; +end +type TMSTYLECHANG=class(tuieventbase) + {** + @explan(说明)窗口样式改变消息 %% + **} + private + FSTyle; + function _getvalue_(n); + begin + return FSTyle._getvalue_(n); + end + function _setvalue_(n,v); + begin + return FSTyle._setvalue_(n,v); + end + public + function create(m,w,l,h);override; + begin + inherited; + FSTyle := new TSTYLESTRUCT(l); + end + property styleold index "styleold" read _getvalue_ write _setvalue_; + property stylenew index "stylenew" read _getvalue_ write _setvalue_; + {** + @param(stylenew)(integer) 新样式 %% + @param(styleold)(integer) 旧样式 %% + **} +end + + +implementation + +initialization +finalization + +end. \ No newline at end of file diff --git a/funcext/tvclib/utslvclgdi.tsf b/funcext/tvclib/utslvclgdi.tsf new file mode 100644 index 0000000..c75f14d --- /dev/null +++ b/funcext/tvclib/utslvclgdi.tsf @@ -0,0 +1,2990 @@ +unit utslvclgdi; +{** + @explan(说明) gdi 对象库 %% + @date(20220507) +**} +interface +uses cstructurelib,utslvclmemstruct,utslvclauxiliary,utslvclbase; + +function GetTextWidthAndHeightWidthFont(s,f,mul); +type TGdi = class(TSLUIBASE) + private + static GDICache; + FCanvas; + function SetCanvas(c); + begin + FCanvas := c; + Onchange(); + end + protected FHandle; //gdi句柄 + FGdistate; + FGDIstruct; + class function sinit();override; + begin + if not GDICache then + begin + inherited; + if _wapi then + GDICache := new TResourcescache(_wapi); + end + end + public + function HandleAllocated();virtual; + begin + return FHandle <> 0 and ifnumber(FHandle); + end + function HandleNeeded();virtual; + begin + return FHandle; + end + function DestroyHandle();virtual; + begin + if HandleAllocated()then + begin + unreference(); + FHandle := 0; + end + end + function GetGDIinfo();virtual; + begin + if not FGDIstruct then + begin + FGDIstruct := 1; + end + //return array(); + end + function Onchange();virtual; + begin + end + function GetFormatGdiStr(); + begin + v := gdiformatstr(); + if ifstring(v)then return getmsgd_Crc32(v); + return ""; + end + function reference();virtual; + begin + return GDICache.reference(GetFormatGdiStr()); + end + function addsource(v);virtual; + begin + GDICache.addsource(GetFormatGdiStr(),v); + end + function unreference();virtual; + begin + GDICache.unreference(GetFormatGdiStr()); + end + + function destroyresource();virtual; + begin + GDICache.destroyresource(GetFormatGdiStr()); + end + function gdiformatstr();virtual; + begin + return 0; + end + function create();override; + begin + inherited; + FGdistate := array(); + end + function Recycling();override; + begin + FCanvas := nil; + DestroyHandle(); + inherited; + end + property Canvas read FCanvas write SetCanvas; + property Handle read HandleNeeded; +end +type Tcustomfont = class(tgdi) + private + FHeight; + FWidth; + Fescapement; + Forientation; + Fweight; + Fitalic; + Funderline; + Fstrikeout; + Fcharset; + Foutprecision; + Fclipprecision; + Fquality; + Fpitchandfamily; + Ffacename; + FColor; + FBKColor; + FBkmode; + static LOGSTRUCT; + static LOGSTRUCTarray; + class function sinit();override; + begin + inherited; + if not LOGSTRUCTarray then + begin + LOGSTRUCTarray := array( + ("height","int",15), + ("width","int",0), + ("escapement","int",0), + ("orientation","int",0), + ("weight","int",400), + ("italic","byte",0), + ("underline","byte",0), + ("strikeout","byte",0), + ("charset","byte",134), + ("outprecision","byte",3), + ("clipprecision","byte",2), + ("quality","byte",1), + ("pitchandfamily","byte",FIXED_PITCH), + ("facename","char[32]","新宋体")); + dt := MemoryAlignmentCalculate(LOGSTRUCTarray,1,nil,nil); + LOGSTRUCT := new tslcstructureobj(dt,nil); + end + end + function SetColor(c); + begin + if ifnumber(c)and c <> FColor then + begin + FColor := c; + if Canvas then Canvas.OnFontColorChange(); + end + end + function SetbkColor(c); + begin + if ifnumber(c)and c <> FBKColor then + begin + FBKColor := c; + if Canvas then Canvas.OnFontbkColorChange(); + end + end + function SetbkMode(c); + begin + nc :=(c=OPAQUE)?OPAQUE:TRANSPARENT; + if FBkmode <> nc then + begin + FBkmode := nc; + if Canvas then Canvas.OnFontbkmodeChange(); + end + end + function Setheight(v) + begin + if ifnumber(v)and v <> Fheight then + begin + Fheight := v; + onchange(); + end + end + function Setwidth(v) + begin + if ifnumber(v)and v <> Fwidth then + begin + Fwidth := v; + onchange(); + end + end + function Setescapement(v) + begin + if ifnumber(v)and v <> Fescapement then + begin + Fescapement := v; + onchange(); + end + end + function Setorientation(v) + begin + if ifnumber(v)and v <> Forientation then + begin + Forientation := v; + onchange(); + end + end + function Setweight(v) + begin + if not(v=400 or v=700)then return; + if v <> Fweight then + begin + Fweight := v; + onchange(); + end + end + function Setitalic(v) + begin + nv := v?true:false; + if nv <> Fitalic then + begin + Fitalic := nv; + onchange(); + end + end + function Setunderline(v) + begin + nv := v?true:false; + if nv <> Funderline then + begin + Funderline := nv; + onchange(); + end + end + function Setstrikeout(v) + begin + nv := v?true:false; + if nv <> Fstrikeout then + begin + Fstrikeout := nv; + onchange(); + end + end + function Setcharset(v) + begin + if ifnumber(v)and v <> Fcharset then + begin + Fcharset := v; + onchange(); + end + end + function Setoutprecision(v) + begin + if not(v in array(OUT_DEFAULT_PRECIS,OUT_DEVICE_PRECIS,OUT_OUTLINE_PRCIS,OUT_RASTER_PRECIS, + OUT_STRING_PRECIS,OUT_STROKE_PRECIS,OUT_TT_ONLY_PRECIS,OUT_TT_PRECIS))then return; + if v <> Foutprecision then + begin + Foutprecision := v; + onchange(); + end + end + function Setclipprecision(v) + begin + if not ifnumber(v)then return; + if(v .&(CLIP_DEFAULT_PRECIS .| CLIP_STROKE_PRECIS .| CLIP_MASK .| CLIP_LH_ANGLES .| CLIP_TT_ALWAYS))and v <> Fclipprecision then + begin + Fclipprecision := v; + onchange(); + end + end + function Setquality(v) + begin + if not(v in array(DEFAULT_QUALITY,DRAFT_QUALITY,PROOF_QUALITY))then return; + if v <> Fquality then + begin + Fquality := v; + onchange(); + end + end + function Setpitchandfamily(v) + begin + if not(v in array(DEFAULT_PITCH,FIXED_PITCH,VARIABLE_PITCH, + FF_DECORATIVE,FF_MODERN,FF_ROMAN,FF_SCRIPT,FF_SWISS))then return; + if v <> Fpitchandfamily then + begin + Fpitchandfamily := v; + onchange(); + end + end + function Setfacename(v) + begin + if ifstring(v)and v <> Ffacename and length(v)<= 32 then + begin + Ffacename := v; + onchange(); + end + end + protected + function gdiformatstr();override; + begin + s := ""; + for i,v in LOGSTRUCTarray do + begin + v0 := v[0]; + s += v0; + s += ":"; + if v0="facename" then + begin + s += invoke(self,"f"+v0); + end else + vvi := invoke(self,"f"+v0); + if ifnumber(vvi)then s += inttostr(vvi); + else s += "0"; + s += ";"; + end + r := "class:font;"+s; + return r; + end + public + function HandleNeeded();override; + begin + if not HandleAllocated()then + begin + hp := reference(); + if not hp then + begin + for i,v in LOGSTRUCTarray do + begin + v0 := v[0]; + LOGSTRUCT._setvalue_(v0,invoke(self,"f"+v0)); + end + hp := _wapi.CreateFontIndirectA(LOGSTRUCT._getptr_); + addsource(hp); + end + FHandle := hp; + end + return FHandle; + end + function fontinfo(); + begin + {** + @explan(说明) 获得字体信息 %% + **} + r := array(); + for i,v in LOGSTRUCTarray do + begin + r[v[0]]:= invoke(self,v[0]); + end + r["color"]:= color; + r["bkcolor"]:= bkcolor; + return r; + end + function create();override; + begin + inherited; + fheight := 15; + fwidth := 7; + fescapement := 0; + forientation := 0; + fweight := 400; + fitalic := 0; + funderline := 0; + fstrikeout := 0; + fcharset := 134; + foutprecision := 3; + fclipprecision := 2; + fquality := 1; + fpitchandfamily := FIXED_PITCH; + ffacename := "新宋体"; + FColor := 0; + Onchange(); + end + function Onchange();override; + begin + if Canvas then Canvas.OnFontChange(); + DestroyHandle(); + end + function copyfont(f);virtual; + begin + {** + @explan(说明) 字体信息拷贝 %% + @param(f)(Tcostmtont) + **} + if not(f is class(Tcustomfont))then exit; + return SetValues(f.fontinfo()); + val := array(); + for i,v in LOGSTRUCTarray do + begin + v0 := v[0]; + fvi := invoke(f,v0); + val[v0]:= fvi; + end + val["color"]:= f.color; + val["bkcolor"]:= f.bkcolor; + return SetValues(val); + end + function SetValues(vs);virtual; + begin + {** + @explan(说明) 通过数组设置字体属性 %% + @param(vs)(array)字体信息数据 %% + **} + if not ifarray(vs)then exit; + for i,v in LOGSTRUCTarray do + begin + v0 := v[0]; + vsv := vs[v0]; + if not ifnil(vsv)then + begin + ovi := invoke(self,"f"+v0); + if ovi <> vsv then + begin + invoke(self,"f"+v0,1,vsv); + cg := true; + end + end + end + if ifnumber(vs["color"])then + begin + cg := true; + SetColor(vs["color"]); + end + if cg then Onchange(); + return cg; + end + function GetFontWidth(); + begin + if FWidth>0 then return FWidth; + return abs(FHeight)/2; + end + property height read Fheight write Setheight; + property width read Fwidth write Setwidth; + property escapement read Fescapement write Setescapement; + property orientation read Forientation write Setorientation; + property weight read Fweight write Setweight; + property italic read Fitalic write Setitalic; + property underline read Funderline write Setunderline; + property strikeout read Fstrikeout write Setstrikeout; + property charset read Fcharset write Setcharset; + property outprecision read Foutprecision write Setoutprecision; + property clipprecision read Fclipprecision write Setclipprecision; + property quality read Fquality write Setquality; + property pitchandfamily read Fpitchandfamily write Setpitchandfamily; + property facename read Ffacename write Setfacename; + property Color read FColor write SetColor; + property bkColor read FBKColor Write SetBkColor; + property bkmode read FBkmode Write SetBkMode; +end +type TFontControl=class(Tcustomfont) + {** + @explan(说明) 控件字体 %% + **} + private + FControl; + Function SetControl(v); + begin + if(v <> FControl)and(v is class(tcontrol))then + begin + FControl := v; + end + end + protected + function Onchange();override; + begin + inherited; + if FControl then + begin + FControl.FontChanged(); + end + end + public + function create();override; + begin + inherited; + end + function Recycling();override; + begin + FControl := nil; + inherited; + end + property Control read FControl write SetControl; +end +type tcustompen=class(tgdi) + private + FStyle; + FColor; + FWidth; + static LOGSTRUCT; + class function sinit();override; + begin + inherited; + if not LOGSTRUCT then + begin + LOGSTRUCTarray := array(("lopenstyle","int",0), + ("lopnwidth","int",1), + ("lopnwidth2","int",0), + ("lopncolor","int",0)); + dt := MemoryAlignmentCalculate(LOGSTRUCTarray,1,nil,nil); + LOGSTRUCT := new tslcstructureobj(dt,nil); + end + end + function HandleNeeded();override; + begin + if not HandleAllocated()then + begin + hp := reference(); + if not hp then + begin + if fStyle in array(PS_NULL,PS_SOLID,PS_INSIDEFRAME)then + begin + w := FWidth; + end else + w := 0; + hp := _wapi.CreatePen(FStyle,w,FColor); + addsource(hp); + end + FHandle := hp; + end + return FHandle; + end + function gdiformatstr();override; + begin + return format("class:pen;style:%d;color:%d;width:%d",FStyle,FColor,FWidth); + end + function Onchange();override; + begin + if Canvas then Canvas.OnPenChange(); + DestroyHandle(); + end + function SetColor(c); + begin + if ifnumber(c)and c <> FColor then + begin + Onchange(); + FColor := c; + end + end + function SetStyle(s); + begin + if(s in array(0,1,2,3,4,5,6)) and s <> FStyle then + begin + Onchange(); + FStyle := s; + end + end + function SetWidth(w); + begin + if w >= 0 and w<20 and c <> FWidth then + begin + Onchange(); + FWidth := w; + end + end + function copypen(p); + begin + {** + @explan(说明)拷贝pen属性 %% + @param(p)(tcustompen) 源 %% + **} + if p is class(tcustompen)then + begin + ps := p.style; + wd := p.width; + cl := p.color; + if ps <> FStyle or wd <> FWidth or cl <> FColor then + begin + Onchange(); + FStyle := ps; + FWidth := wd; + FColor := cl; + end + end + end + public + function create(); + begin + inherited; + FStyle := PS_SOLID; + FWidth := 1; + FColor := 0; + end + property Color read FColor write SetColor; + property Width read FWidth write SetWidth; + property Style read FStyle write SetStyle; +end +type tcustombrush=class(tgdi) + private + FStyle; + FColor; + FHatch; + static LOGSTRUCT; + function SetColor(c); + begin + if ifnumber(c)and c <> FColor then + begin + onchange(); + FColor := c; + end + end + public + class function sinit();override; + begin + inherited; + if not LOGSTRUCT then + begin + + LOGSTRUCTarray := array(("lbstyle","int",BS_SOLID), + ("lbcolor","int",0), + ("lbhatch","intptr",0)); + dt := MemoryAlignmentCalculate(LOGSTRUCTarray,1,nil,nil); + LOGSTRUCT := new tslcstructureobj(dt,nil); + end + end + function onchange();override; + begin + if Canvas then Canvas.OnBrushChange(); + DestroyHandle(); + end + function HandleNeeded();override; + begin + if not HandleAllocated()then + begin + hp := reference(); + if not hp then + begin + //LOGSTRUCT._setvalue_("lbstyle",FStyle); + //LOGSTRUCT._setvalue_("lbcolor",FColor); + //LOGSTRUCT._setvalue_("lbhatch",FHatch); + //hp := _wapi.CreateBrushIndirect(LOGSTRUCT._getptr_); + hp := _wapi.CreateSolidBrush(FColor); + addsource(hp); + end + FHandle := hp; + end + return FHandle; + end + function gdiformatstr();override; + begin + return format("class:brush;style:%d;color:%d;hatch:%d",FStyle,FColor,FHatch); + end + function create();override; + begin + inherited create(); + sinit(); + FStyle := BS_SOLID; + FHatch := 0; + FColor := 0; + end + function copybrush(b); + begin + if b is class(tcustombrush)then + begin + if FColor <> b.color then + begin + onchange(); + FColor := b.color; + end + end + end + //property Style read FStyle write SetStyle; + property Color read FColor write SetColor; + //property Hatch read FHatch write SetHatch; +end +type TRgn = class(TSLUIBASE) + {** + @explan(说明) 区域 %% + **} + private + FHandle; + function GetHandle(); + begin + if not HandleAllocated()then FHandle := CreateRgn(); + return FHandle; + end + function SetHandle(v); + begin + if v <> FHandle then + begin + DestroyHandle(); + if ifnumber(v)and v then FHandle := v; + end + end + public + function Create();override; + begin + inherited; + end + function HandleAllocated(); + begin + return FHandle and ifnumber(FHandle); + end + function DestroyHandle(); + begin + if HandleAllocated()then _wapi.DeleteObject(FHandle); + FHandle := 0; + end + function CreateRgn();virtual; + begin + return _wapi.createrectrgn(0,0,0,0); + end + class function CombineRgn(rgn1,rgn2,f,rgn); + begin + {** + @explan(说明)rgn合并%% + @param(rgn1)(trgn) 区域1 %% + @param(rgn2)(trgn) 区域2 %% + @param(rgn)(trgn) 返回合并后的区域 %% + @param(f)(integer) 合并方式 RGN_AND RGN_COPY RGN_DIFF RGN_OR RGN_XOR %% + @param(integer) 返回 NULLREGION COMPLEXREGION SIMPLEREGION ERROR + **} + if(rgn1 is class(TRGN))and(rgn2 is class(TRGN))then + begin + rgn := new TRgn(); + return _wapi.CombineRgn(rgn.Handle,s1.Handle,rgn2.Handle,f); + end + end + function Recycling();override; + begin + DestroyHandle(); + inherited; + end + property Handle read GetHandle write SetHandle; +end +type TRGNELLIP=class(TRGN) //椭圆 + {** + @explan(说明)椭圆rgn + **} + private + FRect; + function SetRect(v); + begin + if v <> FRect and ifarray(v) and ifnumber(v[0])and ifnumber(v[1])and v[2]>v[0]and v[3]>v[1] then + begin + FRect := v; + DestroyHandle(); + end + end + public + function create();override; + begin + inherited; + FRect := array(0,0,0,0); + end + function CreateRgn();override; + begin + return _wapi.CreateEllipticRgn(FRect[0],FRect[1],FRect[2],FRect[3]); + end + property Rect read FRect write SetRect; +end +type TRGNRECT=class(TRGNELLIP) + {** + @explan(说明)矩形区域%% + + **} + function create();override; + begin + inherited; + end + function CreateRgn();override; + begin + rec := Rect; + return _wapi.CreateRectRgn(rec[0],rec[1],rec[2],rec[3]); + end +end +type TRGNRoundRect=class(TRGNELLIP) + {** + @explan(说明) RoundRect rgn %% + **} + private + FEllipseWidth; + FEllipseHeight; + function SetEllipseWidth(v); + begin + if v >= 0 and v <> FEllipseWidth then + begin + FEllipseWidth := v; + DestroyHandle(); + end + end + function SetEllipseHeight(); + begin + if v >= 0 and v <> FEllipseHeight then + begin + FEllipseHeight := v; + DestroyHandle(); + end + end + public + function Create(AOwner);override; + begin + inherited; + FEllipseHeight := 1; + FEllipseWidth := 1; + end + function CreateRgn();override; + begin + rec := Rect; + return _wapi.CreateRoundRectRgn(rec[0],rec[1],rec[2],rec[3],FEllipseWidth,FEllipseHeight); + end + property EllipseWidth:integer read FEllipseWidth write SetEllipseWidth; + property EllipseHeight:integer read FEllipseHeight write SetEllipseHeight; +end +type TRGNPOLY=class(TRGN) //多边形 + {** + @explan(说明)多边形区域%% + **} + private + FPoints; + FImode; + function pointtovector(pts); //点转换为数组 + begin + t := array(); + lt := 0; + if not ifarray(pts)then return array(); + for i,v in pts do + begin + if ifarray(v)and ifnumber(v[0])and ifnumber(v[1])then + begin + t[lt++]:= v[0]; + t[lt++]:= v[1]; + end + end + return t; + end + function SetImode(v); + begin + if(v in array(1,2))and v <> FImode then + begin + FImode := v; + DestroyHandle(); + end + end + function SetPoints(v); + begin + if v <> FPoints then + begin + FPoints := v; + DestroyHandle(); + end + end + public + function create(); //点 和填充模式 + begin + inherited; + FImode := ALTERNATE; + end + function CreateRgn();override; + begin + t := pointtovector(FPoints); + len := length(t); + if len>5 then return _wapi.CreatePolygonRgn(t,len/2,FImode); + end + property Points read FPoints write SetPoints; + property Imode read FImode write SetImode; +end + +type tcustomimage=class(TSLUIBASE) + {** + @explan(说明)image类采用gdiflat封装 %% + **} + private + FHandle; + FGdi; + Static FImageTypes; + class function GetFileType(t_); + begin + if not(t_ and ifstring(t_))then t := "png"; + else t := lowercase(t_); + if not(t in array("png","jpeg","bmp","gif","tiff"))then exit; + vp := FImageTypes[t]; + if vp then return vp; + dt := MemoryAlignmentCalculate(array((0,"byte[20]",array())),1,nil,nil); + vp := new tslcstructureobj(dt,nil); + //messagebox("image/"+t,"123",0); + nt := _wapi.AnsiToWidChar("image/"+t); + vvp := _wapi.GetEncoderClsid(nt,vp._getptr_); + if vvp <>-1 then + begin + FImageTypes[t]:= vp; + end + return vp; + end + function IFhandle(h); + begin + return ifnumber(h)and h; + end + private + function ImageToStream(t); + begin + {** + @ignore(忽略) %% + @explan(说明) image 转换为stream %% + **} + if not FHandle then exit; + vp := GetFileType(t); + _wapi.CreateStreamOnHGlobal(0,true,st); + r := gdi.GdipSaveImageToStream(FHandle,st,vp._getptr_,0); + if r <> 0 then exit; + return st; + end + public + class function sinit();override; + begin + inherited; + if not ifarray(FImageTypes)then + begin + //return ; + FImageTypes := array(); + for i,v in array("png","jpeg","bmp","gif","tiff") do + begin + GetFileType(v); + end + end + end + function create(); + begin + inherited; + FHandle := 0; + FGdi := new TGdiplusflat(); + end + function DestroyHandle(); + begin + {** + @explan(说明) 销毁句柄 %% + **} + if IFhandle(FHandle)then + begin + gdi.GdipDisposeImage(FHandle); + end + FHandle := 0; + end + function Recycling();override; + begin + {** + @explan(说明) 回收 %% + **} + DestroyHandle(); + inherited; + end + function Destroy();override; + begin + inherited; + end + function LoadFromFile(path); + begin + {** + @explan(说明)打开文件 %% + @param(path)(string) 路径 %% + **} + if not ifstring(path)then exit; + size := filesize("",path); //获取文件大小 + r :=-1; + if readFile(rwraw(),"",path,0,size,data)then + begin + r := StringToImage(data); + end + return r; + //***********GdipLoadImageFromFile 报错**************** + fn := _wapi.AnsiToWidChar(path); + r := gdi.GdipLoadImageFromFile(fn,hd); + if hd then + begin + DestroyHandle(); + FHandle := hd; + end + return r; + end + function SavetoFile(p,t); + begin + {** + @explan(说明) 保存到文件%% + @param(p)(string)路径 %% + @param(t)(string)类型 ,"png" "bmp" "gif" + **} + if not ifstring(p)then return-1; + if not ifstring(t)then t := "png"; + if not FHandle then return-1; + vp := GetFileType(t); + fn := _wapi.AnsiToWidChar(p); + return Gdi.GdipSaveImageToFile(FHandle,fn,vp._getptr_(),0); + end + function ImageToString(t); + begin + {** + @explan(说明) 得到图片内存%% + @param(t)(string) png bmp %% + **} + if not FHandle then exit; + /////////整理imagetostring////////// + vp := GetFileType(t); + s := gdi.imagetostring(FHandle,vp); + return s; + end + function StringToImage(b); + begin + {** + @explan(说明) 从字符串到图片 %% + @param(b)(string) 内存 %% + **} + if not(b and ifstring(b))then return 3; + ////////整理////////////////////// + r := gdi.stringtoimage(b,hd); + if hd then + begin + DestroyHandle(); + FHandle := hd; + end + return r; + end + function ToHbitmap(); + begin + {** + @explan(说明) 转换为bitmap %% + @return(pointer) + **} + if not FHandle then exit; + gdi.GdipCreateHBITMAPFromBitmap(FHandle,fhbmp,rgb(255,255,255)); + return fhbmp; + end + function FromHBitmap(bmp); + begin + {** + @explan(说明) 从bitmap得到图片 %% + @param(bmp)(pointer) hbitmap + **} + if not(IFhandle(bmp))then exit; + if bmp=FHandle then exit; + gdi.GdipCreateBitmapFromHBITMAP(bmp,0,hd); + if hd then + begin + DestroyHandle(); + FHandle := hd; + end + end + function FromHIcon(ico); + begin + {** + @explan(说明) 从hicon得到图片 %% + @param(ico)(pointer) hicon %% + **} + if not(ifnumber(ico)and ico)then exit; + if bmp=ico then exit; + gdi.GdipCreateBitmapFromHICON(ico,hd); + if hd then + begin + DestroyHandle(); + FHandle := hd; + end + end + function tohicon(); + begin + {** + @explan(说明) 得到hcion %% + @return(pointer)hicon + **} + if not FHandle then exit; + gdi.GdipCreateHICONFromBitmap(FHandle,hd); + return hd; + end + property Gdi read FGdi; + property Handle Read FHandle; + {** + @param(gdi)(TGdiplusflat) gdi对象 %% + @param(handle)(pointer) 句柄 %% + **} +end +type TPicturebase=class(TSLUIBASE) + {** + @explan(说明)bitmap,ico基类 %% + **} + private + FImage; + public + function Create();override; + begin + inherited; + try + FImage := new tcustomimage(); + except + raise "^~^ gdi support err!"; + FImage := 0; + end; + end + function Recycling();override; + begin + FImage := nil; + inherited; + end + property Image read FImage; +end + +type TcustomBitmap = class(TPicturebase) + {** + @explan(说明) bitmap 类 %% + **} + private + FHandle; + FId; + FDestroy; + FBytes; + FDIBites; + FBitmap; + static FsysBitmaps; + static FSHDC; + static FSHDC2; + class function sinitdc(); + begin + if not FSHDC then + begin + FSHDC := _wapi.CreateCompatibleDC(0); + FSHDC2 := _wapi.CreateCompatibleDC(0); + end + end + function getvalue(n); + begin + case n of + "bmtype":return FBitmap.bmtype; + "bmwidth":return FBitmap.bmwidth; + "bmheight":return FBitmap.bmheight; + "bmwidthbytes":return FBitmap.bmwidthbytes; + "bmplanes":return FBitmap.bmplanes; + "bmbitspixel":return FBitmap.bmbitspixel; + end + end + + function setvalue(n,v); + begin + case n of + "bmtype" : FBitmap.bmtype :=v ; + "bmwidth" : FBitmap.bmwidth :=v ; + "bmheight" : FBitmap.bmheight :=v ; + "bmwidthbytes" : FBitmap.bmwidthbytes:=v ; + "bmplanes" : FBitmap.bmplanes :=v ; + "bmbitspixel" : FBitmap.bmbitspixel :=v ; + end ; + end + function SetHandle(h); + begin + {** + @explan(说明) 设置句柄 %% + **} + if h=FHandle then exit; + if HandleAllocated()then DestroyHandle(); + FDIBites := FBytes := ""; + FHandle := h; + ReadhInfo(); + end + Function ReadhInfo(); + begin + {** + @explan(说明) 获取信息 %% + **} + if HandleAllocated()and FBitmap then + begin + _wapi.GetObjectA(FHandle,FBitmap._size_(),FBitmap._getptr_()); + end + end + function setid(id);virtual; + begin + {** + @explan(说明) 设置id %%; + **} + if id <> FId then + begin + Fid := id; + DestroyHandle(); + if ifnumber(id)then h := loadsysbmp(id); + if h then + begin + AutoDestroy := false; //不删除 + end else + begin + h := getresourcebyid(id,array("type":"bmp")); + if not h then + begin + if Image then + begin + //echo "\r\nloadok:", + Image.LoadFromFile(id); + //echo "\r\n=================readhandle:",Image.Handle; + h := Image.ToHbitmap(); + end + end + AutoDestroy := true; //删除 + end + if h then + begin + SetHandle(H); + end + end + end + protected + class function loadsysbmp(id);virtual; + begin + {** + @explan(说明) 获取系统的bitmap句柄 %% + @param(id)(menuber of TSystemBitmap) id %% + @return(hbitmap) 句柄 %% + **} + if not ifarray(FsysBitmaps)then FsysBitmaps := array(); + r := FsysBitmaps[id]; + if r then return r; + else + begin + r := _wapi.LoadBitmapA2(nil,id); + FsysBitmaps[id]:= r; + end + return r; + end + function DestroyHandle();virtual; + begin + {** + @explan(说明) 析构句柄 %% + **} + if HandleAllocated()and FDestroy then _wapi.DeleteObject(FHandle); + FHandle := 0; + FBytes := ""; + end + public + function HandleAllocated(); + begin + {** + @explan(说明) 判断是有句柄 %% + @return(bool) + **} + return ifnumber(FHandle)and(FHandle <> 0); + end + function create();override; + begin + inherited; + FBitmap := new TSHBMP(nil); + FDestroy := true; + end + function draw(dc,x,y,flag,rect); + begin + {** + @explan(说明) 粘贴到hdc %% + @param(dc)(tcustomcanvas) canvas 对象%% + @param(x)(integer) canvas 中的x位置%% + @param(y)(integer) canvas 中的y位置%% + @param(rect)(array) bimap 的范围 array(左上右下)%% + @param(flag)(member of TRasterOperationConst) 光栅操作码 %% + **} + if(dc is class(tcustomcanvas))and dc.HandleAllocated()and HandleAllocated()then + begin + sinitdc(); + bw1 := FBitmap.bmwidth; + bh1 := FBitmap.bmheight; + rc := array(0,0,bw1,bh1); + if ifarray(rect)then + begin + if intersectrect(rc,rect,irect)then rc := irect; + end + return _wapi.drawbitmaptodc(FHandle,dc.Handle,x,y,rc,flag,FSHDC); + oldmp := _wapi.SelectObject(FSHDC,FHandle); + if not flag then flag := SRCCOPY; + r := _wapi.BitBlt(dc.handle,x,y,rc[2]-rc[0],rc[3]-rc[1],FSHDC,rc[0],rc[1],flag); + if oldmp then _wapi.SelectObject(FSHDC,oldmp); + return r; + end + end + function StretchDraw(dc,drect,flag,brect); + begin + {** + @explan(说明) 粘贴到hdc %% + @param(dc)(tcustomcanvas) canvas 对象%% + @param(drect)(array) canvas 的范围 array(左上右下)%% + @param(brect)(array) bimap 的范围 array(左上右下)%% + @param(flag)(member of TRasterOperationConst) 光栅操作码 %% + **} + if not(ifarray(drect))then return-1; + if(dc is class(tcustomcanvas))and dc.HandleAllocated()and HandleAllocated()then + begin + sinitdc(); + bw1 := FBitmap.bmwidth; + bh1 := FBitmap.bmheight; + rc := array(0,0,bw1,bh1); + if ifarray(brect)then if intersectrect(rc,brect,irect)then rc := irect; + return _wapi.drawbitmapstretchtodc(FHandle,dc.Handle,drect,rc,flag,FSHDC); + oldmp := _wapi.SelectObject(FSHDC,FHandle); + if not flag then flag := SRCCOPY; + r := _wapi.StretchBlt(dc.handle,drect[0],drect[1],drect[2]-drect[0],drect[3]-drect[1],FSHDC,rc[0],rc[1],rc[2]-rc[0],rc[3]-rc[1],flag); + if oldmp then _wapi.SelectObject(FSHDC,oldmp); + end + return r; + end + function Readvcon(d);override; + begin + {** + @expaln(说明)读取二进制信息 %% + **} + if Image and ifarray(d)and d["type"]="img" then + begin + Image.StringToImage(d["data"]); + bthandle := Image.ToHbitmap(); + SetHandle(bthandle); + AutoDestroy := true; + return; + end + end + function tovcon();override; + begin + {** + @expaln(说明)转换为数据 %% + **} + r := nil; + if Image and HandleAllocated()then + begin + r := array(); + r["type"]:= "bmp"; + Image.FromHBitmap(FHandle); + r["type"]:= "img"; + r["data"]:= Image.ImageToString("png"); + end + return r; + end + function CopyRect(x,y,w,h); + begin + {** + @explan(说明) 拷贝位图 %% + **} + r := nil; + if HandleAllocated()then + begin + if x<0 or y<0 or w<0 or h<0 then return r; + if x+wd>FBitmap.bmwidth then return r; + if y+h>FBitmap.bmheight then return r; + wd1 := FBitmap.bmwidthbytes/FBitmap.bmwidth; + r := array(); + r["type"]:= "bmp"; + r["width"]:= w; + r["bmwidthbytes"]:= wd1 * w; + r["bmplanes"]:= FBitmap.bmplanes; + r["bmbitspixel"]:= FBitmap.bmbitspixel; + r["height"]:= h; + sbt := BmpBits; + sbt2 := ""; + setlength(sbt2,wd1 * w * h * 2); + hr := FBitmap.bmwidthbytes; + jj := 1; + sx := x * wd1; + ex := sx+w * wd1-1; //(x+w)*wd1-1; + for ri := y to y+h-1 do + begin + for ci := sx to ex do + begin + if ri * hr+ci+1>length(sbt)then break; + v := sbt[ri * hr+ci+1]; + sbt2[jj++]:= v; + end + end + r["bytes"]:= sbt2[1:(wd1 * w * h)]; + rt := new tcustombitmap(); + rt.readvcon(r); + return rt; + end + return r; + end + function ToBMPFileString(); + begin + if Image and HandleAllocated()then + begin + r := array(); + Image.FromHBitmap(FHandle); + return Image.ImageToString("bmp"); + end + return ""; + end + function ToIcon(); + begin + {** + @explan(说明)将位图转换为icon %% + @return(ticon|nil) 成功返回图标 %% + **} + if HandleAllocated()then + begin + Image.FromHBitmap(FHandle); + thandle := Image.tohicon(); //采用gdi+ + if not thandle then return 0; + r := new tcustomicon(); + r.Handle := tHandle; + return r; + end + return nil; + end + function Recycling();override; + begin + DestroyHandle(); + FBitmap := nil; + inherited; + end + property id read FId write SetID; + property Handle:pointer read FHandle write SetHandle; + property AutoDestroy:bool read FDestroy write FDestroy; + //property BmpBits read GetBits; + //property DIBits read GetDIBits; + property bmtype index "bmtype" read getvalue write setvalue ; + property bmwidth index "bmwidth" read getvalue write setvalue; + property bmheight index "bmheight" read getvalue write setvalue; + property bmwidthbytes index "bmwidthbytes" read getvalue write setvalue; + property bmplanes index "bmplanes" read getvalue write setvalue; + property bmbitspixel index "bmbitspixel" read getvalue write setvalue; + {** + @param(id)() 资源id %% + @param(Handle)() 句柄 %% + @param(AutoDestroy)() 析构时销毁句柄 %% + **} +end +type TcustomIcon = class(TPicturebase) + private + {** + @explan(说明) 图标对象类 %% + **} + FHandle; + FId; + FMask; + FDestroy; + FMaskBMP; + FColorBMP; + FHICON; + FHandleChanged; + static FSystemIcons; + function getvalue(n); + begin + if not FHICON then return 0; + if FHandleChanged then ReadhInfo(); + case n of + "ficon": return FHICON.ficon; + "xhotspot": return FHICON.xhotspot; + "yhotspot": return FHICON.yhotspot; + "hbmmask": return FHICON.yhotspot; + "hbmcolor": return FHICON.hbmcolor; + end + end + function setvalue(n,v); + begin + if not FHICON then return 0; + if FHandleChanged then ReadhInfo(); + case n of + "ficon": return FHICON.ficon := v; + "xhotspot": return FHICON.xhotspot := v; + "yhotspot": return FHICON.yhotspot := v; + "hbmmask": return FHICON.yhotspot := v; + "hbmcolor": return FHICON.hbmcolor := v; + end + end + function SetHandle(h); + begin + {** + @explan(说明) 设置句柄 %% + **} + if HandleAllocated()then DestroyHandle(); + FHandle := h; + FHandleChanged := true; + end + function GetMaskBitMap(); + begin + if FHandleChanged then ReadhInfo(); + return FMaskBMP; + end + function GetColorBitMap(); + begin + if FHandleChanged then ReadhInfo(); + return FColorBMP; + end + Function ReadhInfo(); + begin + {** + @explan(说明) 获取信息 %% + **} + if FHandleChanged and HandleAllocated()and FHICON then + begin + _wapi.GetIconInfo(FHandle,FHICON._getptr_()); + FHandleChanged := false; + if hbmcolor then + begin + FColorBMP := new TcustomBitmap(); + FColorBMP.AutoDestroy := true; + FColorBMP.Handle := hbmcolor; + end + if hbmmask then + begin + FMaskBMP := new TcustomBitmap(); + FMaskBMP.AutoDestroy := true; + FMaskBMP.handle := hbmmask; + end + end + FHandleChanged := false; + end + function setid(r); + begin + {** + @explan(说明) 设置id %%; + **} + if r <> FId then + begin + Fid := r; + DestroyHandle(); + if ifnumber(r)then h := loadsysico(r); + if h then + begin + FDestroy := false; + end else + begin + h := getresourcebyid(r,array("type":"ico")); + if not h then + begin + if Image then + begin + Image.LoadFromFile(r); + h := Image.tohicon(); + end + end + FDestroy := true; + end + if H then SetHandle(H); + end + end + protected + class function loadsysico(id);virtual; + begin + if not ifarray(FSystemIcons)then FSystemIcons := array(); + r := FSystemIcons[id]; + if r then return r; + r := _wapi.LoadIconA2(nil,id); + FSystemIcons[id]:= r; + return r; + end + function DestroyHandle();virtual; + begin + {** + @explan(说明) 析构句柄 %% + @return(bool) + **} + if HandleAllocated()and FDestroy then _wapi.DestroyIcon(FHandle); + FBitmap := nil; + FMaskBMP := nil; + FColorBMP := nil; + FHandle := 0; + end + public + function HandleAllocated(); + begin + {** + @explan(说明) 判断是有句柄 %% + **} + return ifnumber(FHandle)and(FHandle <> 0); + end + function create(); + begin + inherited; + FHICON := new TSHICON(nil); + FDestroy := true; + end + function Recycling();override; + begin + DestroyHandle(); + FHICON := nil; + inherited; + end + function destroy();override; + begin + inherited; + end + function Tobitmap(); + begin + {** + @explan(说明) 将ico转换为bitmap %% + @return(nil|TcustomBitmap) + **} + if HandleAllocated()and FImage then + begin + FImage.FromHIcon(FHandle); + Hbm := FImage.ToHbitmap(); + if hbm then + begin + r := new TcustomBitmap(); + TBitmap.Handle := Hbm; + return r; + end + end + return nil; + end + function readvcon(d);override; + begin + if Image and ifarray(d)and d["type"]="img" then + begin + Image.StringToImage(d["data"]); + bthandle := Image.tohicon(); + SetHandle(bthandle); + AutoDestroy := true; + end + end + function tovcon();override; + begin + r := nil; + if Image and HandleAllocated()then + begin + r := array("type":"ico"); + r["ficon"]:= ficon; + r["type"]:= "img"; + Image.FromHIcon(FHandle); + r["data"]:= Image.ImageToString("png"); + end + return r; + end + property id read FId write SetID; + property Handle read FHandle write SetHandle; + property MaskBMP:tbitmap read GetMaskBitMap; + property ColorBMP:tbitmap read GetColorBitMap; + property AutoDestroy read FDestroy write FDestroy; + property ficon index "ficon" read getvalue write setvalue; + property xhotspot index "xhotspot" read getvalue write setvalue; + property yhotspot index "yhotspot" read getvalue write setvalue; + property hbmmask index "hbmmask" read getvalue write setvalue; + property hbmcolor index "hbmcolor" read getvalue write setvalue; + {** + @param(id)(integer|string) 资源id %% + @param(Handle)(intptr) 句柄 %% + @param(MaskBMP)(TcustomBitmap) mask位图 %% + @param(ColorBMP)(TcustomBitmap) color位图 %% + @param(AutoDestroy)(bool) 是否自动是否资源 %% + **} +end +type tcustomcursor=class(tcustomicon) + {** + @explan(说明)光标类 %% + **} + private + static FSystemCursors; + protected + class function loadsysico(id);override; + begin + {** + @param(id)(member of TSystemCursor) cursor id %% + @return(pointer) 句柄 %% + **} + if not ifarray(FSystemCursors)then FSystemCursors := array(); + r := FSystemCursors[id]; + if r then return r; + r := _wapi.LoadCursorA2(nil,id); + if r then FSystemCursors[id]:= r; + return r; + end + public + function create();override; + begin + inherited; + end + function show();override; + begin + {** + @explan(说明) 显示光标 + **} + if HandleAllocated()then + begin + //hd := _wapi.SetCursor(_wapi.LoadCursorA2(0,IDC_WAIT)); + hd := _wapi.SetCursor(self.Handle); + return hd; + end + end + function Recycling();override; + begin + inherited; + end +end +type TCustomImageList=class(tcomponent) + {** + @explan(说明) imgelist 类封装 %% + **} + private + FHeight; //高度 + FWidth; //宽度 + FHandle; //句柄 + FInitialCount; + FAutoDestroy; //是否销毁句柄 + FCGrow; + FimageCount; //长度 + FOnChange; + FChanged; + FBKColor; + FImages; + FDrawBimpFirst; + FBmpItems; + FBmpAdding; + function inDesigning(); + begin + return csDesigning in ComponentState; + end + function addbmps(); + begin + if ifarray(FImages)and FImages["type"]="bmps" then + begin + DestroyHandle(); + for i,vi in FImages["items"] do + begin + addbmp(vi); + end + FChanged := true; + change(); + end + end + function SetImages(v); + begin + if v=FImages then exit; + FImages := v; + if inDesigning()then + begin + //return ; + end + addbmps(); + end + function GetImages(); + begin + return FImages; + end + function change();virtual; + begin + {** + @explan(说明) 修改时的回调 %%; + **} + if FChanged and (datatype(FOnChange)=7) then call(FOnChange,self(true)); + FChanged := false; + end + function GetIconSize(); + begin + {** + @explan(说明) 获得位图的高度和宽度 %% + @return(array) array(cx,cy) %% + **} + x := y := 0; + _wapi.ImageList_GetIconSize(FHandle,x,y); + r := array(x,y); + return r; + end + function setbkcolor(c); + begin + if not ifnumber(c)then exit; + if c <> FBKColor then + begin + FBKColor := c; + if HandleAllocated()then + begin + _wapi.ImageList_SetBkColor(FHandle,c); + end + end + end + function readinfo() + begin + {** + @explan(说明) 读取信息 %% + **} + if HandleAllocated()then + begin + FimageCount := 0; + FimageCount := _wapi.ImageList_GetImageCount(FHandle); + xy := GetIconSize(); + FBKColor := _wapi.ImageList_GetBkColor(FHandle); + FWidth := xy[0]; + FHeight := xy[1]; + end + end + function indexvalidate(i); + begin + {** + @explan(说明) 是否有效 %% + **} + return HandleAllocated()and i-0.5; + end + function hcreateimagelist(); + begin + if not HandleAllocated()then + begin + hd := _wapi.ImageList_Create(FWidth,FHeight,0x00000001,FInitialCount,FcGrow); + if hd then + begin + _wapi.ImageList_SetBkColor(hd,FBKColor); + SetHandle(hd); + FAutoDestroy := true; + FChanged := true; + change(); + end + end + end + protected + function SetHandle(H); + begin + {** + @explan(说明) 设置句柄 %% + **} + if h and ifnumber(h)and h <> FHandle then + begin + DestroyHandle(); + FHandle := h; + readinfo(); + FAutoDestroy := true; + end + end + function SetWidth(w); + begin + if w>0 and w <> FWidth then + begin + FWidth := w; + FChanged := true; + DestroyHandle(); + addbmps(); + if inDesigning()then change(); + end + end + function SetHeight(h); + begin + if h>0 and FHeight <> h then + begin + FHeight := h; + FChanged := true; + DestroyHandle(); + addbmps(); + if inDesigning()then change(); + //if not inDesigning() then DestroyHandle(); + end + end + function HandleNeeded(); + begin + if not HandleAllocated()then hcreateimagelist(); + return FHandle; + end + public + function create(Owner);override; + begin + FcGrow := 100; + FWidth := 24; + FHeight := 24; + FInitialCount := 100; + FAutoDestroy := true; + FimageCount := 0; + FBKColor := rgb(255,255,255); + FBmpItems := new tnumindexarray(); + //FDrawBimpFirst := true; + inherited; + end + function HandleAllocated(); + begin + {** + @explan(说明) 句柄是否有效 %% + **} + return ifnumber(FHandle)and FHandle <> 0; + end + function DestroyHandle(); + begin + {** + @explan(说明)销毁句柄 %% + **} + if HandleAllocated()and FAutoDestroy then _wapi.ImageList_Destroy(FHandle); + FHandle := 0; + FimageCount := 0; + FBmpItems := new tnumindexarray(); + end + function add(Image,Mask); + begin + {** + @ignore 忽略%% + @explan(说明) 添加位图 %% + **} + if not FAutoDestroy then exit; + if not(Image is class(tcustombitmap))then exit; + HandleNeeded(); + r :=-1; + if mask is class(tcustombitmap)then + begin + r := _wapi.ImageList_Add(FHandle,Image.Handle,Mask.Handle); + end else + if ifnumber(mask)then + begin + r := _wapi.ImageList_AddMasked(FHandle,Image.Handle,Mask); + end else + r := _wapi.ImageList_Add(FHandle,Image.Handle,nil); + if r>-0.5 then + begin + FimageCount := _wapi.ImageList_GetImageCount(FHandle); + end + return r; + end + function addbmp(bmp); + begin + {** + @explan(说明) 添加bitmap 到imagelist %% + @param(bmp)(tcustombitmap) %% + **} + if not FAutoDestroy then exit; + if not(bmp is class(tcustombitmap))then exit; + HandleNeeded(); + if not(HandleAllocated())then exit; + ct := FimageCount; + FBmpAdding := true; + try + addIcon(bmp.ToIcon()); + if FimageCount>ct then + begin + //////////////拷贝bitamp不销毁/////////////////// + nbmp := new tcustombitmap(); + bmp.AutoDestroy := false; + nbmp.Handle := bmp.Handle; + nbmp.AutoDestroy := true; + ////////////////////////////// + FBmpItems.push(nbmp); + end + finally + FBmpAdding := false; + end; + end + function addIcon(ico); + begin + {** + @explan(说明) 添加图标 %%; + **} + if not(ico is class(tcustomicon))then exit; + if not(ico.HandleAllocated())then exit; + HandleNeeded(); + if not(HandleAllocated())then exit; + h := Handle; + _wapi.ImageList_ReplaceIcon(h,-1,ico.Handle); + ct := FimageCount; + FimageCount := _wapi.ImageList_GetImageCount(h); + if not FBmpAdding then + begin + if FimageCount>ct then + begin + FBmpItems.push(ico.Tobitmap()); + end + end + return; + end + function draw(i,dc,x,y,flag); + begin + {** + @explan(说明) 绘制imge %% + @param(i)(integer) 序号 %% + @param(dc)(tcustomcanvas) dc 对象 %% + @param(x)(integer) x坐标 %% + @param(y)(integer) y坐标 %% + @param(flag)(member of TImageListDrawStyle) 标记 %% + **} + if not(dc is class(tcustomcanvas))then exit; + if not dc.HandleAllocated()then exit; + if indexvalidate(i)then + begin + if not(flag >= 0)then flag := ILD_NORMAL; + if DrawBimpFirst then + begin + bmp := FBmpItems[i]; + if bmp then + begin + rc := array(x,y,x+height,y+width); + bmp.StretchDraw(dc,rc,(flag=ILC_COLOR4?SRCAND:nil)); // + end else + begin + _wapi.ImageList_Draw(Fhandle,i,DC.Handle,x,y,flag); + end + end else + begin + _wapi.ImageList_Draw(Fhandle,i,DC.Handle,x,y,flag); + end + end + end + function Removeimge(i); + begin + {** + @explan(说明) 删除 %% + **} + if indexvalidate(i)then + begin + if _wapi.ImageList_Remove(FHandle,i)then + begin + FBmpItems.splices(i,1); + FimageCount--; + end + end + end + function Replaceimge(i,btmap,msk); + begin + {** + @explan(说明) 替换 image %% + @param(i)(integer) 位置 %%; + @param(btmap)(tcustombitmap) 位图 %% + @param(msk)(tbitmap|hbitmap) mask %% + **} + hmsk := 0; + if indexvalidate(i)then + begin + if(btmap is class(tcustombitmap))and(btmap.HandleAllocated())then + begin + if(msk is class(tcustombitmap))and(msk.HandleAllocated())then hmsk := msk.Handle; + else if ifnumber(mask)then hmsk := mask; + if _wapi.ImageList_Replace(FHandle,i,btmap.Handle,hmsk)then + begin + FBmpItems.splices(i,1,array(btmap)); + end + end + end + end + function GetIcon(i,flag); + begin + {** + @explan(说明) 获取ticon 对象 %% + @param(i)(integer) 序号 %% + @param(flag)(member of TImageListDrawStyle) 样式 %% + **} + if HandleAllocated()and i-0.5 then + begin + hi := _wapi.ImageList_GetIcon(FHandle,i,flag); + if hi then + begin + r := new tcustomicon(); + r.handle := hi; + r.AutoDestroy := true; + return r; + end + end + end + function loadfromsysbmp(id,cx,cGrow); + begin + {** + @ignore 忽略 %% + @explan(说明) 导入系统位图生成imagelist %% + **} + hd := _wapi.ImageList_LoadImageA2(nil,id,cx,cGrow,CLR_NONE,IMAGE_BITMAP,LR_SHARED); + SetHandle(hd); + end + function GetHotSpot();virtual; + begin + return array(0,0); + end + function Recycling();override; + begin + DestroyHandle(); + FOnChange := nil; + inherited; + end + function destroy();override; + begin + inherited; + end + function SetSysImageListHandle(h); + begin + {** + @ignore 忽略 %% + @explan(说明) 设置构造好的iamgelist 到对象,默认不销毁 %% + **} + if h <> FHandle then + begin + SetHandle(H); + FAutoDestroy := false; + end + end + property Handle read HandleNeeded write SetHandle; + property AutoDestroy read FAutoDestroy write FAutoDestroy; + property ImageCount read FimageCount; + property Height:integer read FHeight write Setheight; + property Width:integer read FWidth write SetWidth; + property imgHeight:integer read FHeight write Setheight; + property imgWidth:integer read FWidth write SetWidth; + property OnChange read FOnChange write FOnChange; + property BkColor:COLORREF read FBKColor write setbkcolor; + property Images:imagesdata read GetImages write SetImages; + property DrawBimpFirst read FDrawBimpFirst write FDrawBimpFirst; + function publishs();override; + begin + return array("name","images","imgwidth","imgheight","bkcolor"); + end + {** + @param(Handle)(HIMAGELIS) imagelist句柄 %% + @param(AutoDestroy)(bool) 是否销毁句柄 %% + @param(ImageCount)(integer) 图标数量 %% + @param(OnChange)(function[TCustomImageList]) 改变时的回调 %% + **} +end +type tcustomcontrolimagelist=class(TCustomImageList) + {** + @explan(说明) 控件imagleit %% + **} + private + FImageControls; + public + function HandleChanged();virtual; + begin + {** + @explan(说明) 句柄发生变化 %% + **} + for i := 0 to FImageControls.Count-1 do + begin + FImageControls[i].ImageChanged(); + end + end + function create(AOwner);override; + begin + inherited; + FImageControls := new TFpList(); + OnChange := thisfunction(HandleChanged); + end + function addControl(v); + begin + id := FImageControls.indexof(v); + if id=-1 then + begin + FImageControls.append(v); + end + end + function deleteControl(v); + begin + {** + @explan(说明) 删除控件 %% + **} + id := FImageControls.indexof(v); + if id >= 0 then + begin + v.ImageList := nil; //设置为空 + FImageControls.deli(id); + end + end + function Recycling();override; + begin + {** + @explan(说明) 回收空间%% + **} + while FImageControls.Count>0 do + begin + deleteControl(FImageControls[0]); + end + inherited; + end +end +type TcustomCanvas = class(TSLUIBASE) + {** + @explan(说明) 画布对象 %% + **} + private + FHandle; + FFont; + FBrush; + FPen; + FState; + FTEXTMETRICA; + FSaveGdi; + FRgn; + FCounter; + FTabLength; + FTabLenParam; + static FHDC; + type TCounter=class + private + FCurrentId; + public + function clean(); + begin + FCurrentId := 0; + end + function Create(); + begin + FCurrentId := 0; + end + function InCrease(); + begin + FCurrentId++; + end + function DeCrease(); + begin + if FCurrentId>0 then FCurrentId--; + end + property CurrenId read FCurrentId; + end + function SetTextTabLen(v); + begin + nv := integer(v); + if nv <> FTabLength then + begin + FTabLength := nv; + if not FTabLenParam then FTabLenParam := new Ttagdrawtextparams(); + FTabLenParam.itablength := nv; + end + end + function SetPen(p); + begin + FPen.copypen(p); + end + function SetFont(f); + begin + if ifarray(f)then + begin + FFont.SetValues(f); + end else + FFont.copyfont(f); + end + function SetBrush(b); + begin + FBrush.copybrush(b); + end + function SelectObject(hgdi); + begin + if HandleAllocated()then + begin + return _wapi.SelectObject(FHandle,hgdi); + end + end + function SetHandle(h); + begin + if ifnumber(h)then + begin + flashhandle(); + if FHandle <> h then + begin + FCounter.clean(); + end + FHandle := h; + if h then + begin + _wapi.GetTextMetricsA(FHandle,FTEXTMETRICA._getptr_); + end + end + end + function flashhandle(); + begin + FState := 1+2+4+8+16+32+64; + end + function ifrect(rect); + begin + return ifarray(rect)and ifnumber(rect[0])and ifnumber(rect[1])and ifnumber(rect[2])and ifnumber(rect[3]); + end + function pointtovector(pts); //点转换为数组 + begin + {** + @explan(说明) 将两列的二维数组转换为一维数组 %% + @param(pts)(array) 一维的数组%% + @return(array) 两列数组 %% + **} + {** + @example(点数组转换为一维数组) + // array((x1,y1),(x2,y2),(x3,y3)...) => array(x1,y1,x2,y2,x3,y3,...) + a := array((1,2),(3,4)); + return pointtovector(a);//array(1,2,3,4); + **} + t := array(); + lt := 0; + if not ifarray(pts)then return array(); + for i,v in pts do + begin + if ifarray(v)and ifnumber(v[0])and ifnumber(v[1])then + begin + t[lt++]:= v[0]; + t[lt++]:= v[1]; + end + end + return t; + end + public + function GetTextExtent(s,mul); + begin + {** + @explan(说明) 获得 字符串绘制宽度和高度 %% + @param(s)(string) 字符串 %% + @param(mul)(bool) 多行 默认多行true%% + **} + r := array(0,0); + if ifstring(s)and HandleAllocated()then + begin + requiregdi(); + if ifnil(mul)then mul := true; + if mul then + begin + ss := str2array(s,"\n"); + if length(ss)then + begin + for i,v in ss do + begin + ri := array(0,0); + vi := trim(v); + if not vi then vi := "\r"; + _wapi.GetTextExtentPoint32A2(FHandle,vi,length(v),ri); + r[0]:= max(r[0],ri[0]); + r[1]+= ri[1]; + end + end + end else + _wapi.GetTextExtentPoint32A2(FHandle,s,length(s),r); + end + return r; + end + function SelectClipRgn(rgn); + begin + {** + @explan(说明) 设置区域 %% + @param(rgn)(TRgn) 选择区域 %% + **} + if rgn=FRgn then exit; + r := FRgn; + FRgn := rgn; + if not HandleAllocated()then exit; + if FRgn is class(TRgn)then + begin + r1 := _wapi.SelectClipRgn(FHandle,FRgn.Handle); + end else + begin + r1 := _wapi.SelectClipRgn(FHandle,nil); + end + if r is class(trgn)then return r; + return r1; + end + function create();override; + begin + inherited; + FTabLength := 0; + FCounter := new TCounter(); + FHandle := 0; + FState := 0; + FPen := new tcustompen(); + FPen.Canvas := self; + FBrush := new tcustombrush(); + FBrush.Canvas := self; + FFont := new Tcustomfont(); + FFont.Canvas := self; + FTEXTMETRICA := new ttagTEXTMETRICA(); + end + function Recycling();override; + begin + {** + @explan(说明)资源回收 %% + **} + FBrush.Recycling(); + FPen.Recycling(); + FBrush := nil; + FPen := nil; + FState := nil; + inherited; + end + function destroy();override; + begin + inherited; + end + function HandleAllocated(); + begin + {** + @explan(说明) 判断canvas句柄是否构造 %% + @return(bool) + **} + return ifnumber(FHandle)and(FHandle <> 0); + end; + procedure requiregdi(rq); + begin + {** + @explan(说明) 初始化gdi对象 如画刷 画笔 等 %% + **} + if HandleAllocated()then + begin + if FState .& 1 then + begin + SelectObject(FPen.Handle); + end + if FState .& 2 then + begin + SelectObject(FBrush.Handle); + end + if FState .& 4 then + begin + SelectObject(FFont.Handle); + end + if FState .& 8 then + begin + _wapi.SetTextColor(FHandle,FFont.Color); + end + if FState .& 16 then + begin + _wapi.SetBkColor(FHandle,FFont.bkColor); + end + if FState .& 32 then + begin + _wapi.SetbkMode(FHandle,(FFont.bkmode=OPAQUE)?OPAQUE:TRANSPARENT); //OPAQUE + end + if FRgn is class(trgn)then + begin + _wapi.SelectClipRgn(FHandle,FRgn.Handle); + end + FState := 0; + end + end + function OnFontbkmodeChange(); + begin + FState .|= 32; + end + function OnPenChange(); + begin + FState .|= 1; + end + function OnBrushChange(); + begin + FState .|= 2; + end + function OnFontChange(); + begin + FState .|= 4; + end + function OnFontColorChange(); + begin + FState .|= 8; + end + function OnFontbkColorChange(); + begin + FState .|= 16; + end + function SetViewportOrg(xy); + begin + {** + @explan(说明)设置选择基准点 %% + @param(xy)(array) array(x,y)%% + @return(integer) %% + **} + if HandleAllocated()then + begin + if not ifarray(xy)then return 0; + return _wapi.SetViewportOrgEx(FHandle,xy[0],xy[1],nil); + end + end + function SetPixel(xy,colr); + begin + {** + @explan(说明) 画一个像素 %% + @param(xy)(array) array(x,y)%% + @param(colr)(integer) 颜色rgb值 %% + @return(integer) %% + **} + if HandleAllocated()then return _wapi.SetPixel(FHandle,xy[0],xy[1],colr); + end + function fillrgn(rgn); + begin + {** + @explan(说明)区域填充 %% + @param(rgn)(trgn) 区域 %% + **} + if not HandleAllocated()then exit; + if not(rgn is class(TRgn))then exit; + _wapi.FillRgn(FHandle,rgn.Handle,FBrush.Handle); + end + function FillRect(rec); //填充 + begin + {** + @explan(说明)填充rect %% + @param(rec)(array) 区域 array(左,上,右,下)%% + @param(br)(tcustombrush) 画刷 %% + **} + if HandleAllocated()then + begin + return _wapi.FillRect(FHandle,(ifrect(rec)?rec:zeros(4)),FBrush.Handle); + end + end + function InvertRect(rec); //反向填充,rec区域,br画刷 + begin + {** + @explan(说明)反向填充区域 %% + @param(rec)(array) 区域 array(左,上,右,下)%% + **} + if not HandleAllocated()then exit; + return _wapi.InvertRect(FHandle,rec,FBrush.Handle); + end + function moveto(pos); + begin + {** + @explan(说明)移动当前点%% + @param(pos)(array) 位置array(x,y) %% + @return(array) 原来位置 %% + **} + ret := array(0,0); + if not ifarray(pos)then return-1; + if HandleAllocated()then + begin + _wapi.MoveToEx(FHandle,pos[0],pos[1],ret); + end + return ret; + end + function lineto(pos); //画线 + begin + {** + @explan(说明)画线到点%% + @param(pos)(array) 位置array(x,y) %% + **} + if not ifarray(pos)then return-1; + if HandleAllocated()then + begin + requiregdi(); + return _wapi.LineTo(FHandle,pos[0],pos[1]); + end + end + function textout(str,pos); //输出文字,str文字,pos开始位置 + begin + {** + @explan(说明)输出文本%% + @param(str)(string) 字符串 %% + @param(pos)(array) 位置array(x,y) %% + **} + if not ifstring(str)then return 0; + if not ifarray(pos)then pos := array(0,0); + if HandleAllocated()then + begin + requiregdi(); + return _wapi.TextOutA(FHandle,pos[0],pos[1],str,length(str)); + end + end + function drawtext(str,rec,uft); //在区域中绘制文字 + begin + {** + @explan(说明)在指定区域上输出文本%% + @param(str)(string) 绘制的文字 %% + @param(rec)(array) array(left,top,right,bottom) %% + @param(uft)(integer) DT_CALCRECT：这个参数比较重要，可以使DrawText函数计算出输出文本的尺寸。如果输出文本有多行，DrawText函数使用lpRect定义的矩形的宽度，并扩展矩形的底部以容纳输出文本的最后一行。如果输出文本只有一行，则DrawText函数改变矩形的右边界，以容纳下正文行的最后一个字符。出现上述任何一种情况，DrawText函数将返回格式化文本的高度，而不是绘制文本。 + DT_CENTER：指定文本水平居中显示。 + DT_VCENTER：指定文本垂直居中显示。该标记只在单行文本输出时有效，所以它必须与DT_SINGLELINE结合使用。 + DT_SINGLELINE：单行显示文本，回车和换行符都不断行。 + %% + **} + if not ifstring(str)then return-1; + if not ifnumber(uft)then uft := DT_NOPREFIX; //默认忽略 &占位符 + if not ifarray(rec)then rec := nil; + if HandleAllocated()then + begin + requiregdi(); + if FTabLength then + begin + return _wapi.DrawTextExA(FHandle,str,length(str),rec,uft .| DT_EXPANDTABS .| DT_TABSTOP,FTabLenParam._getptr_()); + end else + return _wapi.DrawTextA(FHandle,str,length(str),rec,uft); + // + end + end + function StretchDraw(rec,bmp); + begin + {** + @explan(说明) 绘制bitmap %% + @param(rec)(array of integer) array(左,上,右,下) %% + @param(bmp)(tcustombitmap) 位图 %% + **} + if not(bmp is class(tcustombitmap))then exit; + bmp.StretchDraw(self,rec); + end + function DrawBitmap(bmp,p); + begin + {** + @explan(说明)绘制bitmap %% + @param(bmp)(tcustombitmap) 图标 %% + @param(p)( array of integer) 位置 array(x,y) + **} + if not(bmp is class(tcustombitmap))then return-1; + if not ifarray(p)then p := array(0,0); + bmp.draw(self,p[0],p[1]); + end + function DrawIcon(ico,p); + begin + {** + @explan(说明)绘制icon %% + @param(ico)(ticon) 图标 %% + @param(p)( array of integer) 位置 array(x,y) + **} + if HandleAllocated()then + begin + if not(ifarray(p)and ifnumber(p[1])and ifnumber(p[0]))then p := array(0,0); + if(ico is class(tcustomicon))and ico.Handle then return _wapi.DrawIcon(FHandle,p[0],p[1],ico.Handle); + end + end + function draw(name_,points,f,m); + begin + {** + @explan(说明)gdi画图函数%% + @param(name_)(string) 图形名称, rectangle 矩形 ;ellipse 椭圆;roundrect 圆角矩形;chord 弧线 ;pie 饼 ;polybezier 贝塞尔 ;polygon多条直线 %% + @param(points)(array) 点数组 例如 array((0,0),(1,2)) 表述两个点的数组,点的多少根据name_参数确定 %% + @param(f)(integer) 作图辅助参数 在画弧线的时候会用到的方向 %% + @param(m)(integer) 在polypolyline 使用表示绘图样式 %% + **} + if not HandleAllocated()then return 0; + requiregdi(); + if not ifstring(name_)then return 0; + _name_1 := lowercase(name_); + r := length(points); + c := mcols(points); + if not(r>1 and c=2)then return 0; + if "framecontrol"=_name_1 then + begin + if r<2 then return 0; + nrc := array(points[0][0],points[0][1],points[1][0],points[1][1]); + ret := _wapi.DrawFrameControl(FHandle,nrc,(f 4 then return 0; + if not ifnil(f)then SetArcDirection(FHandle,f); + ret := _wapi.Arc(FHandle,points[0,0],points[0,1],points[1,0],points[1,1],points[2,0],points[2,1],points[3,0],points[3,1]); + end else + if(("polygon"=_name_1)or("polyline"=_name_1))then + begin + if r<2 then return 0; + pt := pointtovector(points); + if "polygon"=_name_1 then + begin + if r<3 then return 0; + ret := _wapi.Polygon(FHandle,pt,r); + end else + ret := _wapi.polyline(FHandle,pt,r); + end else + if "polypolyline"=_name_1 then + begin + if ifarray(f)and(sum(f)=length(points))then + begin + pt := pointtovector(points); + ret := _wapi.polypolyline(FHandle,pt,f,m); + end + end else + if("polybezier"=_name_1)then + begin + if r<3 then return 0; + pt := pointtovector(points); + ret := _wapi.PolyBezier(FHandle,pt,r); + end + return ret; + end + + function CopyBitmap(rect); + begin + {** + @explan(说明) 获取canvas区域到位图 %% + @param(array of integer) 区域 array(左,上,右,下); + @return(tcustombitmap|nil) 成功返回位图 %% + **} + r := nil; + if not(ifarray(rect)and rect[2]>rect[0]and rect[3]>rect[1])then return r; + if not HandleAllocated()then return r; + if not FHDC then FHDC := _wapi.CreateCompatibleDC(0); + if not FHDC then return r; + bthandle := _wapi.CreateCompatibleBitmap(FSHDC2,w,h); + if not bthandle then return r; + oldb := _wapi.SelectObject(FHDC,bthandle); + _wapi.BitBlt(FHDC,0,0,rect[2]-rect[0],rect[3]-rect[1],FHandle,rect[0],rect[1],SRCCOPY); + if oldb then _wapi.SelectObject(FHDC,oldb); + R := new tcustombitmap(); + R.handle := bthandle; + return r; + end + function SetWorldTransform(trans); + begin + {** + @explan(说明)文本旋转%% + @param(trans)(array) array(cos,-sin,sin,cos,x,y)%% + **} + _xformobj._setvalue_("em11",trans[0]); + _xformobj._setvalue_("em12",trans[1]); + _xformobj._setvalue_("em21",trans[2]); + _xformobj._setvalue_("em22",trans[3]); + _xformobj._setvalue_("edx",trans[4]); + _xformobj._setvalue_("edy",trans[5]); + return _wapi.SetWorldTransform(FHandle,_xformobj._getptr_); + end + function SetPolyFillMode(md); //设置填充样式 + begin + {** + @explan(说明)设置填充模式 %% + @param(md)(integer) 填充模式 ALTERNA WINDING %% + **} + if HandleAllocated()then if ifnumber(md)then return _wapi.SetPolyFillMode(FHandle,md); + return-1; + end + function SetBkMode(m); + begin + {** + @explan(说明)文本背景样式%% + @param(m)(integer) 背景样式OPAQUE or TRANSPARENT %% + **} + if HandleAllocated()then return _wapi.SetBkMode(FHandle,m); + end + function GetBkMode(); + begin + {** + @explan(说明)文本背景样式%% + @return(integer) 背景样式%% + **} + if HandleAllocated()then return _wapi.GetBkMode(FHandle); + end + function SetTextAlign(fmt); + begin + {** + @explan(说明)文字对其方式%% + @param(fmt)(integer) 对其方式TA_LEFT; + TA_RIGHT; + TA_CENTER; + TA_TOP; + TA_BOTTOM;默认左对齐 %% + **} + if not ifnumber(fmt)then fmt := _wapi.TA_LEFT; + if HandleAllocated()then return _wapi.SetTextAlign(FHandle,fmt); + end + function ReleaseDC();virtual; + begin + //if HandleAllocated() then _wapi.ReleaseDC(FHandle); + end + + {function BeginPath(); + begin + if HandleAllocated() then return _wapi.BeginPath(FHandle); + end + function EndPath(); + begin + if HandleAllocated() then return _wapi.EndPath(FHandle); + end + function StrokePath(); + begin + requiregdi(); + if HandleAllocated() then return _wapi.StrokePath(FHandle); + end + function FillPath(); + begin + requiregdi(); + if HandleAllocated() then return _wapi.FillPath(FHandle); + end + function StrokeAndFillPath(); + begin + requiregdi(); + if HandleAllocated() then return _wapi.StrokeAndFillPath(FHandle); + end} + function DeleteDC(); + begin + if HandleAllocated()then _wapi.DeleteDC(FHandle); + FHandle := 0; + end + function SaveDC(); + begin + {** + @explan(说明) 保存当前的dc %% + **} + if HandleAllocated()then + begin + FCounter.InCrease(); + _wapi.SaveDC(FHandle); + end + end + function RestoreDC(); + begin + {** + @explan(说明) 还原dc %% + **} + if HandleAllocated()then + begin + if FCounter.CurrenId>0 then + begin + FCounter.DeCrease(); + _wapi.RestoreDC(FHandle,-1); + end + end + end + property Handle read FHandle write SetHandle; + property pen read FPen write SetPen; + property font read FFont write SetFont; + property brush read FBrush write SetBrush; + property bkmode write SetBkMode; + property TextMetric read FTEXTMETRICA; + property TextTabLength read FTabLength write SetTextTabLen; + {** + @param(pen)(tcustompen) 画笔 %% + @param(brush)(TBRUSH) 画刷 %% + @param(font)(Tcustomfont) 字体 %% + @param(bkmode)(integer) 背景样式 OPAQUE or TRANSPARENT 默认 TRANSPARENT %% + @param(TextMetric)(ttagTEXTMETRICA) 文本样式信息 %% + **} +end +type TControlCanvs=class(TcustomCanvas) + function Create(); + begin + inherited; + end + property ClipRect read FClipRect write SetClipRect; + private + Function SetClipRect(v); + begin + if ifarray(v)and v[0]= 1 then + begin + Fcache[name]["count"]-= 1; + return 1; + end + {else + begin + destroyresource(name); + end} + end + return 0; + end + function addsource(name,value);virtual; + begin + {** + @explan(说明)添加资源 %% + @param(name)(string) 资源名称 %% + @param(value)(obj) 资源值 %% + **} + //RETURN ; //不缓存 + v := Fcache[name]; + if not(v)then + begin + Fcache[name]["value"]:= value; + Fcache[name]["count"]:= 1; + //return 1; + end else + begin + if Fcache[name]["value"]=value then + begin + Fcache[name]["count"]++; + end else + if value then + begin + destroyresource(name); + return addsource(name,value); + end + end + FCacheLength := length(FCache); + maxlen := 256; + if FCacheLength>maxlen then + begin + ct := 0; + rdxs := array(); + for i,v in FCache do + begin + if v["count"]=0 then + begin + rdxs[ct++]:= i; + end + if FCacheLength-ct <= maxlen then + begin + break; + end + end + for i,v in rdxs do + begin + destroyresource(v); + end + end + return 0; + end + function destroyresource(name);virtual; + begin + {** + @explan(说明)删除指定的资源 %% + @param(name)(string) 资源名称 %% + **} + v := Fcache[name]; + if v then + begin + hd := v["value"]; + reindex(Fcache,array(name:nil)); + _wapi.DeleteObject(hd); + end + end +end +function getresourcebyid(id,options); +begin + {** + @explan(说明)获得resource信息%% + @param(id)(obj) id 对象 %% + @param(options)(array) 额外参数 %% + **} + global G_O_TSWIN32API_; + w32 := G_O_TSWIN32API_; + if not w32 then return 0; + if not ifarray(options)then return 0; + h := 0; + if options["type"]="bmp" then + begin + if ifnumber(id)then h := w32.LoadBitmapA2(nil,id); + else if ifstring(id)then + begin + //h := w32.LoadImageA(0,id,0,100,100,0x10 .| 0x40);// + h := w32.LoadImageA(0,id,0,0,0,0x10 .| 0x40); // + //h := w32.LoadBitmapA(nil,id); + end + end else + if options["type"]="ico" then + begin + if ifnumber(id)then h := w32.LoadIconA2(nil,id); + else if ifstring(id)then h := w32.LoadImageA(0,id,0x1,0,0,0x10); + end + return h; +end +function sinitgidplus(); +begin + FGDI := new TGdiplusflat(); + vot := array( + ("gdiplusversion","int",1), + ("debugeventcallback","int",0), + ("suppressbackgroundthread","int",0), + ("suppressexternalcodecs","int",0)); + og := new ctslctrans(tslarraytocstructcalc(vot)); + ftoken :=-1; + ig :=-1; + FGDI.GdiplusStartup(ftoken,og._getptr_,ig); +end +function GetTextWidthAndHeightWidthFont(s,f,mul); +begin + {** + @explan(说明) 获得文本在给定字体f下的绘制宽高 %% + @param(s)(string) 文本 %% + @param(f)(tfont) 给定字体 %% + @param(mul)(bool) 是否多行文本 %% + **} + if ifstring(s)and s then + begin + cv := static GetOneCanvas(); + if f is class(Tcustomfont)then cv.font := f; + if ifarray(f)and f then cv.font.SetValues(f); + return cv.GetTextExtent(s,mul); + end + return array(0,0); +end +function GetOneCanvas(); +begin + cv := new tcustomcanvas();//(getapplication()); + cv.handle := cv._wapi.CreateCompatibleDC(0); + return cv; +end +initialization +sinitgidplus(); +class(tcustomimage).sinit(); +global G_T_BITMAP_; +global G_T_ICON_; +G_T_BITMAP_ := class(TcustomBitmap); +G_T_ICON_ := class(TcustomIcon); +finalization + +end. \ No newline at end of file diff --git a/funcext/tvclib/utslvclgrid.tsf b/funcext/tvclib/utslvclgrid.tsf new file mode 100644 index 0000000..3a79878 --- /dev/null +++ b/funcext/tvclib/utslvclgrid.tsf @@ -0,0 +1,1226 @@ +unit utslvclgrid; +interface +uses utslvclauxiliary,utslvclmemstruct,utslvclgdi; +{** + @explan(说明) 表格控件相关 %% + @date(20220510) +**} +type TcustomGridCtl = class(TCustomControl) + {** + @explan(说明) 自绘制表格控件 %% + **} + function Create(AOwner);override; + begin + inherited; + FLocalX := 0; + FLocalY := 0; + Width := 300; + Height := 260; + FMouseSizeColumnWidth := 1; + FAutoScroll := 3; + FItemCount := 0; + FFixedRows := 1; + FColumFixed := 0; + FColWidth := 5; //10; + FRowWidth := 10; + FC_NORMAL := OCR_NORMAL; + FC_SIZE := OCR_SIZEWE; + FC_SIZE2 := OCR_SIZENS; + FMarginLeft := 1; + FMarginTop := 1; + FMarginRight := 0; + FMarginBottom := 0; + FRowHeight := 30; + FColsWidths := new tnumindexarray(); + FRowsHeight := new tnumindexarray(); + FVariableRows := false; + FSI := new TScrollinfo(); + end + function GetItemRect(i);virtual; + begin + {** + @explan(说明) 获得行的区域 %% + @param(i)(integer) 行号 %% + @return(array) array(左,上,右,下); + **} + yrct := GetItemYBound(i); + if not yrct then return nil; + basex := FMarginLeft-FColWidth * GetXpos(); + //r := array(basex,yrct[0],yrct[1],0); + r := array(basex,yrct[0],0,yrct[1]); + for ii := 0 to FColsWidths.length()-1 do + begin + basex += FColsWidths[ii]; + end + r[2]:= basex; + return r; + end + function GetItemStartY(i);virtual; + begin + {** + @explan(说明) 获得行的区域范围 %% + @param(i)(integer) 行号 %% + @return(array) array(上,下); + **} + if(i<0 or i >= GetItemCount())then return nil; + yb := FMarginTop; + itv := FRowHeight; + if FVariableRows then + begin + for ii := 0 to i-1 do + begin + yb += FRowsHeight[ii]; + end + itv := FRowWidth; + end else + yb += i * FRowHeight; + if i= 0 and j= x then return i; + if basex >= x then return i; + end + return r; + end + function InvalidateItem(i);virtual; + begin + {** + @explan(说明) 刷新行%% + @param(i)(integer) 行号 %% + **} + bd := GetItemYBound(i); + if not bd then return false; + rec := ClientRect; + if bd[1]>rec[3]or bd[0]rec[3]or rec1[3]rec[2]or rec1[2]= x then return i; + if basex >= x then return i; + end + end else + begin + r := integer((y-FMarginTop)/FRowHeight); + if y <= FYfiexed then + begin + if r >= FItemCount then return-1; + return r; + end + ybase := GetYPos(); + r += ybase; + if r >= FItemCount then return-1; + return r; + end + return r; + end + function SetColumns(cls,beg,len);virtual; + begin + {** + @explan(说明) 设置列宽信息 %% + @param(cls)(array of integer) 列宽 %% + @param(beg)(integer) 开始位置 %% + @param(len)(integer) 替代长度 %% + **} + clsa := array(); + for i,v in cls do + begin + if v >= 0 then clsa[length(clsa)]:= v; + end + FColsWidths.splices(beg>0?beg:0,len >= 0?len:FColsWidths.Length(),clsa); + InitialScroll(nil,nil,0); + end + function SetRows(rows,beg,len);virtual; + begin + if not FVariableRows then return; + clsa := array(); + for i,v in rows do + begin + if v>0 then clsa[length(clsa)]:= v; + end + FRowsHeight.splices(beg>0?beg:0,len >= 0?len:FRowsHeight.Length(),clsa); + InitialScroll(nil,nil,0); + end + function GetColumnWidth(i); + begin + {** + @explan(说明) 获得第i列宽度 %% + @param(i)(integer) 列号 %% + @return(integer) 宽度 %% + **} + return FColsWidths[i]; + end + function SetColumnWidth(i,w); + begin + {** + @explan(说明) 设置列宽 %% + @param(i)(integer) 列序号 %% + @param(w)(integer) 新宽度 0 %% + **} + vi := FColsWidths[i]; + if vi >= 0 and w >= 0 and vi <> w then UpDateColumWidth(i,w); + end + function DrawCell(cvs,rec,i,j);virtual; + begin + {** + @explan(说明) 绘制单元格 %% + @param(cvs)(tcustomcanvas) 画布 %% + @param(rec)(array) array(左上右下) %% + @param(i)(integer) 行号 %% + @param(j)(integer) 列号 %% + **} + dr := array(rec[0:1],rec[2:3]); + if i0 then ps[2]:= min(ClientRect[2]-FMarginRight,ps[2]); + if FMarginBottom>0 then ps[3]:= min(ClientRect[3]-FMarginBottom,ps[3]); + FValidateRect := ps; + tp := ps[1]; + bo := ps[3]; + //***************计算表头区域******************* + basex := FMarginLeft-xpos * FColWidth; + x := basex; + x2 := FMarginLeft; + cvs.Font := font; + drawcol := array(); + for i,v in FColsWidths.Data do + begin + if i= ps[0])and x2= FColumFixed then + begin + if(x+v >= ps[0])and x= ps[1])and y2= FFixedRows then + begin + if(y+v >= ps[1])and y= vj[1]then continue; + for i,vi in drawrow do + begin + if i= FColumFixed then + begin + if FindMerge(i,j,mergb)then + begin + end else + partb[partbl++]:= array(array(vj[0],vi[0],vj[1],vi[1]),i,j); + end else + if i >= FFixedRows and j= FFixedRows and j >= FColumFixed then + begin + if FindMerge(i,j,mergd)then + begin + end else + partd[partdl++]:= array(array(vj[0],vi[0],vj[1],vi[1]),i,j); + end + end + end + if parta or merga then + begin + DrawAllParts(cvs,parta,merga,array(FMarginLeft,FMarginTop,FXfiexed,FYfiexed)); + end + if partb or mergb then + begin + DrawAllParts(cvs,partb,mergb,array(FXfiexed,FMarginTop,ps[2],FYfiexed)); + end + if partc or mergc then + begin + DrawAllParts(cvs,partc,mergc,array(FMarginLeft,FYfiexed,FXfiexed,ps[3])); + end + if partd or mergd then + begin + DrawAllParts(cvs,partd,mergd,array(FXfiexed,FYfiexed,ps[2],ps[3])); + end + end + function MouseDown(o,e);override; + begin + if csDesigning in ComponentState then return false; + if e.button()<> mbLeft then return false; + if FC_CURRENT=FC_SIZE then //调整大小 + begin + FSizeColum := 1; + _wapi.ClipCursor(FCursorRect); + return true; + end else + if FC_CURRENT=FC_SIZE2 then + begin + FSizeColum := 2; + _wapi.ClipCursor(FCursorRect); + return true; + end + end + function MouseUp(o,e);override; + begin + if FSizeColum then + begin + FSizeColum := false; + _wapi.ClipCursor(0); + return true; + end + end + function MouseMove(o,e);override; + begin + if csDesigning in ComponentState then return false; + if not FMouseSizeColumnWidth then + begin + setcursornormal(); + return 0; + end + y := e.yPos; + X := e.xpos; + if FMouseSizeColumnWidth .& 1>0 then + begin + if x0)and FVariableRows then + begin + basey := FMarginTop; + if y >= FYfiexed then + begin + xdx := GetYpos(); + basey := FMarginTop-FRowWidth * xdx; + end + end + if(FMouseSizeColumnWidth=0)then + begin + setcursornormal(); + return 0; + end + if FColsWidths.length()>0 and GetItemCount()>0 and x>(FMarginLeft+5)and y>(FMarginTop+5) {and y<(FMarginTop+FRowHeight*FFixedRows) }then + begin + if FSizeColum=1 then + begin + wd := FColsWidths[FCurrentSizeId]; + UpDateColumWidth(FCurrentSizeId,wd+x-FCurrentSizePos); + FCurrentSizePos := x; + return true; + end else + if FSizeColum=2 then + begin + wd := FRowsHeight[FCurrentSizeId]; + UpDateRowWidth(FCurrentSizeId,wd+y-FCurrentSizePos); + FCurrentSizePos := y; + return true; + end else + begin + bx := basex; + rc := ClientRect; + if FMouseSizeColumnWidth .& 1>0 then + begin + for i,v in FColsWidths.Data do + begin + if abs(x-bx-v)<3 then + begin + FCurrentSizeId := i; + FCurrentSizePos := x; + FCursorRect := array(clientToScreen(max(bx+6,rc[0]+6),y-10),clientToScreen(rc[2],y+10)); + setcursorsize(); + return true; + end + bx += v; + end + end + if FVariableRows and(FMouseSizeColumnWidth .& 2>0)then + begin + bx := basey; + for i,v in FRowsHeight.Data do + begin + if abs(y-bx-v)<3 then + begin + FCurrentSizeId := i; + FCurrentSizePos := y; + FCursorRect := array(clientToScreen(x-10,max(rc[1]+6,bx+6)),clientToScreen(x+10,rc[3])); + setcursorsize2(); + return true; + end + bx += v; + end + end + end + end + setcursornormal(); + return false; + end + //系统处理函数 + function DoWMSIZE(o,e);override; //大小调整 + begin + InitialScroll(e.lolParam,e.hilparam); + inherited; + end + function DoMouseWheel(o,e);override; + begin + hwnd := self.Handle; + FSI.fMask := SIF_ALL; + _wapi.GetScrollInfo(hwnd,SB_VERT,FSI._getptr_); + // 保存当前滑块位置，迟些进行比较 + yPos := FSI.nPos; + dd := 0; + if e.delta<0 and FSI.nMax>yPos then + begin + dd++; + end + if e.delta>0 and FSI.nMin yPos)then + begin + //_wapi.ScrollWindow(hwnd, 0, FRowHeight * (yPos - FSI.nPos), nil, ClipScroll()); + ivrect := ClientRect; + ivrect[1]:= FYfiexed; //FMarginTop+FRowHeight*FFixedRows; + InvalidateRect(ivrect,false); + //UpdateWindow(hwnd); + end + return 0; + end + function DoHScroll(o,e);override; + begin + FSI.fMask := SIF_ALL; + _wapi.GetScrollInfo(e.hwnd,SB_HORZ,FSI._getptr_); + // 保存当前滑块位置，迟些进行比较 + xPos := FSI.nPos; + case e.lowparam of + // 用户点击滚动条左边的三角形 + SB_LEFT: + begin + FSI.nPos := FSI.nMin; + end + SB_RIGHT: + begin + FSI.nPos := FSI.nMax; + end + SB_LINELEFT: + begin + FSI.nPos -= 1; + end + // 用户点击滚动条右边的三角形 + SB_LINERIGHT: + begin + FSI.nPos += 1; + end + // 用户点击滑块左边的滚动条轴 + SB_PAGELEFT: + begin + FSI.nPos -= FSI.nPage; + end + // 用户点击滑块右边的滚动条轴 + SB_PAGERIGHT: + begin + FSI.nPos += FSI.nPage; + end + // 用户拖动滚动条 + SB_THUMBTRACK: + begin + FSI.nPos := FSI.nTrackPos; + end + end; + if FSI.nPos=xPos then return; + // 设置滚动条滑块的新位置 + FSI.fMask := SIF_POS; + _wapi.SetScrollInfo(e.hwnd,SB_HORZ,FSI._getptr_,TRUE); + // 获得滚动条滑块的位置，由于窗口调整，它可能不是同一个值 + _wapi.GetScrollInfo(e.hwnd,SB_HORZ,FSI._getptr_); + // 与此前的保存的值进行比较，如果不同则滚动窗口 + FLocalX := FSI.nPos; + if(FSI.nPos <> xPos)then + begin + //_wapi.ScrollWindow(e.hwnd, FColWidth * (xPos - FSI.nPos), 0, NIL,ClipScroll()); + ivrect := ClientRect; + ivrect[0]:= FXfiexed; //FMarginTop+FRowHeight*FFixedRows; + InvalidateRect(ivrect,false); + //UpdateWindow(hwnd); + end + end + function MergeCells(cells); + begin + {** + @explan(说明) 单元格 %% + @param(cells)(array) array(开始行,开始列,结束行,结束列) %% + **} + nm := new TMerger(); + nm.SetMergeCells(cells); + if nm.isok then + begin + if not ifarray(FMergers)then FMergers := array(); + FMergers[length(FMergers)]:= nm; + end + end + function GetMergeInfo(); + begin + {** + @explan(说明) 获得合并信息 %% + **} + r := array(); + for i,v in FMergers do + begin + r[i]:= v.FCells; + end + return r; + end + function CleanMergeCells(); + begin + {** + @explan(说明) 清空合并信息 %% + **} + FMergers := array(); + end + function GetGridMargin(); + begin + return array(FMarginLeft,FMarginTop,FMarginRight,FMarginBottom); + end + function SetGridMargin(l,t,r,b); + begin + if l >= 0 then nl := integer(l); + if t >= 0 then nt := integer(t); + if r >= 0 then nr := integer(r); + if b >= 0 then nb := integer(b); + f := false; + if nl >= 0 and nl <> FMarginLeft then + begin + f := true; + FMarginLeft := nl; + end + if nt >= 0 and nt <> FMarginTop then + begin + f := true; + FMarginTop := nt; + end + if nr >= 0 and nr <> FMarginRight then + begin + //f := true; + FMarginRight := nr; + end + if nb >= 0 and nb <> FMarginBottom then + begin + //f := true; + FMarginBottom := nb; + end + if f then InitialScroll(nil,nil,0); + end + //******************* + property AutoScroll read FAutoScroll write setAutoScroll; + property ItemCount read GetItemCount write SetItemCount; + property ItemHeight read FRowHeight write SetRowHeigt; + property MouseSizeCell read FMouseSizeColumnWidth write FMouseSizeColumnWidth; + property FixedRows read FFixedRows write SetFixedRows; + property FixedColumns read FColumFixed write SetFixedColumns; + property ColumnCount read GetColumnCount; + property VariableRows read FVariableRows write SetVariableRows; + {** + @param(ItemCount)(integer) 行数 %% + @param(MouseSizeCell)(bool) 鼠标改变列宽 %% + @param(FixedRows)(integer) 固定的行数作为列标 %% + **} + protected + function ItemUpDated(flag,idx);virtual; + begin + {** + @explan(说明) 更新状态 %% + @param(flag)(bool) 是否强制刷新,默认当项宽度不变的时候不刷新 %% + @param(idx)(integer) 更新id以后的序号 %% + **} + if HandleAllocated()and not(IsUpDating())then + begin + InitialScroll(nil,nil,idx); + end + end + function InitialScroll(x,y,idx);virtual; + begin + if not HandleAllocated()then return; + UpDateFixed(); + if IsUpDating()then return; + if not(x>0 and y>0)then + begin + rc := ClientRect; + xClient := rc[2]; + yClient := rc[3]; + end else + begin + xClient := x; + yClient := y; + end + xClient -= FXfiexed; + yClient -= FYfiexed; + if xClient FVariableRows then + begin + if not FVariableRows then + begin + if FItemCount>0 then + begin + FRowsHeight.splices(0,FRowsHeight.length(),(zeros(FItemCount)+FRowHeight)); + end + end else + begin + FItemCount := FRowsHeight.Length(); + end + FVariableRows := nv; + InitialScroll(nil,nil,0); + end + end + function setAutoScroll(sc); + begin + if not(nv in array(0,1,2,3))then return 0; + if FAutoScroll <> sc then + begin + FAutoScroll := sc; + InitialScroll(nil,nil,0); + end + end + function GetColumnCount(); + begin + return FColsWidths.length(); + end + + function SetItemCount(ct); + begin + if FItemCount <> ct and ct >= 0 then + begin + FItemCount := ct; + if not FVariableRows then InitialScroll(nil,nil,0); + end + end + function SetRowHeigt(h); + begin + if FRowHeight <> h and h >= 5 then + begin + FRowHeight := h; + InitialScroll(nil,nil,0); + end + end + function SetFixedColumns(rs); + begin + if rs >= 0 and FColumFixed <> rs then + begin + FColumFixed := rs; + InitialScroll(nil,nil,0); + end + end + function SetFixedRows(rs); + begin + if rs >= 0 and FFixedRows <> rs then + begin + FFixedRows := rs; + InitialScroll(nil,nil,0); + end + end + + function UpDateColumWidth(idx,value); + begin + if idx >= 0 and value >= 0 then + begin + if FColsWidths[idx]=value then return; + FColsWidths[idx]:= value; + InitialScroll(nil,nil,0); + end + end + function UpDateRowWidth(idx,value); + begin + if FVariableRows and idx >= 0 and value>0 then + begin + if FRowsHeight[idx]=value then return; + FRowsHeight[idx]:= value; + InitialScroll(nil,nil,0); + end + end + + function UpDateFixed(); //更新固定宽度 + begin + xfix := 0; + FxWidth := 0; + nx := min(FColumFixed,FColsWidths.length())-1; + for i := 0 to FColsWidths.length()-1 do + begin + vi := FColsWidths[i]; + if i <= nx then xfix += vi; + FxWidth += vi; + end + if FVariableRows then + begin + FyHeight := FMarginTop; + FYfiexed := FMarginTop; + ny := min(FFixedRows,FRowsHeight.length())-1; + for i := 0 to FRowsHeight.length()-1 do + begin + vi := FRowsHeight[i]; + if i <= ny then FYfiexed += vi; + FyHeight += vi; + end + end else + begin + FYfiexed := FMarginTop+FFixedRows * FRowHeight; + end + FXfiexed := FMarginLeft+xfix; + end + function setcursorsize2(); + begin + IF FC_CURRENT <> FC_SIZE2 then + begin + cursor := FC_SIZE2; + FC_CURRENT := FC_SIZE2; + end + end + function setcursorsize(); + begin + IF FC_CURRENT <> FC_SIZE then + begin + cursor := FC_SIZE; + FC_CURRENT := FC_SIZE; + end + end + function setcursornormal(); + begin + if FC_CURRENT <> FC_NORMAL then + begin + cursor := FC_NORMAL; + FC_CURRENT := FC_NORMAL; + end + end + function GetHeaderRect(); + begin + end + type TPAINTCOUNT=class + {** + @explan(说明) 绘制计数 %% + **} + function create(v); + begin + if v is class(TControl)then + begin + FPainter := v; + v.BeginUpDate(); + end + end + function Destroy(); + begin + if FPainter then FPainter.EndUpDate(); + FPainter := nil; + end + FPainter; + end + type TMerger=class + public + FCells; + function Create(); + begin + FCells := array(); // r,c value + end + function isok(); + begin + return length(FCells); + end + function mergeid(i,j); + begin + i := FCells[0]; + j := FCells[1]; + end + function CellInMerge(i,j); + begin + if isok()then + begin + if i >= FCells[0]and i <= FCells[2]and j >= FCells[1]and j <= FCells[3]then return true; + end + return false; + end + function GetRange(); + begin + r := array(); + if isok()then + begin + return FCells; + end + return r; + end + function SetMergeCells(rec); + begin + FCells := array(); + if not ifarray(rec)then return; + if(rec[2]>= rec[0]and rec[3]>rec[1])or(rec[2]>rec[0]and rec[3]>= rec[1])then FCells := rec; + end + end + FMergers; + FAutoScroll; + //固定*********** + FXfiexed; + FYfiexed; + //********鼠标************* + FC_NORMAL; + FC_SIZE; + FC_SIZE2; + FC_CURRENT; + //******位置*************** + FMarginLeft; + FMarginTop; + FMarginRight; + FMarginBottom; + //*******表头*********** + FColWidth; + FRowWidth; // 变高基础高度 + FxWidth; + FyHeight; + FFixedRows; + FColsWidths; + FRowsHeight; + FColumFixed; + FRowHeight; + FVariableRows; //列高可变 + //****************表体******************* + FItemCount; + //*******滚动条******* + FSI; + //调整列宽 + FMouseSizeColumnWidth; + FSizeColum; + FCursorRect; + FCurrentSizeId; + FCurrentSizePos; +end +implementation +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 + +end. \ No newline at end of file diff --git a/funcext/tvclib/utslvclmemstruct.tsf b/funcext/tvclib/utslvclmemstruct.tsf index a9a320e..0ec150a 100644 --- a/funcext/tvclib/utslvclmemstruct.tsf +++ b/funcext/tvclib/utslvclmemstruct.tsf @@ -4,7 +4,181 @@ unit utslvclmemstruct; @date(20220429) %% **} interface -uses cstructurelib; +uses cstructurelib,utslvclauxiliary; + +type TTagMSG=class(tslcstructureobj) + {** + @explan(说明) 消息循环对象类 %% + **} + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("hwnd","intptr",0), + ("message","int",0), + ("wparam","intptr",0), + ("lparam","intptr",0), + ("time","int",0), + ("pt","int[2]", + (0,0)), + ("lprivate","int",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property hwnd index "hwnd" read _getvalue_ write _setvalue_; + property message index "message" read _getvalue_ write _setvalue_; + property wparam index "wparam" read _getvalue_ write _setvalue_; + property lparam index "lparam" read _getvalue_ write _setvalue_; + property time index "time" read _getvalue_ write _setvalue_; + property pt index "pt" read _getvalue_ write _setvalue_; + property lprivate index "lprivate" read _getvalue_ write _setvalue_; +end + +type TNOTIFYICONDATAA=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("cbsize","int",0), + ("hwnd","intptr",0), + ("uid","int",0), + ("uflags","int",0), + ("ucallbackmessage","int",0), + ("hicon","intptr",0), + ("sztip","char[128]",0), + ("dwstate","int",0), + ("dwstatemask","int",0), + ("szinfo","char[256]",0), + ("dummyunionname","int",0), + ("szinfotitle","char[64]",0), + ("dwinfoflags","int",0), + ("guiditem","user",( + ("data1","int",0),("data2","short",0),("data3","short",0),("data4","char[8]","") + )), + ("hballoonicon","intptr",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + cbsize := _size_(); + end + property cbsize index "cbsize" read _getvalue_ write _setvalue_; + property hwnd index "hwnd" read _getvalue_ write _setvalue_; + property uid index "uid" read _getvalue_ write _setvalue_; + property uflags index "uflags" read _getvalue_ write _setvalue_; + property ucallbackmessage index "ucallbackmessage" read _getvalue_ write _setvalue_; + property hicon index "hicon" read _getvalue_ write _setvalue_; + property sztip index "sztip" read _getvalue_ write _setvalue_; + property dwstate index "dwstate" read _getvalue_ write _setvalue_; + property dwstatemask index "dwstatemask" read _getvalue_ write _setvalue_; + property szinfo index "szinfo" read _getvalue_ write _setvalue_; + property uTimeout index "dummyunionname" read _getvalue_ write _setvalue_; + property uVersion index "dummyunionname" read _getvalue_ write _setvalue_; + property dummyunionname index "dummyunionname" read _getvalue_ write _setvalue_; + property szinfotitle index "szinfotitle" read _getvalue_ write _setvalue_; + property dwinfoflags index "dwinfoflags" read _getvalue_ write _setvalue_; + property guiditem index "guiditem" read _getvalue_ write _setvalue_; + property hballoonicon index "hballoonicon" read _getvalue_ write _setvalue_; +end + +type TtagSIZE=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + (0,"int",0), + (1,"int",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property cx index 0 read _getvalue_ write _setvalue_; + property cy index 1 read _getvalue_ write _setvalue_; +end +type TCPoint=class(TtagSIZE) + function create(p); + begin + inherited; + end +end +type TCRect=class(tslcstructureobj) + {** + @explan(说明)矩形区域内存分配 %% + **} + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + (0,"int",0), + (1,"int",0), + (2,"int",0), + (3,"int",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property left index 0 read _getvalue_ write _setvalue_; + property top index 1 read _getvalue_ write _setvalue_; + property right index 2 read _getvalue_ write _setvalue_; + property bottom index 3 read _getvalue_ write _setvalue_; +end + +type TCRectF=class(tslcstructureobj) + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + (0,"float",0), + (1,"float",0), + (2,"float",0), + (3,"float",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property left index 0 read _getvalue_ write _setvalue_; + property top index 1 read _getvalue_ write _setvalue_; + property right index 2 read _getvalue_ write _setvalue_; + property bottom index 3 read _getvalue_ write _setvalue_; +end +type TCPointF=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + (0,"float",0), + (1,"float",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property cx index 0 read _getvalue_ write _setvalue_; + property cy index 1 read _getvalue_ write _setvalue_; +end type TCREATESTRUCT=class(tslcstructureobj) private static SSTRUCT; @@ -74,6 +248,502 @@ type TScrollinfo = class(tslcstructureobj) // property npos:integer index "npos" read _getvalue_ write _setvalue_; property ntrackpos:integer index "ntrackpos" read _getvalue_ write _setvalue_; end +type TPAINTSTRUCT=class(tslcstructureobj) + {** + @expaln(说明)wm_paint消息结构体 %% + **} + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("hdc","intptr",0), + ("ferase","int",0), + ("rcpaint","int[4]", + (0,0,0,0)), + ("frestore","int",0), + ("fincupdate","int",0), + ("rgbreserved","byte[32]",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property hdc index "hdc" read _getvalue_; + property ferase index "ferase" read _getvalue_; + property rcpaint index "rcpaint" read _getvalue_; + property frestore index "frestore" read _getvalue_; + property fincupdate index "fincupdate" read _getvalue_; + property rgbreserved index "rgbreserved" read _getvalue_; +end +type TBrowseinfoA=class(tcstructwithcharptr) + {** + @explan(说明)文件夹选择结构构造 %% + **} + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("hwndowner","intptr",0), + ("pidlroot","intptr",0), + ("pszdisplayname","intptr",0), + ("lpsztitle","intptr",0), + ("ulflags","int",0), + ("lpfn","intptr",0), + ("lparam","intptr",0), + ("iimage","int",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),nil,array("lpsztitle":nil,"pszdisplayname":nil)); + lpsztitle := 1024; + pszdisplayname := 1024; + end + property hwndowner index "hwndowner" read _getvalue_ write _setvalue_; + property pidlroot index "pidlroot" read _getvalue_ write _setvalue_; + property pszdisplayname index "pszdisplayname" read _getvalue_ write _setvalue_; + property lpsztitle index "lpsztitle" read _getvalue_ write _setvalue_; + property ulflags index "ulflags" read _getvalue_ write _setvalue_; + property lpfn index "lpfn" read _getvalue_ write _setvalue_; + property lparam index "lparam" read _getvalue_ write _setvalue_; + property iimage index "iimage" read _getvalue_ write _setvalue_; +end +type TBrowseinfoA_=class(tslcstructureobj) + {** + @explan(说明)文件夹选择结构读取 %% + **} + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("hwndowner","intptr",0), + ("pidlroot","intptr",0), + ("pszdisplayname","intptr",0), + ("lpsztitle","intptr",0), + ("ulflags","int",0), + ("lpfn","intptr",0), + ("lparam","intptr",0), + ("iimage","int",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end +end +type TtagOFNA=class(tcstructwithcharptr) //字体构造 + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := array( + ("lstructsize","int",152), + ("hwndowner","intptr",0), + ("hinstance","intptr",0), + ("lpstrfilter","intptr",0), + ("lpstrcustomfilter","intptr",0), + ("nmaxcustfilter","int",0), + ("nfilterindex","int",1), + ("lpstrfile","char*",2049), + ("nmaxfile","int",2048), + ("lpstrfiletitle","char*",512), + ("nmaxfiletitle","int",511), + ("lpstrinitialdir","intptr",0), + ("lpstrtitle","intptr",0), + ("flags","int",0), //6148 + ("nfileoffset","byte[2]",(0,0)), + ("nfileextension","byte[2]",(0,0)), + ("lpstrdefext","intptr",0), + ("lcustdata","intptr",0), + ("lpfnhook","intptr",0), + ("lptemplatename","intptr",0), + ("pvreserved","intptr",0), + ("dwreserved","int",0), + ("flagsex","int",0)); + return SSTRUCT; + end + public + function create() + begin + inherited create(getstruct(),array( + "lpstrfiletitle":"nmaxfiletitle", + "lpstrfile":"nmaxfile", + "lpstrcustomfilter":"nmaxcustfilter", + "lpstrtitle":nil, + "lpstrdefext":nil),array( + "lpstrfilter":nil + )); + lstructsize := _size_(); + end + property lstructsize index "lstructsize" read _getvalue_ write _setvalue_; + property hwndowner index "hwndowner" read _getvalue_ write _setvalue_; + property hinstance index "hinstance" read _getvalue_ write _setvalue_; + property lpstrfilter index "lpstrfilter" read _getvalue_ write _setvalue_; + property lpstrcustomfilter index "lpstrcustomfilter" read _getvalue_ write _setvalue_; + property nmaxcustfilter index "nmaxcustfilter" read _getvalue_ write _setvalue_; + property nfilterindex index "nfilterindex" read _getvalue_ write _setvalue_; + property lpstrfile index "lpstrfile" read _getvalue_ write _setvalue_; + property nmaxfile index "nmaxfile" read _getvalue_ write _setvalue_; + property lpstrfiletitle index "lpstrfiletitle" read _getvalue_ write _setvalue_; + property nmaxfiletitle index "nmaxfiletitle" read _getvalue_ write _setvalue_; + property lpstrinitialdir index "lpstrinitialdir" read _getvalue_ write _setvalue_; + property lpstrtitle index "lpstrtitle" read _getvalue_ write _setvalue_; + property flags index "flags" read _getvalue_ write _setvalue_; + property nfileoffset index "nfileoffset" read _getvalue_ write _setvalue_; + property nfileextension index "nfileextension" read _getvalue_ write _setvalue_; + property lpstrdefext index "lpstrdefext" read _getvalue_ write _setvalue_; + property lcustdata index "lcustdata" read _getvalue_ write _setvalue_; + property lpfnhook index "lpfnhook" read _getvalue_ write _setvalue_; + property lptemplatename index "lptemplatename" read _getvalue_ write _setvalue_; + property lpeditinfo index "lpeditinfo" read _getvalue_ write _setvalue_; + property lpstrprompt index "lpstrprompt" read _getvalue_ write _setvalue_; + property pvreserved index "pvreserved" read _getvalue_ write _setvalue_; + property dwreserved index "dwreserved" read _getvalue_ write _setvalue_; + property flagsex index "flagsex" read _getvalue_ write _setvalue_; +end +type TtagOFNA_ = class(tslcstructureobj) //字体读取 + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate( + array( + ("lstructsize","int",152), + ("hwndowner","intptr",0), + ("hinstance","intptr",0), + ("lpstrfilter","intptr",0), + ("lpstrcustomfilter","intptr",0), + ("nmaxcustfilter","int",0), + ("nfilterindex","int",1), + ("lpstrfile","intptr",2049), + ("nmaxfile","int",2048), + ("lpstrfiletitle","intptr",512), + ("nmaxfiletitle","int",511), + ("lpstrinitialdir","intptr",0), + ("lpstrtitle","intptr",0), + ("flags","int",0), //6148 + ("nfileoffset","byte[2]",(0,0)), + ("nfileextension","byte[2]",(0,0)), + ("lpstrdefext","intptr",0), + ("lcustdata","intptr",0), + ("lpfnhook","intptr",0), + ("lptemplatename","intptr",0), + ("pvreserved","intptr",0), + ("dwreserved","int",0), + ("flagsex","int",0))); + //lpstrdefext + return SSTRUCT; + end + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + end + type TSHBMP=class(tslcstructureobj) + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("bmtype","int",0), + ("bmwidth","int",0), + ("bmheight","int",0), + ("bmwidthbytes","int",0), + ("bmplanes","short",0), + ("bmbitspixel","short",0), + ("bmbits","intptr",0))); + return SSTRUCT; + end + function getstruct2() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("bmtype","int",0), + ("bmwidth","int",0), + ("bmheight","int",0), + ("bmwidthbytes","int",0), + ("bmplanes","byte",0), + ("bmbitspixel","byte",0), + {$ifdef win64} + ("nop1","byte[6]",array(0,0,0,0,0,0)), + {$else} + ("nop1","byte[2]",array(0,0)), + {$endif} + ("bmbits","intptr",100))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property bmtype index "bmtype" read _getvalue_ write _setvalue_; + property bmwidth index "bmwidth" read _getvalue_ write _setvalue_; + property bmheight index "bmheight" read _getvalue_ write _setvalue_; + property bmwidthbytes index "bmwidthbytes" read _getvalue_ write _setvalue_; + property bmplanes index "bmplanes" read _getvalue_ write _setvalue_; + property bmbitspixel index "bmbitspixel" read _getvalue_ write _setvalue_; + property nop1 index "nop1" read _getvalue_ write _setvalue_; + property bmbits index "bmbits" read _getvalue_ write _setvalue_; + {** + @ignore(忽略) %% + @param(bmwidth)(integer) 宽度%%; + @param(bmheight)(integer) 高度%%; + @param(bmwidthbytes)(integer) 行字节数%%; + @param(bmplanes)(integer) 调色板位数%%; + @param(bmbitspixel)(integer) 像素%%; + **} +end + + +type TSHICON=class(tslcstructureobj) + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("ficon","int",0), + ("xhotspot","int",0), + ("yhotspot","int",0), + ("hbmmask","intptr",0), + ("hbmcolor","intptr",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property ficon index "ficon" read _getvalue_ write _setvalue_; + property xhotspot index "xhotspot" read _getvalue_ write _setvalue_; + property yhotspot index "yhotspot" read _getvalue_ write _setvalue_; + property hbmmask index "hbmmask" read _getvalue_ write _setvalue_; + property hbmcolor index "hbmcolor" read _getvalue_ write _setvalue_; +end +type ttagCHOOSECOLORA=class(tslcstructureobj) + {** + @explan(说明) 颜色选择结构体类 %% + **} + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("lstructsize","int",0), + ("hwndowner","intptr",0), + ("hinstance","intptr",0), + ("rgbresult","int",0), + ("lpcustcolors","user*",array((0,"int[16]",array(0)))), + ("flags","int",0), + ("lcustdata","intptr",0), + ("lpfnhook","intptr",0), + ("lptemplatename","char*",100))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + lstructsize := _size_(); + end + property lstructsize index "lstructsize" read _getvalue_ write _setvalue_; + property hwndowner index "hwndowner" read _getvalue_ write _setvalue_; + property hinstance index "hinstance" read _getvalue_ write _setvalue_; + property rgbresult index "rgbresult" read _getvalue_ write _setvalue_; + property lpcustcolors index "lpcustcolors" read _getvalue_ write _setvalue_; + property flags index "flags" read _getvalue_ write _setvalue_; + property lcustdata index "lcustdata" read _getvalue_ write _setvalue_; + property lpfnhook index "lpfnhook" read _getvalue_ write _setvalue_; + property lptemplatename index "lptemplatename" read _getvalue_ write _setvalue_; +end +type ttagCHOOSEFONTA=class(tslcstructureobj) + {** + @explan(说明)字体选择结构体 %% + **} + private + static SSTRUCT; + Flogfont; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("lstructsize","int",0), + ("hwndowner","intptr",0), + ("hdc","intptr",0), + ("lplogfont","intptr",0), + ("ipointsize","int",0), + ("flags","int",0), + ("rgbcolors","int",0), + ("lcustdata","intptr",0), + ("lpfnhook","intptr",0), + ("lptemplatename","char*",100), + ("hinstance","intptr",0), + ("lpszstyle","intptr",100), + ("nfonttype","short",0), + ("___missing_alignment__","short",0), + ("nsizemin","int",0), + ("nsizemax","int",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + lg := inherited _getvalue_("lplogfont"); + Flogfont := new ttagLOGFONTA(lg ?: nil); + lplogfont := Flogfont._getptr_; + lstructsize := _size_(); + end + function _getvalue_(id);override; + begin + if id="lplogfont" then + begin + return new ttagLOGFONTA(inherited); + end else + return inherited; + end + function _setvalue_(id,v);override; + begin + if id="lplogfont" and ifnumber(v)and v then + begin + inherited _setvalue_(id,v); + end else + if v is class(ttagLOGFONTA)then + begin + inherited _setvalue_(id,v._getptr_); + end else + inherited; + end + function SetFontInfo(v); + begin + if ifarray(v)then + begin + for i,vi in v do + begin + Flogfont._setvalue_(i,vi); + end + end + end + property lstructsize index "lstructsize" read _getvalue_ write _setvalue_; + property hwndowner index "hwndowner" read _getvalue_ write _setvalue_; + property hdc index "hdc" read _getvalue_ write _setvalue_; + property lplogfont index "lplogfont" read _getvalue_ write _setvalue_; + property ipointsize index "ipointsize" read _getvalue_ write _setvalue_; + property flags index "flags" read _getvalue_ write _setvalue_; + property rgbcolors index "rgbcolors" read _getvalue_ write _setvalue_; + property lcustdata index "lcustdata" read _getvalue_ write _setvalue_; + property lpfnhook index "lpfnhook" read _getvalue_ write _setvalue_; + property lptemplatename index "lptemplatename" read _getvalue_ write _setvalue_; + property hinstance index "hinstance" read _getvalue_ write _setvalue_; + property lpszstyle index "lpszstyle" read _getvalue_ write _setvalue_; + property nfonttype index "nfonttype" read _getvalue_ write _setvalue_; + //property ___missing_alignment__ index "___missing_alignment__" read _getvalue_ write _setvalue_; + property nsizemin index "nsizemin" read _getvalue_ write _setvalue_; + property nsizemax index "nsizemax" read _getvalue_ write _setvalue_; +end +type ttagLOGFONTA=class(tslcstructureobj) + {** + @explan(说明) 逻辑字体对象结构表示 %% + **} + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("height","int",15), + ("width","int",0), + ("escapement","int",0), + ("orientation","int",0), + ("weight","int",400), + ("italic","byte",0), + ("underline","byte",0), + ("strikeout","byte",0), + ("charset","byte",134), + ("outprecision","byte",3), + ("clipprecision","byte",2), + ("quality","byte",1), + ("pitchandfamily","byte",FIXED_PITCH), + ("facename","char[32]","新宋体"))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property height index "height" read _getvalue_ write _setvalue_; + property width index "width" read _getvalue_ write _setvalue_; + property escapement index "escapement" read _getvalue_ write _setvalue_; + property orientation index "orientation" read _getvalue_ write _setvalue_; + property weight index "weight" read _getvalue_ write _setvalue_; + property italic index "italic" read _getvalue_ write _setvalue_; + property underline index "underline" read _getvalue_ write _setvalue_; + property strikeout index "strikeout" read _getvalue_ write _setvalue_; + property charset index "charset" read _getvalue_ write _setvalue_; + property outprecision index "outprecision" read _getvalue_ write _setvalue_; + property clipprecision index "clipprecision" read _getvalue_ write _setvalue_; + property quality index "quality" read _getvalue_ write _setvalue_; + property pitchandfamily index "pitchandfamily" read _getvalue_ write _setvalue_; + property facename index "facename" read _getvalue_ write _setvalue_; +end +type ttagTEXTMETRICA=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("tmheight","int",0), + ("tmascent","int",0), + ("tmdescent","int",0), + ("tminternalleading","int",0), + ("tmexternalleading","int",0), + ("tmavecharwidth","int",0), + ("tmmaxcharwidth","int",0), + ("tmweight","int",0), + ("tmoverhang","int",0), + ("tmdigitizedaspectx","int",0), + ("tmdigitizedaspecty","int",0), + ("tmfirstchar","byte",0), + ("tmlastchar","byte",0), + ("tmdefaultchar","byte",0), + ("tmbreakchar","byte",0), + ("tmitalic","byte",0), + ("tmunderlined","byte",0), + ("tmstruckout","byte",0), + ("tmpitchandfamily","byte",0), + ("tmcharset","byte",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property tmheight index "tmheight" read _getvalue_ write _setvalue_; + property tmascent index "tmascent" read _getvalue_ write _setvalue_; + property tmdescent index "tmdescent" read _getvalue_ write _setvalue_; + property tminternalleading index "tminternalleading" read _getvalue_ write _setvalue_; + property tmexternalleading index "tmexternalleading" read _getvalue_ write _setvalue_; + property tmavecharwidth index "tmavecharwidth" read _getvalue_ write _setvalue_; + property tmmaxcharwidth index "tmmaxcharwidth" read _getvalue_ write _setvalue_; + property tmweight index "tmweight" read _getvalue_ write _setvalue_; + property tmoverhang index "tmoverhang" read _getvalue_ write _setvalue_; + property tmdigitizedaspectx index "tmdigitizedaspectx" read _getvalue_ write _setvalue_; + property tmdigitizedaspecty index "tmdigitizedaspecty" read _getvalue_ write _setvalue_; + property tmfirstchar index "tmfirstchar" read _getvalue_ write _setvalue_; + property tmlastchar index "tmlastchar" read _getvalue_ write _setvalue_; + property tmdefaultchar index "tmdefaultchar" read _getvalue_ write _setvalue_; + property tmbreakchar index "tmbreakchar" read _getvalue_ write _setvalue_; + property tmitalic index "tmitalic" read _getvalue_ write _setvalue_; + property tmunderlined index "tmunderlined" read _getvalue_ write _setvalue_; + property tmstruckout index "tmstruckout" read _getvalue_ write _setvalue_; + property tmpitchandfamily index "tmpitchandfamily" read _getvalue_ write _setvalue_; + property tmcharset index "tmcharset" read _getvalue_ write _setvalue_; +end type Ttagdrawtextparams=class(tslcstructureobj) private static SSTRUCT; @@ -150,7 +820,121 @@ type tvclwindowpos_class= class(tslcstructureobj) // property hwndinsertafter:integer index "hwndinsertafter" read _getvalue_ write _setvalue_; property hwnd:integer index "hwnd" read _getvalue_ write _setvalue_; end +type TNMHDR=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("hwndfrom","intptr",0), + ("idfrom","intptr",0), + ("code","int",0))); + return SSTRUCT; + end + public + class function memsize(); + begin + if not SSTRUCT then getstruct(); + if SSTRUCT then + begin + ldata := length(SSTRUCT)-1; + return SSTRUCT[ldata,3]+SSTRUCT[ldata,4]-SSTRUCT[0,3]; + end + return 0; + end + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property hwndfrom index "hwndfrom" read _getvalue_ write _setvalue_; + property idfrom index "idfrom" read _getvalue_ write _setvalue_; + property code index "code" read _getvalue_ write _setvalue_; +end +type TWINDOWINFO=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("cbsize","int",0), + ("rcwindow","int[4]", + (0,0,0,0)), + ("rcclient","int[4]", + (0,0,0,0)), + ("dwstyle","int",0), + ("dwexstyle","int",0), + ("dwwindowstatus","int",0), + ("cxwindowborders","int",0), + ("cywindowborders","int",0), + ("atomwindowtype","byte[2]",(0,0)), + ("wcreatorversion","short",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property cbsize index "cbsize" read _getvalue_ write _setvalue_; + property rcwindow index "rcwindow" read _getvalue_ write _setvalue_; + property rcclient index "rcclient" read _getvalue_ write _setvalue_; + property dwstyle index "dwstyle" read _getvalue_ write _setvalue_; + property dwexstyle index "dwexstyle" read _getvalue_ write _setvalue_; + property dwwindowstatus index "dwwindowstatus" read _getvalue_ write _setvalue_; + property cxwindowborders index "cxwindowborders" read _getvalue_ write _setvalue_; + property cywindowborders index "cywindowborders" read _getvalue_ write _setvalue_; + property atomwindowtype index "atomwindowtype" read _getvalue_ write _setvalue_; + property wcreatorversion index "wcreatorversion" read _getvalue_ write _setvalue_; +end +type TCHECK_RESULT=class(tslcstructureobj) + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("errline","int",0), + ("errmsg","char[4096]",0) + )); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property errline index "errline" read _getvalue_ write _setvalue_; + property errmsg index "errmsg" read _getvalue_ write _setvalue_; +end + +type TNMMOUSE=class(tslcstructureobj) + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("hdr","user",array( + ("hwndfrom","intptr",0), + ("idfrom","intptr",0), + ("code","int",0))), + ("dwitemspec","intptr",0), + ("dwitemdata","intptr",0), + ("pt","int[2]", + (0,0)), + ("dwhitinfo","intptr",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property hdr index "hdr" read _getvalue_ write _setvalue_; + property dwitemspec index "dwitemspec" read _getvalue_ write _setvalue_; + property dwitemdata index "dwitemdata" read _getvalue_ write _setvalue_; + property pt index "pt" read _getvalue_ write _setvalue_; + property dwhitinfo index "dwhitinfo" read _getvalue_ write _setvalue_; +end type Ttagminmaxinfo=class(tslcstructureobj) //窗口大小相关 private static SSTRUCT; @@ -180,6 +964,48 @@ type Ttagminmaxinfo=class(tslcstructureobj) // property ptmintracksize index "ptmintracksize" read _getvalue_ write _setvalue_; property ptmaxtracksize index "ptmaxtracksize" read _getvalue_ write _setvalue_; end +/////////////////////////////////////////////////////////////// +type tagWNDCLASSA=class(tslcstructureobj) // 窗口类对象 %% + static classstruct; + class function getstruct(); + begin + if not classstruct then + begin + classstruct := MemoryAlignmentCalculate(array( + ("cbsize","int",0), + ("style","int",0), + ("lpfnwndproc","intptr",0), + ("cbclsextra","int",0), + ("cbwndextra","int",0), + ("hinstance","intptr",0), + ("hicon","intptr",0), + ("hcursor","intptr",0), + ("hbrbackground","intptr",0), + ("lpszmenuname","intptr",0), //("lpszmenuname","char*",100), + ("lpszclassname","char*",100), + ("hiconsm","intptr",0))); + end + return classstruct; + end + function create(ptr); + begin + class(tslcstructureobj).create(getstruct(),ptr); + _setvalue_("cbsize",_size_()); + end + property style:integer index "style" read _getvalue_ write _setvalue_; + property cbsize:integer index "cbsize" read _getvalue_ write _setvalue_; + property lpfnwndproc:pointer index "lpfnwndproc" read _getvalue_ write _setvalue_; + property cbclsextra:integer index "cbclsextra" read _getvalue_ write _setvalue_; + property cbwndextra:integer index "cbwndextra" read _getvalue_ write _setvalue_; + property hinstance:pointer index "hinstance" read _getvalue_ write _setvalue_; + property cbwndextra:integer index "cbwndextra" read _getvalue_ write _setvalue_; + property hicon:pointer index "hicon" read _getvalue_ write _setvalue_; + property hcursor:pointer index "hcursor" read _getvalue_ write _setvalue_; + property lpszmenuname:pointer index "lpszmenuname" read _getvalue_ write _setvalue_; + property hbrbackground:pointer index "hbrbackground" read _getvalue_ write _setvalue_; + property lpszclassname:string index "lpszclassname" read _getvalue_ write _setvalue_; + property hiconsm:pointer index "hiconsm" read _getvalue_ write _setvalue_; +end /////////////////////////////windows进程相关结构体////////// type T_startupinfoa=class(tslcstructureobj) private @@ -277,7 +1103,345 @@ type T_security_attributes=class(tslcstructureobj) property lpsecuritydescriptor index "lpsecuritydescriptor" read _getvalue_ write _setvalue_; property binherithandle index "binherithandle" read _getvalue_ write _setvalue_; end +type TCreateParams=class() + {** + @explan(说明) 窗口控件构造参数对象 %% + **} + {** + @ignore(忽略) + **} + private + FParams; + public + {** + @param(Caption)(string) 控件标题 %% + @param(Style)(integer) 控件样式 %% + @param(ExStyle)(integer) 控件扩展样式 %% + @param(winclass)() 窗口类样式 %% + **} + Caption:string; + Style:integer; + ExStyle:integer; + X,Y:Integer; + CreateWithSubClass; + Width,Height:Integer; + WndParent:HWnd; + Param:Pointer; + winclass:tagWNDCLASSA; + subclass:tagWNDCLASSA; + WinClassName:string; + {** + @param(tagWNDCLASSA)() 依赖标准控件基类 %% + @param(WinClassName)() 窗口类名称 %% + @param(SubClassName)() 依赖窗口基类名称 %% + @param(subclasswndproc)() 依赖窗口基类消息函数 %% + @param(Winclasswndproc)() 窗口类消息函数 %% + @param(cstyle)(integer) 窗口类样式 %% + @param(id)(integer) 窗口id 自动分配 %% + @param(happ)(pointer) 进程句柄 自动分配 %% + **} + SubClassName:string; + subclasswndproc:pointer; + Winclasswndproc:pointer; + id; + cstyle; + //cbrush; + happ; + public + function create(); + begin + FParams := array(); + Caption := ""; + Style := 0; + ExStyle := 0; + id := x := y := 0; + Width := Height := 0; + WndParent := 0; + Param := 0; + WinClassName := 0; + SubClassName := 0; + WinClassName := "tsui_window"; + subclasswndproc := 0; + Winclasswndproc := 0; + winclass := new tagWNDCLASSA(); + subclass := new tagWNDCLASSA(); + cbsize := winclass._size_(); + winclass._setvalue_("cbsize",cbsize); + subclass._setvalue_("cbsize",cbsize); + cstyle := 0; + end + function operator[](index); + begin + if ifstring(index)then + begin + nindex := lowercase(index); + try + return invoke(self(true),nindex); + except + return FParams[nindex]; + end + end else + return FParams[index]; + end + function operator[1](index,value); + begin + if ifstring(index)then + begin + nindex := lowercase(index); + try + invoke(self(true),index,1,value); + except + FParams[nindex]:= value; + end + end else + FParams[index]:= value; + end +end + +////////////////////////socket 结构体//////////////////////////////////// +type TSockaddr=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("sa_family","short",0), + ("sa_data","char[14]",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property sa_family index "sa_family" read _getvalue_ write _setvalue_; + property sa_data index "sa_data" read _getvalue_ write _setvalue_; +end +type TSockaddr_in=class(tslcstructureobj) + private + static SSTRUCT; + FOpr; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("sin_family","short",0), + ("sin_port","short",0), + ("sin_addr","int",0), + ("sin_zero","char[8]",0))); + return SSTRUCT; + end + function writeIntShortN(n,V); + begin + if not(n >= 0 and n <= 1)then exit; + nv := sin_addr; + bs := FOpr.IntToShorts(nv); + bs[n]:= v; + sin_addr := FOpr.ShortsToInt(bs); + end + function writeIntByteN(n,V); + begin + if not(n >= 0 and n <= 3)then exit; + nv := sin_addr; + bs := FOpr.IntAsBytes(nv); + bs[n]:= v; + sin_addr := FOpr.bytesasint(bs); + end + function ReadIntShortN(N); + begin + if not(n >= 0 and n <= 1)then exit; + nv := sin_addr; + bs := FOpr.IntToShorts(nv); + return bs[n]; + end + function ReadIntByteN(N); + begin + if not(n >= 0 and n <= 3)then exit; + nv := sin_addr; + bs := FOpr.IntAsBytes(nv); + return bs[n]; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + FOpr := new TByteDataOP(); + end + property s_b1 index 0 read ReadIntByteN write writeIntByteN; + property s_b2 index 1 read ReadIntByteN write writeIntByteN; + property s_b3 index 2 read ReadIntByteN write writeIntByteN; + property s_b4 index 3 read ReadIntByteN write writeIntByteN; + property s_w1 index 0 read ReadIntShortN write writeIntShortN; + property s_w2 index 1 read ReadIntShortN write writeIntShortN; + property sin_family index "sin_family" read _getvalue_ write _setvalue_; + property sin_port index "sin_port" read _getvalue_ write _setvalue_; + property sin_addr index "sin_addr" read _getvalue_ write _setvalue_; + property sin_zero index "sin_zero" read _getvalue_ write _setvalue_; +end +type TSockaddr_in6=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("sin6_family","short",0), + ("sin6_port","short",0), + ("sin6_flowinfo","long",0), + ("sin6_addr","byte[16]",array()), //union byte16 short8 + ("sin6_scope_id","long",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property sin6_family index "sin6_family" read _getvalue_ write _setvalue_; + property sin6_port index "sin6_port" read _getvalue_ write _setvalue_; + property sin6_flowinfo index "sin6_flowinfo" read _getvalue_ write _setvalue_; + property sin6_addr index "sin6_addr" read _getvalue_ write _setvalue_; + property sin6_scope_id index "sin6_scope_id" read _getvalue_ write _setvalue_; +end +type TWSADATA=class(tslcstructureobj) //有点不理解 + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then + {$IFDEF win64} + SSTRUCT := MemoryAlignmentCalculate(array( + ("wversion","short",0), + ("whighversion","short",0), + ("imaxsockets","short",0), + ("imaxudpdg","short",0), + ("lpvendorinfo","char*",100), + ("szdescription","char[257]",0), + ("szsystemstatus","char[129]",0))); + {$ELSE} + SSTRUCT := MemoryAlignmentCalculate(array( + ("wversion","short",0), + ("whighversion","short",0), + ("szdescription","char[157]",0), + ("szsystemstatus","char[129]",0), + ("imaxsockets","short",0), + ("imaxudpdg","short",0), + ("lpvendorinfo","char*",100))); + {$ENDIF} + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + property wversion index "wversion" read _getvalue_ write _setvalue_; + property whighversion index "whighversion" read _getvalue_ write _setvalue_; + property imaxsockets index "imaxsockets" read _getvalue_ write _setvalue_; + property imaxudpdg index "imaxudpdg" read _getvalue_ write _setvalue_; + property lpvendorinfo index "lpvendorinfo" read _getvalue_ write _setvalue_; + property szdescription index "szdescription" read _getvalue_ write _setvalue_; + property szsystemstatus index "szsystemstatus" read _getvalue_ write _setvalue_; +end implementation +(* +type Ttagprocessentry32=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(("dwsize","int",0) + ,("cntusage","int",0) + ,("th32processid","int",0) + ,("th32defaultheapid","intptr",0) + ,("th32moduleid","int",0) + ,("cntthreads","int",0) + ,("th32parentprocessid","int",0) + ,("pcpriclassbase","int",0) + ,("dwflags","int",0) + ,("szexefile","char[260]",0) + )); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + dwsize := _size_(); + end + property dwsize index "dwsize" read _getvalue_ write _setvalue_; + property cntusage index "cntusage" read _getvalue_ write _setvalue_; + property th32processid index "th32processid" read _getvalue_ write _setvalue_; + property th32defaultheapid index "th32defaultheapid" read _getvalue_ write _setvalue_; + property th32moduleid index "th32moduleid" read _getvalue_ write _setvalue_; + property cntthreads index "cntthreads" read _getvalue_ write _setvalue_; + property th32parentprocessid index "th32parentprocessid" read _getvalue_ write _setvalue_; + property pcpriclassbase index "pcpriclassbase" read _getvalue_ write _setvalue_; + property dwflags index "dwflags" read _getvalue_ write _setvalue_; + property szexefile index "szexefile" read _getvalue_ write _setvalue_; +end + +type Ttagmoduleentry32=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(("dwsize","int",0) + ,("th32moduleid","int",0) + ,("th32processid","int",0) + ,("glblcntusage","int",0) + ,("proccntusage","int",0) + ,("modbaseaddr","intptr",0) + ,("modbasesize","int",0) + ,("hmodule","intptr",0) + ,("szmodule","char[256]",0) + ,("szexepath","char[260]",0) + )); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + dwsize := _size_(); + end + property dwsize index "dwsize" read _getvalue_ write _setvalue_; + property th32moduleid index "th32moduleid" read _getvalue_ write _setvalue_; + property th32processid index "th32processid" read _getvalue_ write _setvalue_; + property glblcntusage index "glblcntusage" read _getvalue_ write _setvalue_; + property proccntusage index "proccntusage" read _getvalue_ write _setvalue_; + property modbaseaddr index "modbaseaddr" read _getvalue_ write _setvalue_; + property modbasesize index "modbasesize" read _getvalue_ write _setvalue_; + property hmodule index "hmodule" read _getvalue_ write _setvalue_; + property szmodule index "szmodule" read _getvalue_ write _setvalue_; + property szexepath index "szexepath" read _getvalue_ write _setvalue_; +end +type TMONITORINFO=class(tslcstructureobj) + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("cbsize","int",0), + ("rcmonitor","int[4]", + (0,0,0,0)), + ("rcwork","int[4]", + (0,0,0,0)), + ("dwflags","int",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + cbsize := _size_(); + end + property cbsize index "cbsize" read _getvalue_ write _setvalue_; + property rcmonitor index "rcmonitor" read _getvalue_ write _setvalue_; + property rcwork index "rcwork" read _getvalue_ write _setvalue_; + property dwflags index "dwflags" read _getvalue_ write _setvalue_; +end + + +*) initialization diff --git a/funcext/tvclib/utslvclmenu.tsf b/funcext/tvclib/utslvclmenu.tsf new file mode 100644 index 0000000..df7edf2 --- /dev/null +++ b/funcext/tvclib/utslvclmenu.tsf @@ -0,0 +1,1020 @@ +unit utslvclmenu; +interface +{** + @explan(说明) 菜单相关 %% + @date(20220509) %% +**} +uses utslvclauxiliary,cstructurelib,utslvclgdi,utslvclaction; +type TcustomMenu = class(tcomponent) + {** + @explan(说明) 菜单类 %% + **} +private +#!begin + static FSIDC; //command 计数器 + FActionLink:TMenuActionLink; + Fhandle:hmenu; + FCaption:string; + FParent:tmenu; + FItems; + FAutoChecked:bool; + FChecked :bool; + FEnabled :bool; + FVisible :bool; + FCommand :integer; + FOnclick; + FOwnerDraw; + FOnselect; + FOnDrawItem; //绘制 + FOnMeasureItem; //测量 + FOninitmenupopup; + FOnrbuttonup; + FMtype; //样式 + FMenuitemInfo; + FOnDesignClick; + FBitmap; + FShortCut; + function modifyshowcaption(item); + begin + s := item.caption; + st := item.ShortCut; + if st then r := s+" ("+st+")"; + else r := s; + return r; + end + function SetBitmap(v); //设置bmp + begin + if v <> FBitmap then SetBitmapsub(v); + end + function SetBitmapsub(v); //子项设置bmp + begin + FBitmap := v; + if v is class(tcustombitmap)then + begin + if FBitmap.HandleAllocated()then + begin + if Parent then + begin + if not(Parent is class(TcustomMainmenu))then + begin + return parent.setmenuiteminfo(indexof(),MIIM_BITMAP,"hbmpitem",v.Handle); + end + end + end + end else + begin + if Parent then + begin + if not(Parent is class(TcustomMainmenu))then + begin + parent.setmenuiteminfo(indexof(),MIIM_BITMAP,"hbmpitem",-1); + end + end + end + end + function ancestor(); + begin + if parent then return parent.ancestor(); + else return self(true); + end + function ancestorof(item); + begin + {** + @explan(说明) 判断item是否为子节点 %% + @param(item)(TcustomMenu) 判断的节点 %% + **} + if item is class(TcustomMenu)then + begin + if item=self then return 1; + for i := 0 to FItems.count-1 do + begin + if FItems[i].ancestorof(item)then return 1; + end + end + return 0; + end + function inmenutree(item); + begin + ac := ancestor(); + if ac.ancestorof(item)then return true; + return 0; + end + function removehmenuitem(item,pi); + begin + {** + @explan(说明) 删除hmenu节点 %% + **} + if _wapi.RemoveMenu(FHandle,pi,MF_BYPOSITION)then menuchanged(); + end + function addhmenuitem(item,bef); + begin + {** + @explan(说明) 添加到hmenu %% + **} + mif := item.Itemstruct; + mif._setvalue_("wid",item.command); + ic := modifyshowcaption(item); + mif._setvalue_("dwtypedata",ic); + bm := item.Bitmap; + if(bm is class(tcustombitmap))and bm.HandleAllocated()and(not(self is class(TcustomMainmenu)))then + begin + mif._setvalue_("hbmpitem",bm.handle); + bsk := true; + end + if item.HandleAllocated()then + begin + mif._setvalue_("hsubmenu",item.handle); + mif._setvalue_("fmask",MIIM_ID .| MIIM_STRING .| MIIM_STATE .| MIIM_FTYPE .| MIIM_SUBMENU .|(bsk?MIIM_BITMAP:0)); + end else + begin + mif._setvalue_("fmask",MIIM_ID .| MIIM_STRING .| MIIM_STATE .| MIIM_FTYPE .|(bsk?MIIM_BITMAP:0)); + end + IF item.TSeparator then + begin + mif._setvalue_("ftype",MFT_SEPARATOR); + end else + if item.TOwnerdraw then + begin + mif._setvalue_("ftype",MFT_OWNERDRAW); + end else + begin + mif._setvalue_("ftype",MFT_STRING); + end + state := 0; + if item.Checked then + begin + state .|= MFS_CHECKED; + end else + state .|= MFS_UNCHECKED; + if item.Enabled then + begin + state .|= MFS_ENABLED; + end else + state .|= MFS_DISABLED; + mif._setvalue_("fstate",state); + _wapi.InsertMenuItemA(FHandle,bef,true,mif._getptr_); + menuchanged(); + end + Function SetMenuType(nms,n); + begin + if not(n)then + begin + ms := MF_STRING; + end else + begin + ms := nms; + end + if FMtype <> ms then + begin + FMtype := ms; + if ms=MF_STRING then ft := MFT_STRING; + if ms=MF_SEPARATOR then ft := MFT_SEPARATOR; + if ms=MF_OWNERDRAW then ft := MFT_OWNERDRAW; + if parent then + begin + parent.setmenuiteminfo(indexof(),MIIM_FTYPE,"ftype",ft); + end + end + end + function getitems(); + begin + return FItems.data(); + end + function GetItemcount(); + begin + return FItems.count; + end + function GetMenuType(ms); + begin + return FMtype=ms; + end + function ifchild(item); + begin + if item is class(TcustomMenu)then + begin + for i := 0 to FItems.count-1 do if FItems[i]=item then return 1; + end + return 0; + end + function dispatchrbuttonup(e); + begin + if e.lparam=FHandle then + begin + it := FItems[e.wparam]; + CallMessgeFunction(it.Onrbuttonup,it,e); + return 1; + end + return itemsdispatch(e); + end + function dispatchloop(e); + begin + if e.wparam=FHandle then + begin + CallMessgeFunction(Oninitmenupopup,self(true),e); + return 1; + end + return itemsdispatch(e); + end + function dispatchcommand(e); + begin + if e.lowparam=FCommand then + begin + //if FAutoChecked then checked := not(checked); + doClick(self(true),e); + return 1; + end else + begin + return itemsdispatch(e); + end + return 0; + end + function itemsdispatch(e); + begin + for i := 0 to FItems.count-1 do if FItems[i].dispatch(e)then return 1; + end + function dispatchselect(e); + begin + cmd := e.lowparam; + if cmd>1000 then + begin + if cmd=FCommand then + begin + CallMessgeFunction(FOnselect,self(true),e); + return 1; + end else + begin + return itemsdispatch(e); + end + end else + begin + if FHandle=e.lparam then + begin + it := FItems[cmd]; + if ifobj(it)then CallMessgeFunction(it.Onselect,it,e); + return 1; + end else + return itemsdispatch(e); + end + end + function dispatchbycmdid(e); + begin + if e.itemID=FCommand then + begin + case e.msg of + WM_MEASUREITEM: + begin + DoMeasureItem(self(true),e); + end + WM_DRAWITEM: + begin + DoDrawItem(self(true),e); + end + end; + return 1; + end else + begin + return itemsdispatch(e); + end + end + function itemsate(); + begin + state := 0; + if FEnabled then state .|= MF_ENABLED; + else state .|= MF_DISABLED; + if FChecked then state .|= MF_CHECKED; + else state .|= MF_UNCHECKED; + return state; + end + function doClick(o,e);virtual; + begin + if csDesigning in ComponentState then + begin + CallMessgeFunction(FOnDesignClick,o,e); + end + if Action and Action.Execute() then + begin + + end else + CallMessgeFunction(Onclick,o,e); + end + function DoMeasureItem(o,e);virtual; + begin + return CallMessgeFunction(OnMeasureItem,o,e); + end + function DoDrawItem(o,e);virtual; + begin + return CallMessgeFunction(OnDrawItem,o,e); + end + function modifyitem(item,uflags); + begin + {** + @explan(说明) 修改菜单子项的状态 %% + @param(item)(TcustomMenu) 菜单子项 %% + @param(uflags)(integer) 状态常量 %% + **} + if HandleAllocated()then + begin + idx := indexof(item); + vv := vid := array(); + vvdx := 0; + if((uflags .& MIIM_STRING)=MIIM_STRING)then + begin + vid[vvdx]:= "dwtypedata"; + vv[vvdx++]:= modifyshowcaption(item); + end + if(uflags .& MF_POPUP)=MF_POPUP then + begin + vid[vvdx]:= "hsubmenu"; + vv[vvdx++]:= item.handle; + end + setmenuiteminfo(idx,uflags,vid,vv); + menuchanged(); + return; + end + end + function GetZorder(); + begin + r := indexof(); + return r; + end + function SetZorder(n); + begin + if not(n >= 0)then exit; + f := Parent; + if f is class(TcustomMenu)then + begin + odn := indexof(); + if odn=n then exit; + nn := f.GetItemByIndex(n); + if nn then f.RemoveItem(self(true)); + f.insertitem(self(true),nn); + end + end + +#!end + protected + function SetAction(Value);virtual; + begin + if ifnil(Value)then + begin + if FActionLink then + begin + FActionLink.SetAction(nil); + end + excludestate(FControlStyle,csActionClient); + end else + if Value is class(TBasicAction)then + begin + includestate(FControlStyle,csActionClient); + if ifnil(FActionLink)then FActionLink := createobject(GetActionLinkClass(),self); + FActionLink.Action := Value; + FActionLink.Onchange := thisfunction(DoActionChange); + ActionChange(Value,csLoading in Value.ComponentState); + Value.FreeNotification(Self); + end + end + procedure DoActionChange(Sender:TObject); + begin + if Sender=Action then ActionChange(Sender,False); + end + function GetAction();virtual; + begin + if FActionLink then + begin + return FActionLink.Action; + end + end + function GetActionLinkClass();virtual; + begin + {** + @explan(说明) 返回actionlinkclass %% + @return(TMenuActionLink class) + **} + return class(TMenuActionLink); + end + procedure ActionChange(Sender:TObject;CheckDefaults:Boolean);virtual; + begin + if Sender is class(TCustomAction)then + begin + NewAction := Sender; + if (not CheckDefaults) or (Caption='') or (Caption=Name) then Caption := NewAction.Caption; + if (not CheckDefaults) then ShortCut := NewAction.ShortCut; + if (not CheckDefaults) or Enabled then Enabled := NewAction.Enabled; + if (not CheckDefaults) or FChecked then Checked := NewAction.Checked; + end; + end + function SetCaption(v);virtual; + begin + if not(ifstring(v)and(FCaption <> v))then exit; + FCaption := v; + if Parent then + begin + vs := modifyshowcaption(self); + parent.setmenuiteminfo(indexof(),MIIM_STRING,"dwtypedata",vs); + end + end + function SetVisible(v);virtual; + begin + nv := v?true:false; + if FVisible=nv then exit; + FVisible := nv; + TOwnerDraw := FVisible?false:true; + end + function SetChecked(v);virtual; + begin + nv := v?true:false; + if nv <> FChecked then + begin + FChecked := nv; + if parent then parent.setmenuiteminfo(indexof(),MIIM_STATE,"fstate",itemsate()); + end + end + function SetEnabled(v);virtual; + begin + nv := v?true:false; + if nv <> FEnabled then + begin + FEnabled := nv; + if parent then + begin + parent.setmenuiteminfo(indexof(),MIIM_STATE,"fstate",itemsate()); + end + end + end + function HandleNeeded(); + begin + {** + @explan(说明) 获取节点句柄,必须有子节点%% + @return(pointer) 节点句柄 %% + **} + if not HandleAllocated()then CreateHandle(); + return Fhandle; + end + //FCompStyle:integer; + public + function ExecuteCommand(cmd,d);override; + begin + if cmd = 'doshortcut' then + begin + if csDesigning in ComponentState then return ; + if Visible and Enabled and Parent and GetMenuType(0) then + begin + if d = ShortCut then + begin + DoClick(self,new tuieventbase(0,0,0,0)); + return "havedoshortcut"; + end + end + end + end + function Notification(AComponent:TComponent;Operation:TOperation);override; + begin + inherited; + if Operation=opRemove then + begin + if AComponent=Action then Action := nil; + end + end + class function sinit();override; + begin + {** + @explan(说明) 初始化类成员 %%; + **} + inherited; + if not FSIDC then + begin + FSIDC := new tidcreater(5000); + end + end + function dispatch(e);override; //分发 + begin + {** + @explan(说明) 菜单消息分发 %% + @param(e)(tuieventbase) 消息对象 %% + **} + case e.msg of + WM_COMMAND: + begin + return dispatchcommand(e); + end + WM_MENUSELECT: + begin + return dispatchselect(e); + end + WM_INITMENUPOPUP: + begin + return dispatchloop(e); + end + WM_MENURBUTTONUP: + begin + return dispatchrbuttonup(e); + end else + return dispatchbycmdid(e); + end; + return 0; + end + Function create(AOwner:tcomponent);override; + begin + inherited; + FMtype := MF_STRING; + FParent := nil; + FChecked := False; + FVisible := True; + FEnabled := True; + FItems := new TFpList(); + FCaption := "menu"; + FCommand := FSIDC.createid(); + menustr := array( + ("cbsize","int",0), + ("fmask","int",0), + ("ftype","int",0), + ("fstate","int",0), + ("wid","int",0), + ("hsubmenu","intptr",0), + ("hbmpchecked","intptr",0), + ("hbmpunchecked","intptr",0), + ("dwitemdata","intptr",0), + ("dwtypedata","intptr",0), + ("cch","int",90), + ("hbmpitem","intptr",0)); + FMenuitemInfo := new tcstructwithcharptr(menustr,array("dwtypedata":"cch")); + FMenuitemInfo._setvalue_("cbsize",FMenuitemInfo._size_()); + end + function HandleAllocated(); + begin + {** + @explan(说明)菜单句柄是否已有效%% + **} + return ifnumber(FHandle)and FHandle; + end + function DestroyHandle(); + begin + {** + @explan(说明) 销毁菜单句柄 %% + **} + if HandleAllocated()then + begin + for i := 0 to FItems.count-1 do + begin + it := FItems[i]; + if it is class(TcustomMenu)then it.DestroyHandle(); + end + _wapi.DestroyMenu(FHandle); + FHandle := 0; + end + end + function CreateMenu();virtual; + begin + {** + @explan(说明) 构造菜单句柄,通过overrid此函数实现不同类型菜单构造 %% + @return(pointer) 句柄 %% + **} + return _wapi.CreatePopupMenu(); + end + function CreateHandle(); + begin + {** + @explan(说明)更新节点句柄 %% + **} + if not HandleAllocated()then + begin + IF FItems.count>0 then + begin + FHandle := CreateMenu(); + end else + if self(true)is class(TcustomMainmenu)then //修改 + begin + FHandle := CreateMenu(); + end + end + for i := 0 to FItems.count-1 do + begin + it := FItems[i]; + ch := it.handle; + addhmenuitem(it,i+1); + end + end + function Recycling();override; + begin + {** + @explan(说明) 菜单资源回收%% + **} + //DestroyHandle(); + if parent is class(TcustomMenu)then + begin + parent.RemoveItem(self); + end + FSIDC.deleteid(FCommand); + FItems.clean(); + FOnDesignClick := nil; + FOnclick := nil; + FOwnerDraw := nil; + FOnselect := nil; + FOnDrawItem := nil; + FOnMeasureItem := nil; + FOninitmenupopup := nil; + FOnrbuttonup := nil; + inherited; + end + function removefromparent(); + begin + {** + @explan(说明) 从父节点中删除自己 %% + **} + if Fparent then + begin + Fparent.removeitem(self); + FParent := nil; + end + return self; + end + function indexof(item); + begin + {** + @explan(说明) 查看对象位置 %% + @param(item)(TcustomMenu | nil) 如为nil 返回在自己在父节点位置,为菜单返回该菜单,在本菜单的位置 %% + **} + if ifnil(item)then + begin + if FParent then return FParent.indexof(self(true)); + return-1; + end + return FItems.indexof(item); + end + function GetItemByIndex(idx); + begin + {** + @explan(说明) 根据序号id 获得菜单%% + @param(idx)(integer) 序号id %% + @return(TcustomMenu|nil) 如果存在返回菜单项,如果不错返回nil + **} + if ifnumber(idx)>= 0 then + begin + return FItems.geti(idx); + end + return nil; + end + function setmenuiteminfo(idx,mv,vid,vv); //设置信息 + begin + {** + @explan(说明)设置菜单信息 %% + @param(mv)(integer) mask %% + @param(vid)(string) 下标 %% + @param(vv)() 值 %% + **} + FMenuitemInfo._setvalue_("fmask",mv); + if ifstring(vid)then + begin + FMenuitemInfo._setvalue_(vid,vv); + end else + if ifarray(vid)and ifarray(vv)and(length(vid)=length(vv))then + begin + for i,v in vid do + begin + FMenuitemInfo._setvalue_(v,vv[i]); + end + end + if HandleAllocated()then return _wapi.SetMenuItemInfoA(Fhandle,idx,true,FMenuitemInfo._getptr_); + end + function insertitem(item,bef);virtual; + begin + {** + @explan(说明) 添加节点 %% + @param(item)(TcustomMenu) 待添加的节点 %% + @param(bef)(TcustomMenu | integer) 基准位置 %% + **} + if not(item is class(TcustomMenu))then return-2; + if not ifchild(item)then + begin + if bef is class(TcustomMenu)then + begin + beforid := indexof(bef); + end else + if ifnumber(bef)then + begin + beforid := bef; + end else + beforid := FItems.count(); + item.removefromparent(); + flagprant := false; + if FItems.count=0 then + begin + if Fparent then + begin + if Fparent.HandleAllocated()then + begin + flagprant := true; + end + end + end + FItems.insertbefor(item,beforid); + item.setfparent(self(true)); + if HandleAllocated()then + begin + addhmenuitem(item,beforid); + end + if flagprant then + begin + mks := MIIM_SUBMENU .| MIIM_STRING; + mksv := array("dwtypedata","hsubmenu"); + vs := modifyshowcaption(self); + mksvv := array(vs,self.handle); + if FBitmap is class(tcustombitmap)and FBitmap.HandleAllocated()then + begin + mks .|= MIIM_BITMAP; + mksv[2]:= "hbmpitem"; + mksvv[2]:= FBitmap.Handle; + end + Fparent.setmenuiteminfo(indexof(),mks,mksv,mksvv); + end + end + return-1; + end + function setfparent(p); + begin + {** + @ignore(忽略) %% + @explan(说明) 设置fprent %% + **} + FParent := p; + end + function removeItemByIndex(idx); + begin + {** + @explan(说明)根据序号删除子菜单 %% + @param(idx)(integer) 序号id %% + **} + it := GetItemByIndex(idx); + if it is class(TcustomMenu)then + begin + return removeItem(it); + end + return nil; + end + function RecyclingAllItems(); + begin + {** + @explan(说明) 销毁当前节点的 所有子节点,子节点不可以再被使用 %% + **} + while FItems.count >= 1 do + begin + it := FItems[0]; + it.Recycling(); + end + end + function removeitem(item);virtual; + begin + {** + @explan(说明) 删除节点 %% + @param(item)(TcustomMenu) 将删除的菜单项 %% + **} + pi := FItems.indexof(item); + if pi<0 then return-1; + if HandleAllocated()then removehmenuitem(item,pi); + FItems.deli(pi); + if FItems.count<1 then + begin + if Fparent then + begin + DestroyHandle(); //销毁菜单 + vs := modifyshowcaption(self); + Fparent.setmenuiteminfo(indexof(),MIIM_STRING .| MIIM_SUBMENU,array("dwtypedata","hsubmenu"),array(vs,0)); + //Fparent.modifyitem(self(true),FMtype.|MF_POPUP); //修改样式 + end + end + item.setfparent(nil); + end + private + function setparentforproperty(f); + begin + if f is class(TcustomMenu)then + begin + f.insertitem(self); + end else + if parent is class(TcustomMenu)then + begin + parent.removeitem(self); + end + end + public + function SetChangedPublish(n,v);virtual; + begin + {** + @explan(说明) 设计器相关函数 %% + **} + ts := array("tstring","tseparator","townerdraw"); + if(n in ts)then + begin + for i,vi in ts do DeleteChangedPublish(vi); + if v then inherited; + return; + end + inherited; + end + function menuchanged();virtual; + begin + {** + @explan(说明) 菜单改变时的回调 %% + **} + end + published + //property Visible read FVisible write SetVisible; + property Action:taction read GetAction write SetAction; + {** + @param(Action)(taction) action对象 %%; + **} + property caption:string read FCaption write SetCaption; + property Enabled:bool read FEnabled write SetEnabled; + property ItemCount read GetItemcount; + property Items read getitems; + property Handle read HandleNeeded; + property Parent read FParent write setparentforproperty; + property Command read FCommand; + property Bitmap:tbitmap read FBitmap write SetBitmap; + property Onclick:eventhandler read FOnclick write FOnclick; + {** + @param(caption)(string) 菜单显示文字 %%; + @param(ItemCount)(integer) 菜单子项个数 %% + @param(Handle)(pointer) 菜单句柄 %% + @param(Parent)(TcustomMenu) 父节点 %% + @param(Command)(integer) 菜单id %% + @param(onclick)(function[TcustomMenu,tuieventbase]) 菜单点击回调函数 %% + **} + //property OwnerDraw read FOwnerDraw write FOwnerDraw; + property TSeparator:bool index 0x800 read GetMenuType write SetMenuType; + property Itemstruct read FMenuitemInfo; + property TString index 0 read GetMenuType write SetMenuType; + Property TOwnerdraw:bool index 0x100 read GetMenuType write SetMenuType; + property Checked:bool read FChecked write SetChecked; + property OnDrawItem:eventhandler read FOnDrawItem write FOnDrawItem; + property OnMeasureItem:eventhandler read FOnMeasureItem write FOnMeasureItem; + property OnSelect:eventhandler read FOnselect write FOnselect; + property Oninitmenupopup read FOninitmenupopup write FOninitmenupopup; + property Onrbuttonup:eventhandler read FOnrbuttonup write FOnrbuttonup; + property Zorder read GetZorder write SetZorder; + property OnDesignClick read FOnDesignClick write FOnDesignClick; + property ShortCut read getShortCut write SetShortCut; + function publishs();override; + begin + return array("action","bitmap","caption","checked","enabled","name","townerdraw","tseparator", + "onclick","onrbuttonup","onselect"); + end + {** + @param(Parent)(TcustomMenu|nil)添加父节点,如果非tmenu,从父节点移除 %% + @param(OnDrawItem)(function[TcustomMenu,TMDRAWITEM]) 自绘制菜单回调函数 %% + @param(OnMeasureItem)(function[TcustomMenu,TMMEASUREITEM]) 自绘制菜单高度宽度设置回调函数 %% + @param(Onrbuttonup)(function[TcustomMenu,tuieventbase]) 菜单右击回调函数 %% + @param(OnSelect)(function[TcustomMenu,TMMENUSELECT]) 菜单被鼠标选中回调函数 %% + @param(Oninitmenupopup)(function[TcustomMenu,tuieventbase]) 进入菜单循环菜单回调函数 %% + **} + private + function getShortCut(); + begin + return formatshortcut(FShortCut); + end + + function SetShortCut(v); + begin + if v and ifstring(v) then + begin + nst := parsershortcutstr(v); + end else nst := nil; + if nst <> FShortCut then + begin + FShortCut := nst; + if Parent then + begin + vs := modifyshowcaption(self); + parent.setmenuiteminfo(indexof(),MIIM_STRING,"dwtypedata",vs); + end + end + end +end +type TcustomPopupmenu=class(TcustomMenu) + {** + @explan(说明) 弹出菜单 %% + **} + function create(AOwner);override; + begin + inherited; + end + function publishs();override; + begin + return array("name","caption","enabled","onrbuttonup"); + end +end +type TcustomMainmenu=class(TcustomMenu) + {** + @explan(说明) 主菜单类 %% + **} + private + FWndHandle; + function setmenu(); + begin + if _wapi.IsWindow(FWndHandle)then + begin + _wapi.SetMenu(FWndHandle,self.handle); + end + end + function setwndhandle(v); + begin + if FWndHandle <> v then + begin + if _wapi.IsWindow(FWndHandle)then + begin + _wapi.SetMenu(FWndHandle,0); + end + FWndHandle := v; + setmenu(); + end + end + function DrawMenuBar(); + begin + if HandleAllocated()and _wapi.IsWindow(FWndHandle)then + begin + _wapi.DrawMenuBar(FWndHandle); + end + end + public + function insertitem(item,bef);override; + begin + inherited; + DrawMenuBar(); + end + function removeitem(item);override; + begin + inherited; + DrawMenuBar(); + end + function menuchanged();override; + begin + if _wapi.IsWindow(FWndHandle)then _wapi.DrawMenuBar(FWndHandle); + end + function create(AOwner);override; + begin + inherited; + end + function CreateMenu();override; + begin + r := nil; + r := _wapi.CreateMenu(); + return r; + end + property Hwnd:pointer read FWndHandle write setwndhandle; + function publishs();override; + begin + return array("name"); + end + {** + @param(Hwnd)()窗口句柄 %%; + **} +end +type TMenuActionLink=class(TControlActionLink) + {** + @explan(说明) 菜单actionlink %% + **} + protected + procedure AssignClient(AClient);override; + begin + {** + @explan(说明)赋值control %% + @param(AClient)(tcontrol) %% + **} + if AClient is class(TcustomMenu)then FClient := AClient; + end + function IsshortcutLinked();override; + begin + return FClient and(Action is CLASS(TCustomAction)); + end + function IsVisibleLinked():Boolean;override; + begin + return false; + end + function IsCheckedLinked():Boolean;override; + begin + return FClient and(Action is CLASS(TCustomAction)); + end + public + procedure SetShortCut(const Value:String);override; + begin + if IsshortcutLinked() then + begin + return FClient.ShortCut := Value; + end + end + function create(AOwner);override; + begin + inherited; + end + procedure SetChecked(Value:Boolean);override; + begin + if IsCheckedLinked()then return FClient.Checked := Value; + end +end + +implementation + +initialization + + +end. \ No newline at end of file diff --git a/funcext/tvclib/utslvclstdctl.tsf b/funcext/tvclib/utslvclstdctl.tsf new file mode 100644 index 0000000..4d2b821 --- /dev/null +++ b/funcext/tvclib/utslvclstdctl.tsf @@ -0,0 +1,4856 @@ +unit utslvclstdctl; +interface +{** +@explan(说明) 标准控件库 %% +@date(20220509) +**} +uses utslvclauxiliary,utslvclbase,utslvclgdi,utslvclaction,utslvclmenu; +type TcustomClipBoard=class(tcomponent) + {** + @explan(说明) 剪切板类 %% + **} + private + private + FIsopen; + function CloseClipboard(); + begin + if FIsopen then FIsopen := not _wapi.CloseClipboard(); + return not(FIsopen); + end + function OpenClipboard(); + begin + {** + @explan(说明) 打开剪切板 %% + **} + IF not(FIsopen)then FIsopen := _wapi.OpenClipboard(0); + return FIsopen; + end + function EmptyClipboard(); + begin + {** + @explan(说明) 清空剪切板 %% + **} + if FIsopen then _wapi.EmptyClipboard(); + end + function SetText(s); + begin + {** + @explan(说明) 设置字符串到剪切板 %% + @param(s)(string|nil) 字符串如果为nil则清空 %% + **} + ret :=-1; + if not(ifstring(s)and length(s)>0)then + begin + return-1; + end + OpenClipboard(); + try + EmptyClipboard(); + _wapi.setclipboardtext(0,s); + finally + CloseClipboard(); + end; + return ret; + end + function GetText(); + begin + {** + @explan(说明) 获得剪切板字符串 %% + @return(string) 字符串 %% + **} + OpenClipboard(); + try + if _wapi.IsClipboardFormatAvailable(CF_TEXT)then + begin + r := _Wapi.getclipboardtext(0); + end + finally + CloseClipboard(); + end; + return r; + end + function SetBitmap(v); + begin + if v is class(tcustombitmap)then + begin + if V.HandleAllocated()then + begin + OpenClipboard(); + try + EmptyClipboard(); + _wapi.setclipboardbmp(v.Handle); + finally + CloseClipboard(); + end; + return ret; + end + end + end + function Getbitmap(); + begin + OpenClipboard(); + try + if _wapi.IsClipboardFormatAvailable(CF_BITMAP)then + begin + sid := _wapi.getclipboardbmp(); + if sid then + begin + bmp := new tcustombitmap(); + bmp.Handle := sid; + return bmp; + end + return false; + end + finally + CloseClipboard(); + end; + return r; + end + public + function create(AOwner);override; + begin + {** + @explan(说明) 构造剪切板类对象 %% + **} + inherited; + end + function Recycling();override; + begin + CloseClipboard(); + inherited; + end + function destroy();override; + begin + inherited; + end + property Text read GetText write SetText; + property Bmp read GetBitmap write SetBitmap; + function publishs();override; + begin + return array("name","text","bmp"); + end + {** + @explan(Text)(string) 设置或者获取剪切板文本 %% + **} +end +type TCustomTimer = class(tcomponent)//定时器类 + {** + @explan(说明)定时器类,间隔是以毫秒为最小单位 %% + **} + {** + @example(范例--定时器) + //构造计算器,第一个参数为间隔(毫秒),第二个为函数指针 + tm := new TCustomTimer(1000,function(o,e)begin echo now(); end ); + tm.start();//启动定时器 + tm.stop();//停止 + **} + private + static _STIMERS; //TIMER对象 + static FSIDC; //id 构造器 + class function Sgettimer(id); + begin + {** + @explan(说明) 通过id获得定时器对象 %% + @param(id)(integer) 定时器id %% + **} + return _STIMERS[id]; + end + class function Ssettimer(tm); + begin + {** + @explan(说明)存储定时器 %% + @param(tm)(TCustomTimer) 定时器对象%% + **} + _STIMERS[tm.id]:= tm; + end + class function Sdeltimer(tid); + begin + {** + @explan(说明) 删除定时器 %% + @param(tid)(integer) id%% + **} + if tid and(ifnumber(tid))then reindex(_STIMERS,array(tid:nil)); + end + protected FOntimeout; + private + FOntimer; + Fid; + FInterval; + FStart; + _kill0; //标记 + function SetEnabled(f); + begin + if f then start(); + else stop(); + end + function SetInterval(intv); //设置间隔 + begin + {** + @explan(说明)设置间隔 %% + @param(intv)(integer) 间隔,毫秒 %% + **} + if not(ifnumber(intv))then return FInterval; + if FStart then + begin + ndstart := 1; + stop(); + end + if intv <> FInterval and ifnumber(intv)and intv>0 then //时间不等 + begin + FInterval := intv; + end + if ndstart then start(); + end + public + {** + @param(FSIDC)(tidcreater) id构造器%% + @param(_STIMERS)(array) 全局存储%% + @param(FOntimer)(fpointer) timeout执行对象%% + @param(_kill0)(bool) 标记%% + **} + function create(AOwner);override; + begin + inherited; + FID := FSIDC.createid(); + FStart := false; + FInterval := 1000; + end + function timeout(cmd,t); //一次性事件 + begin + {** + @explan(说明) 一次性事件 %% + @param(cmd)(fpointer) 执行回调 %% + @param(t)(integer) t毫秒后执行 %% + **} + FOntimeout := cmd; + if ifnumber(t)then SetInterval(t); + FOntimer := function(o,e) + begin + try + stop(); + CallMessgeFunction(FOntimeout,o,e); + finally + FOntimeout := nil; + end; + end; + start(); + end + function start(); //开始 + begin + {** + @explan(说明)启动 %% + **} + if not((datatype(FOntimer) = 7 )and FInterval)>0 then return-1; + if FStart then return FStart; + ret := _wapi.SetTimer(nil,Fid,FInterval,getwinprocptr(2)); + _kill0 := ret; + Ssettimer(self(true)); + FStart := ret <> 0; + return FStart; + end + function stop(); //停止 + begin + {** + @explan(说明)停止 %% + **} + if FStart then + begin + if _kill0 then + begin + FStart := not((_wapi.KillTimer(nil,_kill0))<> 0); + if FStart=false then _kill0 := 0; + end + Sdeltimer(FID); + end + return not FStart; + end + function Recycling();override; + begin + {** + @explan(说明)析构预备 %% + **} + stop(); + FSIDC.deleteid(FID); + FOntimer := nil; + FOntimeout := nil; + FTimerStrc := nil; + inherited; + end + function destroy();override; + begin + inherited; + end + class function _timeproc_(hwnd,message,wparam,lparam); + begin + {** + @explan(说明) 定时回调入接口 %% + @param(hwnd)(integer) 窗口句柄 %% + @param(message)(integer) 消息id %% + @param(lparam)(integer) 消息参数2 %% + @param(wparam)(integer) 消息参数1 %% + **} + e := new tuieventbase(message,wparam,lparam,hwnd); + for i,iv in mrows(_STIMERS,1) do + begin + v := _STIMERS[iv]; + if v is class(TCustomTimer)then if v.tproc(e)then return; + end + //return _twinproc_(hwnd,message,wparam,lparam); + end + class function Sinit();override; + begin + {** + @explan(说明)初始化定时器全局 %% + **} + if not FSIDC then + begin + _STIMERS := array(); + FSIDC := new tidcreater(); + end + inherited; + end + function tproc(e);virtual; + begin + if e.wparam and(e.wparam=_kill0)then + begin + CallMessgeFunction(FOntimer,self(true),e); + return 1; + end + end + property Interval:integer read FInterval write SetInterval; + property Ontimer:eventhandler read FOntimer write FOntimer; + property Enabled:bool read FStart Write SetEnabled; + property id read FID; + function publishs();override; + begin + return array("name","interval","ontimer"); + end + {** + @param(Interval)(integer) 设置运行间隔 %% + @param(Ontimer)(funtion[self,tuieventbase]) 定时调度 %% + @param(Enabled)(bool) 是否已经启动 %% + **} +end +type TCustomTimer = class(tcomponent)//定时器类 + {** + @explan(说明)定时器类,间隔是以毫秒为最小单位 %% + **} + {** + @example(范例--定时器) + //构造计算器,第一个参数为间隔(毫秒),第二个为函数指针 + tm := new TCustomTimer(1000,function(o,e)begin echo now(); end ); + tm.start();//启动定时器 + tm.stop();//停止 + **} + private + static _STIMERS; //TIMER对象 + static FSIDC; //id 构造器 + class function Sgettimer(id); + begin + {** + @explan(说明) 通过id获得定时器对象 %% + @param(id)(integer) 定时器id %% + **} + return _STIMERS[id]; + end + class function Ssettimer(tm); + begin + {** + @explan(说明)存储定时器 %% + @param(tm)(TCustomTimer) 定时器对象%% + **} + _STIMERS[tm.id]:= tm; + end + class function Sdeltimer(tid); + begin + {** + @explan(说明) 删除定时器 %% + @param(tid)(integer) id%% + **} + if tid and(ifnumber(tid))then reindex(_STIMERS,array(tid:nil)); + end + protected FOntimeout; + private + FOntimer; + Fid; + FInterval; + FStart; + _kill0; //标记 + function SetEnabled(f); + begin + if f then start(); + else stop(); + end + function SetInterval(intv); //设置间隔 + begin + {** + @explan(说明)设置间隔 %% + @param(intv)(integer) 间隔,毫秒 %% + **} + if not(ifnumber(intv))then return FInterval; + if FStart then + begin + ndstart := 1; + stop(); + end + if intv <> FInterval and ifnumber(intv)and intv>0 then //时间不等 + begin + FInterval := intv; + end + if ndstart then start(); + end + public + {** + @param(FSIDC)(tidcreater) id构造器%% + @param(_STIMERS)(array) 全局存储%% + @param(FOntimer)(fpointer) timeout执行对象%% + @param(_kill0)(bool) 标记%% + **} + function create(AOwner);override; + begin + inherited; + FID := FSIDC.createid(); + FStart := false; + FInterval := 1000; + end + function timeout(cmd,t); //一次性事件 + begin + {** + @explan(说明) 一次性事件 %% + @param(cmd)(fpointer) 执行回调 %% + @param(t)(integer) t毫秒后执行 %% + **} + FOntimeout := cmd; + if ifnumber(t)then SetInterval(t); + FOntimer := function(o,e) + begin + try + stop(); + CallMessgeFunction(FOntimeout,o,e); + finally + FOntimeout := nil; + end; + end; + start(); + end + function start(); //开始 + begin + {** + @explan(说明)启动 %% + **} + if not((datatype(FOntimer) = 7 )and FInterval)>0 then return-1; + if FStart then return FStart; + ret := _wapi.SetTimer(nil,Fid,FInterval,getwinprocptr(2)); + _kill0 := ret; + Ssettimer(self(true)); + FStart := ret <> 0; + return FStart; + end + function stop(); //停止 + begin + {** + @explan(说明)停止 %% + **} + if FStart then + begin + if _kill0 then + begin + FStart := not((_wapi.KillTimer(nil,_kill0))<> 0); + if FStart=false then _kill0 := 0; + end + Sdeltimer(FID); + end + return not FStart; + end + function Recycling();override; + begin + {** + @explan(说明)析构预备 %% + **} + stop(); + FSIDC.deleteid(FID); + FOntimer := nil; + FOntimeout := nil; + FTimerStrc := nil; + inherited; + end + function destroy();override; + begin + inherited; + end + class function _timeproc_(hwnd,message,wparam,lparam); + begin + {** + @explan(说明) 定时回调入接口 %% + @param(hwnd)(integer) 窗口句柄 %% + @param(message)(integer) 消息id %% + @param(lparam)(integer) 消息参数2 %% + @param(wparam)(integer) 消息参数1 %% + **} + e := new tuieventbase(message,wparam,lparam,hwnd); + for i,iv in mrows(_STIMERS,1) do + begin + v := _STIMERS[iv]; + if v is class(TCustomTimer)then if v.tproc(e)then return; + end + //return _twinproc_(hwnd,message,wparam,lparam); + end + class function Sinit();override; + begin + {** + @explan(说明)初始化定时器全局 %% + **} + if not FSIDC then + begin + _STIMERS := array(); + FSIDC := new tidcreater(); + end + inherited; + end + function tproc(e);virtual; + begin + if e.wparam and(e.wparam=_kill0)then + begin + CallMessgeFunction(FOntimer,self(true),e); + return 1; + end + end + property Interval:integer read FInterval write SetInterval; + property Ontimer:eventhandler read FOntimer write FOntimer; + property Enabled:bool read FStart Write SetEnabled; + property id read FID; + function publishs();override; + begin + return array("name","interval","ontimer"); + end + {** + @param(Interval)(integer) 设置运行间隔 %% + @param(Ontimer)(funtion[self,tuieventbase]) 定时调度 %% + @param(Enabled)(bool) 是否已经启动 %% + **} +end +type teditable=class(TSLUIBASE) + private + FInsertState; + FReadOnly; + FLineWrap; + FString; + FCaretX; + FLeftCharCount; + Flimitlength; + FSelBegin; + FSelLength; + FCanShowCaret; + FFontWidth; + FFontHeight; + FCaretY; + FMouseLbuttonDown; + FHafChar; //半个中文 + FBorder; + ////////////////////// + FHost; // + FHostDc; + FClientRect; + FFont; + FVisible; + function SetVisible(v); + begin + nv := v?true:false; + if nv <> FVisible then + begin + FVisible := nv; + if not(FVisible)and FSetFocused then + begin + KillFocus(); + InvalidateRect(nil,false); + end + CalcFontSize(); + end + end + function SetFont(f); + begin + if f then + begin + FFont := f; + if FCanShowCaret and FHost and FHost.HandleAllocated() and FHost.Handle=_wapi.GetFocus() then + begin + recreateCarete(); + return InvalidateRect(nil,false); + end + CalcFontSize(); + InvalidateRect(nil,false); + updatecaret(); + end + end + function InvalidateRect(rec,flg); + begin + if FHost and FHost.HandleAllocated()then + begin + FHost.InvalidateRect(rec?rec:FClientRect,flg); + end + end + function SetHost(host); + begin + if FHost=host then return; + ohost := FHost; + FHost := nil; + if host is class(TWinControl)then + begin + SetFont(host.font); + FHost := host; + end else + begin + if ohost then ohost.InvalidateRect(GetEntryRect(),false); + end + end + function SetBorder(v); + begin + n := v?true:false; + if n <> FBorder then + begin + FBorder := n; + InvalidateRect(nil,false); + end + end + Function Setplaceholder(p); + begin + if p and ifstring(p)and Fplaceholder <> p then + begin + Fplaceholder := p; + if FHost and not(FString)and FHost.HandleAllocated()then InvalidateRect(nil,false); + end + end + function recreateCarete(); + begin + DestroyCaret(); + CreateCaret(); + end + function CreateCaret(); //构造光标 + begin + if not(FReadOnly)and not(FCanShowCaret)and FHost and FHost.HandleAllocated()then + begin + CalcFontSize(); + h := FFontHeight+4; + hd := FHost.Handle; + _wapi.CreateCaret(hd,nil,1,h); + _wapi.ShowCaret(hd); + FCanShowCaret := true; + end + FIsCaretShow := true; + end + function DestroyCaret(); //销毁光标 + begin + if FCanShowCaret and FHost and FHost.HandleAllocated()then + begin + _wapi.HideCaret(FHost.Handle); + _wapi.DestroyCaret(); + FCanShowCaret := false; + end + FIsCaretShow := false; + end + function updatecaret(); + begin + if FCanShowCaret and FHost and FHost.HandleAllocated()then + begin + rec := GetEntryRect(); + cx :=(FCaretX-FLeftCharCount-1) * FFontWidth+rec[0]; + _Wapi.SetCaretPos(cx,FCaretY); + end + end + function InitSel(); + begin + FSelBegin := FCaretX; + FSelLength := 0; + end + function GetCharPosByX(x); + begin + rc := GetEntryRect(); + cp := FLeftCharCount+integer((x-rc[0])/FFontWidth+0.4)+1; + if bytetype(FString,cp)=2 then return cp+1; + return cp; + end + function CalcFontSize(); + begin + FFontWidth := font.width; + FFontHeight := font.Height; + rec := GetEntryRect(); + FCaretY := max(0,integer((rec[1]+(rec[3]-rec[1]-FFontHeight)/2))-2); + end + function setReadOnly(v); + begin + nv := v?true:false; + if nv <> FReadOnly then + begin + FReadOnly := nv; + InvalidateRect(nil,false); + end + end + function setEditText(s); + begin + if ifstring(s)and s <> FString then + begin + s1 := filterstring(s); + if s1=fstring then return; + FString := s1; + if FCaretX=1 then + begin + InitSel(); + InvalidateRect(nil,false); + end else + MoveCaretTo(1,0); + doOnChange(); + end + end + function setLimitLength(n); + begin + if n >= 0 and n <> Flimitlength then + begin + Flimitlength := n; + end + end + function MoveCaretTo(x_,ifsel); + begin + if x_<1 then x := 1; + else x := min(x_,length(FString)+1); + if x=FCaretX then return; + rec := GetEntryRect(); + x1 := FLeftCharCount+1; //rec[0]; + fw := font.width; + x2 := integer((rec[2]-rec[0])/fw); + if x(x1+x2)then + begin + FLeftCharCount +=(x-x1-x2); + end + FCaretX := x; + ////////////显示光标位置//////////////////// + //_wapi.SetCaretPos(); + if ifsel then + begin + FSelLength := x-FSelBegin; + end else + InitSel(); + InvalidateRect(nil,false); + updatecaret(); + end + function selectall(); + begin + if FString and(FSelBegin <> 1 or FSelLength <> length(FString))then + begin + FSelBegin := 1; + FSelLength := length(FString); + InvalidateRect(nil,false); + end + end + function getselstring(b,e); + begin + if FSelLength <> 0 then + begin + x1 := FSelBegin-(FSelLength<0); + X2 := FSelBegin+FSelLength-(FSelLength>0); + b := min(x1,x2); + e := max(x1,x2); + return FString[b:e]; + end + return ""; + end + function DeleteSel(); + begin + if FSelLength <> 0 then + begin + x1 := FSelBegin-(FSelLength<0); + X2 := FSelBegin+FSelLength-(FSelLength>0); + b := min(x1,x2); + e := min(max(x1,x2),length(FString)); + FString[b:e]:= ""; + cx := max(1,min(x1,x2)); + InitSel(); + BeginUpDate(); + InvalidateRect(nil,false); + MoveCaretTo(cx,0); + DeletePerfect(); + EndUpDate(); + doOnChange(); + end + end + function DeletePerfect(); + begin + if FLeftCharCount>0 then + begin + sz := FFontWidth * (length(FString)-FLeftCharCount); + rec := GetEntryRect(); + syl :=((rec[2]-rec[0]-sz)/FFontWidth); + if syl>1 then + begin + FLeftCharCount := max(0,FLeftCharCount-integer(syl)); + updatecaret(); + InvalidateRect(nil,false); + end + end + end + function dodelete(); + begin + if FReadOnly then return; + if FSelLength <> 0 then return deletesel(); + len := length(FString); + if FCaretX <= length(FString)then + begin + if bytetype(FString,FCaretX)=1 then + begin + FString[(FCaretX):(FCaretX+1)]:= ""; + end else + begin + FString[(FCaretX):(FCaretX)]:= ""; + end + BeginUpDate(); + InvalidateRect(nil,false); + DeletePerfect(); + EndUpDate(); + doOnChange(); + end + end + function BeginUpDate(); + begin + if FHost and FHost.HandleAllocated()then + begin + FHost.BeginUpDate(); + end + end + function EndUpDate(); + begin + if FHost and FHost.HandleAllocated()then + begin + FHost.EndUpDate(); + end + end + function dobackspace(); + begin + if FReadOnly then return; + if FSelLength <> 0 then return deletesel(); + len := length(FString); + if FCaretX>1 then + begin + cx := FCaretX; + if bytetype(FString,FCaretX-1)=2 then + begin + FString[(FCaretX-2):(FCaretX-1)]:= ""; + cx -= 2; + end else + begin + FString[(FCaretX-1):(FCaretX-1)]:= ""; + cx--; + end + BeginUpDate(); + MoveCaretTo(cx,0); + DeletePerfect(); + EndUpDate(); + doOnChange(); + end + end + function GetCBoard(); + begin + if not FCopyer then + begin + FCopyer := new TcustomClipBoard(class(tUIglobalData).uigetdata("tuiapplication")); + end + return FCopyer; + end + function CopyToClipboard(); //复制选择 + begin + r := getselstring(); + GetCBoard().text := r; + end + function PasteFromClipBoard(); + begin + if readonly then return; + t := GetCBoard().text; + if t then InsertChar(t); + end + protected + function doOnChange();virtual; + begin + end + function doonmaxtext();virtual; + begin + end + function doonsetfocus();virtual; + begin + end + function doonkillfocus();virtual; + begin + end + function filterstring(c);virtual; //过滤 + begin + s1 := ""; + if ifstring(c)and c then + begin + s1 := replacetext(c,"\r",""); + s1 := replacetext(s1,"\n",""); + s1 := replacetext(s1,"\t"," "); + end + return s1; + end + function PaintBorder();virtual; + begin + if FBorder or(FFocusBorder and FSetFocused)then + begin + rbc := ClientRect; + if ifarray(rbc)and rbc[2]>rbc[0]and rbc[3]>rbc[1]then + begin + dc := FHost.Canvas; + dc.pen.width := 1; + if FSetFocused then dc.pen.color := rgb(200,150,150); + else dc.pen.color := rgb(180,180,180); + dc.brush.Color := FHost.Color; + dc.draw("RoundRect",array(rbc[0:1],rbc[2:3],array(3,3))); + end + end + end + function PaintPlaceHolder(rec);virtual; + begin + if not(FString)and Fplaceholder and ifstring(Fplaceholder)then + begin + dc := FHost.Canvas; + bc := dc.font.color; + dc.font.color := Fplaceholdercolor; + dc.drawtext(Fplaceholder,rec,DT_VCENTER .| DT_SINGLELINE); + dc.font.color := bc; + return true; + end + end + function PaintText(s,rec);virtual; + begin + if FHost and FHost.HandleAllocated()and ifstring(s)and s then + begin + dc := FHost.Canvas; + if not dc.HandleAllocated()then return; + neb := not(FHost.Enabled); + if neb then + begin + dc.font.Color := 0xc0c0c0; + end + if FMarked then + begin + ns := s; + if ifstring(FPassWordChar)and FPassWordChar then vc := FPassWordChar[1]; + else vc := "#"; + for i := 1 to length(ns) do + begin + ns[i]:= vc; + end + dc.drawtext(ns,rec,DT_VCENTER .| DT_SINGLELINE); + end else + dc.drawtext(s,rec,DT_VCENTER .| DT_SINGLELINE); + end + end + public + function create(); + begin + Fplaceholdercolor := rgb(200,200,200); + fselbkcolor := rgb(51,153,255); + freadonlyColor := rgb(240,240,240); + FVisible := true; + FReadOnly := false; + FFocusBorder := true; + FString := ""; + FSelBegin := 1; + FSelLength := 0; + FBorder := true; + FCaretX := 1; + FLeftCharCount := 0; //1; + FFont := new Tcustomfont(); + end + function InsertChar(c_); //插入 + begin + if FSelLength <> 0 then + begin + dobackspace(); + end + len := length(FString); + c := filterstring(c_); + if not(ifstring(c)and c)then return; + if Flimitlength>0 then + begin + if Flimitlength <= len then + begin + doonmaxtext(); + return; + end else + begin + clen := length(c); + nct := Flimitlength-len; + if nct(rc[2]-rc[0])then return; + end + if FCaretX=1 then + begin + FString := c+FString; + end else + if FCaretX=length(FString)+1 then + begin + FString += c; + end else + begin + FString[FCaretX:0]:= c; + end + MoveCaretTo(FCaretX+length(c),0); + doOnChange(); + end + function ExecuteCommand(cmd,pm);virtual; + begin + case cmd of + "echome": + begin + MoveCaretTo(1,pm); + end + "ecend": + begin + MoveCaretTo(length(FString)+1,pm); + end + "ecreadonlycolor": + begin + if pm>0 or pm<0 then freadonlyColor := pm; + return freadonlyColor; + end + "ecselbkcolor": + begin + if pm>0 or pm<0 then fselbkcolor := pm; + return fselbkcolor; + end + "ecplaceholdercolor": + begin + if pm>0 or pm<0 then Fplaceholdercolor := pm; + return Fplaceholdercolor; + end + "ecinsert": + begin + if ifstring(pm)and pm then InsertChar(pm); + end + "ecleft": + begin + if FCaretX>1 then MoveCaretTo(FCaretX-(1+(bytetype(FString,FCaretX-1)=2)),pm); + end + "ecright": + begin + if FCaretX <= length(FString)then MoveCaretTo(FCaretX+(1+(bytetype(FString,FCaretX)=1)),pm); + end + "ecselall": + begin + selectall(); + end + "ecsel": + begin + if ifarray(pm)and pm[0]>0 and pm[1]>0 then + begin + MoveCaretTo(pm[0],0); + MoveCaretTo(Pm[1],1); + end + end + "ecclcsel": + begin + if FSelLength <> 0 then + begin + InitSel(); + InvalidateRect(nil,false); + end + end + "ecgetsel": + begin + r := getselstring(b,e); + pm := array(b,e); + return r; + end + "ecdelete": + begin + dodelete(); + end + "ecbackspace": + begin + dobackspace(); + end + "eccopy": + begin + CopyToClipboard(); + end + "ecpaste": + begin + PasteFromClipBoard(); + end + "eccut": + begin + CopyToClipboard(); + DeleteSel(); + end + "ecpasswordchar": + begin + if ifstring(pm)and pm then FPassWordChar := pm[1]; + else return FPassWordChar; + end + "ecmarked": + begin + if ifnil(pm)then + begin + return FMarked; + end else + begin + nv := pm?true:false; + if FMarked <> nv then + begin + FMarked := nv; + InvalidateRect(nil,false); + end + end + end + "ecgetposbyx": + begin + if x >= 0 or x<0 then return GetCharPosByX(x); + end + "eccaretpos": + begin + return FCaretX; + end + end; + end + function GetEntryRect();virtual; + begin + r := ClientRect; + if not ifarray(r)then return array(0,0,0,0); + r[0]+= 1; + r[2]-= 1; + r[1]+= 1; + r[3]-= 1; + return r; + end + function WMKEYDOWN(o,e);virtual; + begin + fsft := ssShift in e.shiftstate; + fctl := ssCtrl in e.shiftstate; + case e.CharCode of + VK_INSERT: + begin + FInsertState := not FInsertState; + end + VK_LEFT: + begin + ExecuteCommand("ecleft",fsft); + end + VK_RIGHT: + begin + ExecuteCommand("ecright",fsft); + end + VK_DELETE: + begin + dodelete(); + end + VK_HOME: + begin + ExecuteCommand("echome",fsft); + end + VK_END: + begin + ExecuteCommand("ecend",fsft); + end + ord("C"): + begin + if fctl then + begin + ExecuteCommand("eccopy"); + end + end + ord("V"): + begin + if fctl then + begin + ExecuteCommand("ecpaste"); + end + end + ord("X"): + begin + if fctl then + begin + ExecuteCommand("eccut"); + end + end + ord("A"): + begin + if fctl then selectall(); + end + end + end + function WMCHAR(o,e);virtual; + begin + c := e.CharCode; + case c of + VK_BACK: + begin + return dobackspace(); + end + end + if c<32 then return; + if FReadOnly then return; + if c .& 0x80 then + begin + if FHafChar then + begin + InsertChar(FHafChar+e.char); + FHafChar := ""; + end else + begin + FHafChar := e.char; + end + end else + InsertChar(e.char); + end + function FontChanged(o);override; + begin + if FHost and FHost.HandleAllocated()then + begin + if _wapi.GetFocus()=FHost.Handle then + begin + recreateCarete(); + end else + begin + CalcFontSize(); + InvalidateRect(nil,false); + end + end + end + function Paint(); + begin + if not FVisible then return; + if not(FHost and FHost.HandleAllocated()and FHost.Canvas.HandleAllocated())then return; + dc := FHost.Canvas; + dc.font := font; + rec := GetEntryRect(); + if FReadOnly then + begin + dc.brush.color := freadonlyColor; + dc.FillRect(rec); + end + PaintBorder(); + if PaintPlaceHolder(rec)then return; + fw := FFontWidth; + fh := FFontHeight; + if FSelLength <> 0 then //绘制阴影 + begin + x1 := FSelBegin-FLeftCharCount-1; + if FSelLength>0 then + begin + x2 := x1+FSelLength; + end else + begin + x2 := x1; + x1 := x2+FSelLength; + end + x1 := max(0,x1); + x2 := max(0,x2); + if x2>x1 then + begin + bc := dc.brush.color; + dc.brush.color := fselbkcolor; ////rgb(0,220,220); + rcb := rec; + rcb[0]:= x1 * fw+rec[0]; + rcb[2]:= x2 * fw+rec[0]; + if dh>0 then + begin + rcb[1]+= FCaretY; + rcb[3]-= FCaretY; + end + dc.FillRect(rcb); + dc.brush.color := bc; + end + end + if FLeftCharCount>0 then + begin + if bytetype(FString,FLeftCharCount)=1 then + begin + rec[0]-= fw; + dstr := FString[FLeftCharCount:]; + end else + dstr := FString[(FLeftCharCount+1):]; + end else + dstr := FString; + PaintText(dstr,rec); + //dc.drawtext(dstr,rec,DT_VCENTER .| DT_SINGLELINE); + end + function MouseUp(o,e); + begin + if not(FHost and FHost.HandleAllocated())then return; + FMouseLbuttonDown := false; + _wapi.ClipCursor(0); + end + function MouseMove(o,e); + begin + if not FVisible then return; + if not(FHost and FHost.HandleAllocated())then return; + //move ; + if not FMouseLbuttonDown then return; + rec := GetEntryRect(); + x := e.xpos; + if xrec[2]-2 then x += FFontWidth * 3; + nx := GetCharPosByX(x); + MoveCaretTo(nx,true); + end + function MouseDown(o,e); + begin + if not FVisible then return; + if not(FHost and FHost.HandleAllocated())then return; + rec := GetEntryRect(); + if not(pointinrect(e.pos,FClientRect))then return; + x := e.xpos; + if xrec[0]then + begin + if e.button()=mbLeft then + begin + x := GetCharPosByX(e.xpos); + MoveCaretTo(x,0); + FMouseLbuttonDown := true; + crect := rec; + if FHost then //固定区域 + begin + ps := array(FHost.clienttoscreen(crect[0],crect[1]),FHost.clienttoscreen(crect[2],crect[3])); + _wapi.ClipCursor(ps); + end + end + if not FIsCaretShow then return SetFocus(); + end + end + function SetFocus(); + begin + if not FVisible then return; + FSetFocused := true; + if FHost and FHost.HandleAllocated()then + begin + if _wapi.GetFocus()<> FHost.Handle then return FHost.SetFocus(); + end + CreateCaret(); + updatecaret(); + if FFocusBorder then InvalidateRect(nil,false); + doonsetfocus(); + end + function KillFocus(); + begin + FMouseLbuttonDown := false; + _wapi.ClipCursor(0); //添加输入焦点处理 + FSetFocused := false; + DestroyCaret(); + if FFocusBorder then InvalidateRect(nil,false); + doonkillfocus(); + end + function Recycling();override; + begin + FKillFocus := 0; + FOnSetFocus := 0; + FPassWordChar := "#"; + FMarked := 0; + FOnMaxText := 0; + FOnUpdate := 0; + FOnChange := 0; + Fplaceholder := 0; + FHost := nil; + FFont := nil; + inherited; + end + property Visible read FVisible write SetVisible; + property text:string read FString write setEditText; + property onmaxtext:eventhandler read FOnMaxText write FOnMaxText; //eventhandler 修改 + property placeholder:string read Fplaceholder write Setplaceholder; + property readonly:bool read FReadOnly write setReadOnly; + property limitlength:integer read Flimitlength write setLimitLength; + property LineWrap:bool read FLineWrap write FLineWrap; + property Border read FBorder write SetBorder; + property Font read FFont write SetFont; + property ClientRect read FClientRect write FClientRect; //区域 + property host read FHost write SetHost; + property HasFocus read FSetFocused; + property Focusedborder read FFocusBorder write FFocusBorder; + private + FIsCaretShow; + FKillFocus; + FOnSetFocus; + FPassWordChar; + FMarked; + FOnMaxText; + FOnUpdate; + FOnChange; + Fplaceholder; + FSetFocused; + FFocusBorder; + Fplaceholdercolor; + fselbkcolor; + freadonlyColor; + static FCopyer; +end +type tVirtualCalender=class(TSLUIBASE) + {** + @explan(说明) 月历控件虚拟类 + **} + function create(); + begin + inherited; + FFont := new Tcustomfont(); + FDateRows := 8; + FCalenderState := 3; + FLeft := 0; + FTop := 0; + FCellWidth := 30; + FCellHeight := 16; + FYear := 2021; + FMonth := 3; + FDate := 3; + FHasMonthSel := true; + FHasToday := true; + FTodayHeight := 20; + FMonthselheight := 25; + FDateMatrix := array(); + CalcDateMatrx(); + end + function InvalidateRect(rec,f); + begin + if FHost and FHost.HandleAllocated()then + begin + FHost.InvalidateRect(rec ?: GetCalenderRect,f); + end + end + function dodatechanged();virtual; + begin + if FHost and FHost.HandleAllocated()then + begin + FHost.DoDatechanged(); + end + end + function ExecuteCommand(cmd,p); + begin + case cmd of + "metodaybutton": + begin + if ifnil(p)then return FHasToday; + else + begin + nv := p?true:false; + if FHasToday <> nv then + begin + FHasToday := nv; + CalcDateMatrx(); + InvalidateRect(nil,false); + end + end + end + "mestate": + begin + if(p <> FCalenderState)and(p in array(1,2,3))then + begin + FCalenderState := p; + CalcDateMatrx(); + InvalidateRect(nil,false); + end else + return FCalenderState; + end + "meyear": + begin + //设置年 + if(p>0 or p <= 0)and p <> FYear then + begin + FYear := p; + CalcDateMatrx(); + InvalidateRect(nil,false); + dodatechanged(); + end + return FYear; + end + "meminc": + begin + d := incmonth(encodedate(FYear,FMonth,FDate),not(p>0 or p<1)?1:(p)); + decodedate(d,y,m,d); + FYear := y; + FMonth := max(m,1); + FDate := max(d,1); + CalcDateMatrx(); + InvalidateRect(nil,false); + dodatechanged(); + end + "memonth": + begin + //设置月 + if FMonth <> p and(p>0 or p<13)then + begin + ModifyDate(FYear,p,FDate); + FMonth := p; + CalcDateMatrx(); + InvalidateRect(nil,false); + dodatechanged(); + end + return FMonth; + end + "meyearmonth": + begin + //设置年,月 + if ifarray(p)and ifnumber(p[0])and ifnumber(p[1])then + begin + if p[0]<> FYear or p[1]<> FMonth then + begin + ExecuteCommand("meymd",encodedate(p[0],p[1],FDate)); + end + end + end + "medate": + begin + if p <> FDate and p>0 and p <= getmonthdates(FYear,FMonth)then + begin + FDate := p; + CalcDateMatrx(); + InvalidateRect(nil,false); + dodatechanged(); + end + return FDate; + end + "meymd": + begin + if p >= 0 or p<0 then + begin + decodedate(p,y,m,d); + if y <> FYear or FMonth <> m or FDate <> d then + begin + FYear := y; + FMonth := m; + FDate := d; + CalcDateMatrx(); + InvalidateRect(nil,false); + dodatechanged(); + end + end else + return encodedate(FYear,FMonth,FDate); + end + "meselbypos": + begin + r := ExecuteCommand("megetbypos",p); + if not r then return; + if r="today" then + begin + FCalenderState := 3; + ExecuteCommand("meymd",date()); + end + case FCalenderState of + 3: + begin + ExecuteCommand("medate",r); + end + 2: + begin + FCalenderState := 3; + m := FMonth; + d := FDate; + y := FYear; + ExecuteCommand("memonth",r); + if(m=FMonth)and(d=FDate)and(y := FYear)then + begin + CalcDateMatrx(); + InvalidateRect(nil,false); + end + end + 1: + begin + FCalenderState := 2; + m := FMonth; + d := FDate; + y := FYear; + ExecuteCommand("meyear",r); + if(m=FMonth)and(d=FDate)and(y := FYear)then + begin + CalcDateMatrx(); + InvalidateRect(nil,false); + end + end + end; + return r; + end + "mestatebypos": //切换状态 + begin + r := ExecuteCommand("megetstatepos",p); + ExecuteCommand("mestate",r); + return r; + end + "megetstatepos": //状态改变区域 + begin + if not(FYearRect and FMonthRect)then return; + if(p)then + begin + p0 := p[0]; + p1 := p[1]; + if not(p0>0 or p0<0)then return; + if not(p1>0 or p1<0)then return; + x := p0-FLeft; + y := p1-FTop; + pp := array(x,y); + if pointinrect(pp,FYearRect)then return 1; + if pointinrect(pp,FMonthRect)then return 2; + return 0; + end + end + "megetincpos": //获得month inc month dec + begin + if not(FIncRect and FDecRect)then return; + if(p)then + begin + p0 := p[0]; + p1 := p[1]; + if not(p0>0 or p0<0)then return; + if not(p1>0 or p1<0)then return; + x := p0-FLeft; + y := p1-FTop; + pp := array(x,y); + if pointinrect(pp,FIncRect)then return 1; + if pointinrect(pp,FDecRect)then return-1; + end + end + "megetbypos": + begin + if ifarray(p)then + begin + p0 := p[0]; + p1 := p[1]; + if not(p0>0 or p0<0)then return; + if not(p1>0 or p1<0)then return; + x := p0-FLeft; + y := p1-FTop-(FHasMonthSel * FMonthselheight); + pp := array(x,y); + if pointinrect(pp,FTodyRect)then + begin + return "today"; + end + if FCalenderState=3 then + begin + for i := 1 to 6 do + begin + for j := 0 to 6 do + begin + d := FDateMatrix[i,j]; + if ifarray(d)then + begin + rec := d["rec"]; + if pointinrect(pp,rec)then + begin + return d["value"]; + end + end + end + end + end else + if FCalenderState in array(2,1)then + begin + for i,d in FDateMatrix do + begin + if ifarray(d)then + begin + rec := d["rec"]; + if pointinrect(pp,rec)then + begin + return d["value"]; + end + end + end + end + end + end + end + end + function paint(); + begin + if not(host and host.HandleAllocated())then return; + dc := host.Canvas; + if not(dc and dc.HandleAllocated())then return; + dc.font := font; + if FHasMonthSel then + begin + dc.brush.color := rgb(200,220,220); + dc.fillrect(array(FLeft,FTop,FLeft+FCellWidth * 7,FTop+FMonthselheight)); + if FDecRect then dc.draw("framecontrol",array((FDecRect[0]+FLeft,FDecRect[1]+FTop),(FDecRect[2]+FLeft,FDecRect[3]+FTop)),DFC_SCROLL,DFCS_SCROLLLEFT); + if FIncRect then dc.draw("framecontrol",array((FIncRect[0]+FLeft,FIncRect[1]+FTop),(FIncRect[2]+FLeft,FIncRect[3]+FTop)),DFC_SCROLL,DFCS_SCROLLRIGHT); + if FYearRect then + begin + rec := FYearRect; + rec[0]+= FLeft; + rec[2]+= FLeft; + rec[1]+= FTop; + rec[3]+= FTop; + if FCalenderState=1 then + begin + dc.brush.color := rgb(240,240,250); + dc.fillrect(rec); + end + dc.font.weight := 700; + dc.drawtext(inttostr(FYear)+"年",rec,DT_CENTER); + end + if FMonthRect then + begin + rec := FMonthRect; + rec[0]+= FLeft; + rec[2]+= FLeft; + rec[1]+= FTop; + rec[3]+= FTop; + if FCalenderState=2 then + begin + dc.brush.color := rgb(240,240,250); + dc.fillrect(rec); + end + dc.font.weight := 700; + dc.drawtext(inttostr(FMonth)+"月",rec,DT_CENTER); + end + end + t := FTop+(FMonthselheight * FHasMonthSel); + if FCalenderState in array(1,2)then + begin + for i,d in FDateMatrix do + begin + if not ifarray(d)then continue; + rec := d["rec"]; + if not rec then continue; + rec[0]+= FLeft; + rec[2]+= FLeft; + rec[1]+= t; + rec[3]+= t; + if d["sel"]then + begin + dc.brush.color := rgb(200,200,100); + dc.FillRect(rec); + end + dc.drawtext(d["text"],rec,DT_CENTER .| DT_VCENTER .| DT_SINGLELINE); + end + end else + if FCalenderState=3 then + begin + for i := 0 to 6 do + begin + for j := 0 to 6 do + begin + d := FDateMatrix[i,j]; + if not ifarray(d)then continue; + rec := d["rec"]; + if not rec then continue; + rec[0]+= FLeft; + rec[2]+= FLeft; + rec[1]+= t; + rec[3]+= t; + if d["sel"]then + begin + dc.brush.color := rgb(200,200,100); + dc.FillRect(rec); + end + if i=0 then dc.font.weight := 700; + else dc.font.weight := 400; + dc.drawtext(d["text"],rec,DT_CENTER .| DT_VCENTER .| DT_SINGLELINE); + end + end + dc.pen.width := 1; + dc.pen.color := 0; + dc.moveto(array(FLeft,t+FCellHeight)); + dc.LineTo(array(FLeft+FCellWidth * 7,t+FCellHeight)); + end + if FTodyRect then + begin + rec := FTodyRect; + rec[0]+= FLeft; + rec[2]+= FLeft; + rec[1]+= t; + rec[3]+= t; + dc.brush.color := rgb(200,200,200); + dc.fillrect(rec); + dc.drawtext(" today: "+datetimetostr(date()),rec,DT_LEFT); + end + end + function recycling();override; + begin + inherited; + FHost := nil; + FFont := nil; + end + public + property Left read FLeft write SetLeft; + property top read FTop write SetTop; + property host read FHost write sethost; + property ClientRect read GetCalenderRect; + private + function ModifyDate(y,m,d); + begin + ct := getmonthdates(y,m); + if d>ct then d := ct; + end + function sethost(h); + begin + if host <> h then + begin + FHost := h; + end + end + function SetLeft(v); + begin + if FLeft <> v then + begin + FLeft := integer(v); + InvalidateRect(nil,false); + end + end + function settop(v); + begin + if FTop <> v then + begin + FTop := integer(v); + InvalidateRect(nil,false); + end + end + function GetCalenderRect(); + begin + return array(FLeft,FTop,FLeft+FCellWidth * 7,FTop+FHasMonthSel * FMonthselheight+FCellHeight * FDateRows+FHasToday * FTodayHeight); + end + function CalcDateMatrx(); + begin + FDecRect := array(); + FIncRect := array(); + FTodyRect := array(); + if FHasMonthSel then + begin + FDecRect := array(5,2,25,22); + x := 7 * FCellWidth-25; + FIncRect := array(x,2,x+20,22); + FYearRect := array(60,2,110,22); + FMonthRect := array(115,2,165,22); + end + if FHasToday then + begin + x := 7 * FCellWidth; + y := FDateRows * FCellHeight; + FTodyRect := array(0,y,x,y+FTodayHeight); + end + FDateMatrix := array(); + if FCalenderState=3 then + begin + for i,v in array("日","一","二","三","四","五","六") do + begin + x0 := i * FCellWidth; + x1 := x0+FCellWidth; + y0 := cidx * FCellHeight; + y1 := y0+FCellHeight; + data := array(); + data["rec"]:= array(x0,y0,x1,y1); + data["text"]:= v; + FDateMatrix[0,i]:= data; + end + if FYear>0 and FMonth>0 then + begin + ct := getmonthdates(FYear,FMonth); + cidx := 1; + for i := 1 to ct do + begin + dt := encodedate(FYear,FMonth,i); + dw :=(dayofweek(dt)-1); + if i=1 then //之前的 + begin + //上一个月 + end + x0 := dw * FCellWidth; + x1 := x0+FCellWidth; + y0 := cidx * FCellHeight; + y1 := y0+FCellHeight; + data := array(); + data["rec"]:= array(x0,y0,x1,y1); + data["text"]:= inttostr(i); + data["value"]:= i; + data["sel"]:=(FDate=i); + FDateMatrix[cidx,dw]:= data; + if dw=6 then + begin + cidx++; + end + if i=ct then + begin + //下一个月 + end + end + end + end else + if FCalenderState=2 then //月选择 + begin + cw := integer(FCellWidth * 1.5); + ch := integer(FCellHeight * 2); + for i := 1 to 12 do + begin + data := array(); + divmod(i-1,4,a,b); + x0 := b * cw+10; + x1 := x0+cw; + y0 := a * ch+10; + y1 := y0+ch; + data := array(); + data["rec"]:= array(x0,y0,x1,y1); + data["text"]:= inttostr(i)+"月"; + data["value"]:= i; + data["sel"]:=(FMonth=i); + FDateMatrix[i]:= data; + end + end else + if FCalenderState=1 then //年选择 + begin + cw := integer(FCellWidth * 1.5); + ch :=(FCellHeight); + for i,v in((FYear-13)->(FYear+14)) do + begin + data := array(); + divmod(i,4,a,b); + x0 := b * cw+10; + x1 := x0+cw; + y0 := a * ch+10; + y1 := y0+ch; + data := array(); + data["rec"]:= array(x0,y0,x1,y1); + data["text"]:= inttostr(v); + data["value"]:= v; + data["sel"]:=(FYear=v); + FDateMatrix[i]:= data; + end + end + end + private + FFont; + FDateRows; + FYearRect; + FMonthRect; + FCalenderState; + FTodyRect; + FHasToday; + FTodayHeight; + FIncRect; + FDecRect; + FMonthselheight; + FHasMonthSel; + FDateMatrix; + FDate; + FMonth; + FYear; + FHost; + FLeft; + FTop; + FCellWidth; + FCellHeight; +end +type tcustomedit=class(TCustomControl) + {** + @explan(说明) 单行文本编辑框类 %% + **} + private + FEditable; + type TEntryEditable=class(teditable) + function Create(); + begin + inherited; + end + function doonmaxtext();override; + begin + if host then host.doonmaxtext(); + end + function doOnChange();override; + begin + if host then host.DoChanged(); + end + end + public + function Create(AOwner);override; + begin + inherited; + Left := 10; + Top := 10; + //Ftextalign := 0; + Width := 80; + Height := 25; + FEditable := new TEntryEditable(); + FEditable.host := self(true); + end + function ExecuteCommand(cmd,pm);override; + begin + if FEditable then return FEditable.ExecuteCommand(cmd,pm); + end + function SetSel(bgid,edid); + begin + {** + @explan(说明)设置选择文本 %% + @param(bgid)(integer) 开始位置 默认为0 %% + @param(edid)(integer) 结束位置 默认为整体长度 %% + **} + return ExecuteCommand("ecsel",array(bgid+1,edid+1)); + end + function Paint();override; + begin + if FEditable then FEditable.Paint(); + end + function MouseUp(o,e);override; + begin + if csDesigning in ComponentState then return; + if e.skip then return; + if FEditable then FEditable.MouseUp(o,e); + inherited; + end + function MouseMove(o,e);override; + begin + if csDesigning in ComponentState then return; + if e.skip then return; + if FEditable then FEditable.MouseMove(o,e); + inherited; + end + function MouseDown(o,e);override; + begin + if csDesigning in ComponentState then return; + if e.skip then return; + if FEditable then FEditable.MouseDown(o,e); + inherited; + end + function dosetfocus(o,e);override; + begin + if csDesigning in ComponentState then return; + if FEditable then + begin + FEditable.SetFocus(); + end + inherited; + end + function dokillfocus(o,e);override; + begin + if csDesigning in ComponentState then return; + if FEditable then + begin + FEditable.killFocus(); + end + inherited; + end + function DoWMSIZE(o,e);override; + begin + if FEditable then + begin + rc := ClientRect; + FEditable.ClientRect := rc; + end + inherited; + end + function keypress(o,e);override; + begin + if csDesigning in ComponentState then return; + if e.skip then return; + if FEditable then + begin + FEditable.WMCHAR(o,e); + end + inherited; + end + function KeyDown(o,e);override; + begin + if csDesigning in ComponentState then return; + if e.skip then return; + if FEditable then FEditable.WMKEYDOWN(o,e); + inherited; + end + function doonmaxtext(); + begin + CallMessgeFunction(FOnMaxText,self(true),new tuieventbase(0,0,0,0)); + end + function DoChanged(); + begin + CallMessgeFunction(FOnChange,self(true),new tuieventbase(0,0,0,0)); + CallMessgeFunction(FOnUpdate,self(true),new tuieventbase(0,0,0,0)); + end + function FontChanged(sender);override; + begin + inherited; + FEditable.font := Font; + end + function Recycling();override; + begin + inherited; + FOnUpdate := nil; + FOnChange := nil; + fonmaxtext := nil; + if FEditable then FEditable.Recycling(); + FEditable := nil; + end + function publishs();override; + begin + return array("name","align","anchors","font","enabled","popupmenu","visible","height","width","left","top","text","placeholder" + ,"readonly","limitlength","linewrap","tabstop","onmousemove","onpopupmenu","onmousedown","onmouseup","onkeyup" + ,"onkeydown","onkeypress","onmaxtext","onkillfocus","onsetfocus","onchange"); + end + property text:string read getentrytext write setentrytext; + property onmaxtext:eventhandler read Fonmaxtext write fonmaxtext; + property onupdate read FOnUpdate write FOnUpdate; + property onchange read FOnChange write FOnChange; + property readonly:bool read getReadOnly write setReadOnly; + property limitlength:integer read getlimitlength write setLimitLength; + property LineWrap:bool read getLineWrap write setLineWrap; + property placeholder:string read getplaceholder write Setplaceholder; + property Border read getBorder write SetBorder; + {** + @param(LineWrap)(bool)自动换行,默认为false不自动换行%% + @param(onmaxtext)(fpointer)达到文本最大回调%% + @param(onupdate)(fpointer)文本更新回调%% + @param(onchange)(fpointer)文本改变回调%% + @param(readonly)(bool)只读%% + @param(onlimitlength)(integer)设置输入字符的长度%% + **} + private + function getBorder(); + begin + if FEditable then return FEditable.Border; + end + function setBorder(s);override; + begin + if FEditable then return FEditable.Border := s; + end + function getentrytext(); + begin + if FEditable then return FEditable.text; + return ""; + end + function setentrytext(s); + begin + if FEditable then return FEditable.text := s; + end + function getplaceholder(); + begin + if FEditable then return FEditable.placeholder; + end + function setplaceholder(v); + begin + if FEditable then return FEditable.placeholder := v; + end + function getReadOnly(); + begin + if FEditable then return FEditable.readonly; + end + function setReadOnly(v); + begin + if FEditable then return FEditable.readonly := v; + end + function getlimitlength(); + begin + if FEditable then return FEditable.limitlength; + end + function setLimitLength(n); + begin + if FEditable then return FEditable.limitlength := n; + end + function getLineWrap(); + begin + if FEditable then return FEditable.LineWrap; + end + function setLineWrap(v); + begin + if FEditable then return FEditable.LineWrap := v; + end + FOnUpdate; + FOnChange; + fonmaxtext; +end +type tthreeEntry=class(TCustomControl) + private + type tpickerEditer=class(teditable) + function Create(); + begin + inherited; + border := false; + end + function valuemodify(); + begin + //修改日期 + if host then Host.ExecuteCommand("dtchanged",self); + end + fprev; + fnext; + protected + function doonsetfocus();override; + begin + ExecuteCommand("ecselall"); + end + function doonkillfocus();override; + begin + valuemodify(); + ExecuteCommand("ecclcsel"); + end + public + function GetEntryRect();override; + begin + r := ClientRect; + if not ifarray(r)then return array(0,0,0,0); + return r; + end + function WMCHAR(o,e);override; + begin + case e.char of + "0" to "9":return inherited; + end; + case e.CharCode of + VK_DELETE,VK_BACK:inherited; + end; + end + function WMKEYDOWN(o,e);override; + begin + case e.CharCode of + 13: + begin + return valuemodify(); + end + VK_LEFT: + begin + return GoToPrev(); + end + VK_RIGHT: + begin + return gotonext(); + end + VK_UP: + begin + return inc(); + end + VK_DOWN: + begin + return dec(); + end + end + inherited; + end + function inc(); + begin + s := text; + text := inttostr(strtointdef(s,0)+1); + valuemodify(); + end + function dec(); + begin + s := text; + text := inttostr(strtointdef(s,0)-1); + valuemodify(); + end + private + function gotonext(); + begin + valuemodify(); + if fnext then + begin + KillFocus(); + fnext.SetFocus(); + end + end + function GoToPrev(); + begin + valuemodify(); + if fprev then + begin + KillFocus(); + fprev.SetFocus(); + end + end + end + public + function create(aowner); + begin + inherited; + border := true; + left := 0; + top := 0; + height := 24; + width := 105; + FFontWidth := font.width; + //color := rgb(100,100,100); + FEntrys := array(); + for i := 0 to 2 do + begin + o := new tpickerEditer(); + FEntrys[i]:= o; + o.limitlength := getEntryWidth(i); + end + for i := 0 to 2 do + begin + FEntrys[i].fnext := FEntrys[(i+1)mod 3]; + FEntrys[(i+1)mod 3].Fprev := FEntrys[i]; + end + calcCtls(); + FEntrys :: mcell.host := self(true); + end + function paint();override; + begin + for i,v in FEntrys do + begin + v.paint(); + end + dc := Canvas; + for i,v in FSymInfo do + begin + if not ifarray(v)then continue; + dc.drawtext(v["sym"],v["rec"],DT_CENTER .| DT_VCENTER .| DT_SINGLELINE); + end + PaintBtn(); + end + function PaintBtn();virtual; + begin + if FBtnRect then + begin + dc := Canvas; + dc.Draw("framecontrol",array(FBtnRect[0:1],FBtnRect[2:3]),DFC_SCROLL,DFCS_SCROLLDOWN); + end + end + function DoWMSIZE(o,e);override; + begin + calcCtls(); + InvalidateRect(nil,false); + inherited; + end + function dosetfocus(o,e);override; + begin + if csDesigning in ComponentState then return; + for i,v in FEntrys do + begin + if v.HasFocus then return v.SetFocus(); + end + for i,v in FEditable do + begin + return v.SetFocus(); + end + inherited; + end + function dokillfocus(o,e);override; + begin + if csDesigning in ComponentState then return; + for i,v in FEntrys do + begin + if v.HasFocus then return v.killFocus(); + end + inherited; + end + function keypress(o,e);override; + begin + if csDesigning in ComponentState then return; + if e.skip then return; + for i,v in FEntrys do + begin + if v.HasFocus then return v.WMCHAR(o,e); + end + inherited; + end + function KeyDown(o,e);override; + begin + if csDesigning in ComponentState then return; + if e.skip then return; + for i,v in FEntrys do + begin + if v.HasFocus then return v.WMKEYDOWN(o,e); + end + inherited; + end + function btnClicked(p);virtual; + begin + if pointinrect(p,FBtnRect)then + begin + return 1; + end + end + function MouseUp(o,e);override; + begin + if csDesigning in ComponentState then return; + if e.skip then return; + if e.button()=mbLeft then + begin + p := e.pos; + if btnClicked(p)then return; + for i,v in FEntrys do + begin + if v.HasFocus then return v.MouseUp(o,e); + end + end + inherited; + end + function MouseMove(o,e);override; + begin + if csDesigning in ComponentState then return; + if e.skip then return; + for i,v in FEntrys do + begin + if v.HasFocus then + begin + return v.MouseMove(o,e); + end + end + inherited; + end + function MouseDown(o,e);override; + begin + if csDesigning in ComponentState then return; + if e.skip then return; + if e.button()=mbLeft then + begin + p := e.pos; + if pointinrect(p,FBtnRect)then return; + idx :=-1; + for i,v in FEntrys do + begin + if pointinrect(p,v.GetEntryRect())then + begin + idx := i; + end else + v.KillFocus(); + end + if idx >= 0 then return FEntrys[idx].MouseDown(o,e); + end + inherited; + end + function recycling();override; + begin + inherited; + For i,v in FEntrys do + begin + v.recycling(); + end + FEntrys := array(); + FSymInfo := array(); + end + function FontChanged(o);override; + begin + //改变 + FFontWidth := font.width; + for i,v in FEntrys do v.Font := font; + calcCtls(); + end + protected + function calcCtls();virtual; + begin + rec := ClientRect; + h := rec[3]-rec[1]; + wd := rec[2]-rec[0]; + FBtnRect := array(max(0,integer(rec[2]-min(25,h))),rec[1],rec[2]-1,rec[3]-1); + x := rec[0]+1; + FSymInfo := array(); + for i,v in FEntrys do + begin + nx := x+integer(FFontWidth * (getEntryWidth(i))+2); + rc := array(x,rec[1],nx,rec[3]); + v.ClientRect := rc; + x := nx; + if i=2 then return; + nx := x+FFontWidth+1; + rc := array(x,rec[1],nx,rec[3]); + FSymInfo[i,"sym"]:= getSym(i); + FSymInfo[i,"rec"]:= rc; + x := nx; + end + end + property BtnRect Read FBtnRect; + property entrys read FEntrys; + private + function getEntryWidth(i);virtual; + begin + case i of + 0:return 4; + else return 2; + end + end + function getSym(i);virtual; + begin + return "/"; + end + FSymInfo; + FBtnRect; + FFontWidth; + FEntrys; +end +type TCustomListBoxbase=class(TCustomScrollControl) + {** + @explan(说明) listbox基类 + **} + private + FItemCount; + FMaxItemWidth; + protected /////////////////滚动条相关////////////////////////////////////////// + function GetClientXCapacity();virtual; //宽度容量 + begin + r := integer(ClientRect[2]/GetXScrollDelta()); + return r; + end + function GetClientYCapacity();virtual; //高度容量 + begin + return integer(ClientRect[3]/GetYScrollDelta()); + end + function GetClientXCount();virtual; //宽度间隔 + begin + return FMaxItemWidth; + end + function GetClientYCount();virtual; //高度项 + begin + return FItemCount-1; + end + function GetXScrollDelta();override; + begin + return FFontWidth; + end + function GetYScrollDelta();override; + begin + return FFontHeight+4; + end + function PositionChanged();virtual; + begin + InvalidateRect(nil,false); + end + private + function PaintLines(FirstLine,LastLine); + begin + cvs := Canvas; + for i := FirstLine to LastLine do + begin + rc := GetIdxRect(i); + PaintIdx(i,rc,cvs); + end + end + public + function Create(AOwner);override; + begin + inherited; + FMaxItemWidth := 1; + FItemCount := 0; + FFontHeight := font.Height; + FFontWidth := font.Width; + left := 0; + top := 0; + height := 100; + width := 125; + autoscroll := 1; + ThumbTrack := true; + FScroolChanged := false; + end + function UpDateScrollBar(); //滚动条改变 + begin + DoControlAlign(); + end + function IncPaintLock(); //锁定刷新 + begin + BeginUpdate(); + end + function DecPaintLock(); //释放刷新 + begin + EndUpdate(); + end + function DoEndUpDate();override; //锁定刷新释放 + begin + if not(IsUpDating())then + begin + if FScroolChanged then + begin + FScroolChanged := false; + return UpDateScrollBar(); + 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)/GetYScrollDelta())); + LastLine := integer(min(FItemCount-1,yPos+(bo)/GetYScrollDelta())); + cvs := Canvas; + cvs.Font := font; + PaintLines(FirstLine,LastLine); + end + function MouseUp(o,e);override; + begin + if e.Button()=mbLeft then + begin + CallMessgeFunction(onclick,o,e); + end + e.skip := true; + end + function MouseDown(o,e);override; + begin + if e.Button()=mbLeft and e.shiftdouble()then + begin + CallMessgeFunction(ondblclick,o,e); + e.skip := true; + end + end + function PaintIdx(idx,rc,cvs);virtual; + begin + {** + @explan(说明)绘制项 %% + @param(idx)(integer) 序号%% + @param(rc)(array) 绘制区域%% + @param(cvs)(tcustomcanvas) 画布 %% + **} + end + function InvalidateIdxRect(idx,cnt);virtual; + begin + if idx >= 0 and idx= 1)then cnt := 1; + rc := ClientRect; + y := GetYPos(); + dy := GetYScrollDelta(); + idxtop :=(idx-y) * dy; + if idxtop >= rc[3]then + begin + return; + end + if(idxtop+cnt * dy)<= 0 then + begin + return; + end + rc[1]:= idxtop; + rc[3]:= min(rc[3],idxtop+cnt * dy); + InvalidateRect(rc,false); + end + end + function GetIdxByYpos(y);virtual; + begin + py := GetYPos(); + r := integer(y/GetYScrollDelta())+py; + if r >= FItemCount then return-1; + return r; + end + function GetIdxRect(idx);virtual; + begin + {** + @explan(说明)通过序号获得项绘制区域 %% + @param(idx)(integer) 项序号 %% + @return(array) array(左上右下) %% + **} + if idx >= 0 then + begin + rc := ClientRect; + yp := GetYPos(); + xp := GetXpos(); + DY := GetYScrollDelta(); + rc[1]:=(idx-yp) * DY; + rc[0]:=(0-xp) * GetXScrollDelta(); + rc[3]:= rc[1]+DY; + return rc; + end + return array(); + end + function InsureIdxInClient(idx); //确保指定项在区域中 + begin + {** + @explan(说明)确保指定项在区域中 %% + @param(idx)(integer) 项序号 %% + **} + rc := GetIdxRect(idx); + c := ClientRect; + if rc[1]c[3]then + begin + SetYpos(1+GetYPos()+(rc[3]-c[3]+1)/GetYScrollDelta()); + end + end + function GetClientIdxs();virtual; + begin + {** + @explan(说明)获得客户区项的序号 %% + @return(array) 序号数组 %% + **} + rc := ClientRect; + r := GetRectIdxs(rc); + return r[0]-> r[1]; + end + function doControlALign();override; + begin + if(IsUpDating())then + begin + FScroolChanged := true; + end else + begin + FMaxItemWidth := GetMaxItemWidth(); + InitialScroll(); + end + end + function EnsureIdxVisible(idx); + begin + if idx >= FItemCount then idx := FItemCount-1; + if not(idx >= 0)then return; + rc := ClientRect; + idxs := GetRectIdxs(rc); + if idx <= idxs[0]then + begin + SetYpos(idx); + end else + if idx >= idxs[1]then + begin + ndx := integer((rc[3]-rc[1])/GetYScrollDelta()); + SetYpos(idx-ndx); + end + end + function FontChanged(o);override; + begin + wd := font.width; + h := font.Height; + if h <> FFontHeight or wd <> FFontWidth then + begin + FFontHeight := h; + FFontWidth := wd; + UpDateScrollBar(); + end + end + function GetItemCount();virtual; + begin + return FItemCount; + end + property ItemCount read GetItemCount write SetItemCount; + property ItemHeight read GetYScrollDelta; + {** + @param(ItemCount)(integer) 项数量 %% + **} + protected + function SetItemCount(n);override; + begin + if not(n >= 0)then return; + nn := integer(n); + if nn <> FItemCount then + begin + FItemCount := nn; + UpDateScrollBar(); + end + end + private + FFontHeight; + FFontWidth; + FScroolChanged; //滚动条修改 + function GetRectIdxs(rc); + begin + yp := GetYPos(); + tp := rc[1]; + bo := rc[3]; + FirstLine := integer(tp/GetYScrollDelta())+yp; + LastLine := integer((bo)/GetYScrollDelta())+yp; + return array(FirstLine,LastLine); + end + function GetMaxItemWidth();virtual; + begin + return 1; + end +end +type TcustomListBox=class(TCustomListBoxbase) + {** + @explan(说明) listbox控件 %% + **} + function Create(AOwner);override; + begin + inherited; + border := true; + FitemData := new tnumindexarray(); + FSelBegin :=-1; + FSelEnd :=-1; + FMultisel := false; + end + function MouseUp(o,e);override; + begin + if FIsMouseDown then + begin + _wapi.clipcursor(ps); + FIsMouseDown := false; + selchange := 0; + case FMultisel of + 0: + begin + selchange := FFormerSelBegin <> FSelBegin; + end + 1: + begin + selchange :=((FFormerSelBegin <> FSelBegin)or(FFormerSelEnd <> FSelEnd))and((FFormerSelBegin <> FSelEnd)or(FFormerSelEnd <> FSelBegin)); + end + 2: + begin + selchange := 1; + end + end; + if selchange then CallMessgeFunction(FselectionChange,o,e); + end + inherited; + end + function MouseDown(o,e);override; + begin + if csDesigning in ComponentState then return; + if(e.Button()=mbLeft)and not(e.shiftdouble())then + begin + FFormerSelBegin := FSelBegin; + FFormerSelEnd := FSelEnd; + idx := GetIdxByYpos(e.ypos); + IncPaintLock(); + if FMultisel=2 then + begin + if FMultisel3Data[idx]then Reindex(FMultisel3Data,array(idx:nil)); + else FMultisel3Data[idx]:= not FMultisel3Data[idx]; + InvalidateIdxRect(idx); + end else + if idx <> FSelBegin and idx <> FSelEnd then + begin + SelRange(false); + FSelBegin := FSelEnd := idx; + SelRange(true); + end + DecPaintLock(); + FIsMouseDown := true; + crect := ClientRect; + ps := array(clienttoscreen(crect[0],crect[1]),clienttoscreen(crect[2],crect[3])); + _wapi.clipcursor(ps); + end else + FIsMouseDown := false; + inherited; + end + function MouseMove(o,e);override; + begin + if FIsMouseDown then + begin + rc := ClientRect; + y := e.ypos; + dy := GetYScrollDelta(); + if y>rc[3]-4 then + begin + y += dy; + end else + if y<4 then + begin + y -= dy; + end + idx := GetIdxByYpos(y); + if idx<0 then return; + if FMultisel=2 then + begin + end else + if idx <> FSelEnd then + begin + IncPaintLock(); + SelRange(false); + if FMultisel=1 then FSelEnd := idx; + else + begin + FSelBegin := FSelEnd := idx; + end + SelRange(true); + DecPaintLock(); + end + EnsureIdxVisible(idx); + end + end + function PaintIdx(idx,rc,cvs);virtual; + begin + {** + @explan(说明)绘制项 %% + @param(item)(TCustomListItem) 项 %% + @param(rc)(array) 绘制区域%% + @param(cvs)(tcustomcanvas) 画布 %% + **} + PaintIdxBkg(idx,rc,cvs); + PaintIdexText(idx,rc,cvs); + end + function PaintIdexText(idx,rc,cvs);virtual; + begin + cvs.DrawText(getItemText(idx),rc,DT_NOPREFIX); + end + function getCurrentSelection();virtual; + begin + {** + @explan(说明)获取当前选中项的索引，仅用于单选的列表框%% + **} + if FMultisel=0 then + begin + return FSelBegin; + end + return-1; + end + function setCurrentSelection(n);virtual; + begin + {** + @explan(说明)设置当前选中项的索引，仅用于单选的列表框%% + @param(n)(integer)%% + **} + if FMultisel=1 then + begin + if isValidIndex(n)then + begin + FSelBegin := FSelEnd := n; + InvalidateRect(nil,false); + end else + if ifarray(n)and isValidIndex(n[1])and isValidIndex(n[0])then + begin + FSelBegin := MinValue(n); + FSelEnd := MaxValue(n); + end + return; + end else + if FMultisel=2 then + begin + FMultisel3Data := array(); + if isValidIndex(n)then + begin + FMultisel3Data[n]:= true; + end else + if ifarray(n)then + begin + for i,v in n do + begin + if isValidIndex(v)then + begin + FMultisel3Data[v]:= true; + end + end + end + return; + end + if not isValidIndex(n)or n=FSelBegin then return; + SelRange(false); + FSelBegin := FSelEnd := n; + SelRange(true); + CallMessgeFunction(FselectionChange,self(true),new tuieventbase(0,0,0,0)); + end + function getItemSelectedState(n); + begin + {** + @explan(说明)获取指定项的选中状态%% + @param(n)(integer)指定项下标%% + @return(bool)是否被选中%% + **} + if not isValidIndex(n)then return nil; + case FMultisel of + 0: + begin + return n=FSelBegin; + end + 1: + begin + if FSelBegin <= FSelEnd then return n >= FSelBegin and n <= FSelEnd; + return n >= FSelEnd and n <= FSelBegin; + end + 2: + begin + return FMultisel3Data[n]=1; + end + end + return nil; + end + function setItemSelectedState(n,state); + begin + {** + @explan(说明)设置指定项选中状态，仅用于非连续多选的列表框%% + @param(n)(integer)指定项索引%% + @param(state)(bool)状态%% + **} + b := state?1:0; + if FMultisel <> 2 or not isValidIndex(n)or b=getItemSelectedState(n)then return; + if b then FMultisel3Data[n]:= b; + else reindex(FMultisel3Data,array(n:nil)); + CallMessgeFunction(FselectionChange,self(true),new tuieventbase(0,0,0,0)); + InvalidateIdxRect(n); + end + function appendItem(item);virtual; + begin + {** + @explan(说明)在列表框最后添加一个项%% + @param(item)(string)要添加的字符串%% + @return(integer)所添加项在列表框中的索引%% + **} + if CheckListItem(item)then + begin + FitemData.Push(item); + class(TCustomListBoxbase).ItemCount := FitemData.length(); + return ItemCount-1; + end + return-1; + end + function appendItems(ari);virtual; + begin + {** + @explan(说明)在列表框最后添加多个项%% + @param(ari)(array)要添加的字符串组成的数组%% + @return(integer)所添加的最后一项在列表框中的索引%% + **} + if CheckListItems(ari)then + begin + FitemData.Pushs(ari); + class(TCustomListBoxbase).ItemCount := FitemData.length(); + return ItemCount-1; + end + return-1; + end + function insertItem(item,n);virtual; + begin + {** + @explan(说明)在指定索引处插入一项%% + @param(item)(string)插入的字符串%% + @param(n)(integer)指定下标索引%% + @return(integer)返回插入的字符串的下标，出错则返回-1%% + **} + if ifnil(n)then return appendItem(item); + if FitemData.Length()<1 then return appendItem(item); + if isValidIndex(n)and CheckListItem(item)then + begin + SelectedChangeSwitch(n,1,1); + FitemData.splice(n,0,item); + class(TCustomListBoxbase).ItemCount := FitemData.length(); + return n; + end + return-1; + end + function insertItems(ari,n);virtual; + begin + {** + @explan(说明)在指定索引处插入多个项，将该函数用于多选列表框将会导致所有选择项丢失%% + @param(ari)(array of string)插入项组成的数组%% + @param(n)(integer)指定下标索引，缺省则插至末尾%% + @return(integer)返回插入的最后的字符串的下标，出错则返回-1%% + **} + if ifnil(n)then return appendItems(ari); + if FitemData.Length()<1 then return appendItems(item); + if CheckListItems(ari)and isValidIndex(n)then + begin + SelectedChangeSwitch(n,length(ari),1); + FitemData.splices(n,0,ari); + class(TCustomListBoxbase).ItemCount := FitemData.length(); + return n+length(ari)-1; + end else + return-1; + end + function deleteItem(n);override; + begin + {** + @explan(说明)删除指定的合法下标索引的项%% + @param(n)(integer)指定项下标索引%% + @return(integer)剩余的项的数量，出错则返回-1%% + **} + if not isValidIndex(n)then return-1; + SelectedChangeSwitch(n,1,0); + FitemData.splice(n,1); + class(TCustomListBoxbase).ItemCount := FitemData.length(); + return FitemData.Length(); + end + function deleteItems(n,cnt); + begin + {** + @explan(说明)删除指定的合法下标处开始多个项%% + @param(n)(integer)指定项下标索引%% + @param(cnt)(integer)删除项数，当删除的项超过尾项时，删至尾项%% + @return(integer)剩余的项的数量，出错则返回-1%% + **} + if not isValidIndex(n)or cnt <= 0 then return-1; + SelectedChangeSwitch(n,cnt,0); + FitemData.splice(n,cnt); + class(TCustomListBoxbase).ItemCount := FitemData.length(); + return FitemData.Length(); + end + function DeleteSelectedItems(); + begin + {** + @explan(说明) 删除选中的项目 %% + **} + if FMultisel=2 then + begin + if FMultisel3Data then + begin + r := array(); + ri := 0; + for i := 0 to FitemData.length()-1 do if not FMultisel3Data[i]then r[ri++]:= FitemData[i]; + setdata(r); + end + end else + begin + if FSelBegin >= 0 and FSelEnd >= FSelBegin then deleteItems(const FSelBegin,FSelEnd-FSelBegin+1); + end + end + function findStrBeginwith(str,b,n);virtual; + begin + {** + @explan(说明)在列表框中指定项之后查找以字符串开头的项，到达末尾即从头开始%% + @param(str)(string)给定字符串%% + @param(b)(bool)1:不区分大小写，0:区分大小写%% + @param(n)(integer)指定项下标，默认为-1%% + @return(integer)返回找到的项的下标，未找到则返回-1%% + **} + if ifnil(b)then b := 0; + if ifnil(n)then n :=-1; + if CheckListItem(str)and ifnumber(n)then + begin + if not isValidIndex(n)then n :=-1; + if b then + begin + return findBeginwithCaseIndepent(str,n); + end else + return findBeginwith(str,n); + end + ShowErrorMessage("function findStrBeginwith:ErrorParameter(s)"); + return-1; + end + function findStrExact(str,b,n);virtual; + begin + {** + @explan(说明)在列表框中指定项之后查找与字符串相同的项，到达末尾即从头开始%% + @param(str)(string)给定字符串%% + @param(b)(bool)1:不区分大小写，0:区分大小写，默认为0%% + @param(n)(integer)指定项下标，默认为-1%% + @return(integer)匹配项的索引，查找失败则返回-1%% + **} + if ifnil(b)then b := 0; + if ifnil(n)then n :=-1; + if CheckListItem(str)and ifnumber(n)then + begin + if not isValidIndex(n)then n :=-1; + if b then return findExactCaseIndepent(str,n); + else return findExact(str,n); + end + ShowErrorMessage("function findStrExact:ErrorParameter(s)"); + return-1; + end + function setData(ari);virtual; + begin + IncPaintLock(); + Clean(); + AppendItems(ari); + DecPaintLock(); + end + function getSelectedIndexes();virtual; + begin + {** + @explan(说明)获取列表框内当前选中项的索引组成的数组%% + @return(array)当未选中任何项时，返回空数组%% + **} + r := array(); + case FMultisel of + 0: + begin + return FSelBegin=-1?r:array(FSelBegin); + end + 1: + begin + if FSelBegin<0 then return r; + if FSelBegin <= FSelEnd then return FSelBegin -> FSelEnd; + else return FSelEnd -> FSelBegin; + end + 2: + begin + ri := 0; + for i,v in FMultisel3Data do r[ri++]:= i; + return r; + end + end + end + function getItem(n); + begin + {** + @explan(说明)获取指定项%% + @param(n)(integer)指定项下标%% + @return()指定项%% + **} + return FitemData[n]; + end + function getItemText(i);virtual; + begin + {** + @explan(说明) 获得item的文本 %% + @param(i)(integer) 序号 %% + @return(string) 项显示字符串 %% + **} + r := FitemData[i]; + if ifstring(r)then return r; + return ""; + end + function clean();virtual; + begin + FitemData.splice(0,FitemData.Length()); + cleanAllSelectedState(); + class(TCustomListBoxbase).ItemCount := 0; + end + function Recycling();override; + begin + FselectionChange := nil; + return inherited; + end + property ItemCount read GetItemCount; + property Multisel:bool read FMultisel write SetMultisel; + property onSelectionChange:eventhandler read FselectionChange write FselectionChange; + property Items:strings read GetData write setData; + function publishs();override; + begin + return array("name","caption","anchors","align","enabled", + "font","visible","border","color", + "height","width","left","top","items", + "multisel","popupmenu","wsdlgmodalframe", + "onmousedown","onmouseup", + "onselectionchange" + ); + end + protected + function CheckListItems(s); + begin + if ifarray(s)then + begin + for i := 0 to length(s)-1 do if not CheckListItem(s[i])then return 0; + return 1; + end else + return 0; + end + function CheckListItem(s);virtual; + begin + {** + @explan(说明) 项检查,重写该方法可以控制项的类型 %% + **} + return ifstring(s); + end + function isValidIndex(n); + begin + return(n >= 0)and n= min(FSelBegin,FSelEnd)and idx <= max(FSelBegin,FSelEnd))or(FMultisel=2 and FMultisel3Data[idx])then + begin + cvs.brush.Color := rgb(204,231,255); + end else + cvs.Brush.Color := Color; + cvs.FillRect(rc); + end + function SetMultisel(n); + begin + if n <> FMultisel and(n in array(0,1,2))then + begin + SelRange(false); + FSelBegin := FSelEnd :=-1; + if n=2 then + begin + FMultisel3Data := array(); + end + FMultisel := n; + end + end + function GetData(); + begin + return FitemData.Data; + end + function findBeginwith(str,n); + begin + len := class(TCustomListBoxbase).ItemCount; + while i++<> len do if AnsiStartsStr(str,getItem((i+n)%len))then return(i+n)%len; + return-1; + end + function findBeginwithCaseIndepent(str,n); + begin + len := class(TCustomListBoxbase).ItemCount; + while i++<> len do if AnsiStartsText(str,getItem((i+n)%len))then return(i+n)%len; + return-1; + end + function findExact(str,n); + begin + len := class(TCustomListBoxbase).ItemCount; + while i++<> len do if getItem((i+n)%len)=str then return(i+n)%len; + return-1; + end + function findExactCaseIndepent(str,n); + begin + len := class(TCustomListBoxbase).ItemCount; + while i++<> len do if UpperCase(getItem((i+n)%len))=UpperCase(str)then return(i+n)%len; + return-1; + end + function SelRange(sel); + begin + if FSelBegin >= 0 and FSelEnd >= 0 then + begin + InvalidateIdxRect(min(FSelBegin,FSelEnd),abs(FSelBegin-FSelEnd)+1); + end + end + function SelectedChangeSwitch(idx,cnt,isAdd); + begin + case FMultisel of + 0: + begin + SelectedChange(idx,cnt,isAdd); + end + 1: + begin + cleanAllSelectedState(); + end + 2: + begin + MultiSelectedChange(idx,cnt,isAdd); + end + end; + end + function SelectedChange(idx,cnt,isAdd); + begin + //单选列表框在列表框项数增加或者删除时处理选中项的变动 + //idx 增删开始处索引 + //cnt 元素数量 + //isAdd 1：添加，0：删除 + if FSelBegin= idx+cnt then t := FSelBegin-cnt; + else + begin + t :=-1; + selchange := 1; + end + end + FSelBegin := FSelEnd := t; + if selchange then CallMessgeFunction(FselectionChange,self(true),nil); + end + function MultiSelectedChange(idx,cnt,isAdd); + begin + //非连续的多选类型在列表框项数增加或者删除时处理选中项的变动 + //idx 增删开始处索引 + //cnt 元素数量 + //isAdd 1：添加，0：删除 + d := array(); + if isAdd then + begin + for i,v in FMultisel3Data do if v then d[i >= idx?i+cnt:i]:= 1; + end else + begin + selchange := 0; + back := idx+cnt; + for i,v in FMultisel3Data do if v then + begin + if i= back then d[i-cnt]:= 1; + else selchange := 1; + end + end + FMultisel3Data := d; + if selchange then CallMessgeFunction(FselectionChange,self(true),nil); + end + function cleanAllSelectedState(); + begin + selchange := 0; + if FMultisel=2 then + begin + for i,v in FMultisel3Data do if v then selchange := 1; + FMultisel3Data := array(); + end else + begin + if FSelBegin <>-1 then selchange := 1; + FSelBegin := FSelEnd :=-1; + FFormerSelBegin := FFormerSelEnd :=-1; + end + if selchange then CallMessgeFunction(FselectionChange,self(true),nil); + end + // FselectionCancel; + FselectionChange; + FSelBegin; + FSelEnd; + FIsMouseDown; + FMultisel; + FMultisel3Data; + FFormerSelBegin; + FFormerSelEnd; +end +type TCustomComboBoxbase=class(TCustomControl) + {** + @explan(说明) combox 基类 %% + **} + function Create(AOwner);override; + begin + inherited; + FBtnWidth := 20; + FmaxListItemShow := 10; + FScreenRect := _wapi.GetScreenRect(); + FListBox := CreateAlist(); + if FListBox is class(TWinControl)then + begin + //FListBox.Parent := self(true); + FListBox.OnClose := function(o,e) + begin + e.skip := true; + o.Visible := false; + end + end + SetBoundsRect(array(0,0,100,23)); + end + function CreateAlist();virtual; + begin + {** + @expaln(说明) 构造一个弹出框 %% + @return(twincontrol) 弹出窗口 %% + **} + return ""; + end + function Paint();override; + begin + rc := ClientRect; + FBtnRect := rc; + dc := canvas; + FBtnRect[0]:= FBtnRect[2]-FBtnWidth; + dc.Draw("framecontrol",array(FBtnRect[0:1],FBtnRect[2:3]),DFC_SCROLL,1); + end + function MouseUp(o,e);override; + begin + if csDesigning in ComponentState then return; + x := e.xpos; + y := e.ypos; + if x>FBtnRect[0]and xFBtnRect[1]and y0 then + begin + nv := integer(v); + if nv <> FmaxListItemShow then + begin + FmaxListItemShow := nv; + end + end + end + function SetBtnWidth(n); + begin + if not(n>10 and n<100)then return; + nn := int(n); + if nn <> FBtnWidth then + begin + SetBtnWidth := nn; + InValidateRect(nil,false); + DoControlAlign(); + end + end + function GetItemIndex();virtual; + begin + end + function SetItemIndex();virtual; + begin + end +end +type TcustomComboBox=class(TCustomComboBoxbase) + {** + @explan(说明) comboBox下拉框 %% + **} + private + type TComboListBox=class(TcustomListBox) + function Create(AOwner); + begin + inherited; + caption := "combox list box"; + end + function MouseUp(o,e);override; + begin + inherited; + visible := false; + end + end + public + function create(AOwner);override; + begin + inherited; + FEdit := new TcustomEdit(self); + FEdit.OnKeyDown := function(o,e) + begin + case e.charcode of + VK_UP: + begin + ItemIndex -= 1; + e.skip := true; + end + VK_DOWN: + begin + ItemIndex += 1; + e.skip := true; + end + end; + end + FEdit.onchange := function(o,e); + begin + if not o.Readonly then + begin + CallMessgeFunction(Foneditchanged,o,e); + end + end + FEdit.onupdate := function(o,e); + begin + if not o.Readonly then + begin + CallMessgeFunction(FoneditUpdate,o,e); + end + end + Freadonly := true; + FListBox.Border := true; + FListBox.Visible := false; + FListBox.WsPopUp := true; + FListBox.onselectionchange := function(o,e); + begin + FEdit.Text := getCurrentItemText(); + ShowDropDown(false); + CallMessgeFunction(OnSelchanged,self,true); + end + FEdit.Readonly := Freadonly; + FListBox.parent := self; + FEdit.parent := self; + end + function CreateAlist();override; + begin + r := new TComboListBox(self); + return r; + end + function SetDesigning(Value,SetChildren);override; + begin + inherited; + if FEdit then FEdit.Enabled := not Value; + end + function DoControlAlign();override; + begin + rc := ClientRect; + rc[2]-= 20; + FEdit.SetBoundsRect(rc); + end + function appendItem(str);virtual; + begin + {** + @explan(说明)添加子项数据%% + @param(str)(string) 子项字符串%% + **} + FListBox.appendItem(str); + end + function AppendItems(arr);virtual; + begin + {** + @explan(说明)添加子项数据%% + @param(arr)(array of string) 子项字符串数组%% + **} + FListBox.appendItems(arr); + end + function insertItem(str,i);virtual; + begin + {** + @explan(说明)插入子项 %% + @param(str)(string) 显示标题 %% + @param(i)(integer) 在i前插入子项 %% + **} + FListBox.insertItem(str,i); + end + function deleteItem(i);virtual; + begin + {** + @explan(说明)删除子项 %% + @param(i)(integer) 删除子项的位置 %% + **} + FListBox.deleteItem(i); + end + function clean() + begin + {** + @explan(说明)清空数据 %% + **} + FListBox.Clean(); + end + function getitems(); + begin + {** + @explan(说明)获得所有数据 %% + @return(array of string) 字符串项 %% + **} + return FListBox.items(); + end + function GetItem(n); + begin + return FListBox.GetItem(n); + end + function getItemCount(); + begin + {** + @explan(说明)统计子项个数 %% + @return(integer)子项个数 %% + **} + //return _send_(CB_GETCOUNT,0,0); + return FListBox.ItemCount; + end + function getItemText(i); + begin + {** + @explan(说明)获取第i个子项的内容 %% + @param(i)(integer) 子项的位置 %% + @return(string) 子项标题 %% + **} + return FListBox.getItemText(i); + end + function getCurrentItemText(); + begin + {** + @explan(说明)获取选中的子项字符串 %% + @return(string) 子项字符串 %% + **} + return getItemText(FListBox.GetCurrentSelection()); + end + property readonly:bool read Freadonly write setReadOnly; + property textheight read FTextHeight Write FTextHeight; + property itemheight read FItemHeight write FItemHeight; + property items:strings read Getitems write setItems; + property oneditchanged:eventhandler read Foneditchanged write Foneditchanged; + property onEditUpdate:eventhandler read FoneditUpdate write FoneditUpdate; + property onkillfocus read Fonkillfocus write Fonkillfocus; + property onsetfocus read Fonsetfocus write Fonsetfocus; + property Editer read FEdit; + {** + @param(oneditchanged)(function[tcomboBox,tuieventbase])文本被改变回调,文本显示后调用%% + **} + function publishs();override; + begin + return array("name","font","border", + "visible","anchors","align","enabled", + "height","width","left","top", + "readonly","itemindex", + "items","oncloseup","ondropdown","onselchanged","oneditchanged","oneditupdate"); + end + function setReadOnly(v); + begin + nv := v?true:false; + if nv <> Freadonly then + begin + Freadonly := nv; + FEdit.Readonly := nv; + end + end + private + function GetItemIndex();override; + begin + return FListBox.GetCurrentSelection(); + end + function SetItemIndex(idx);override; + begin + return FListBox.SetCurrentSelection(idx); + end + FTextHeight; + FItemHeight; + Freadonly; + Foneditchanged; + FoneditUpdate; + Fonkillfocus; + Fonsetfocus; + FEdit; + function setItems(d); + begin + return FListBox.SetData(d); + end +end +type TcustomToolButton=class(tcomponent) + {** + @explan(说明) 工具栏项 %% + **} + function Create(AOwner);override; + begin + inherited; + FCaption := "toolbtn"; //标题 + FImageId :=-1; //imageid + FEnabled := true; //有效 可以点击 + FVisible := true; //可见 + end + function ExecuteCommand(cmd,d);override; + begin + if cmd="doshortcut" then //shortcut + begin + if csDesigning in ComponentState then return; + if Enabled and Visible then + begin + if d=ShortCut then + begin + DoOnClick(self,new tuieventbase(0,0,0,0)); + return "havedoshortcut"; + end + end + end + end + function DoOnClick(o,e);virtual; + begin + if action and action.Execute()then + begin + end else + CallMessgeFunction(OnClick,o,e); + end + function GetRect(); + begin + {** + @explan(说明) 获得区域%% + @return(array) 区域 %% + **} + if parent and parent.HandleAllocated()then return parent.GetItemRect(self); + end + function publishs();override; + begin + return array("name","caption","enabled","imageid","visible","onclick"); + end + function Recycling();override; + begin + if FToolbar then + begin + FToolbar.DeleteButton(self(true)); + end + if FActionLink is class(TControlActionLink)then + begin + FActionLink.Recycling(); + FActionLink := nil; + end + FToolbar := nil; + inherited; + FCaption := ""; //标题 + FOnClick := nil; //点击 + FImageId :=-1; //imageid + FEnabled := true; //有效 可以点击 + FVisible := true; //可见 + end + property OnClick:eventhandler read FOnClick write FOnClick; + property Caption:string read FCaption write SetCaption; + property ImageId:integer read FImageId write SetImageId; + property Enabled:bool read FEnabled write SetEnabled; + property Visible:bool read FVisible write SetVisible; + property ToolBar read FToolbar write SetParent; + property Parent read FToolbar write SetParent; + property willaddBar read FWillAddbar; + property Action:taction read GetAction write SetAction; + property ShortCut read getShortCut write SetShortCut; + {** + @param(OnClick)(function[o:TToolButton;e:tuieventbase]) 点击消息 %% + @param(Caption)(string) 标题 %% + @param(ImageId)(integer) 图标id %% + @param(Enabled)(bool) 是否有效 %% + @param(Visible)(bool) 是否可见 %% + **} + private + FShortCut; + function getShortCut(); + begin + return formatshortcut(FShortCut); + end + function SetShortCut(v); + begin + if v and ifstring(v)then + begin + nst := parsershortcutstr(v); + end else + nst := nil; + if nst <> FShortCut then + begin + FShortCut := nst; + end + end + function SetParent(tb); + begin + if FToolbar=tb then return; //相同 + if FWillAddbar=tb and tb then + begin + FToolbar := tb; + FWillAddbar := nil; + return; + end + if FToolbar <> tb then + begin + if FToolbar is class(TcustomToolBar)then //删除 + begin + FWillAddbar :=-1986; + FToolbar.DeleteButton(self(true)); + FWillAddbar := nil; + FToolbar := nil; + end + end + if tb is class(TcustomToolBar)then + begin + FWillAddbar := tb; + tb.AddButton(self(true)); + SetParent(tb); + end + FWillAddbar := nil; + end + function SetCaption(s); + begin + if ifstring(s)and s <> FCaption then + begin + FCaption := s; + end + end + function SetEnabled(v); + begin + nv := v?true:false; + if nv <> FEnabled then + begin + FEnabled := nv; + if FToolbar then FToolbar.BtnChanged(); + end + end + function SetVisible(v); + begin + nv := v?true:false; + if nv <> FVisible then + begin + FVisible := nv; + if FToolbar then FToolbar.BtnChanged(); + end + end + protected //action + function SetAction(Value);virtual; + begin + if ifnil(Value)then + begin + if FActionLink then + begin + FActionLink.SetAction(nil); + end + excludestate(FControlStyle,csActionClient); + end else + if Value is class(TBasicAction)then + begin + includestate(FControlStyle,csActionClient); + if ifnil(FActionLink)then FActionLink := createobject(GetActionLinkClass(),self); + FActionLink.Action := Value; + FActionLink.Onchange := thisfunction(DoActionChange); + ActionChange(Value,csLoading in Value.ComponentState); + Value.FreeNotification(Self); + end + end + procedure DoActionChange(Sender:TObject); + begin + if Sender=Action then ActionChange(Sender,False); + end + function GetAction();virtual; + begin + if FActionLink then + begin + return FActionLink.Action; + end + end + function GetActionLinkClass();virtual; + begin + {** + @explan(说明) 返回actionlinkclass %% + @return(TMenuActionLink class) + **} + return class(TtoolbuttonActionLink); + end + procedure ActionChange(Sender:TObject;CheckDefaults:Boolean);virtual; + begin + if Sender is class(TCustomAction)then + begin + NewAction := Sender; + if(not CheckDefaults)or(Caption='')or(Caption=Name)then Caption := NewAction.Caption; + if(not CheckDefaults)then ShortCut := NewAction.ShortCut; + if(not CheckDefaults)or Enabled then Enabled := NewAction.Enabled; + //if not CheckDefaults or FChecked then Checked := NewAction.Checked; + end; + end + protected + function SetImageId(id);virtual; + begin + if ifnumber(id)and id <> FImageId then + begin + FImageId := id; //刷新一下 + if FToolbar then FToolbar.BtnChanged(); //FToolbar.InvalidateRect(nil,false); + end + end + private + FCaption; //标题 + FOnClick; //点击 + FCommandId; //command id 可以不要 + FImageId; //imageid + FEnabled; //有效 可以点击 + FVisible; //可见 + FToolbar; //工具栏 + FWillAddbar; + FActionLink; +end +type TcustomToolBar=class(TCustomControl) + {** + @explan(说明) 工具栏控件 %% + **} + function Create(AOwner);override; + begin + inherited; + height := 34; + Width := 300; + Align := alTop; + FButtons := new tnumindexarray(); + caption := "ToolBar"; + FBtnRects := array(); + FTipWnd := new TTipWnd(self); + FTipWnd.Parent := self; + global G_T_TTIMER_; + if G_T_TTIMER_ then + begin + FTimer := createobject(G_T_TTIMER_,self); + FTimer.Interval := 200; + FTimer.Ontimer := thisfunction(DoTimerShowTip); + end + end + function MouseDown(o,e);override; + begin + if csDesigning in ComponentState then return; + FShowLoked := true; + if e.Button()=mbLeft then + begin + FMouseDownIdx := PosInBtn(e.pos); + EndShowWnd(); + if FMouseDownIdx >= 0 then + begin + if not(FButtons[FMouseDownIdx].Enabled)then + begin + FMouseDownIdx :=-1; + return; + end + InvalidateRect(nil,false); + end + end + end + function MouseUp(o,e);override; + begin + if csDesigning in ComponentState then return; + FShowLoked := false; + if e.Button()=mbLeft then + begin + idx := PosInBtn(e.pos); + if idx >= 0 then + begin + if FMouseDownIdx=idx then + begin + bi := FButtons[idx]; + bi.DoOnClick(bi,e); + end; + end + end + if FMouseDownIdx >= 0 then + begin + FMouseDownIdx :=-1; + InvalidateRect(nil,false); + end + end + function MouseMove(o,e);override; + begin + if csDesigning in ComponentState then return; + if FTimer.Enabled then return; + idx := PosInBtn(e.pos); + if idx<0 then return; + FShowtimeIndexA := idx; + FTimer.Start(); + end + function CNALIGN(o,e):CN_ALIGN;override; + begin + case Align of + alTop,alBottom: + begin + bs := UnAlignBounds; + nh := CalcHeightFixWidth(e.width); + dh := nh-(bs[3]-bs[1]); + bs[3]+= dh; + FUnAlignBounds := bs; + end + alLeft,alRight: + begin + bs := UnAlignBounds; + nh := CalcWidthFixHeight(e.height); + dh := nh-(bs[2]-bs[0]); + bs[2]+= dh; + FUnAlignBounds := bs; + end + end + inherited; + end + function DoTimerShowTip(); //定时器 + begin + FCurrentPos := array(0,0); + _wapi.getcursorPos(FCurrentPos); + FCurrentPos := ScreenToClient(FCurrentPos[0],FCurrentPos[1]); + idx := PosInBtn(FCurrentPos); + if idx<0 then + begin + EndShowWnd(); + FShowLoked := false; + FMouseDownIdx :=-1; + InvalidateRect(nil,false); + return; + end + if FShowLoked then return; + if FShowTimeIndexA=idx then //依然存在 + begin + if not FTipWnd.Visible then + begin + st := FButtons[idx].ShortCut; + FTipWnd.Tip := FButtons[idx].Caption+(st?(" ("+st+")"):""); + FTipWnd.ShowTIp(); + end + end else + begin + EndShowWnd(); + end + end + function AddButton(btn); + begin + {** + @explan(说明) 添加工具栏项%% + **} + InsertButton(btn); + end + function SetBtnIndex(btn,idx); + begin + {** + @explan(说明) 修改按钮的位置 %%; + @param(btn)(TToolButton) 工具栏项 %% + @param(idx)(TToolButton | integer) 位置 %% + **} + if not(idx >= 0)then return-1; + cidx := IndexOfBtn(btn); + if cidx<0 then return-1; + if cidx=idx then return idx; + btnlength := FButtons.Length(); + if idx>cidx then + begin + for i := cidx to min(btnlength-1,idx)-1 do + begin + FButtons.swap(i,i+1); + end + end else + begin + for i := idx to cidx-1 do + begin + FButtons.swap(i,i+1); + end + end + if Btn.Visible then InvalidateRect(nil,false); + return cidx; + end + function InsertButton(btn,idx); + begin + {** + @explan(说明) 在指定位置插入按钮 %% + @param(btn)(TToolButton) 工具栏项 %% + @param(idx)(TToolButton | integer) 位置 %% + **} + if not(btn is class(TcustomToolButton))then return; + cidx := IndexOfBtn(btn); + //位置计算 + if cidx >= 0 then return; + if btn.willaddBar <> self then + begin + return btn.parent := self(true); + end + FButtons.push(btn); + nidx := nil; + if idx >= 0 then nidx := idx; + else if ifobj(idx)then nidx := IndexOfBtn(idx); + if nidx >= 0 then SetBtnIndex(btn,nidx); + if btn.Visible then + begin + IncPaintLock(); + InvalidateRect(nil,false); + FWillModifyToolbar := true; + DecPaintLock(); + end + end + function DeleteButton(btn); //删除按钮 + begin + {** + @explan(说明) 在删除按钮 %% + @explan(说明) 删除button %% + @param(btn)(TToolButton) 工具栏项%% + **} + idx := IndexOfBtn(btn); + if idx=-1 then return-1; + if btn.willaddBar <>-1986 then + begin + return btn.Parent := nil; + end + FButtons.splice(idx,1); + if btn.Visible then + begin + IncPaintLock(); + InvalidateRect(nil,false); + FWillModifyToolbar := true; + DecPaintLock(); + end + end + function GetItemRect(btn); //获得按钮区域 + begin + {** + @explan(说明) 获得按钮的区域 %% + @param(btn)(TToolButton) 工具栏项%% + @return(array) 区域 %% + **} + idx := IndexOfBtn(btn); + if idx >= 0 then + begin + return FBtnRects[idx]; + end + end + function IncPaintLock(); //锁定刷新 + begin + {** + @explan(说明) 锁定绘制,和 DecPaintLock() 成对使用 %% + **} + BeginUpdate(); + end + function DecPaintLock(); //释放刷新 + begin + {** + @explan(说明) 取消绘制锁定,和 IncPaintLock() 成对使用 %% + **} + EndUpdate(); + end + function CalcHeightFixWidth(w); + begin + {** + @explan(说明) 固定宽度计算工具栏高度 %% + @param(w)(integer) 给定宽度 %% + @return(intger) 计算的高度 %% + **} + bw := 0; + if WSSizebox then + begin + bw := 16; + end else + if WsDlgModalFrame then + begin + bw := 6; + end else + if Border then bw := 2; + imglst := ImageList; //图标 + imgw := 36; + imgh := 36; + if imglst is class(TCustomImageList)then + begin + imgw := imglst.Width+4; + imgh := imglst.height+4; + end + nh := w-bw; + bct := 0; + for i := 0 to FButtons.Length()-1 do //调整大小 + begin + bi := FButtons[i]; + if not(bi.Visible)then + begin + continue; + end + bct++; + end + if bct=0 then return imgh+bw; + rct := integer((nh+2)/(imgw+1)); + if rct<1 then rct := 1; + //echo "总共:",bct,"每行:",rct,"===行数",(integer( bct/rct)+1),"\r\n"; + nt := bct/rct; + return((frac(nt)>0)?(integer(nt)+1):(nt)) * (imgh+1)+bw; + return(integer(bct/rct)+1) * (imgh+1)+bw; + end + function CalcWidthFixHeight(h); + begin + {** + @explan(说明) 固定高度计算工具栏宽度 %% + @param(w)(integer) 给定高度 %% + @return(intger) 宽度 %% + **} + bw := 0; + if WSSizebox then + begin + bw := 16; + end else + if WsDlgModalFrame then + begin + bw := 6; + end else + if Border then bw := 2; + imglst := ImageList; //图标 + imgw := 36; + imgh := 36; + if imglst is class(TCustomImageList)then + begin + imgw := imglst.Width+4; + imgh := imglst.height+4; + end + nh := h-bw; + bct := 0; + for i := 0 to FButtons.Length()-1 do + begin + bi := FButtons[i]; + if not(bi.Visible)then + begin + continue; + end + bct++; + end + if bct=0 then return imgw+bw; + rct := integer((nh+2)/(imgh+1)); + if rct<1 then rct := 1; + nt := bct/rct; + return((frac(nt)>0)?(integer(nt)+1):(nt)) * (imgw+1)+bw; + return(integer(bct/rct)+1) * (imgw+1)+bw; + end + function Paint();override; + begin + c := canvas; + for i := 0 to FButtons.length()-1 do + begin + bi := FButtons[i]; + if not(bi.Visible)then continue; + ci := FBtnRects[i]; + if not ifarray(ci)then return; + if FMouseDownIdx=i then + begin + c.draw("framecontrol",array(ci[0:1],ci[2:3]),DFC_BUTTON,DFCS_BUTTONCHECK); + end else + c.draw("framecontrol",array(ci[0:1],ci[2:3]),DFC_BUTTON,DFCS_BUTTONPUSH); + igslist := ImageList; + if igslist is class(TCustomImageList)then + begin + igid := bi.ImageId; + if igid >= 0 and igid=0表示正确序号 %% + **} + for i := 0 to FButtons.Length()-1 do + begin + if btn=FButtons[i]then return i; + end + return-1; + end + function Recycling();override; + begin + while FButtons.Length()>0 do + begin + DeleteButton(FButtons[0]); + end + inherited; + FShowLoked := true; + FBtnRects := nil; + FButtons := nil; + FTipWnd := nil; + FShowtimeIndexA := nil; + FTimer := nil; + FCurrentPos := nil; + FMouseDownIdx :=-1; + end + function BtnChanged(); + begin + CalcButtonsRect(); + InvalidateRect(nil,false); + end + function publishs();override; + begin + return array("name","align","caption","enabled","font","left","top","width","height", + "visible","imagelist"); + if Align <> alNone then + begin + return array("name","align","caption","enabled","font", + "visible","imagelist"); + end else + return array("name","align","caption","enabled","font","left","top","width","height", + "visible","imagelist"); + end + protected + procedure SetAlign(Value:TAlign);override; + begin + if Align=Value then exit; + if Value in array(alClient)then + begin + return; + end + inherited; + end + function ImageChanged();override; + begin + if IsUpDating()then return; + if Parent then + begin + Parent.DoControlAlign(); + CalcButtonsRect(); + InvalidateRect(nil,false); + end + end + private + function EndShowWnd(); + begin + FShowTimeIndexA :=-1; + FTimer.Stop(); + FTipWnd.Visible := false; + end + function CalcButtonsRect(); + begin + if(IsUpDating())then + begin + FWillModifyToolbar := true; + return; + end + imglst := ImageList; //图标 + imgw := 36; + imgh := 36; + if imglst is class(TCustomImageList)then + begin + imgw := imglst.Width+4; + imgh := imglst.height+4; + end + rc := ClientRect; + FBtnRects := array(); + x := y := 0; + rct := 0; + case Align of + alLeft,alRight: + begin + for i := 0 to FButtons.Length()-1 do //调整大小 + begin + bi := FButtons[i]; + if not(bi.Visible)then + begin + FBtnRects[i]:= array(0,0,0,0); + continue; + end + if y+imgh>rc[3]then + begin + if rct=0 then + begin + FBtnRects[i]:= array(x,y,x+imgw,y+imgh); + y := 0; + x += imgw+1; + end else + begin + y := 0; + x += imgw+1; + FBtnRects[i]:= array(x,y,x+imgw,y+imgh); + y += imgh+1; + rct := 1; + end + end else + begin + FBtnRects[i]:= array(x,y,x+imgw,y+imgh); + y += imgh+1; + rct++; + end + end + end else + begin + for i := 0 to FButtons.Length()-1 do //调整大小 + begin + bi := FButtons[i]; + if not(bi.Visible)then + begin + FBtnRects[i]:= array(0,0,0,0); + continue; + end + if x+imgw>rc[2]then + begin + if rct=0 then + begin + FBtnRects[i]:= array(x,y,x+imgw,y+imgh); + x := 0; + y += imgh+1; + end else + begin + x := 0; + y += imgh+1; + FBtnRects[i]:= array(x,y,x+imgw,y+imgh); + x += imgw+1; + rct := 1; + end + end else + begin + FBtnRects[i]:= array(x,y,x+imgw,y+imgh); + x += imgw+1; + rct++; + end + end + end + end; + end + function PosInBtn(p); + begin + for i := 0 to FButtons.length()-1 do + begin + ri := FBtnRects[i]; + if ri and pointinrect(p,ri)then + begin + return i; + end + end + return-1; + end + FShowLoked; + FBtnRects; + FButtons; + FTipWnd; + FShowtimeIndexA; + FTimer; + FCurrentPos; + FMouseDownIdx; + FWillModifyToolbar; +end +type TCustomSpinEdit = class(TCustomControl) + {** + @explan(说明)spinedit控件 + **} + private + FEdit; + FUDwidth; + FUPrect; + FDownrect; + FCI; + CI_UP; + CI_DOWN; + CIS_NONE; + CIS_MOUSEDOWN; + CIS_MOUSEUP; + CIS_MOUSEON; + FIncrement: Double; + FDecimals: Integer; + FMaxValue: Double; + FMinValue: Double; + FValue: Double; + FOnIncrease; + FOnDecrease; + FLeveTimer; + function DrawItem(id,f); + begin + ys := 0; + case id of + CI_UP: + begin + rec := FUPrect; + ys := DFCS_SCROLLup; + end + CI_DOWN: + begin + rec := FDownrect; + ys := DFCS_SCROLLDOWN; + end else + return; + end + case f of + CIS_MOUSEDOWN: + begin + //_wapi.DrawFrameControl(Canvas.Handle,rec,DFC_BUTTON,DFCS_BUTTONPUSH); + Canvas.Draw("framecontrol",array(rec[0:1],rec[2:3]),DFC_BUTTON,DFCS_BUTTONPUSH) + end + CIS_NONE: + begin + Canvas.Draw("framecontrol",array(rec[0:1],rec[2:3]),DFC_SCROLL,ys); + end + CIS_MOUSEON: + begin + //canvas.pen.color := rgb(100,200,100); + //canvas.draw("Rectangle",array(rec[0:1],rec[2:3])); + end + end; + end + type TSpinCEdit=class(tedit) + function create(AOwner);override; + begin + inherited; + border := false; + caption := "0"; + end + function SetDesigning(f,fc); + begin + if f then Enabled := false; + else Enabled := true; + end + end + FChar; + protected + function UpdateControl();virtual; + begin + FEdit.Text := inttostr(FValue); + end + function GetValue();virtual; + begin + if FEdit.HandleAllocated()then + begin + r := FEdit.text; + r := StrToIntDef(r,FValue); + if r <> FValue then + begin + FValue := r; + end + end + return FValue; + end + procedure SetValue(const AValue:Double);virtual; + begin + if AValue <> FValue then + begin + if AValue >= FMinValue and AValue <= FMaxValue then + begin + FValue := AValue; + UpdateControl(); + end + end + end + procedure SetMaxValue(const AValue:Double);virtual; + begin + if AValue <> FMaxValue then + begin + FMaxValue := AValue; + end + end + procedure SetMinValue(const AValue:Double);virtual; + begin + if AValue <> FMinValue then + begin + FMinValue := AValue; + end + end + procedure SetIncrement(const AIncrement:Double);virtual; + begin + nv := integer(AIncrement); + if FIncrement <> nv and nv>0 then + begin + FIncrement := nv; + end + end + function doIncrease(o,e);virtual; + begin + nv := GetValue()+FIncrement; + if nv <= FMaxValue and nv >= FMinValue then + begin + CallMessgeFunction(FOnDecrease,o,e); + if not e.skip then + begin + FValue := nv; + UpdateControl(); + end + end else + begin + if nv>FMaxValue then SetValue(FMaxValue); + else if nv= FMinValue then + begin + CallMessgeFunction(FOnDecrease,o,e); + if not e.skip then + begin + FValue := nv; + UpdateControl(); + end + end else + begin + if nv>FMaxValue then SetValue(FMaxValue); + else if nv FTip then + begin + FTip := s; + wh := GetTextWidthAndHeightWidthFont(s,seLF.font,1); + //width := wh[0]+5; + //height := wh[1]+5; + FSize := array(wh[0]+5,wh[1]+5); + end + end + private + FSize; +end +initialization +global G_T_TTIMER_; +G_T_TTIMER_ := class(TCustomTimer); +end. \ No newline at end of file diff --git a/funcext/tvclib/utslvcltree.tsf b/funcext/tvclib/utslvcltree.tsf new file mode 100644 index 0000000..b0b709d --- /dev/null +++ b/funcext/tvclib/utslvcltree.tsf @@ -0,0 +1,1922 @@ +unit utslvcltree; +interface +{** + @explan(说明) 树控件相关 %% + @date(20220510) +**} +uses utslvclauxiliary,utslvclbase,utslvclgdi; +type TVirtualListItem = class(tsluibase) + {** + @ignore(忽略) %% + @explan(说明) list 的 item项目基类 + **} + type THandleClass=class + end + function Create(List);override; + begin + {** + @explan(说明) 构造函数%% + @param(list)(TVirtualList) item的所有者,必须是TVirtualList或者其派生 %% + **} + if(List is class(TVirtualList))then + begin + FOwner := List; + end + hd := new THandleClass(); + try + FHandle := inttostr(int64(hd)); ////当前句柄唯一标识 + except + FHandle := inttostr(gettslvariableptr(hd)); + end; + inherited create(); + FWidth := 30; + end + function paint(cvs,x,y,xwidth,yheight);virtual; + begin + {** + @explan(说明) 绘制 %% + @param(cvs)(tcustomcanvas) canvas对象 %% + @param(x)(integer) 当前x轴位置 %% + @param(y)(integer) 当前y轴位置 %% + @param(xwidth)(integer) 最大项的宽度 %% + @param(yheight)(integer) 高度 %% + **} + end + property Width read FWidth write SetWidth; + property Handle read FHandle; + property Owner read FOwner; + {** + @param(width)(integer) 宽度 %% + @param(Owner)(TVirtualList) 所有者 %% + **} + function Recycling();override; + begin + FOwner := nil; + inherited; + end + private + FHandle; + function SetWidth(w);virtual; + begin + if w>0 and w <> FWidth then + begin + if Owner and(Owner.ItemMaxWidth=FWidth)or(Owner.ItemMaxWidth0 then dflg := false; + cvs.Draw("FrameControl",dr,DFC_BUTTON,dflg?DFCS_CHECKED:DFCS_BUTTONCHECK); + if(not dflg)and(ItemCount>0)then + begin + if allChildChecked()then + begin + cvs.Draw("FrameControl",dr,DFC_BUTTON,DFCS_CHECKED); + end else + if ChildChecked()then + begin + cvs.brush.color := rgb(10,10,10); + cvs.fillrect(dr[0]+8 union dr[1]-4); + ow := Owner; + if self=ow.CurrentNode then cvs.brush.color := FFocusColor[ow.hasFocus()]; + else cvs.brush.color := ow.Color; + end + end + end + function DrawExpand(cvs,x,rec,sz,flag); //绘制展开按钮 + begin + sz2 := integer(sz/2); + y := rec[1]; + h := rec[3]; + ys := y+(h-sz)/2; + dr := array(array(x,ys),array(x+sz,ys+sz)); + cvs.draw("rectangle",dr); + cvs.MoveTo(array(x+2,ys+sz/2)); + cvs.LineTo(array(x+sz-2,ys+sz/2)); + if not flag then + begin + cvs.MoveTo(array(x+sz/2,ys+2)); + cvs.LineTo(array(x+sz/2,ys+sz-2)); + end + end + + function ChildChecked(); + begin + for i := 0 to FItems.Count-1 do + begin + it := FItems[i]; + ow := Owner; + if ow and ow.OnlyLeafNodeCheckMark then + begin + if it.checked and it.ItemCount<1 then return true; + if it.ChildChecked()then return true; + end else + begin + if it.Checked then return true; + if it.ChildChecked()then return true; + end + end + return false; + end + function allChildChecked(); + begin + if FItems.Count<1 then return false; + for i := 0 to FItems.Count-1 do + begin + it := FItems[i]; + if it.ItemCount<1 then + begin + if not it.Checked then return false; + end else + begin + if not it.allChildChecked()then return false; + end + end + return true; + end + public + function Paint(cvs,x,y,w,h);override; //绘制 + begin + {** + @explan(说明)绘制节点%% + **} + ow := Owner; + if not ow then return; + cvs.Pen.Color := rgb(50,50,50); + cvs.Pen.style := PS_SOLID; + cvs.Pen.width := 1; + inv := 3; + BasePos := FBasePos+x; + FCheckPos := BasePos; + fitemcountflg := ItemCount or FDirtype; + for i := 1 to Hierarchy do + BasePos += FHierarchyWidth; + cbase := BasePos; + itc := 0; + ExpWidth := FExpandWidth; + ifsel := false; + if self=ow.CurrentNode then + begin + ifsel := true; + cvs.brush.Color := FFocusColor[ow.hasFocus()]; + end else + cvs.brush.Color := ow.Color; + if fitemcountflg then + begin + itc := true; + BasePos += inv; + FExpandPos := BasePos; + DrawExpand(cvs,BasePos,array(x,y,w,h),ExpWidth-2,FExpanded); + BasePos += ExpWidth; + end else //else ExpWidth := 0; + begin + BasePos += ExpWidth+inv; + end + CheckWidth := FCheckWidth; + if ow.CheckBox then + begin + BasePos += inv; + FCheckPos := BasePos; + DrawCheckBox(cvs,BasePos,array(x,y,w,h),CheckWidth,FChecked); + BasePos += CheckWidth; + BasePos += inv; + end else + CheckWidth := false; + img := ow.ImageList; + iwidth := 0; + if(img and img.HandleAllocated())then + begin + if(ifsel and FSelImgId >= 0)or(FImgId >= 0)or(FExpandImgId >= 0 and fitemcountflg>0 and FExpanded)then //绘制selimage + begin + if(FExpandImgId >= 0)and fitemcountflg>0 and FExpanded then + begin + img.Draw(FExpandImgId,cvs,BasePos,y+1,nil); + end else + if(ifsel and FSelImgId >= 0)then + begin + img.Draw(FSelImgId,cvs,BasePos,y+1,nil); + end else + if FImgId >= 0 then + begin + img.Draw(FImgId,cvs,BasePos,y+1,nil); + end + BasePos += img.Height; + BasePos += inv; + end + //echo "\r\nimg"; + end + FCaptionRect := array(BasePos,y,x+1000,y+h); + cvs.FillRect(FCaptionRect); + cvs.drawtext(FCaption,FCaptionRect,DT_VCENTER .| DT_SINGLELINE .| DT_NOPREFIX); + if ow.HasLine then + begin + cvs.Pen.Color := rgb(150,150,150); + cvs.Pen.style := PS_DOT; + for i,v in ow.GetHierarchyByHandle(self.Handle) do + begin + FLG := TRUE; + //nx := cbase-FHierarchyWidth*(i+1)+6; + nx := cbase+FHierarchyWidth *(i-FHierarchy-1)+6; + if nx>cbase-5 then break; + cvs.MoveTo(array(nx,y)); + if i=FHierarchy and Parent.LastChild=self then + cvs.LineTo(array(nx,y+h/2+1)); + else cvs.LineTo(array(nx,y+h)); + end + cvs.MoveTo(array(cbase+ExpWidth,y+h/2)); + cvs.LineTo(array(cbase-FHierarchyWidth+6,y+h/2)); + end + end + function MouseUp(o,e); + begin + {** + @explan(说明) 点击消息处理 + **} + ps := e.pos; + px := ps[0]; + rec := o.GetIndexRect(o.GetItemIndexByYpos(e.ypos)); //获得位置 + recx := rec[0]; + if(FItems.Count or FDirtype)and px >= FExpandPos and px <=(FExpandPos+FExpandWidth)then //点击展开 + begin + if mbLeft=e.button()then + begin + if FExpanded then UnExpand(); + else Expand(); + end else + begin + e.skip := true; + end + end else + if Owner.CheckBox and MouseCanChecked and px >= FCheckPos and px <=(FCheckPos+FCheckWidth)then //点击checkbox + begin + //setprofiler(1+2+4); + if mbLeft=e.button()then + begin + Checked := not FChecked; + p := parent; + while p and(p is class(TcustomTreeCtlNode)) do + begin + Owner.InvalidateItem(p,0); + p := p.parent; + end + end else + e.skip := true; + //exportfile(ftstream(),"","d:\\tst\\abc.stm",getprofilerinfo(true)); + end else + if px>FCheckPos then //点击文本 + begin + return true; + end + return false; + end + function Create(AOwner);override; + begin + inherited; + FMouseCanChecked := true; + FModifyChildrenChecked := true; + FFocusColor := array(rgb(230,240,250),rgb(0,192,250)); + //FNodeHash := array(); + FCheckWidth := 16; + FExpandWidth := 12; + FBasePos := 10; + FHierarchyWidth := 20; + FItems := new TFpList(); //子项 + FHierarchy :=-1; + FEexpanded := false; + FChecked := false; + FExpandImgId :=-1; + end + function GetNodeByIndex(idx); + begin + {** + @explan(说明) 通过序号获得子节点%% + @param(idx)(TcustomTreeCtlNode) %% + **} + if idx >= 0 then return FItems[idx]; + return nil; + end + function indexof(v); //获得序号 + begin + return FItems.indexof(v); + end + function UpDateHierarchy(); //更新层级 + begin + if not Parent then return; + ph := Parent.Hierarchy; + nh := ph+1; + if FHierarchy <> nh then + begin + FHierarchy := nh; + for i := 0 to FItems.Count-1 do + begin + FItems[i].UpDateHierarchy(); + end + end + UpDateWidth(); + end + function AppendNodeStr(s);override; + begin + {** + @explan(说明) 追加一个节点 %% + @param(s)(string) 字符串 %% + @return(TcustomTreeCtlNode) 新节点 %% + **} + ow := Owner; + idx := FItems.Count; + return InsertNodeStr(s,idx); + end + function InsertNodeStr(s,idx);override; + begin + {** + @explan(说明) 插入一个节点 %% + @param(s)(string) 字符串 %% + @param(idx)(integer) 序号 %% + @return(TcustomTreeCtlNode) 新节点 %% + **} + if not(idx >= 0)then idx := 0; + ow := Owner; + if not ow then return; + it := ow.CreateTreeNode(ow); //new TcustomTreeCtlNode(ow); + it.Caption := s; + InsertNode(it,idx); + return it; + end + function GetIndex();virtual; + begin + {** + @explan(说明) 获得在父节点中的序号 %% + @return(integer) 序号 %% + **} + if Parent then Parent.indexof(self); + end + function AncestorIsExpand();virtual; + begin + {** + @explan(说明) 是否一致展开 %% + @return(bool) 展开为true,否则为false %% + **} + r := Expanded; + if not(r)then return false; + if Parent then return Parent.AncestorIsExpand(); + return r; + end + function AppendNode(it);virtual; + begin + {** + @explan(说明) 插入一个节点 %% + @param(it)(TcustomTreeCtlNode) 节点 %% + @return(bool) 是否成功 %% + **} + return InsertNode(it,FItems.Count); + end + function HasNode(nd);virtual; + begin + {** + @explan(说明) 是否为某个节点的祖先节点 %% + @param(nd)(TcustomTreeCtlNode) 子节点 %% + @return(TcustomTreeCtlNode|0) 如果为祖先节点,就返回查询节点的父节点 %% + **} + if not(nd is class(TcustomTreeCtlNode))then return 0; + ow := Owner; + if not ow then return; + if ow <> nd.Owner then return 0; + p1 := nd.Parent; + p := p1; + while p do + begin + if p=self then return p1; + if p is class(TcustomTreeCtlNode)then p := p.Parent; + end + return 0; + end + function DeleteNode(nd);virtual; + begin + {** + @explan(说明) 删除节点 %% + @param(nd)(TcustomTreeCtlNode) 待删除节点 %% + **} + if nd=self then return 0; + pn := HasNode(nd); + if not pn then return; + return pn.DeleteChildNode(nd); + end + + function DeleteChildNode(nd); + begin + {** + @explan(说明) 删除子节点%% + @param(nd)(TcustomTreeCtlNode) 节点 %% + **} + idx :=-1; + idx := indexof(nd); + if idx=-1 then return 0; + return DeleteNodeByIndex(idx); + end + function DeleteNodeByIndex(idx); + begin + {** + @explan(说明) 根据位置删除节点%% + @param(idx)(integer) 序号 %% + **} + nd := FItems[idx]; + if not nd then return; + try + Owner.IncPaintLock(); + nd.UnExpand(); + if Owner.NodeInList(nd)then //在显示 + begin + Owner.DeleteItemByIndex(Owner.GetItemIndex(nd)); + end + FItems.Deli(idx); + CurrentDeleteNode := nd; + nd.parent := self(true); + CurrentDeleteNode := nil; + finally + Owner.DecPaintLock(); + end + return true; + end + function DeleteChildren();virtual; // + begin + {** + @explan(说明) 删除所有的子节点%% + **} + try + Owner.IncPaintLock(); + r := true; + if self=Owner.RootNode then + begin + while ItemCount>0 DO + begin + DeleteChildNode(FItems[0]); + end + r := false; + end + if r then + begin + UnExpand(); //折叠 + while ItemCount>0 do + begin + idx := 0; //ItemCount-1; + it := FItems[idx]; + CurrentDeleteNode := it; + it.parent := self(true); + CurrentDeleteNode := nil; + FItems.Deli(idx); + end + end + finally + Owner.DecPaintLock(); + end + end + function GetLastShowNode(); + begin + {** + @explan(说明) 获得展示的最后第一个节点 %% + @return(TcustomTreeCtlNode) %% + **} + if FItems.Count<1 or not(FExpanded)then return self; + it := FItems[FItems.Count-1]; + return it.GetLastShowNode(); + end + function InsertNodes(its,idx);virtual; + begin + {** + @explan(说明) 插入一个节点 %% + @param(it)( array of TcustomTreeCtlNode) 字符串 %% + @param(idx)(integer) 序号 %% + **} + idx0 := idx; + if not(idx >= 0)then idx0 := 0; + if idx>FItems.Count then idx0 := FItems.Count; + nits := array(); + nitsi := 0; + flag := false; + bidx := idx0; + for i,it in its do + begin + if(it is class(TcustomTreeCtlNode))and(not it.Parent)then + begin + odexp := it.Expanded; + it.UnExpand(); + FItems.InsertBefor(it,idx0); + CurrentAddNode := it; + it.Parent := self(true); + CurrentAddNode := nil; + it.UpDateHierarchy(); + nits[nitsi++]:= it; + idx0++; + flag := true; + end + end + if flag and Expanded and Owner.NodeInList(self)then + begin + preItem := FItems[bidx-1]; + bx := 0; + //if preItem then bx := Owner.GetItemIndex( preItem.GetLastShowNode())+1; + if preItem then bx := Owner.GetItemIndex(preItem.GetLastShowNode(),bidx)+1; + else bx := owner.GetItemIndex(self)+1; + owner.InsertItems(nits,bx); + end + end + function InsertNode(it,idx);virtual; + begin + {** + @explan(说明) 插入一个节点 %% + @param(it)(TcustomTreeCtlNode) 字符串 %% + @param(idx)(integer) 序号 %% + **} + if(it is class(TcustomTreeCtlNode))and(not it.Parent)then + begin + if idx<0 then idx := 0; + if idx>FItems.Count then idx := FItems.Count; + if not(idx >= 0)then idx := 0; + odexp := it.Expanded; + it.UnExpand(); + FItems.InsertBefor(it,idx); + CurrentAddNode := it; + it.Parent := self(true); + CurrentAddNode := nil; + it.UpDateHierarchy(); + if Expanded and Owner.NodeInList(self)then + begin + preItem := FItems[idx-1]; + bx := 0; + if preItem then bx := Owner.GetItemIndex(preItem.GetLastShowNode())+1; + else bx := owner.GetItemIndex(self)+1; + owner.InsertItem(it,bx); + end + return true; + end + end + function Expand();virtual; //展开 + begin + {** + @explan(说明) 展开节点 %% + **} + if Owner and Owner.RootNode=self then return; + if FExpanded then return; + if ItemCount<1 then //空节点展开 + begin + if FDirtype then + begin + Owner.EmptyNodeExpanding(self(true)); + end + return; + end + //if not Owner.NodeInList(self) then return; + idx :=-1; + if(Owner.NodeInList(self))then + begin + its := GetShowNodes(); + idx := Owner.GetItemIndex(self); + Owner.InsertItems(its,idx+1); + end + FExpanded := true; + //return true; + if Owner.SingleExpand then + begin + p := Parent; + if p is class(TcustomTreeCtlNode)then + begin + PItems := p.FItems; + ct := PItems.Count; + if ct>1 then + begin + Owner.UpDateWindow(); + for i := 0 to ct-1 do + begin + vi := PItems[i]; + if vi=self then continue; + vi.UnExpand(); + end + end + end + end + if idx >= 0 then + begin + owner.InvalidateItem(self,flag); + end + return true; + end + function UnExpand();virtual; //折叠 + begin + {** + @explan(说明) 折叠节点 %% + **} + if Owner and Owner.RootNode=self then return; + if not FExpanded then return; + if ItemCount<1 then return; + idx :=-1; + idx := Owner.GetItemIndex(self); + it := GetLastShowNode(); + idx2 := Owner.GetItemIndex(it,idx); + owner.DeleteItemByBounds(idx+1,idx2); + //父节点为展开 + FExpanded := false; + if idx >= 0 then + begin + Owner.InvalidateItem(self,flag); + end + end + function RecyclingChildren();virtual; + begin + while ItemCount>0 do + begin + it := FItems[0]; + //echo "\r\n删除",it.Caption; + it.Recycling(); + end + end + function Recycling();override; + begin + p := FParent; + if p then + begin + p.DeleteNode(self); + end + while ItemCount>0 do + begin + it := FItems[0]; + it.Recycling(); + end + //if self<>Owner.RootNode then + inherited; + end + function GetShowItemCount(); + begin + r := 1; + if not FExpanded then return r; + for i := 0 to FItems.Count-1 do + begin + it := FItems[i]; + r++; + if it.ItemCount and it.Expanded then r += it.GetShowItemCount(); + end + return r; + end + function GetShowNodes(); + begin + {** + @explan(说明) 获得展开的所有子节点 %% + @return(array of TcustomTreeCtlNode) %% + **} + lst := array(); + for i := 0 to FItems.Count-1 do + begin + it := FItems[i]; + lst union=array(it); + if it.ItemCount and it.Expanded then lst union=it.GetShowNodes(); + end + return lst; + end + function toarray();virtual; + begin + {** + @explan(说明) 转换为数组 %% + **} + r := array(); + r["type"]:= "treenode"; + r["caption"]:= FCaption; + mid := FImgId; + smid := FSelImgId; + r["imgid"]:= mid >= 0?mid:(-1); + r["selimgid"]:= smid >= 0?smid:(-1); + if _tag then r["tag"]:= _tag; + if Checked then r["checked"]:= true; + if ItemCount then + begin + r["nodes"]["type"]:= "treenodes"; + for i := 0 to ItemCount-1 do + begin + r["nodes"]["items"][i]:= GetNodeByIndex(i).toarray(); + end + end + return r; + end + property ImgId read FImgId write SetImgId; + property SelImgId read FSelImgId write SetSelImgId; + property ExpandImgId read FExpandImgId write SetExpandImgId; + property ItemCount read GetItemCount; //节点数 + property Hierarchy Read FHierarchy; //层次 + property Expanded read GetExpanded; //展开 + property Parent read FParent write SetParent; //父节点 + property Checked read FChecked write SetChecked; //选择 + property LastChild read GetLstChild; + property dirtype read FDirtype write FDirtype; //目录类型 + property Caption read FCaption write SetCaption; //标题 + property MouseCanChecked read FMouseCanChecked write FMouseCanChecked; + property ModifyChildrenChecked read FModifyChildrenChecked write FModifyChildrenChecked; + {** + @param(ItemCount)(integer) 子节点数量 %% + @param(Hierarchy)(integer) 层级 %% + @param(Handle)(pointer) 句柄 %% + @param(Expanded)(bool) 是否展开 %% + @param(Parent)(TcustomTreeCtlNode) 父节点 %% + **} + protected property CurrentDeleteNode read FCurrentDeleteNode write FCurrentDeleteNode; + property CurrentAddNode read FCurrentAddNode write FCurrentAddNode; + function Gitems(); + begin + return FItems; + end + function SetParent(V);virtual; + begin + ow := Owner; + if not ow then return; + if ow.RootNode=self then return; + tp := Parent; + if(v is class(TcustomTreeCtlNode))and v.Owner=ow then + begin + if v.CurrentAddNode=self then + begin + FParent := v; //新节点 + end else + if v.CurrentDeleteNode=self then //从节点移除 + begin + FParent := nil; + end else + begin + if tp=v then return; + if tp then + begin + tp.DeleteNode(self(true)); + end + v.InsertNode(self(true),v.ItemCount); + end + end else + begin + if tp then tp.DeleteNode(self(true)); + end + end + function SetChecked(v);virtual; //设置checked + begin + nv := v?true:false; + if nv <> FChecked then + begin + FChecked := nv; + if ModifyChildrenChecked then + begin + for i := 0 to ItemCount-1 do + begin + FItems[i].Checked := nv; + end + end + ow := Owner; + if ow then ow.InvalidateItem(self,false); + end + end + private + function GetLstChild(); + begin + return FItems[FItems.Count-1]; + end + function SetImgId(id); + begin + if(id>-2)and(id<1000)and id <> FImgId then + begin + FImgId := integer(id); + end + end + function SetExpandImgId(id); + begin + if id>-2 and(id<1000)and id <> FExpandImgId then + begin + FExpandImgId := integer(id); + end + end + function SetSelImgId(id); + begin + if(id>-2)and(id<1000)and id <> FSelImgId then + begin + FSelImgId := id; + end + end + FDirtype; + FImgId; + FMouseCanChecked; + FModifyChildrenChecked; + FSelImgId; + FCurrentDeleteNode; + FCurrentAddNode; + FExpanded; + FExpandImgId; + FHierarchy; //层级 + FCaption; //标题 + FChecked; //选择 + function SetCaption(v);virtual; //设置标题 + begin + if ifstring(v)and V <> FCaption then + begin + FCaption := v; + UpDateWidth(); + end + end + function UpDateWidth(); + begin + bwid := 60; + for i := 1 to FHierarchy do + begin + bwid += FHierarchyWidth; + end + if ifstring(FCaption)and FCaption then + begin + fw := 8; + if Owner then + begin + ft := Owner.Font; + fw := abs(ft.Width); + if fw=0 then fw := integer(abs(ft.Height)/2); + end + bwid += length(FCaption)* fw; + end + width := bwid; + end + function GetExpanded();virtual; //已经展开 + begin + if Owner and Owner.RootNode=self then return true; + return FExpanded; + end + function GetItemCount(); //子节点数 + begin + return FItems.Count; + end +end +type TVirtualListFixed = class(TCustomScrollControl) + {** + @ignore(忽略) %% + @explan(说明) 滚动条窗口 %% + **} + protected + function GetClientXCapacity();virtual; //宽度容量 + begin + r := integer(ClientRect[2]/GetXScrollDelta()); + return r; + end + function GetClientYCapacity();virtual; //高度容量 + begin + return integer(ClientRect[3]/GetYScrollDelta()); + end + function GetClientXCount();virtual; //宽度间隔 + begin + return ColCount; + end + function GetClientYCount();virtual; //高度项 + begin + return FItemCount; + end + function GetXScrollDelta();override; + begin + return FColWidth; + end + function GetYScrollDelta();override; + begin + return FItemHeight; + end + function PositionChanged();virtual; + begin + InvalidateRect(nil,false); + end + function UpDateScrollBar(); + begin + DoControlAlign(); + end + public + function IncPaintLock(); + begin + BeginUpdate(); + end + function DecPaintLock(); + begin + EndUpdate(); + end + function DoEndUpDate();override; + begin + if not(IsUpDating())then + begin + if FScroolChanged then + begin + FScroolChanged := false; + UpDateScrollBar(); + end + end + inherited; + end + function GetItemIndexByYpos(y);virtual; + begin + py := GetYPos(); + return integer(y/GetYScrollDelta())+py; + end + function ItemUpDated();virtual; + begin + //空函数 + UpDateScrollBar(); + end + function GetValidateRect();virtual; + begin + {** + @explan(说明) 获得绘制区域 %% + @return(array) array(左,上,右,下) %% + **} + return FValidateRect; + end + function Create(AOwner);override; + begin + inherited; + FItemHeight := 25; + FItemCount := 0; + height := 400; + width := 300; + FColWidth := 10; + FColCount := 0; + border := true; + autoscroll := 3; + ThumbTrack := true; + FScroolChanged := false; + end + function SetTopLine(v);virtual; + begin + SetYpos(v); + end + function paint();override; + begin + xpos := GetXpos(); + ypos := GetYPos(); + // 计算需要重绘的区域 + ps := PAINTSTRUCT().rcPaint; + tp := ps[1]; + bo := ps[3]; + FValidateRect := ps; + FirstLine := integer(max(0,yPos+(tp)/FItemHeight)); + LastLine := integer(min(ItemCount-1,yPos+(bo)/FItemHeight)); + FirstCol := integer(max(0,xPos+ps[0]/FColWidth)); + LastCol := integer(min(FColCount-1,xPos+ps[2]/FColWidth)); + x := FColWidth *(0-xPos); + cvs := Canvas; + cvs.Font := font; + PaintRect(cvs,yPos,FItemHeight,FirstLine,LastLine,xPos,FColWidth,FirstCol,LastCol); + FValidateRect := array(); + end + function PaintRect(cvs,yPos,ht,FirstLine,LastLine,xPos,wd,FirstCol,LastCol);virtual; + begin + {** + @explan(说明) 绘制无效区域 %% + **} + for i := FirstLine to LastLine do + begin + y := ht *(i-yPos)+FMarginTop; + for j := FirstCol to LastCol do + begin + x := wd *(j-xPos); + cvs.Textout(format("%d=%d",i,j),array(x,y)); + end + end + end + function Clean();virtual; + begin + {** + @explan(说明) 清空 %% + **} + ColCount := 0; + end + function GetIndexClientRect(idx);virtual; + begin + if idx >= 0 then + begin + rc := ClientRect; + yp := GetYPos(); + rc[1]:=(idx-yp)* FItemHeight; + rc[3]:= rc[1]+FItemHeight; + return rc; + end + end + function GetIndexRect(idx);virtual; + begin + {** + @explan(说明) 通过id获得item区域 %% + @param(idx)(integer) 序号 %% + @return(array) array(左,上,右,下) %% + **} + r := GetIndexClientRect(idx); + if r then + begin + r[0]:= FColWidth *(0-GetXpos()); + end + return r; + end + function GetClientItemIndexs();virtual; + begin + rc := ClientRect; + r := GetRectItemIndexs(rc); + return r[0]-> r[1]; + end + function doControlALign();override; + begin + if(IsUpDating())then + begin + FScroolChanged := true; + end else + begin + InitialScroll(); + end + end + property ItemCount read GetItemCount write SetItemCount; + property ItemHeight read FItemHeight write SetItemHeight; + property ColCount read FColCount write SetColCount; + property ColWidth read FColWidth write SetColWidth; + private + FValidateRect; + FItemCount; //项数量 + FItemHeight; //项高 + FColCount; //列数 + FColWidth; //列宽 + FScroolChanged; //滚动条修改 + function GetRectItemIndexs(rc); + begin + yp := GetYPos(); + tp := rc[1]; + bo := rc[3]; + FirstLine := integer(tp/GetYScrollDelta())+yp; + LastLine := integer((bo)/GetYScrollDelta())+yp; + return array(FirstLine,LastLine); + end + function SetColWidth(h); + begin + if FColWidth <> h and h>5 then + begin + FColWidth := h; + UpDateScrollBar(); + end + end + function SetColCount(v); + begin + nv := GZNumber(v); + if nv >= 0 and nv <> FColCount then + begin + FColCount := nv; + UpDateScrollBar(); + end + end + function GetItemCount();virtual; + begin + return FItemCount; + end + function SetItemCount(v);virtual; + begin + nv := GZNumber(v); + if nv >= 0 and nv <> FItemCount then + begin + FItemCount := nv; + UpDateScrollBar(); + end + end + function SetItemHeight(v); + begin + nv := GZNumber(v); + if FItemHeight <> nv then + begin + FItemHeight := nv; + UpDateScrollBar(); + end + end + function GZNumber(v); + begin + return v>0?integer(v):0; + end +end +type TVirtualList = class(TVirtualListFixed) + {** + @ignore(忽略) %% + @explan(说明) 虚拟的list + **} + function GetClientYCount();override; //高度项 + begin + return FItems.Count; + end + function GetClientXCount();override; //宽度间隔 + begin + return integer(FxClientMax/ColWidth); + end + function Create(AOwner);override; + begin + inherited; + FxClientMax := ColWidth; + FItemMinWidth := FxClientMax; + FHashItems := array(); + FItems := new TFpList(); + end + function GetItemByIndex(idx); + begin + {** + @explan(说明) 通过id获得序号 %% + @param(idx)(integer) 序号 %% + @return(TVirtualListItem) 项 %% + **} + if idx >= 0 and IdxFItems.Count-1 then idx :=-1; + return idx; + end + Function GetItemByYPos(y); + begin + {** + @explan(说明) 通过y轴位置获得item %% + @param(y)(integer) y轴位置 %% + @return(TVirtualListItem) 项 %% + **} + idx := GetItemIndexByYpos(y); + if idx >= 0 then return FItems[idx]; + end + function GetItemIndex(item,guess); + begin + {** + @explan(说明) 获得item序号 %% + @param(item)(TVirtualListItem) item %% + @return(integer) 序号 %% + **} + for i :=(guess>0?guess:0)to FItems.Count-1 do + begin + if item=FItems[i]then return i; + end + return-1; + return FItems.Indexof(item); + end + function GetItemRect(item); + begin + {** + @explan(说明) 获得item区域 %% + @param(item)(TVirtualListItem) item %% + @return(array) array(左,上,右,下) %% + **} + idx := GetItemIndex(item); + if idx >= 0 then return GetItemRectByIndex(idx); + return array(); + end + function GetItemRectByIndex(idx);virtual; + begin + {** + @explan(说明) 通过id获得item区域 %% + @param(idx)(integer) 序号 %% + @return(array) array(左,上,右,下) %% + **} + if idx >= 0 and idx= 0 and idx= 0 and idxFxClientMax then + begin + FItemMaxItemIndex := idx0; + FxClientMax := it.Width; + end else + begin + if FItemMaxItemIndex >= idx0 then FItemMaxItemIndex++; + end + FItems.InsertBefor(it,idx0); + idx0++; + FHashItems[it.handle]:= it; + end + end + ItemUpDated(); + finally + DecPaintLock(); + end; + end + function InsertItem(it,idx);virtual; + begin + {** + @explan(说明) 在位置出入项 %% + @param(it)(TVirtualListItem) item %% + @param(idx)(integer) 位置 %% + **} + //idx0 := FItems.Count; + try + IncPaintLock(); + idx0 :=(idx >= 0 and idxFxClientMax then + begin + FItemMaxItemIndex := idx0; + FxClientMax := it.Width; + end else + begin + if FItemMaxItemIndex >= idx0 then FItemMaxItemIndex++; + end + FItems.InsertBefor(it,idx0); + FHashItems[it.handle]:= it; + r := true; + end + end + ItemUpDated(); + finally + DecPaintLock(); + end; + return r; + end + function DeleteItemByBounds(b,e);virtual; + begin + idx := b; + ei := e; + if not(idx >= 0 and idx)then return false; + Try + IncPaintLock(); + while idx <= ei do + begin + ei--; + if FItemMaxItemIndex>idx then FItemMaxItemIndex -= 1; + else if FItemMaxItemIndex=idx then FItemMaxItemIndex := nil; + it := FItems[idx]; + if it then reindex(FHashItems,array(it.Handle:nil)); + FItems.Deli(idx); + end + ItemUpDated(); + finally + DecPaintLock(); + end + end + function DeleteItemByIndex(idx);virtual; + begin + {** + @explan(说明) 删除位置的项 %% + @param(idx)(integer) 位置 %% + **} + if idx >= 0 and idxidx then FItemMaxItemIndex -= 1; + else if FItemMaxItemIndex=idx then FItemMaxItemIndex := nil; + it := FItems[idx]; + if it then reindex(FHashItems,array(it.Handle:nil)); + FItems.Deli(idx); + ItemUpDated(); + finally + DecPaintLock(); + end; + return true; + end + return false; + end + function AppendItem(v);virtual; + begin + {** + @explan(说明) 追加项 %% + @param(v)(TVirtualListItem) item %% + **} + return InsertItem(v,FItems.Count); + end + function AppendItems(vs);virtual; + begin + {** + @explan(说明) 批量追加项 %% + @param(v)(array of TVirtualListItem) 项集 %% + **} + id := FItems.count; + try + IncPaintLock(); + for i,v in vs do + begin + if v is class(TVirtualListItem)then + begin + if FHashItems[v.handle]then continue; + wd := v.width; + if not(FItemMaxItemIndex >= 0)then + begin + FxClientMax := CalcMaxItemWidth(); + owd := FxClientMax; + end + if FxClientMax mx)then + begin + FxClientMax := mx; + end + UpDateScrollBar(); + DecPaintLock(); + end + function PaintRect(cvs,yPos,ht,FirstLine,LastLine,xPos,wd,FirstCol,LastCol);override; + begin + x := wd *(0-xPos); + rc := ClientRect; + PrevPaint(FirstLine,LastLine); + for i := FirstLine to LastLine do + begin + nrc := GetIndexRect(i); + //ri GetItemRectByIndex(i); + it := FItems[i]; + //y := ht * (i - yPos)+100; + it.paint(cvs,x,nrc[1],rc[2]-rc[1]-x,ht); + end + end + function SetTopLine(idx);override; + begin + {** + @explan(说明) 将idx行放入client区域 %% + @param(idx)(integer) 行号 %% + **} + if idx >= 0 and idx5 and FItemMinWidth <> w then + begin + FItemMinWidth := w; + if FItemMinWidth>FxClientMax then + begin + FxClientMax := FItemMinWidth; + ColCount := integer(FxClientMax/ColWidth+0.5); + end + end + end + function CalcMaxItemWidth();virtual; + begin + {** + @explan(说明)计算最大的item宽度 %% + **} + mx := FItemMinWidth; + if ifnil(FItemMaxItemIndex)then + begin + FItemMaxItemIndex := 0; + for i := 0 to FItems.Count-1 do + begin + nwd := FItems[i].Width; + if nwd>mx then + begin + mx := nwd; + FItemMaxItemIndex := i; + end + end + end else + begin + return FxClientMax; + end + return mx; + end + + private + FHashItems; + function PrevPaint(begid,endid);virtual; + begin + end + function GetItemCount();override; + begin + return FItems.Count; + end + function SetColWidth();override; + begin + end + function SetItemCount();override; + begin + end + function GetItems(); + begin + r := array(); + for i := 0 to FItems.Count-1 do r[i]:= FItems[i]; + return r; + end + FItemMinWidth; + FItemMaxItemIndex; + FItems; //项目 + FxClientMax; //水平宽度 +end +type TcustomTreeCtl = class(TVirtualList) + {** + @explan(说明) 树控件 %% + **} + type TTreeSelCHngedEvent=class(tuieventbase) + {** + @explan(说明) 导航选择改变消息%% + **} + function create(m,w,l,h);override; + begin + inherited; + end + ItemOld; + ItemNew; + Item; + end + function Create(AOwner);override; + begin + inherited; + FSingleExpand := false; + FCheckBox := false; + FHasLine := false; + FNodeHierarchyWidth := 20; + FMulSelected := false; + FMulSelects := array(); + end + function InsertItem(it,idx);override; + begin + if it is class(TcustomTreeCtlNode)then return inherited; + return false; + end + function InsertItems(its,idx);override; + begin + lst := array(); + lsti := 0; + for i,it in its do if it is class(TcustomTreeCtlNode)then lst[lsti++]:= it; + inherited InsertItems(lst,idx); + end + function WMKEYUP(o,e):WM_KEYUP;virtual; + begin + if not FCurrentNode then return; + case e.charcode of + VK_UP,VK_DOWN: + begin + id := GetItemIndex(FCurrentNode); + setsel(GetItemByIndex((VK_UP=e.charcode)?(id-1):(id+1))); + end + VK_LEFT: + begin + if FCurrentNode.Expanded then + begin + FCurrentNode.UnExpand() + end + else + begin + p := FCurrentNode.Parent; + if RootNode=p then return ; + SetSel(p); + end + end + VK_RIGHT: + begin + FCurrentNode.Expand(); + end + end; + end + function hasFocus();virtual; + begin + return true; + end + function AppendItem(it);override; + begin + if it is class(TcustomTreeCtlNode)then return inherited; + return false; + end + function SetSel(it);virtual; + begin + {** + @explan(说明) 设置选中节点 %% + @param(it)(TcustomTreeCtlNode) 节点 %% + **} + if(it is class(TcustomTreeCtlNode))and it.Owner=self then + begin + r := CallSelChange(it); + if r then return; + IF HandleAllocated()then + begin + GoToNode(it); + end + if not r then InValidateRect(nil,false); + //CallSelChange(it); + end + end + function GoToNode(it); + begin + if NodeInList(it)then + begin + //return SetTopLine(GetItemIndex(it)); //滚动 + idxs := GetClientItemIndexs(); + id := GetItemIndex(it); + if(idxs[0]<= id)and(idxs[length(idxs)-1]>= id)then //在可视窗口不需要滚动 + begin + return; + end else + begin + return SetTopLine(max(0,id-integer(length(idxs)/2))); //滚动 +integer(length(idxs)/2) + end + end else + begin + p := it.Parent; + while p do + begin + p.Expand(); + if NodeInList(p)then + begin + f := true; + break; + end + p := p.parent; + end + if f then return GoToNode(it); + end + end + function InitializeWnd();override; + begin + inherited; + if FCurrentNode then GoToNode(FCurrentNode); + end + function imageChanged();override; + begin + if imageList is class(TCustomImageList)then + begin + FBKItemHeight := ItemHeight; + ItemHeight := imageList.Height+2; + end else + begin + if FBKItemHeight>5 then ItemHeight := FBKItemHeight; + end + inherited; + end + function CreateNode();virtual; + begin + {** + @ignore(忽略) %% + **} + return CreateTreeNode(); + r := new TcustomTreeCtlNode(self(true)); + return r; + end + function CreateTreeNode();virtual; + begin + r := new TcustomTreeCtlNode(self(true)); + return r; + end + function DeleteNode(nd);virtual; + begin + if FRootItem then FRootItem.DeleteNode(nd); + end + function NodeInList(it); + begin + {** + @explan(说明)节点是否在窗口中展示 %% + **} + if it=FRootItem then return FRootItem; + return ItemInList(it); + end + function MouseDown(o,e);override; + begin + if e.shiftdouble()and e.button()=mbLeft then //双击 + begin + //添加双击折叠展开 + it := GetItemByYpos(e.ypos); + if it and(it.ItemCount or it.dirtype)and not(it.Expanded)then it.Expand(); + else if it and it.ItemCount and it.Expanded then + begin + it.UnExpand(); + end else + CallMessgeFunction(ondblclick,o,e); + end + end + function MouseUp(o,e);override; + begin + {** + @explan(说明)点击%% + **} + if csDesigning in ComponentState then return; + it := GetItemByYpos(e.ypos); + if it then + begin + if it.MouseUp(o,e)then + begin + SetSel(it); + //CallSelChange(it); //单选 + //多选 + end + end + bt := e.button(); + if bt=mbRight then + begin + CallMessgeFunction(onrclick,o,e); + end else + if bt=mbLeft then + begin + CallMessgeFunction(onclick,o,e); + end + //e.skip := true; + end + function Recycling();override; + begin + //setprofiler(1+2+4); + //exportfile(ftstream(),"","d:\\tst\\abc.stm",getprofilerinfo(true)); + if FRootItem then FRootItem.Recycling(); + FRootItem := nil; + FCurrentNode := nil; + FOnSelChanging := nil; + FonEmptyNodeExapanding := nil; + FNodeHierarchyWidth := 20; + inherited; + end + function GetHierarchyByHandle(h); + begin + if FPaintArray then return FPaintArray[h]; + end + function EmptyNodeExpanding(item); + begin + if HandleAllocated()then + begin + e := new TTreeSelCHngedEvent(self.Handle,0,0,0); + e.item := item; + e.ItemNew := item; + e.ItemOld := item; + calldatafunction(onEmptyNodeExapanding,self(true),e); + end + end + function Clean();override; + begin + if FRootItem then + begin + FRootItem.DeleteChildren(); + end + end + property CurrentNode read FCurrentNode; + property CheckBox:bool read FCheckBox write SetCheckBox; + property HasLine:bool read FHasLine write SetHasLine; + property OnlyLeafNodeCheckMark read FOnlyLeafNodeCheckMark write FOnlyLeafNodeCheckMark; + //property NodeHierarchyWidth read FNodeHierarchyWidth write SetNodeHierarchyWidth; + property RootNode read GetRootNode; + //property MulSelected read FMulSelected write FMulSelected; + property SingleExpand read FSingleExpand write FSingleExpand; + property OnSelChanged:eventhandler read FOnSelChanged write FOnSelChanged; + property OnSelChanging:eventhandler read FOnSelChanging write FOnSelChanging; + property onEmptyNodeExapanding read FonEmptyNodeExapanding write FonEmptyNodeExapanding; + protected + function GetRootNode();virtual; //获得根节点 + begin + if not(FRootItem)or(ifobj(FRootItem)and(FRootItem.ReCycleState <> 0))then + begin + FRootItem := CreateTreeNode(); + end + //echo FRootItem.Owner,"\r\n"; + return FRootItem; + end + private + FOnlyLeafNodeCheckMark; + FNodeHierarchyWidth; + FMulSelected; + FMulSelects; + function SetNodeHierarchyWidth(v); + begin + if v >= 0 and FNodeHierarchyWidth <> v then + begin + end + end + function CallSelChange(it); + begin + r := 0; + if FCurrentNode <> it then + begin + t1 := FCurrentNode; + //if t1 then InvalidateItem(t1,false); + //InvalidateItem(it,false); + ne := new TTreeSelCHngedEvent(self.Handle,1,1,1); + ne.ItemOld := t1; + ne.ItemNew := it; + ne.Item := it; + CallMessgeFunction(FOnSelChanging,self(true),ne); + if ne.Skip then return true; + FCurrentNode := it; + CallMessgeFunction(FOnSelChanged,self(true),ne); + end + return r; + end + FOnSelChanging; + FonEmptyNodeExapanding; + FSingleExpand; + FBKItemHeight; + FOnSelChanged; + FCurrentNode; + FRootItem; + FCheckBox; + FHasLine; + FPaintArray; + function PrevPaint(begid,endid);virtual; + begin + if not FHasLine then return; + currentline := array(); + FPaintArray := array(); + lasthi := 0; + Chi := 0; + //sh := new TMyArrayB(); + for i := ItemCount-1 downto begid do + begin + if not it then + begin + it := GetItemByIndex(i); + lasthi := it.Hierarchy; + if lasthi<1 then continue; + currentline[lasthi]:= 1; + end else + begin + it2 := GetItemByIndex(i); + chi := it2.Hierarchy; + if chi>0 then + begin + currentline[chi]:= 1; + if chi= lasthi then + begin + currentline[chi]:= 1; + end + end + end + lasthi := chi; + if it2 then it := it2; + if i <= endid and it then + begin + FPaintArray[it.Handle]:= currentline; + //sh.unshift( array(array2str(mrows( currentline,1),","),"===>"+inttostr(it.Hierarchy),"%%"+it.caption)); + end + end + end + function SetHasLine(v); //hasline + begin + nv := v?true:false; + if nv <> FHasLine then + begin + FHasLine := nv; + InvalidateRect(nil,false); + end + end + function SetCheckBox(v); + begin + bv := v?true:false; + if bv <> FCheckBox then + begin + FCheckBox := bv; + end + end +end + +implementation + +initialization + +end. \ No newline at end of file diff --git a/funcext/tvclib/uvcpropertytypespersistence.tsf b/funcext/tvclib/uvcpropertytypespersistence.tsf index e9151e4..cfef84a 100644 --- a/funcext/tvclib/uvcpropertytypespersistence.tsf +++ b/funcext/tvclib/uvcpropertytypespersistence.tsf @@ -1,6 +1,6 @@ Unit UVCPropertyTypesPersistence; interface -uses utslvclauxiliary,tslvcl; +uses utslvclauxiliary; {** @explan(说明) 可视控件属性处理库 %% **} @@ -1229,6 +1229,8 @@ type TPropertyImagesData=class(TPropertyType) end function TmfToNode(d);override; begin + global G_T_BITMAP_; + if not G_T_BITMAP_ then return ; if ifstring(d)then begin r := HexFormatStrToTsl(d); @@ -1237,7 +1239,7 @@ type TPropertyImagesData=class(TPropertyType) ret := array(); for i,v in r["items"] do begin - bmp := new tbitmap(); + bmp := createobject(G_T_BITMAP_); bmp.Readvcon(v); ret[i]:= bmp; end @@ -1265,14 +1267,6 @@ type TPropertyImagesData=class(TPropertyType) its[length(its)]:= dv; end end - {for i,v in d do - begin - if v is class(TBitmap) then - begin - dv := v.tovcon(); - its[length(its)] := dv; - end - end } r["items"]:= its; reti := TSlToHexFormatStr(r); ret := "{ "; @@ -1282,6 +1276,8 @@ type TPropertyImagesData=class(TPropertyType) end function ReadTMF(d,o);override; begin + global G_T_BITMAP_; + if not G_T_BITMAP_ then return ; if ifstring(d)then begin r := HexFormatStrToTsl(d); @@ -1290,7 +1286,7 @@ type TPropertyImagesData=class(TPropertyType) ret := array("type":"bmps"); for i,v in r["items"] do begin - bmp := new tbitmap(); + bmp := createobject(G_T_BITMAP_); bmp.Readvcon(v); ret["items"][i]:= bmp; end @@ -1306,10 +1302,12 @@ type TPropertyBitmap=class(TPropertyType) end function TmfToNode(d);override; begin + global G_T_BITMAP_; + if not G_T_BITMAP_ then return ; if ifstring(d)and d then begin tar := HexFormatStrToTsl(d); - bmp := new tbitmap(); + bmp := createobject(G_T_BITMAP_); bmp.Readvcon(tar); return bmp; end @@ -1321,8 +1319,11 @@ type TPropertyBitmap=class(TPropertyType) @explan(说明)修改表格数据转换为tmf文件数据 %% **} reti := ""; - if d is class(tbitmap)then + global G_T_BITMAP_; + + if d is G_T_BITMAP_ then begin + echo " \r\nglob bitmap==="; reti := TSlToHexFormatStr(d.tovcon); end ret := "{ "; @@ -1342,12 +1343,14 @@ type TPropertyIcon=class(TPropertyType) end function TmfToNode(d);override; begin + global G_T_ICON_; + if not G_T_ICON_ then return ; if ifstring(d)and d then begin dd := HexFormatStrToTsl(d); if ifarray(dd)then begin - r := new Ticon(); + r := createobject(G_T_ICON_); r.Readvcon(dd); return r; end @@ -1359,7 +1362,8 @@ type TPropertyIcon=class(TPropertyType) @explan(说明)修改表格数据转换为tmf文件数据 %% **} reti := ""; - if d is class(ticon)then + global G_T_ICON_; + if G_T_ICON_ and (d is G_T_ICON_) then begin reti := TSlToHexFormatStr(d.tovcon()); end @@ -1519,8 +1523,8 @@ type UniObjectMember=class(UniSelProperty) function CreateSelValues();override; begin //FNameMap := FValueMap := array(); - FNameMap := New TMyArrayA(); - FValueMap := New TMyArrayA(); + FNameMap := New tstrindexarray(); + FValueMap := New tstrindexarray(); FInfoObj := CreateInfoOBJ(); r := array(); if not ifobj(FInfoObj)then return array(); @@ -1554,6 +1558,20 @@ type TPropertyAnchors=class(UniObjectMember) return true; end private + type TAnchorKind=class() + //akTop, akLeft, akRight, akBottom + function create(); + begin + akTop := 0; + akTop := 1; + akRight := 2; + akBottom := 3; + end + akTop; + akLeft; + akRight; + akBottom; + end end type TPropertyAlign9=class(UniObjectMember) function EditType();override; diff --git a/funcext/tvclib/uwindowsinterface.tsf b/funcext/tvclib/uwindowsinterface.tsf new file mode 100644 index 0000000..7b6d734 --- /dev/null +++ b/funcext/tvclib/uwindowsinterface.tsf @@ -0,0 +1,601 @@ +unit uwindowsinterface; +interface +{** + @explan(说明) windows平台相关接口 %% + @date(20220509) %% +**} +uses cstructurelib; +type twindowsapi = class + function openresourcemanager(p); //打开资源管理器 + begin + if ifstring(p) then + return WinExec('cmd.exe /C start "" "'+p,1); + end + function getclipboardtext(clpd); + begin + sid := GetClipboardData(0x7); + r := ReadStringFromPtr(sid); + return r; + end + function setclipboardtext(clbd,s); + begin + len := length(s); + hm := GlobalAlloc(2,len+1); //分配内容 + if hm <> 0 then + begin + lm := GlobalLock(hm); //枷锁 + if lm <> 0 then + begin + memcpy(lm,s,len); //内存拷贝 + GlobalUnlock(hm); //解锁 + r := SetClipboardData(1,hm); + if r <> 0 then + begin + ret := 1; + end + end + end + return ret; + end + function getclipboardbmp(); + begin + return GetClipboardData(0x2); + + end + function setclipboardbmp(bmp); + begin + r := SetClipboardData(0x2,bmp); + if r<>0 then + begin + ret := 1; + end + return ret; + end + ////////////////////////////////////////////////////////////////////////////////////////////////////// + class function AnsiToWidChar(c); + begin + if not ifstring(c) then return ""; + iSize := MultiByteToWideChar_a(0, 0, C , -1, "", 0); + if not(iSize>0) then return ""; + pwszUnicode := ""; + setlength(pwszUnicode,isize*2); //少减去2 + MultiByteToWideChar_a(0, 0, c , -1, pwszUnicode , iSize-1); + return pwszUnicode; + end + class function GetEncoderClsid(n:String;ed:pointer); + begin + r := tslvclgetencoderclsid(n,ed); + return r; + end; + function drawbitmaptodc(bm,hdc,x,y,rc,flag,thdc); + begin + oldmp := SelectObject(thdc,bm); + if not flag then flag := 0xcc0020; + r := BitBlt(hdc,x,y,rc[2]-rc[0],rc[3]-rc[1],thdc,rc[0],rc[1],flag); + if oldmp then SelectObject(thdc,oldmp); + return r; + end + function drawbitmapstretchtodc(bm,hdc,drect,rc,flag,thdc); + begin + oldmp := SelectObject(thdc,bm); + if not flag then flag := 0xcc0020; + r := StretchBlt(hdc,drect[0],drect[1],drect[2]-drect[0],drect[3]-drect[1],thdc,rc[0],rc[1],rc[2]-rc[0],rc[3]-rc[1],flag); + if oldmp then SelectObject(thdc,oldmp); + return r; + end + + ////////////////////////clipboar////////////////////// + function OpenClipboard(hwd :pointer):integer;stdcall;external "User32.dll" name "OpenClipboard"; + function EmptyClipboard():integer;stdcall;external "User32.dll" name "EmptyClipboard"; + function CloseClipboard():integer;stdcall;external "User32.dll" name "CloseClipboard"; + function SetClipboardData(uflags:integer;mem:pointer):pointer;stdcall;external "User32.dll" name "SetClipboardData"; + function GetClipboardData(uflags:integer):pointer;stdcall;external "User32.dll" name "GetClipboardData"; + function IsClipboardFormatAvailable(format:integer):integer;stdcall;external "User32.dll" name "IsClipboardFormatAvailable"; + //*********** + function GetDpiForMonitor(hmonitor:pointer; dpiType:integer;var dpiX:integer;var dpiY:integer):pointer;stdcall;external "Shcore.dll" name "GetDpiForMonitor"; + //Kernel32.dll + //进程和内存相关 + class function SetTimer(hWnd:pointer; nIDEvent:pointer; uElapse:integer;lpTimerFunc:pointer):integer;stdcall;external "User32.dll" name "SetTimer"; + class function KillTimer(hWnd:pointer; nIDEvent:pointer):integer;stdcall;external "User32.dll" name "KillTimer"; + + class function MultiByteToWideChar_a(CodePage:integer;dwFlags:integer;lpMultiByteStr:string;cbMultiByte:integer;var lpWideCharStr:string;cchWideChar:integer):integer;stdcall;external "Kernel32.dll" name "MultiByteToWideChar"; + class function GetModuleHandleA(name:pointer):pointer;stdcall;external "Kernel32.dll" name "GetModuleHandleA"; + class function GetComputerNameA(var lpBuffer:string;var nSize:integer):integer;stdcall;external "Kernel32.dll" name "GetComputerNameA"; + class function GetLastError():integer;stdcall;external "Kernel32.dll" name "GetLastError"; + class function GetEnvironmentVariableA(lpName:string;lpBuffer:string;nSize:integer):integer;stdcall;external "Kernel32.dll" name "GetEnvironmentVariableA"; + class function SetEnvironmentVariableA(lpName:string; lpValue:string):integer;stdcall;external "Kernel32.dll" name "SetEnvironmentVariableA"; + class function GetLogicalDriveStringsA(BUFSIZE:integer; szLogicDriveStrings:string):integer;stdcall;external "Kernel32.dll" name "GetLogicalDriveStringsA"; + class function GetDiskFreeSpaceExA(lpDirectoryName:string;var lpFreeBytesAvailableToCaller:int64;var lpTotalNumberOfBytes:int64;var lpTotalNumberOfFreeBytes:int64):integer;stdcall ;external "Kernel32.dll" name "GetDiskFreeSpaceExA"; + function GlobalAlloc(uFlags :integer;dwBytes:integer):pointer;stdcall;external "Kernel32.dll" name "GlobalAlloc"; + function CreateStreamOnHGlobal(hGlobal:pointer;fDeleteOnRelease:integer; var ppstm:pointer):pointer;stdcall;external "Ole32.dll" name "CreateStreamOnHGlobal"; + function GetHGlobalFromStream(pstm:pointer; var phglobal:pointer):pointer;stdcall;external "Ole32.dll" name "GetHGlobalFromStream"; + function GlobalLock(mem :pointer):pointer;stdcall;external "Kernel32.dll" name "GlobalLock"; + function GlobalUnlock(mem :pointer):integer;stdcall;external "Kernel32.dll" name "GlobalUnlock"; + function GlobalSize(menm:pointer):integer;stdcall;external "Kernel32.dll" name "GlobalSize"; + function GetStartupInfoA(lpStartupInfo:pointer):integer;stdcall ;external "Kernel32.dll" name "GetStartupInfoA" ; + function GetExitCodeProcess(hProcess:pointer;var lpExitCode:integer):integer;stdcall ;external "Kernel32.dll" name "GetExitCodeProcess" ; + function CreateProcessA(lpApplicationName:string;lpCommandLine:string;lpProcessAttributes:pointer; + lpThreadAttributes:pointer;bInheritHandles:integer;dwCreationFlags:integer;lpEnvironment:pointer; + lpCurrentDirectory:string;lpStartupInfo:pointer; + lpProcessInformation:pointer):integer;stdcall ;external "Kernel32.dll" name "CreateProcessA" ; + function CreatePipe(var hReadPipe:pointer;var hWritePipe : pointer; + lpPipeAttributes:pointer;nSize:integer):integer;stdcall;external "Kernel32.dll" name "CreatePipe"; + function PeekNamedPipe(hNamedPipe:pointer;var lpBuffer:string; nBufferSize:integer; var lpBytesRead:integer; + varlpTotalBytesAvail:integer;var lpBytesLeftThisMessage:integer):integer;stdcall;external "Kernel32.dll" name "PeekNamedPipe"; + function GetStdHandle(nStdHandle:integer):pointer;stdcall;external "Kernel32.dll" name "GetStdHandle"; + function SetStdHandle(nStdHandle:integer;hHandle:pointer):integer;stdcall;external "Kernel32.dll" name "SetStdHandle"; + function CreateFileA(var lpFileName:string;dwDesiredAccess:integer; + dwShareMode:integer;lpSecurityAttributes:pointer;dwCreationDisposition:integer; + dwFlagsAndAttributes:integer;hTemplateFile:pointer):pointer;stdcall;external "Kernel32.dll" name "CreateFileA"; + function WriteFile(hFile:pointer; lpBuffer:pointer;nNumberOfBytesToWrite:integer;var lpNumberOfBytesWritten:integer; lpOverlapped:pointer):integer;stdcall;external "Kernel32.dll" name "WriteFile"; + function WriteFile2(hFile:pointer; var lpBuffer:string;nNumberOfBytesToWrite:integer;var lpNumberOfBytesWritten:integer; lpOverlapped:pointer):integer;stdcall;external "Kernel32.dll" name "WriteFile"; + function ReadFile__(hFile:pointer;var lpBuffer:string;nNumberOfBytesToRead:integer;var lpNumberOfBytesRead:integer;pOverlapped:pointer):integer;stdcall;external "Kernel32.dll" name "ReadFile"; + function OpenProcess(dwDesiredAccess:integer;bInheritHandle:integer;dwProcessId:integer):pointer;stdcall;external "Kernel32.dll" name "OpenProcess"; + function GetHandleInformation(hObject:pointer;var lpdwFlags:integer):integer;stdcall;external "Kernel32.dll" name "GetHandleInformation"; + function CloseHandle(hObject:pointer):integer;stdcall ;external "Kernel32.dll" name "CloseHandle" ; + function _lclose(hObject:pointer):pointer;stdcall ;external "Kernel32.dll" name "_lclose" ; + function CreateToolhelp32Snapshot(dwFlags:integer;th32ProcessID:integer):pointer;stdcall;external "Kernel32.dll" name "CreateToolhelp32Snapshot"; + function Process32First(hSnapshot:pointer;lppe:pointer):integer;stdcall;external "Kernel32.dll" name "Process32First"; + function Process32Next(hSnapshot:pointer; lppe:pointer):integer;stdcall;external "Kernel32.dll" name "Process32Next"; + function Module32First(hSnapshot:pointer;lpme:pointer):integer;stdcall;external "Kernel32.dll" name "Module32First"; + function Module32Next(hSnapshot:pointer; lppe:pointer):integer;stdcall;external "Kernel32.dll" name "Module32Next"; + function GetCurrentDirectoryA(nBufferLength:integer; var lpBuffer:string):integer;stdcall;external "Kernel32.dll" name "GetCurrentDirectoryA"; + function SetCurrentDirectoryA(lpPathName:string):integer;stdcall;external "Kernel32.dll" name "SetCurrentDirectoryA"; + Function WinExec(lpCmdLine:string;nCmdShow:integer):integer;stdcall; external "kernel32.dll" name "WinExec" ; + function GetDriveTypeA(lpRootPathName:string):integer;stdcall; external "kernel32.dll" name "GetDriveTypeA" ; + (* + DRIVE_UNKNOWN = 0; {未知} + DRIVE_NO_ROOT_DIR = 1; {可移动磁盘} + DRIVE_REMOVABLE = 2; {软盘} + DRIVE_FIXED = 3; {本地硬盘} + DRIVE_REMOTE = 4; {网络磁盘} + DRIVE_CDROM = 5; {CD-ROM} + DRIVE_RAMDISK = 6; {RAM 磁盘} + *) + function EnumProcesses_(var lpidProcess:array of integer;cb:integer; var lpcbNeeded:integer):integer;stdcall;external "Kernel32.dll" name "K32EnumProcesses"; + function GetModuleFileNameExA(hProcess:pointer; hModule:pointer;var lpFilename:string;nSize:integer):integer;stdcall;external "Kernel32.dll" name "K32GetModuleFileNameExA"; + function QueryFullProcessImageNameA(hProcess:pointer; dwFlags:integer;var lpFilename:string;var nSize:integer):integer;stdcall;external "Kernel32.dll" name "QueryFullProcessImageNameA"; + function GetCurrentProcess():pointer;stdcall;external "Kernel32.dll" name "GetCurrentProcess"; + function OpenProcessToken(ProcessHandle:pointer;DesiredAccess:integer; var TokenHandle:pointer):integer;stdcall;external "Advapi32.dll" name "OpenProcessToken"; + //SeDebugPrivilege + function LookupPrivilegeValueA(var PolicyHandle:string;var Name:string; lpLuid:pointer):integer;stdcall;external "Advapi32.dll" name "LookupPrivilegeValueA"; + function AdjustTokenPrivileges(TokenHandle:pointer; DisableAllPrivileges:integer; NewState:pointer ; BufferLength:integer; + PreviousState:pointer; ReturnLength:pointer):integer;stdcall;external "Advapi32.dll" name "AdjustTokenPrivileges"; + //Snapshot from Psapi.lib – WinSDK V7.0* + (* #if (PSAPI_VERSION > 1) + #define EnumProcesses K32EnumProcesses + #define EnumProcessModules K32EnumProcessModules + #define EnumProcessModulesEx K32EnumProcessModulesEx + #define GetModuleBaseNameA K32GetModuleBaseNameA + #define GetModuleBaseNameW K32GetModuleBaseNameW + #define GetModuleFileNameExA K32GetModuleFileNameExA + #define GetModuleFileNameExW K32GetModuleFileNameExW + #define GetModuleInformation K32GetModuleInformation + #define EmptyWorkingSet K32EmptyWorkingSet + #define QueryWorkingSet K32QueryWorkingSet + #define QueryWorkingSetEx K32QueryWorkingSetEx + #define InitializeProcessForWsWatch K32InitializeProcessForWsWatch + #define GetWsChanges K32GetWsChanges + #define GetWsChangesEx K32GetWsChangesEx + #define GetMappedFileNameW K32GetMappedFileNameW + #define GetMappedFileNameA K32GetMappedFileNameA + #define EnumDeviceDrivers K32EnumDeviceDrivers + #define GetDeviceDriverBaseNameA K32GetDeviceDriverBaseNameA + #define GetDeviceDriverBaseNameW K32GetDeviceDriverBaseNameW + #define GetDeviceDriverFileNameA K32GetDeviceDriverFileNameA + #define GetDeviceDriverFileNameW K32GetDeviceDriverFileNameW + #define GetProcessMemoryInfo K32GetProcessMemoryInfo + #define GetPerformanceInfo K32GetPerformanceInfo + #define EnumPageFilesW K32EnumPageFilesW + #define EnumPageFilesA K32EnumPageFilesA + #define GetProcessImageFileNameA K32GetProcessImageFileNameA + #define GetProcessImageFileNameW K32GetProcessImageFileNameW + #endif *) + + + //定时器 + //function SetClassLongA(hWnd:pointer; nIDEvent:pointer):integer;stdcall;external "User32.dll" name " SetClassLongA"; + function GetDpiFromDpiAwarenessContext(v:pointer):integer;stdcall;external "User32.dll" name "GetDpiFromDpiAwarenessContext"; + function GetDpiForWindow(hwnd:pointer):integer;stdcall;external "User32.dll" name "GetDpiForWindow"; + function GetMonitorInfoA(hMonitor:pointer;lpmi:pointer):integer;stdcall;external "User32.dll" name "GetMonitorInfoA"; + function MonitorFromWindow(hwnd:pointer;dwFlags:integer):pointer;stdcall;external "User32.dll" name "MonitorFromWindow"; + function GetSysColor(idx:integer):integer;;stdcall;external "User32.dll" name "GetSysColor"; + function SystemParametersInfoA(uiAction:integer;uiParam:integer; pvParam:pointer; fWinIni:integer):integer;stdcall;external "User32.dll" name "SystemParametersInfoA"; + + //双击间隔 + function SetDoubleClickTime(it:integer):integer;stdcall;external "User32.dll" name "SetDoubleClickTime"; + function GetDoubleClickTime():integer;stdcall;external "User32.dll" name "GetDoubleClickTime"; + //热键 + function RegisterHotKey(hWnd:pointer;id:integer; fsModifiers:integer; vk:integer):integer;stdcall;external "User32.dll" name "RegisterHotKey"; + function UnregisterHotKey(hWnd:pointer;id:integer):integer;stdcall;external "User32.dll" name "UnregisterHotKey"; + function MapVirtualKeyA(uCode:integer; uMapType:integer):integer;stdcall;external "User32.dll" name "MapVirtualKeyA"; + function GetKeyNameTextA(lParam:integer;var lpString:string;cchSize:integer):integer;stdcall;external "User32.dll" name "GetKeyNameTextA"; + + //窗口相关 + class function FindWindowA(lpClassName:string;lpWindowName:string):pointer;stdcall;external "User32.dll" name "FindWindowA"; + class function GetForegroundWindow():pointer;stdcall;external "User32.dll" name "GetForegroundWindow"; + class function GetActiveWindow():pointer;stdcall;external "User32.dll" name "GetActiveWindow"; + class function SetActiveWindow(h:pointer):pointer;stdcall;external "user32.dll" name "SetActiveWindow"; + function UpdateLayeredWindow(hWnd:pointer;hdcDst:pointer;pptDst:pointer;psize:pointer;hdcSrc:pointer;pptSrc:pointer; crKey:integer;pblend:pointer; dwFlags:pointer):integer;stdcall;external "User32.dll" name "UpdateLayeredWindow"; + function GetFocus():pointer;stdcall;external "User32.dll" name "GetFocus"; + function SetLayeredWindowAttributes(hwnd:pointer;crKey:integer;bAlpha:byte;dwFlags:integer):integer;stdcall;external "User32.dll" name "SetLayeredWindowAttributes"; + class function IsWindow(hd:pointer):integer;stdcall;external "User32.dll" name "IsWindow"; + class function IsWindowVisible(hd:pointer):integer;stdcall;external "User32.dll" name "IsWindowVisible"; + function GetWindow(hd:pointer;cd:integer):pointer;stdcall;external "User32.dll" name "GetWindow"; + function GetNextWindow(hd:pointer;cd:integer):pointer;stdcall;external "User32.dll" name "GetNextWindow"; + function GetTopWindow(hd:pointer):pointer;stdcall;external "User32.dll" name "GetTopWindow"; + function IsChild(hd:pointer;cd:pointer):integer;stdcall;external "User32.dll" name "IsChild"; + function RegisterClassExA(wc:pointer):short;stdcall;external "User32.dll" name "RegisterClassExA"; + function EnableWindow(wc:pointer;b:integer):integer;stdcall;external "User32.dll" name "EnableWindow"; + //窗口操作 + function ShowWindow(hwd :pointer;f:integer):integer;stdcall;external "User32.dll" name "ShowWindow"; + function BringWindowToTop(hwd :pointer):integer;stdcall;external "User32.dll" name "BringWindowToTop"; + function SetForegroundWindow(hwd :pointer):integer;stdcall;external "User32.dll" name "SetForegroundWindow"; + function SetWindowPos(wd:pointer;hWndInsertAfter:pointer; + X:integer; Y:integer; cx:integer;cy:integer; uFlags:integer):pointer;stdcall;external "User32.dll" name "SetWindowPos"; + function MoveWindow(wd:pointer; X:integer; Y:integer; cx:integer;cy:integer; bRepaint:integer):pointer;stdcall;external "User32.dll" name "MoveWindow"; + //窗口大小 + function GetClientRect(hwnd :pointer;var rec:array of integer):integer;stdcall;external "User32.dll" name "GetClientRect"; + function GetWindowRect(hwnd :pointer;var rec:array of integer):integer;stdcall;external "User32.dll" name "GetWindowRect"; + function GetWindowInfo(hwnd :pointer;f:pointer):integer;stdcall;external "User32.dll" name "GetWindowInfo"; + + function GetSystemMetrics(ndx :integer):integer;stdcall;external "User32.dll" name "GetSystemMetrics"; + function ClientToScreen(hwnd :pointer;var p:array of integer):integer;stdcall;external "User32.dll" name "ClientToScreen"; + function ScreenToClient(hwnd :pointer;var p:array of integer):integer;stdcall;external "User32.dll" name "ScreenToClient"; + + function GetParent(hwnd :pointer):pointer;stdcall;external "User32.dll" name "GetParent"; + function SetParent(hwnd :pointer;phwnd:pointer):pointer;stdcall;external "User32.dll" name "SetParent"; + function UpdateWindow(hwnd :pointer):integer;stdcall;external "User32.dll" name "UpdateWindow"; + function GetUpdateRect(hWnd:pointer; var lpRect:array of integer;bErase:integer):integer;stdcall;external "User32.dll" name "GetUpdateRect"; + function InvalidateRect(hwnd :pointer;rec:array of integer;f:integer):integer;stdcall;external "User32.dll" name "InvalidateRect"; + function InvalidateRect2(hwnd :pointer;rec:pointer;f:integer):integer;stdcall;external "User32.dll" name "InvalidateRect"; + function ValidateRect(hwnd :pointer;rec:array of integer):integer;stdcall;external "User32.dll" name "ValidateRect"; + function SetFocus(hwnd :pointer):pointer;stdcall;external "User32.dll" name "SetFocus"; + function GetWindowTextLengthA(hwnd :pointer):integer;stdcall;external "User32.dll" name "GetWindowTextLengthA"; + function GetWindowTextA(hwnd :pointer;var s:string;l:integer):integer;stdcall;external "User32.dll" name "GetWindowTextA"; + function SetWindowTextA(hwnd :pointer;s:string):integer;stdcall;external "User32.dll" name "SetWindowTextA"; + function GetClassInfoExA(HH:pointer;lpszClass:string;lpwcx:pointer):integer;stdcall;external "User32.dll" name "GetClassInfoExA"; + function DefWindowProc(hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):integer;stdcall;external "User32.dll" name "DefWindowProc"; + {$IFDEF win64} + function SetWindowLongPtrA(HH:pointer;idx:integer;dwNewLong:pointer):pointer;stdcall;external "User32.dll" name "SetWindowLongPtrA"; + function GetWindowLongPtrA(HH:pointer;idx:integer):pointer;stdcall;external "User32.dll" name "GetWindowLongPtrA"; + function SetClassLongPtrA(HH:pointer;idx:integer;dwNewLong:pointer):pointer;stdcall;external "User32.dll" name "SetClassLongPtrA"; + function GetClassLongPtrA(HH:pointer;idx:integer):pointer;stdcall;external "User32.dll" name "GetClassLongPtrA"; + + {$ELSE} + function SetWindowLongPtrA(HH:pointer;idx:integer;dwNewLong:pointer):pointer;stdcall;external "User32.dll" name "SetWindowLongA"; + function GetWindowLongPtrA(HH:pointer;idx:integer):pointer;stdcall;external "User32.dll" name "GetWindowLongA"; + function SetClassLongPtrA(HH:pointer;idx:integer;dwNewLong:pointer):pointer;stdcall;external "User32.dll" name "SetClassLongA"; + function GetClassLongPtrA(HH:pointer;idx:integer):pointer;stdcall;external "User32.dll" name "GetClassLongA"; + {$ENDIF} + //function SetWindowLongA(HH:pointer;idx:integer;dwNewLong:pointer):pointer;stdcall;external "User32.dll" name "SetWindowLongA"; + //function GetWindowLongA(HH:pointer;idx:integer):pointer;stdcall;external "User32.dll" name "GetWindowLongA"; + function GetClassNameA(HH:pointer;var name:string;len:integer):pointer;stdcall;external "User32.dll" name "GetClassNameA"; + function CreateWindowExA(dwExStyle:integer; lpClassName:string; lpWindowName:string; + dwStyle:integer;x:integer;y:integer;nWidth:integer;nHeight:integer; + hWndParent:pointer;hMenu:pointer; hInstance:pointer;lpParam:pointer):pointer;stdcall;external "User32.dll" name "CreateWindowExA"; + function DestroyWindow(hWnd:pointer):integer;stdcall;external "User32.dll" name "DestroyWindow"; + //消息相关 + function CallWindowProcA(lpPrevWndFunc:pointer;hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):pointer;stdcall;external "User32.dll" name "CallWindowProcA"; + function DefWindowProcA(hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):pointer;stdcall;external "User32.dll" name "DefWindowProcA"; + function SendMessageA(hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):pointer;stdcall;external "User32.dll" name "SendMessageA"; + function PostMessageA(hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):integer;stdcall;external "User32.dll" name "PostMessageA"; + function GetMessageA(lpMsg:pointer;hWnd:pointer;wMsgFilterMin:integer;wMsgFilterMax:integer):integer;stdcall;external "User32.dll" name "GetMessageA"; + function PeekMessageA(lpMsg:pointer; hWnd:pointer; wMsgFilterMin:integer; wMsgFilterMax:integer;wRemoveMsg:integer):integer ;stdcall;external "User32.dll" name "PeekMessageA"; + function PostQuitMessage(code:integer);stdcall;external "User32.dll" name "PostQuitMessage"; + function PostThreadMessageA(idThread:integer ;Msg:integer;wParam:pointer;lParam:pointer):integer;stdcall;external "User32.dll" name "PostThreadMessageA"; + function TranslateMessage(msg:pointer):integer;stdcall;external "User32.dll" name "TranslateMessage"; + function DispatchMessageA(msg:pointer):integer;stdcall;external "User32.dll" name "DispatchMessageA"; + function TranslateAcceleratorA(hWnd:pointer; hAccTable:pointer;lpMsg:pointer):integer;stdcall;external "User32.dll" name "TranslateAcceleratorA"; + function CreateAcceleratorTableA(paccel:pointer;cAccel:integer):pointer;stdcall;external "User32.dll" name "CreateAcceleratorTableA"; + function DestroyAcceleratorTable(hAccel:pointer):integer;stdcall;external "User32.dll" name "DestroyAcceleratorTable"; + //按键状态 + Function GetKeyState(key:integer):short;stdcall;external "User32.dll" name "GetKeyState"; + Function GetAsyncKeyState(key:integer):short;stdcall;external "User32.dll" name "GetAsyncKeyState"; + + //光标 + function WindowFromPoint(X:integer; Y:integer):pointer;stdcall;external "User32.dll" name "WindowFromPoint"; + function ClipCursor(rec:array of integer):integer;stdcall;external "User32.dll" name "ClipCursor"; + + function GetCursorPos(var point: array of integer):integer;stdcall;external "User32.dll" name "GetCursorPos"; + function GetCursorInfo_( pci:pointer):integer;stdcall;external "User32.dll" name "GetCursorInfo"; + function ShowCursor(bshow:integer):integer;stdcall;external "User32.dll" name "ShowCursor"; + function SetCursorPos(x:integer;y:integer):integer;stdcall;external "User32.dll" name "SetCursorPos" ; + Function LoadCursorA(hd:pointer;n:string):pointer;stdcall;external "User32.dll" name "LoadCursorA"; + Function LoadCursorA2(hd:pointer;n:pointer):pointer;stdcall;external "User32.dll" name "LoadCursorA"; + Function SetCursor(hd:pointer):pointer;stdcall;external "User32.dll" name "SetCursor"; + function CreateCursor(hInst:pointer; xHotSpot:integer;yHotSpot:integer; nWidth:integer; nHeight:integer; pvANDPlane:pointer; pvXORPlane:pointer):pointer;stdcall;external "User32.dll" name "CreateCursor"; + //caret 插入符号 + function CreateCaret(hWnd :pointer;hBitmap:pointer;nWidth:integer;nHeight:integer):integer;stdcall;external "User32.dll" name "CreateCaret"; + function SetCaretPos(x:integer;y:integer):integer;stdcall;external "User32.dll" name "SetCaretPos"; + function HideCaret(hwnd :pointer):integer;stdcall;external "User32.dll" name "HideCaret"; + function DestroyCaret():integer;stdcall;external "User32.dll" name "DestroyCaret"; + function SetCaretBlinkTime(uMSeconds :integer):integer;stdcall;external "User32.dll" name "SetCaretBlinkTime"; + function ShowCaret(hwnd :pointer):integer;stdcall;external "User32.dll" name "ShowCaret"; + function GetCaretBlinkTime():integer;stdcall;external "User32.dll" name "GetCaretBlinkTime"; + function GetCaretPos(lp:array of integer):integer;stdcall;external "User32.dll" name "GetCaretPos"; + + function memcpy(dst:pointer;src:string;size_t:integer):pointer;cdecl;external "msvcrt.dll" name "memcpy"; + function memcpy2(var dst:string;src:pointer;size_t:integer):pointer;cdecl;external "msvcrt.dll" name "memcpy"; + function fopen(filename:string; mode:string):pointer;cdecl;external "msvcrt.dll" name "fopen"; + function fclose(f:pointer):integer;cdecl;external "msvcrt.dll" name "fclose"; + function LockFile(hFile:pointer; dwFileOffsetLow:integer; dwFileOffsetHigh:integer;nNumberOfBytesToLockLow:integer;nNumberOfBytesToLockHigh:integer):integer;stdcall;external "Kernel32.dll" name "LockFile"; + function UnlockFile(hFile:pointer; dwFileOffsetLow:integer; dwFileOffsetHigh:integer;nNumberOfBytesToLockLow:integer;nNumberOfBytesToLockHigh:integer):integer;stdcall;external "Kernel32.dll" name "UnlockFile"; + //icon + function DrawIcon(hDC:pointer;X:integer;Y:integer;hIcon:pointer):integer;stdcall;external "User32.dll" name "DrawIcon"; + function CreateIcon(hInstance:pointer;nWidth:integer;nHeight:integer;cPlanes:byte;cBitsPixel:byte ;lpbANDbits:pointer;lpbXORbits:pointer):pointer;stdcall;external "User32.dll" name "CreateIcon"; + function CreateIconIndirect(info:pointer):pointer;stdcall;external "User32.dll" name "CreateIconIndirect"; + function CreateIcon2(hInstance:pointer;nWidth:integer;nHeight:integer;cPlanes:byte;cBitsPixel:byte ;var lpbANDbits:string;var lpbXORbits:string):pointer;stdcall;external "User32.dll" name "CreateIcon"; + function DestroyIcon(icon:pointer):integer;stdcall;external "User32.dll" name "DestroyIcon"; + function GetIconInfo(hIcon:pointer; piconinfo:pointer):integer;stdcall;external "User32.dll" name "GetIconInfo"; + function DestroyCursor(cursor:pointer):integer;stdcall;external "User32.dll" name "DestroyCursor"; + //scroll + function SetScrollRange(hWnd:pointer;nBar:integer;nMinPos:integer; nMaxPos:integer;bRedraw:integer):integer;stdcall;external "User32.dll" name "SetScrollRange"; + function GetScrollRange(hWnd:pointer;nBar:integer;var nMinPos:integer; var nMaxPos:integer):integer;stdcall;external "User32.dll" name "GetScrollRange"; + function SetScrollPos(hWnd:pointer;nBar:integer;Pos:integer;bRedraw:integer):integer;stdcall;external "User32.dll" name "SetScrollPos"; + function GetScrollPos(hWnd:pointer;nBar:integer):integer;stdcall;external "User32.dll" name "GetScrollPos"; + function ScrollWindow(hWnd:pointer;x:integer;y:integer; var lpRect:array of integer;var lpClipRect:array of integer):integer;stdcall;external "User32.dll" name "ScrollWindow"; + function ScrollDC(hDC:pointer;dx:integer;dy:integer;var lprcScroll:array of integer; var lprcClip:array of integer;hrgnUpdate:pointer;lprcUpdate:pointer):integer;stdcall;external "User32.dll" name "ScrollDC"; + function GetScrollInfo(hWnd:pointer;x:integer;info:pointer):integer;stdcall;external "User32.dll" name "GetScrollInfo"; + function SetScrollInfo(hwnd:pointer; nBar:integer; lpsi:pointer;redraw:integer):integer;stdcall;external "User32.dll" name "SetScrollInfo"; + //menu菜单类***************************************************** + Function CreateMenu():pointer;stdcall;external "User32.dll" name "CreateMenu"; + Function CreatePopupMenu():pointer;stdcall;external "User32.dll" name "CreatePopupMenu"; + Function DestroyMenu(hMenu:pointer):integer;stdcall;external "User32.dll" name "DestroyMenu"; + Function IsMenu(hMenu:pointer):integer;stdcall;external "User32.dll" name "IsMenu"; + function DeleteMenu(hMenu:pointer;uPosition:integer;uFlags:integer):integer;stdcall;external "User32.dll" name "DeleteMenu"; //会销毁 + Function GetMenuInfo(hMenu:pointer;lpcmi:pointer):integer;stdcall;external "User32.dll" name "GetMenuInfo"; + Function SetMenuInfo(hMenu:pointer;lpcmi:pointer):integer;stdcall;external "User32.dll" name "SetMenuInfo"; + Function GetSubMenu(hMenu:pointer;nPos:integer):pointer;stdcall;external "User32.dll" name "GetSubMenu"; + Function GetSystemMenu(hWnd:pointer;bRevert:integer):pointer;stdcall;external "User32.dll" name "GetSystemMenu"; + + Function RemoveMenu( hMenu:pointer; uPosition:integer;uFlags:integer):integer;stdcall;external "User32.dll" name "RemoveMenu"; + Function SetMenuItemInfoA( hMenu:pointer; uItem:integer;fByPosition:integer;lpmii:pointer):integer;stdcall;external "User32.dll" name "SetMenuItemInfoA"; + Function InsertMenuItemA( hMenu:pointer;uItem:integer;fByPosition:integer;lpmii:pointer):integer;stdcall;external "User32.dll" name "InsertMenuItemA"; + function AppendMenuA(hMenu:pointer;uFlags:integer;uIDNewItem:pointer; var lpNewItem:string):integer;stdcall ;external "User32.dll" name "AppendMenuA"; + function HiliteMenuItem(hWnd:pointer; hMenu:pointer; uIDHiliteItem:integer; uHilite:integer):integer;stdcall;external "User32.dll" name "HiliteMenuItem"; + Function GetMenuItemInfoA( hMenu:pointer; uItem:integer;fByPosition:integer;lpmii:pointer):integer;stdcall;external "User32.dll" name "GetMenuItemInfoA"; + Function TrackPopupMenu( hMenu:pointer;uFlags:integer; x:integer; y:integer; nReserved:integer;hWnd:pointer; prcRect: array of integer):integer;stdcall;external "User32.dll" name "TrackPopupMenu"; + function TrackPopupMenuEx(hMenu:pointer;uFlags:integer;x:integer;y:integer;hwnd:pointer;lptpm:pointer):integer;stdcall;external "User32.dll" name "TrackPopupMenuEx"; + Function ModifyMenuA( hMenu:pointer; uItem:integer;fByPosition:integer;lpmii:pointer;lpNewItem:string):integer;stdcall;external "User32.dll" name "ModifyMenuA"; + Function GetMenuStringA(hMenu:pointer; uIDItem:integer; var lpString:string; nMaxCount:integer;uFlag:integer):integer;stdcall;external "User32.dll" name "GetMenuStringA"; + Function RedrawWindow(hWnd:pointer;lprcUpdate:array of integer; hrgnUpdate:pointer;flags:integer):integer;stdcall;external "User32.dll" name "RedrawWindow"; + + //***************window menu************************* + Function DrawMenuBar(hwd:pointer):integer;stdcall;external "User32.dll" name "DrawMenuBar"; + Function SetMenu(hwd:pointer;hmenu:pointer):integer;stdcall;external "User32.dll" name "SetMenu"; + Function GetMenu(hwd:pointer):pointer;stdcall;external "User32.dll" name "GetMenu"; + //********************************************** + function GetDesktopWindow():pointer;stdcall;external "User32.dll" name "GetDesktopWindow"; + Function GetDC(hwd :pointer):pointer;stdcall;external "User32.dll" name "GetDC"; + function GetWindowDC(hWnd:pointer):pointer;stdcall;external "User32.dll" name "GetWindowDC"; + Function GetDCEx(hwd :pointer;hrgnClip:pointer;flags:integer):pointer;stdcall;external "User32.dll" name "GetDCEx"; + Function LoadImageA(hinst:pointer;lpszName:string; uType:integer; cxDesired:integer;cyDesired:integer;fuLoad:integer):pointer;stdcall;external "User32.dll" name "LoadImageA"; + function LoadBitmapA(hin:pointer;lpsz:string):pointer;stdcall;external "User32.dll" name "LoadBitmapA"; + function LoadBitmapA2(hin:pointer;lpsz:pointer):pointer;stdcall;external "User32.dll" name "LoadBitmapA"; + Function LoadIconA(hd:pointer;n:string):pointer;stdcall;external "User32.dll" name "LoadIconA"; + Function LoadIconA2(hd:pointer;n:pointer):pointer;stdcall;external "User32.dll" name "LoadIconA"; + Function DrawTextA(hdc :pointer;txt:string;len:integer;rec:array of integer;fmt:integer):integer;stdcall;external "User32.dll" name "DrawTextA"; + Function DrawTextExA(hdc :pointer;txt:string;len:integer;rec:array of integer;fmt:integer;lpdtp:pointer):integer;stdcall;external "User32.dll" name "DrawTextExA"; + Function DrawFrameControl(DC:pointer; var LPRECT: array of integer ; dr1 :integer;dr2:integer):integer;stdcall;external "User32.dll" name "DrawFrameControl"; + function DrawEdge(hdc:pointer;var qrc:array of integer;edge:integer;grfFlags:integer):integer;;stdcall;external "User32.dll" name "DrawEdge"; + function DrawFocusRect(hDC:pointer; var rect:array of integer):integer;stdcall;external "User32.dll" name "DrawFocusRect"; + Function FillRect(dc:pointer;rec:array of integer;br:pointer):integer;stdcall;external "User32.dll" name "FillRect"; + Function InvertRect(dc:pointer;rec:array of integer;br:pointer):integer;stdcall;external "User32.dll" name "InvertRect"; + function ReleaseDC(hwd :pointer;hdc:pointer):integer;stdcall;external "User32.dll" name "ReleaseDC"; + function BeginPaint(hwd :pointer;strc:pointer):pointer;stdcall;external "User32.dll" name "BeginPaint"; + function EndPaint(hwd :pointer;strc:pointer):integer;stdcall;external "User32.dll" name "EndPaint"; + function WindowFromDC(dc:pointer):pointer;stdcall;external "User32.dll" name "WindowFromDC"; + function MessageBoxA(hwnd :pointer;txt:string;cap:string;flag:integer):integer;stdcall;external "User32.dll" name "MessageBoxA"; + function TrackMouseEvent(lpEventTrack:pointer):integer;stdcall;external "User32.dll" name "TrackMouseEvent"; + //Gdi32.dll + function SaveDC(hdc :pointer):integer;stdcall;external "Gdi32.dll" name "SaveDC"; + function RestoreDC(hdc :pointer;nSavedDC:integer):integer;stdcall;external "Gdi32.dll" name "RestoreDC"; + function DeleteDC(hdc :pointer):integer;stdcall;external "Gdi32.dll" name "DeleteDC"; + { + https://msdn.microsoft.com/query/dev14.query?appId=Dev14IDEF1&l=ZH-CN&k=k(WINGDI%2FCreateCompatibleDC);k(CreateCompatibleDC);k(DevLang-C%2B%2B);k(TargetOS-Windows)&rd=true + If the function succeeds, the return value is the handle to a memory DC. + If the function fails, the return value is NULL. + } + function CreateCompatibleDC(hdc :pointer):pointer;stdcall;external "Gdi32.dll" name "CreateCompatibleDC"; + { + https://msdn.microsoft.com/query/dev14.query?appId=Dev14IDEF1&l=ZH-CN&k=k(WINGDI%2FGetTextColor);k(GetTextColor);k(DevLang-C%2B%2B);k(TargetOS-Windows)&rd=true + } + Function GetTextColor(hdc :pointer):integer;stdcall;external "Gdi32.dll" name "GetTextColor"; + Function SetTextColor(hdc :pointer;col:integer):integer;stdcall;external "Gdi32.dll" name "SetTextColor"; + function GetTextExtentPoint32A(hdc:pointer;lpString:string;c:integer; psizl:pointer):integer;stdcall;external "Gdi32.dll" name "GetTextExtentPoint32A"; + function GetTextExtentPoint32A2(hdc:pointer;lpString:string;c:integer; var psizl:array of integer):integer;stdcall;external "Gdi32.dll" name "GetTextExtentPoint32A"; + function GetCharWidthA(hdc:pointer;iFirst:integer;iLast:integer;var lpBuffer:array of integer):integer;stdcall;external "Gdi32.dll" name "GetCharWidthA"; + function GetCharABCWidthsA(hdc:pointer;wFirst:integer;wLast:integer; lpABC:pointer):integer;stdcall;external "Gdi32.dll" name "GetCharABCWidthsA"; + function GetFontLanguageInfo(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "GetFontLanguageInfo"; + Function SetDCPenColor(hdc :pointer;col:integer):integer;stdcall;external "Gdi32.dll" name "SetDCPenColor"; + Function GetDCPenColor(hdc :pointer):integer;stdcall;external "Gdi32.dll" name "GetDCPenColor"; + Function GetDCBrushColor(hdc :pointer):integer;stdcall;external "Gdi32.dll" name "GetDCBrushColor"; + Function SetDCBrushColor(hdc :pointer;col:integer):integer;stdcall;external "Gdi32.dll" name "SetDCBrushColor"; + { + https://msdn.microsoft.com/query/dev14.query?appId=Dev14IDEF1&l=ZH-CN&k=k(WINGDI%2FRectangle);k(Rectangle);k(DevLang-C%2B%2B);k(TargetOS-Windows)&rd=true + } + Function Rectangle(hdc :pointer;l:integer;t:integer;r:integer;b:integer):integer;stdcall;external "Gdi32.dll" name "Rectangle"; + Function Ellipse(hdc :pointer;l:integer;t:integer;r:integer;b:integer):integer;stdcall;external "Gdi32.dll" name "Ellipse"; + Function RoundRect(hdc :pointer;l:integer;t:integer;r:integer;b:integer;wid:integer;ht:integer):integer;stdcall;external "Gdi32.dll" name "RoundRect"; + Function Chord(hdc :pointer;l:integer;t:integer;r:integer;b:integer;wid:integer;ht:integer):integer;stdcall;external "Gdi32.dll" name "Chord"; + Function Pie(hdc :pointer;nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer;nXRadial1:integer;nYRadial1:integer;nXRadial2:integer;nYRadial2:integer):integer;stdcall;external "Gdi32.dll" name "Pie"; + Function SetArcDirection(hdc :pointer;direct:integer):integer;stdcall;external "Gdi32.dll" name "SetArcDirection"; + Function Arc(hdc :pointer;nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer;nXRadial1:integer;nYRadial1:integer;nXRadial2:integer;nYRadial2:integer):integer;stdcall;external "Gdi32.dll" name "Arc"; + Function Polygon(hdc :pointer;points:array of integer;n:integer):integer;stdcall;external "Gdi32.dll" name "Polygon"; + Function PolyBezier(hdc :pointer;points:array of integer;n:integer):integer;stdcall;external "Gdi32.dll" name "PolyBezier"; + Function SetPolyFillMode(hdc :pointer;md:integer):integer;stdcall;external "Gdi32.dll" name "SetPolyFillMode"; + Function Polyline(hdc :pointer;points:array of integer;n:integer):integer;stdcall;external "Gdi32.dll" name "Polyline"; + Function PolyPolyline(hdc :pointer;points:array of integer;pc:array of integer;n:integer):integer;stdcall;external "Gdi32.dll" name "PolyPolyline"; + function ExtFloodFill(hdc:pointer;nXStart:integer; nYStart:integer;crColor:integer;fuFillType:integer):integer;stdcall;external "Gdi32.dll" name "ExtFloodFill"; + function SetTextJustification(hdc:pointer;nBreakExtra:integer;nBreakCount:integer):integer;stdcall;external "Gdi32.dll" name "SetTextJustification"; + function TransparentBlt( hdcDest:pointer; xoriginDest:integer; yoriginDest:integer; wDest:integer; hDest:integer; + hdcSrc:pointer; xoriginSrc:integer; yoriginSrc:integer; wSrc:integer; hSrc:integer; crTransparent:integer):integer;stdcall;external "Msimg32.dll" name "TransparentBlt"; + function AlphaBlend( hdcDest:pointer; xoriginDest:integer; yoriginDest:integer; wDest:integer; hDest:integer; + hdcSrc:pointer; xoriginSrc:integer; yoriginSrc:integer; wSrc:integer; hSrc:integer; ftn:integer):integer;stdcall;external "Msimg32.dll" name "AlphaBlend"; + function SetWindowExtEx(hdc:pointer;nXExtent:integer;nYExtent:integer;lpSize:pointer):integer;stdcall;external "Gdi32.dll" name "SetWindowExtEx"; + function IntersectClipRect(hdc :pointer;nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer):integer;stdcall;external "Gdi32.dll" name "IntersectClipRect"; + function GetDIBits(hdc:pointer; hbm:pointer;start:integer; cLines:integer;lpvBits:pointer;lpbmi:pointer; usage:integer):integer;stdcall;external "Gdi32.dll" name "GetDIBits"; + function GetDIBits2(hdc:pointer; hbm:pointer;start:integer; cLines:integer;var lpvBits:string;lpbmi:pointer; usage:integer):integer;stdcall;external "Gdi32.dll" name "GetDIBits"; + function SetDIBits2(hdc:pointer; hbmp:pointer;uStartScan:integer;cScanLines:integer;var lpvBits:string;lpbmi:pointer;fuColorUse:integer):integer;stdcall;external "Gdi32.dll" name "SetDIBits"; + Function GetBitmapBits(bmp :pointer;len:integer;bf:pointer{var bf: array of integer }):integer;stdcall;external "Gdi32.dll" name "GetBitmapBits"; + Function GetBitmapBits2(bmp :pointer;len:integer;var bf:string):integer;stdcall;external "Gdi32.dll" name "GetBitmapBits"; + Function SetBitmapBits(bmp :pointer;len:integer;bf:pointer{var bf: array of integer }):integer;stdcall;external "Gdi32.dll" name "SetBitmapBits"; + Function SetBitmapBits2(bmp :pointer;len:integer;var bf:string):integer;stdcall;external "Gdi32.dll" name "SetBitmapBits"; + Function SetBitmapDimensionEx(hBitmap:pointer;nWidth:integer; nHeight:integer;VAR lpSize:array of integer):integer;stdcall;external "Gdi32.dll" name "SetBitmapDimensionEx"; + Function GetBitmapDimensionEx(hBitmap:pointer;VAR ps:array of integer):integer;stdcall;external "Gdi32.dll" name "GetBitmapDimensionEx"; + { + https://msdn.microsoft.com/query/dev14.query?appId=Dev14IDEF1&l=ZH-CN&k=k(WINGDI%2FGetTextMetrics);k(GetTextMetrics);k(DevLang-C%2B%2B);k(TargetOS-Windows)&rd=true + } + Function GetTextMetricsA(hdc :pointer;TM:pointer):integer;stdcall;external "Gdi32.dll" name "GetTextMetricsA"; + Function MoveToEx(hdc :pointer;x:integer;y:integer;var point:array of integer):integer;stdcall;external "Gdi32.dll" name "MoveToEx" keepresident; + Function LineTo(hdc :pointer;x:integer;y:integer):integer;stdcall;external "Gdi32.dll" name "LineTo" keepresident; + Function TextOutA(hdc :pointer;X:integer;y:integer;txt:string;len:integer):integer;stdcall;external "Gdi32.dll" name "TextOutA"; + //gdi path******************** + function BeginPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "BeginPath"; + function EndPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "EndPath"; + function FillPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "FillPath"; + function StrokePath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "StrokePath"; + function StrokeAndFillPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "StrokeAndFillPath"; + function AbortPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "AbortPath"; + function CloseFigure(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "CloseFigure"; + function FlattenPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "FlattenPath"; + function GetMiterLimit(hdc:pointer;var plimit:Single):integer;stdcall;external "Gdi32.dll" name "GetMiterLimit"; + function GetPath(hdc:pointer;apt:array of integer;aj:integer;cpt:integer):integer;stdcall;external "Gdi32.dll" name "GetPath"; + function PathToRegion(hdc:pointer):pointer;stdcall;external "Gdi32.dll" name "PathToRegion"; + function SetMiterLimit(hdc:pointer;limit:Single;var od:Single):integer;stdcall;external "Gdi32.dll" name "SetMiterLimit"; + function WidenPath(hdc:pointer):integer;stdcall;external "Gdi32.dll" name "WidenPath"; + function PatBlt(hdc:pointer;nleftrect:integer;ntoprect:integer;nwidth:integer;nheight:pointer;fdwrop:integer):integer;stdcall;external "Gdi32.dll" name "PatBlt"; + + Function BitBlt(hdcDest:pointer;nXDest:integer;nYDest:integer;nWidth:integer;nHeight:integer; + hdcSrc :pointer;nXSrc:integer;nYSrc:integer;dwRop:integer):integer;stdcall;external "Gdi32.dll" name "BitBlt"; + Function StretchBlt(hdcDest:pointer;nXOriginDest:integer; nYOriginDest:integer;nWidthDest:integer; nHeightDest:integer; + hdcSrc :pointer;nXOriginSrc:integer;nYOriginSrc:integer; nWidthSrc:integer; nHeightSrc:integer; dwRop:integer + ):integer;stdcall;external "Gdi32.dll" name "StretchBlt"; + Function SetStretchBltMode(hdc:pointer;iStretchMode:integer):integer;stdcall;external "Gdi32.dll" name "SetStretchBltMode"; + function SelectObject(hdc :pointer;gdiobj:pointer):pointer;stdcall;external "Gdi32.dll" name "SelectObject"; + function DeleteObject(gdiobj :pointer):integer;stdcall;external "Gdi32.dll" name "DeleteObject"; + function CreateBitmap(nWidth:integer; nHeight:integer; cPlanes:integer;cBitsPerPel:integer; + lpvBits:pointer):pointer;stdcall;external "Gdi32.dll" name "CreateBitmap"; + function CreateBitmap2(nWidth:integer; nHeight:integer; cPlanes:integer;cBitsPerPel:integer; + var lpvBits:string):pointer;stdcall;external "Gdi32.dll" name "CreateBitmap"; + function CreateBitmaplndirect(bmp:pointer):pointer;stdcall;external "Gdi32.dll" name "CreateBitmaplndirect"; + function CreateCompatibleBitmap(hdc:pointer;x:integer;y:integer):pointer;stdcall;external "Gdi32.dll" name "CreateCompatibleBitmap"; + function CreatePen(fnPenStyle:integer;nWidth:integer;crColor:integer):pointer;stdcall;external "Gdi32.dll" name "CreatePen"; + function CreatePenIndirect(LOGPEN :pointer):pointer;stdcall;external "Gdi32.dll" name "CreatePen"; + function CreateSolidBrush(crColor:integer):pointer;stdcall;external "Gdi32.dll" name "CreateSolidBrush"; + function CreateBrushIndirect(Logb:pointer):pointer;stdcall;external "Gdi32.dll" name "CreateBrushIndirect"; + function CreatePatternBrush(bmp:pointer):pointer;stdcall;external "Gdi32.dll" name "CreatePatternBrush"; + function CreateHatchBrush(fnStyle:integer;clrref:integer):pointer;stdcall;external "Gdi32.dll" name "CreateHatchBrush"; + function CreateFontA(nHeight:integer;nWidth:integer;nEscapement:integer; nOrientation:integer;fnWeight:integer; + fdwItalic:integer;fdwUnderline:integer;fdwStrikeOut:integer;fdwCharSet:integer;fdwOutputPrecision:integer; + fdwClipPrecision:integer; fdwQuality:integer; fdwPitchAndFamily:integer;lpszFace:string):pointer;stdcall;external "Gdi32.dll" name "CreateFontA"; + function CreateFontIndirectA(lplf:pointer):pointer;stdcall;external "Gdi32.dll" name "CreateFontIndirectA"; + //https://msdn.microsoft.com/zh-cn/library/windows/desktop/dd183436(v=vs.85).aspx clipping functions + function GetStockObject(fnObject:integer):pointer;stdcall;external "Gdi32.dll" name "GetStockObject"; + function CreatePalette(LOGPALETTE:pointer):pointer;stdcall;external "Gdi32.dll" name "CreatePalette"; + function GetDeviceCaps(dc:pointer;idex:integer):integer;stdcall;external "Gdi32.dll" name "GetDeviceCaps"; + function SetPixel(dc:pointer;x:integer;y:integer;col:integer):integer;stdcall;external "Gdi32.dll" name "SetPixel"; + function CreateEllipticRgn(nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer):pointer;stdcall;external "Gdi32.dll" name "CreateEllipticRgn"; + + function CreatePolyPolygonRgn(ps:array of integer;pc:array of integer;len:integer;md:integer):pointer;stdcall;external "Gdi32.dll" name "CreatePolyPolygonRgn"; + function SetROP2(hdc:pointer;fnDrawMode:integer):integer;stdcall;external "Gdi32.dll" name "SetROP2"; + function CreateRectRgn(nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer):pointer;stdcall;external "Gdi32.dll" name "CreateRectRgn"; + function CreatePolygonRgn(ps:array of integer;len:integer;md:integer):pointer;stdcall;external "Gdi32.dll" name "CreatePolygonRgn"; + function CombineRgn(hrgnDest:pointer;hrgnSrc1:pointer;hrgnSrc2:pointer; fnCombineMode:integer):integer;stdcall;external "Gdi32.dll" name "CombineRgn"; + function SelectClipRgn(dc:pointer;rgn:pointer):integer;stdcall;external "Gdi32.dll" name "SelectClipRgn"; + function PtVisible(dc:pointer;x:integer;y:integer):integer;stdcall;external "Gdi32.dll" name "PtVisible"; + function RectVisible(dc:pointer;rect:array of integer):integer;stdcall;external "Gdi32.dll" name "RectVisible"; + function ExcludeClipRect(hdc:pointer;nLeftRect:integer;nTopRect:integer;nRightRect:integer;nBottomRect:integer;):integer;stdcall;external "Gdi32.dll" name "ExcludeClipRect"; + function SetWindowOrgEx(hdc:pointer;x:integer;y:integer;var lppt: array of integer):integer;stdcall;external "Gdi32.dll" name "SetWindowOrgEx"; + function SetViewportOrg(dc:pointer;x:integer;y:integer):integer;stdcall;external "Gdi32.dll" name "SetViewportOrg"; + function SetViewportOrgEx(dc:pointer;x:integer;y:integer;var pt:array of integer):integer;stdcall;external "Gdi32.dll" name "SetViewportOrgEx"; + Function FillRgn(dc:pointer;rgn:pointer;br:pointer):integer;stdcall;external "Gdi32.dll" name "FillRgn"; + Function SetTextAlign(dc:pointer;fMode:integer):integer;stdcall;external "Gdi32.dll" name "SetTextAlign"; + Function SetWorldTransform(dc:pointer;lpXform:pointer):integer;stdcall;external "Gdi32.dll" name "SetWorldTransform"; + Function SetGraphicsMode(dc:pointer;iMode:integer):integer;stdcall;external "Gdi32.dll" name "SetGraphicsMode"; + Function GetGraphicsMode(dc:pointer):integer;stdcall;external "Gdi32.dll" name "GetGraphicsMode"; + Function SetMapMode(dc:pointer;iMode:integer):integer;stdcall;external "Gdi32.dll" name "SetMapMode"; + Function SetBkColor(dc:pointer;clrref:integer):integer;stdcall;external "Gdi32.dll" name "SetBkColor"; + Function GetBkColor(dc:pointer):integer;stdcall;external "Gdi32.dll" name "GetBkColor"; + Function SetBkMode(dc:pointer;clrref:integer):integer;stdcall;external "Gdi32.dll" name "SetBkMode"; + Function GetBkMode(dc:pointer):integer;stdcall;external "Gdi32.dll" name "GetBkMode"; + Function GetObjectA(hgdiobj:pointer;cbBuffer:integer;lpvObject:pointer):integer;stdcall;external "Gdi32.dll" name "GetObjectA"; + //**************Comctl32.dll*************************************************************** + procedure GetEffectiveClientRect(hWnd:pointer;lprc:array of integer;lpInfo:array of integer);stdcall;external "Comctl32.dll" name "GetEffectiveClientRect"; + function ImageList_Add(himl:pointer;hbmImage:pointer; hbmMask:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_Add"; + function ImageList_AddMasked(himl:pointer;hbmImage:pointer; crMask:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_AddMasked"; + function ImageList_BeginDrag(himlTrack:pointer; iTrack:integer;dxHotspot:integer;dyHotspot:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_BeginDrag"; + function ImageList_DragMove(x:integer;y:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_DragMove"; + function ImageList_DragEnter(hwndLock:pointer;x:integer;y:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_DragEnter"; + function ImageList_DragLeave(hwndLock:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_DragLeave"; + procedure ImageList_EndDrag();stdcall;external "Comctl32.dll" name "ImageList_EndDrag"; + function ImageList_Create(cx:integer; cy:integer; flags:integer; cInitial:integer;cGrow:integer):pointer;stdcall;external "Comctl32.dll" name "ImageList_Create"; + function ImageList_Draw(himl:pointer;i:integer;hdcDst:pointer;x:integer;y:integer;fStyle:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_Draw"; + function ImageList_Destroy(himl:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_Add"; + function ImageList_Replace(himl:pointer;id:integer;hbmImage:pointer; hbmMask:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_Replace"; + function ImageList_Remove(himl:pointer;id:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_Remove"; + function ImageList_SetBkColor(himl:pointer;clrBk:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_SetBkColor"; + function ImageList_LoadImageA2(hi:pointer;lpbmp:pointer;cx:integer;cGrow:integer; crMask:integer;uType:integer;uFlags:integer):pointer;stdcall;external "Comctl32.dll" name "ImageList_LoadImageA"; + function ImageList_GetBkColor(himl:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_GetBkColor"; + function ImageList_GetDragImage(ppt:pointer;pptHotspot:pointer):pointer;stdcall;external "Comctl32.dll" name "ImageList_GetDragImage"; + function ImageList_GetImageCount(himl:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_GetImageCount"; + function ImageList_SetImageCount(himl:pointer;clrBk:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_SetImageCount"; + function ImageList_Copy(himlDst:pointer;iDst:integer; himlSrc:pointer;iSrc:integer;uFlags:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_Copy"; + function ImageList_Duplicate(himl:pointer):pointer;stdcall;external "Comctl32.dll" name "ImageList_Duplicate"; + function ImageList_Merge(himl1:pointer;i1:integer;himl2:pointer;i2:integer;dx:integer;dy:integer):pointer;stdcall;external "Comctl32.dll" name "ImageList_Merge"; + function ImageList_SetDragCursorImage(himlDrag:pointer;iDrag:integer;dxHotspot:integer;dyHotspot:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_SetDragCursorImage"; + function ImageList_GetImageInfo(himl:pointer; i:integer;pImageInfo:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_GetImageInfo"; + function ImageList_ReplaceIcon(himl:pointer;i:integer;hicon:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_ReplaceIcon"; + function ImageList_SetIconSize(himl:pointer;cx:integer;cy:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_SetIconSize"; + function ImageList_GetIconSize(himl:pointer;var cx:integer;var cy:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_GetIconSize"; + function ImageList_GetIcon(himl:pointer;i:integer;flags:integer):pointer;stdcall;external "Comctl32.dll" name "ImageList_GetIcon"; + function ImageList_DrawIndirect(pimldp:pointer):pointer;stdcall;external "Comctl32.dll" name "ImageList_DrawIndirect"; + function ImageList_DragShowNolock(fShow:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_DragShowNolock"; + function InitCommonControlsEx(it:pointer):integer;stdcall;external "Comctl32.dll" name "InitCommonControlsEx"; + function Comctl32DllGetVersion(it:pointer):pointer;stdcall;external "Comctl32.dll" name "DllGetVersion"; + function GetOpenFileNameA(LPOPENFILENAMEA:pointer):integer;stdcall;external "Comdlg32.dll" name "GetOpenFileNameA" keepresident; + function GetSaveFileNameA(LPOPENFILENAMEA:pointer):integer;stdcall;external "Comdlg32.dll" name "GetSaveFileNameA"; + function ChooseFontA(LOGFONTA:pointer):integer;stdcall;external "Comdlg32.dll" name "ChooseFontA"; + function ChooseColorA(LOGFONTA:pointer):integer;stdcall;external "Comdlg32.dll" name "ChooseColorA"; + //************************************ + function Shell_NotifyIconA(dwMessage:integer; lpData:pointer):integer;stdcall;external "Shell32.dll" name "Shell_NotifyIconA"; + function ILCreateFromPathA(pszPath:string):pointer;stdcall;external "Shell32.dll" name "ILCreateFromPathA"; + procedure ILFree(pidl:pointer);stdcall;external "Shell32.dll" name "ILFree"; + function SHBrowseForFolderA(LPITEMIDLIST:pointer):pointer;stdcall;external "Shell32.dll" name "SHBrowseForFolderA"; + function SHGetPathFromIDListA(LPBROWSEINFOA:pointer;var buf:string ):integer;stdcall;external "Shell32.dll" name "SHGetPathFromIDListA"; + function shell32DllGetVersion(it:pointer):pointer;stdcall;external "Shell32.dll" name "DllGetVersion"; + function ShellExecuteExA(pExecInfo :pointer):integer;stdcall;external "Shell32.dll" name "ShellExecuteExA"; + function SHGetFolderPathA(hwnd:pointer;csidl:integer;hToken:pointer;dwFlags:integer;var pszPath:string):integer;stdcall;external "Shell32.dll" name "SHGetFolderPathA"; + //socket + function socket(af:integer;tp:integer;protocol:integer):pointer;stdcall;external "Ws2_32.dll" name "socket"; + function WSAStartup(af:SHORT;DA:pointer):integer;stdcall;external "Ws2_32.dll" name "WSAStartup"; + function WSACleanup():integer;stdcall;external "Ws2_32.dll" name "WSACleanup"; + function htonl(hostlong:integer):integer;stdcall;external "Ws2_32.dll" name "htonl"; + function htons(hostshort:short):short;stdcall;external "Ws2_32.dll" name "htons"; + function ntohs(hostshort:short):short;stdcall;external "Ws2_32.dll" name "ntohs"; + function bind(s:pointer;name:pointer;len:integer):integer;stdcall;external "Ws2_32.dll" name "bind"; + function accept(s:pointer;name:pointer;var len:integer):pointer;stdcall;external "Ws2_32.dll" name "accept"; + function send(s:pointer;bufer:string;len:integer;flag:integer):integer;stdcall;external "Ws2_32.dll" name "send"; + function recv(s:pointer;var bufer:string;len:integer;flag:integer):integer;stdcall;external "Ws2_32.dll" name "recv"; + function listen(s:pointer;port:integer):integer;stdcall;external "Ws2_32.dll" name "listen"; + function closesocket(s:pointer):integer;stdcall;external "Ws2_32.dll" name "closesocket"; + function connect(s:pointer;name:pointer;len:integer):integer;stdcall;external "Ws2_32.dll" name "connect"; + function inet_addr(s:string):integer;stdcall;external "Ws2_32.dll" name "inet_addr"; + function WSAGetLastError():integer;stdcall;external "Ws2_32.dll" name "WSAGetLastError"; + function inet_ntoa(ad:integer):string;stdcall;external "Ws2_32.dll" name "inet_ntoa"; + function shutdown(s:pointer;how:integer):integer;stdcall;external "Ws2_32.dll" name "shutdown"; + function WSAAsyncSelect(s:pointer;hWnd:pointer;wMsg:integer;lEvent:integer):integer;stdcall;external "Ws2_32.dll" name "WSAAsyncSelect"; + function ioctlsocket(s:pointer;cmd:integer;var argp:integer):integer;stdcall;external "Ws2_32.dll" name "ioctlsocket"; + function setsockopt(s:pointer;level:integer;optname:integer;optval:string;optlen:integer):integer;stdcall;external "Ws2_32.dll" name "setsockopt"; + function getsockopt(s:pointer;level:integer;optname:integer;var optval:string;var optlen:integer):integer;stdcall;external "Ws2_32.dll" name "getsockopt"; + + +end + +implementation +initialization + +finalization + +end. \ No newline at end of file