liujianjun
/
tslediter
3
0
Fork 1
Code Issues Pull Requests Projects Releases Wiki Activity

界面库 

整理代码
This commit is contained in:
JianjunLiu 2022-10-11 10:34:04 +08:00
parent 25cc144bb7
commit 3546020970
7 changed files with 202 additions and 277 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
designer/udesignerproject.tsf
View File

@ -1801,10 +1801,6 @@ type TFileTree = class(TTreeCtl)
end end
fprojectpath; fprojectpath;
fio; fio;
function CreateTreeNode();override;
begin
return New TTNode(self);
end
function GetInfo(dir,files); //获得信息 function GetInfo(dir,files); //获得信息
begin begin
leafs := array(); leafs := array();
@ -1902,10 +1898,12 @@ type TFileTree = class(TTreeCtl)
fio := ioFileseparator(); fio := ioFileseparator();
ImageList := CreateaImageList(self,FImageIdName); ImageList := CreateaImageList(self,FImageIdName);
hasline := true; hasline := true;
nodecreator := class(TTNode);
FPNode := CreateTreeNode(); FPNode := CreateTreeNode();
FPNode.Caption := "当前工程"; FPNode.Caption := "当前工程";
FPNode.FType := "dir"; FPNode.FType := "dir";
FPNode.parent := RootNode; FPNode.parent := RootNode;
//SetSel(FPNode); //SetSel(FPNode);
end end
function GetNodesByName(nds,n); function GetNodesByName(nds,n);

6
designer/utslvcldcomponents.tsf
View File

@ -550,6 +550,7 @@ type TDComponent = class()
nn := cn+inttostr(i++); nn := cn+inttostr(i++);
if nn in TemporaryNotName then continue; if nn in TemporaryNotName then continue;
obj.name := nn; obj.name := nn;
if obj.Name<>nn then continue;
SetComponentProperties("caption",nn); SetComponentProperties("caption",nn);
oname := nn;//obj.name; oname := nn;//obj.name;
end end
@ -812,10 +813,6 @@ type TComponentTree = class(TTreeView) //
begin begin
if not FLoading then inherited; if not FLoading then inherited;
end end
function CreateTreeNode();override; //构造节点
begin
return new TComponentTreeNode(self(true));
end
function Recycling();override; //»ØÊÕ function Recycling();override; //»ØÊÕ
begin begin
FDesigner := nil; FDesigner := nil;
@ -826,6 +823,7 @@ type TComponentTree = class(TTreeView) //
inherited; inherited;
asdomain := true; asdomain := true;
FDesigner := AOwner; FDesigner := AOwner;
nodecreator := class(TComponentTreeNode);
end end
function GetRootNode();override; //¸ù½Úµã function GetRootNode();override; //¸ù½Úµã
begin begin

204
funcext/tvclib/tcontrol.tsf
View File

@ -11,36 +11,35 @@ type tcontrol = class(tcomponent)
{$define gdipaint} {$define gdipaint}
{$endif} {$endif}
uses utslvclauxiliary,utslvclmemstruct,utslvclevent,utslvclgdi,utslvclaction,utslvclmenu; uses utslvclauxiliary,utslvclmemstruct,utslvclevent,utslvclgdi,utslvclaction,utslvclmenu;
private //计量处数据 private //私有变量
#!begin //members #!begin //members
STATIC FSIDC; STATIC FSIDC; //控件id生成器
FActionLink: TControlActionLink; FActionLink: TControlActionLink;
FCanvas: TCanvas; FCanvas: TCanvas; //为可视控件提供画板
FMessagehandle;//消息表 FMessagehandle;//消息表
FtagPAINTSTRUCT; FtagPAINTSTRUCT; //绘制区域
//;数据
//private
FAnchors; FAnchors;
FAnchorBounds; FAnchorBounds;
FCaption;//标题 FCaption;//标题
FCaptureMouseButtons;//鼠标样式 FCaptureMouseButtons;//鼠标样式
FColor;//颜色 FColor;//颜色
FBKBitmap; FBKBitmap; //背景图片
FControlFlags;//控件标记 FControlFlags;//控件标记
FControlStyle;//控件样式 FControlStyle;//控件样式
FDesktopFont; //FDesktopFont;
FDockOrientation; //FDockOrientation;
FDragCursor; FDragCursor;
FFont; //字体 FFont; //字体
FHostDockSite: TWinControl; FBorder; //边框
FLastDoChangeBounds: TRect; //FHostDockSite: TWinControl;
FLastDoChangeClientSize: TPoint; //FLastDoChangeBounds: TRect;
FLastResizeClientHeight: integer; //FLastDoChangeClientSize: TPoint;
FLastResizeClientWidth: integer; //FLastResizeClientHeight: integer;
FLastResizeHeight: integer; //FLastResizeClientWidth: integer;
FLastResizeWidth: integer; //FLastResizeHeight: integer;
//FLastResizeWidth: integer;
FOnClick; //点击 FOnClick; //点击
Fonrclick; Fonrclick;
FOnContextPopup; FOnContextPopup;
@ -49,7 +48,7 @@ type tcontrol = class(tcomponent)
FOnDragOver; FOnDragOver;
FOnSize; FOnSize;
FOnMove; FOnMove;
FOnEditingDone; //FOnEditingDone;
FOnEndDock; FOnEndDock;
FOnEndDrag; FOnEndDrag;
FOnMouseDown; //按下 FOnMouseDown; //按下
@ -68,18 +67,15 @@ type tcontrol = class(tcomponent)
FOnStartDock; FOnStartDock;
FOnStartDrag; FOnStartDrag;
//FOnTripleClick; //FOnTripleClick;
FBorder; protected //可以重写的函数以及使用的成员变量
protected
//对齐 //对齐
FAlign;//对齐方式 FAlign;//对齐方式
FUnAlignBounds; FUnAlignBounds;
FParent;// TWinControl; //父节点 FParent;// TWinControl; //父节点
//public
//FParentBiDiMode;//: Boolean; //FParentBiDiMode;//: Boolean;
FPopupMenu;//: TPopupMenu; FPopupMenu;//: TPopupMenu;
//FIsControl;//: Boolean; //FIsControl;//: Boolean;
FShowHint;//: Boolean; //FShowHint;//: Boolean;
FParentColor;//: Boolean; FParentColor;//: Boolean;
FParentFont;//: Boolean; FParentFont;//: Boolean;
//FParentShowHint;//: Boolean; //FParentShowHint;//: Boolean;
@ -88,21 +84,19 @@ type tcontrol = class(tcomponent)
FEnabled;//: Boolean; //有效 FEnabled;//: Boolean; //有效
//FMouseEntered;//: boolean; //FMouseEntered;//: boolean;
FVisible;//: Boolean; //可见 FVisible;//: Boolean; //可见
FID; FID; //id
FOnMeasureItem; FOnMeasureItem;
FOnDrawItem; FOnDrawItem;
#!end #!end
//位置信息 //位置信息
//protected
FLeft:integer; //左边 FLeft:integer; //左边
FTop:integer;//: Integer; //上 FTop:integer;//: Integer; //上
FWidth:integer; FWidth:integer;
FHeight:integer; //高度 FHeight:integer; //高度
FControls; FControls; //子控件
FControlState; FControlState; //状态
FCursor; FCursor; //鼠标
{** {**
@param(FLeft)(integer) 左边 %% @param(FLeft)(integer) 左边 %%
@param(FTop)(integer) 上边 %% @param(FTop)(integer) 上边 %%
@ -161,7 +155,6 @@ type tcontrol = class(tcomponent)
FEnabled := nv; FEnabled := nv;
end end
end end
//protected
procedure SetAlign(Value:TAlign);virtual; procedure SetAlign(Value:TAlign);virtual;
begin begin
if not(Value in array(alLeft,alRight,alBottom,alTop,alNone,alClient))then exit; if not(Value in array(alLeft,alRight,alBottom,alTop,alNone,alClient))then exit;
@ -216,7 +209,7 @@ type tcontrol = class(tcomponent)
return 1; return 1;
end end
end end
private private //位置,大小,对齐等属性设置函数
function SetUnAlignBounds(Value); function SetUnAlignBounds(Value);
begin begin
{** {**
@ -280,7 +273,7 @@ type tcontrol = class(tcomponent)
end end
return FtagPAINTSTRUCT; return FtagPAINTSTRUCT;
end end
function bindmessage(id,func); //type_tcontrol function bindmessage(id,func); //绑定事件
begin begin
{** {**
@ignore 忽略 %% @ignore 忽略 %%
@ -289,7 +282,7 @@ type tcontrol = class(tcomponent)
if not ifarray(FMessagehandle)then FMessagehandle := array(); if not ifarray(FMessagehandle)then FMessagehandle := array();
if ifnumber(id)and (datatype(func)=7)then FMessagehandle[id]:= func; if ifnumber(id)and (datatype(func)=7)then FMessagehandle[id]:= func;
end end
private private //事件绑定处理
static FClassDigestA; static FClassDigestA;
class function CtlInfoAndDigest(idx,d); //通过类的指纹保存或者获取控件信息 class function CtlInfoAndDigest(idx,d); //通过类的指纹保存或者获取控件信息
begin begin
@ -348,32 +341,8 @@ type tcontrol = class(tcomponent)
begin begin
bindmessage(i,findfunction(v,o)); bindmessage(i,findfunction(v,o));
end 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 end
for i,v in t["subs"] do protected //部分属性设置
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; function GetControlFont();virtual;
begin begin
if ParentFont and Parent then return Parent.FFont; if ParentFont and Parent then return Parent.FFont;
@ -410,23 +379,20 @@ type tcontrol = class(tcomponent)
return f.Controls.indexof(self); return f.Controls.indexof(self);
end end
end end
function RealGetText: function RealGetText():TCaption;virtual; //标题
TCaption;
virtual; //type_tcontrol
begin begin
return FCaption; return FCaption;
end end
procedure RealSetText(Value:TCaption);virtual; //type_tcontrol procedure RealSetText(Value:TCaption);virtual; //标题
begin begin
FCaption := Value; FCaption := Value;
end end
#!begin //资源处理 #!begin //资源处理
function GetCursor();virtual; function GetCursor();virtual; //鼠标
begin begin
return FCursor; return FCursor;
end end
procedure SetCursor(Value);virtual; procedure SetCursor(Value);virtual;//鼠标
begin begin
if(FCursor is class(tcustomcursor))and ifnumber(Value)and FCursor.id <> Value then if(FCursor is class(tcustomcursor))and ifnumber(Value)and FCursor.id <> Value then
begin begin
@ -434,17 +400,13 @@ type tcontrol = class(tcomponent)
Perform(new tuieventbase(CM_CURSORCHANGED,0,0)); Perform(new tuieventbase(CM_CURSORCHANGED,0,0));
end; end;
end end
procedure SetVisible(Value);virtual; procedure SetVisible(Value);virtual; //可见
begin begin
FVisible := Value?true:false; FVisible := Value?true:false;
end end
//procedure DoOnParentHandleDestruction;virtual;
//begin
//end
#!end #!end
protected protected //消息对象以及坐标
function messagecreater(hwnd,message,wparam,lparam);virtual; ////type_tcontrol function messagecreater(hwnd,message,wparam,lparam);virtual; ////构造消息对象
begin begin
{** {**
@explan(说明)根据消息参数构造消息对象; @explan(说明)根据消息参数构造消息对象;
@ -488,20 +450,20 @@ type tcontrol = class(tcomponent)
return r; return r;
//return new tuieventbase(message,wparam,lparam,hwnd); //return new tuieventbase(message,wparam,lparam,hwnd);
end end
function GetClientOrigin();virtual; ////type_tcontrol function GetClientOrigin();virtual; ////坐标
begin begin
if FParent then base := FParent.ClientOrigin(); if FParent then base := FParent.ClientOrigin();
return array(base[0]+FLeft,base[1]+FTop); return array(base[0]+FLeft,base[1]+FTop);
end end
function GetLogicalClientRect();virtual; //type_tcontrol function GetLogicalClientRect();virtual; //坐标
begin begin
return GetClientRect(); return GetClientRect();
end; end;
function GetClientScrollOffset();virtual; //type_tcontrol function GetClientScrollOffset();virtual; //坐标
begin begin
return array(0,0); return array(0,0);
end end
function GetScrolledClientRect();virtual; //type_tcontrol function GetScrolledClientRect();virtual; //坐标
begin begin
Result := GetClientRect(); Result := GetClientRect();
ScrolledOffset := GetClientScrollOffset(); ScrolledOffset := GetClientScrollOffset();
@ -511,7 +473,7 @@ type tcontrol = class(tcomponent)
Result[3]+= ScrolledOffset[1]; Result[3]+= ScrolledOffset[1];
return Result; return Result;
end; end;
function GetControlOrigin();virtual; //type_tcontrol function GetControlOrigin();virtual; //坐标
begin begin
Result := array(FLeft,FTop); Result := array(FLeft,FTop);
if FParent <> nil then if FParent <> nil then
@ -522,19 +484,19 @@ type tcontrol = class(tcomponent)
end; end;
return Result; return Result;
end end
function ControlAppended(AControl);virtual; function ControlAppended(AControl);virtual;//添加控件
begin begin
{** {**
@explan(说明) 子控件添加 %% @explan(说明) 子控件添加 %%
**} **}
end end
function ControlDeleted(AControl);virtual; function ControlDeleted(AControl);virtual;//子控件被删除
begin begin
{** {**
@explan(说明) 子控件删除 %% @explan(说明) 子控件删除 %%
**} **}
end end
function operatectrl(actrl,op);virtual; //type_tcontrol function operatectrl(actrl,op);virtual; //控件操作通知
begin begin
idx := FControls.indexof(actrl); idx := FControls.indexof(actrl);
if op=opRemove then if op=opRemove then
@ -561,7 +523,7 @@ type tcontrol = class(tcomponent)
end end
return ifop; return ifop;
end end
function SetParent(NewParent);virtual; //type_tcontrol function SetParent(NewParent);virtual; //设置父控件
begin begin
//1.为窗口类 //1.为窗口类
//2.可以作为父窗口 //2.可以作为父窗口
@ -586,35 +548,14 @@ type tcontrol = class(tcomponent)
if Parent then FParent.operatectrl(self(true),opRemove); if Parent then FParent.operatectrl(self(true),opRemove);
end end
end end
procedure SetParentComponent(NewParentComponent);override; //type_tcontrol procedure SetParentComponent(NewParentComponent);override; //设置父窗口
begin begin
SetParent(NewParentComponent); SetParent(NewParentComponent);
end end
public
procedure Notification(AComponent:TComponent;Operation:TOperation);override; //type_tcontrol protected //大小改变
begin //procedure UpdateMouseCursor(X, Y: integer); begin end
{** procedure ChangeBounds(ALeft,ATop,AWidth,AHeight:integer;KeepBase:boolean);virtual; //边界改变
@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 begin
SizeChanged :=(FWidth <> AWidth)or(FHeight <> AHeight); SizeChanged :=(FWidth <> AWidth)or(FHeight <> AHeight);
PosChanged :=(FLeft <> ALeft)or(FTop <> ATop); PosChanged :=(FLeft <> ALeft)or(FTop <> ATop);
@ -667,7 +608,7 @@ type tcontrol = class(tcomponent)
begin begin
return 0; return 0;
end end
public public //鼠标事件
function MouseMove(o,e);virtual; function MouseMove(o,e);virtual;
begin begin
end end
@ -702,7 +643,26 @@ type tcontrol = class(tcomponent)
e.skip := true; e.skip := true;
end end
end end
public public//通知
procedure Notification(AComponent:TComponent;Operation:TOperation);override; //通知
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;
procedure FontChanged(Sender:TObject);virtual; procedure FontChanged(Sender:TObject);virtual;
begin begin
if parent then parent.FontChanged(Sender); if parent then parent.FontChanged(Sender);
@ -951,11 +911,11 @@ type tcontrol = class(tcomponent)
//InvalidateRect(nil,true); updateWindow(); //InvalidateRect(nil,true); updateWindow();
end } end }
end end
public //消息id绑定相关
function CNALIGN(o,e):CN_ALIGN;virtual; function CNALIGN(o,e):CN_ALIGN;virtual;
begin begin
DoCNALIGN(o,e); DoCNALIGN(o,e);
end end
public
function CNANCHOR(o,e):CN_ANCHOR;virtual; function CNANCHOR(o,e):CN_ANCHOR;virtual;
begin begin
if Align <> alNone then exit; if Align <> alNone then exit;
@ -1148,12 +1108,8 @@ type tcontrol = class(tcomponent)
// HelpType is set implicitly when assigning HelpContext or HelpKeyword // HelpType is set implicitly when assigning HelpContext or HelpKeyword
end; end;
end end
function click(o,e);virtual; //type_tcontrol //function click(o,e);virtual;begin end
begin //function DblClick(o,e);virtual;begin end
end
function DblClick(o,e);virtual; //type_tcontrol
begin
end
public public
function ScreenToClient(X,Y);virtual; function ScreenToClient(X,Y);virtual;
begin begin
@ -1185,7 +1141,7 @@ type tcontrol = class(tcomponent)
begin begin
return Fid; return Fid;
end end
function create(Owner);override; //type_tcontrol function create(Owner);override; //构造函数
begin begin
inherited; inherited;
if ifnil(FSIDC)then FSIDC := new tidcreater(100); if ifnil(FSIDC)then FSIDC := new tidcreater(100);
@ -1200,7 +1156,7 @@ type tcontrol = class(tcomponent)
FParentBidiMode := True; FParentBidiMode := True;
FParentColor := false; FParentColor := false;
FParentFont := false; FParentFont := false;
FDesktopFont := True; //FDesktopFont := True;
FParentShowHint := True; FParentShowHint := True;
FIsControl := False; FIsControl := False;
FEnabled := True; FEnabled := True;
@ -1218,7 +1174,7 @@ type tcontrol = class(tcomponent)
FCursor := new tcustomcursor(); FCursor := new tcustomcursor();
FCursor.id := IDC_ARROW; FCursor.id := IDC_ARROW;
end end
procedure CheckNewParent(AParent:TWinControl);virtual; //type_tcontrol procedure CheckNewParent(AParent:TWinControl);virtual; //检查parent
begin begin
{ {
@ignore(忽略) @ignore(忽略)
@ -1227,7 +1183,7 @@ type tcontrol = class(tcomponent)
return(AParent is getparenttype())and AParent.IsContainer(self(true)); return(AParent is getparenttype())and AParent.IsContainer(self(true));
return false; return false;
end end
function Recycling();override; //type_tcontrol function Recycling();override; //销毁处理
begin begin
{** {**
@explan(说明) 资源回收,子类请override该方法然后在destroy中调用 %% @explan(说明) 资源回收,子类请override该方法然后在destroy中调用 %%
@ -1337,7 +1293,7 @@ type tcontrol = class(tcomponent)
begin begin
if ifnumber(id)and FMessagehandle then return FMessagehandle[id]; if ifnumber(id)and FMessagehandle then return FMessagehandle[id];
end end
function dispatch(o,e);virtual; //type_tcontrol function dispatch(o,e);virtual; //分发消息
begin begin
{** {**
@explan(说明)消息分发函数 %% @explan(说明)消息分发函数 %%
@ -1347,13 +1303,13 @@ type tcontrol = class(tcomponent)
func := getmessagehandle(e.Msg); func := getmessagehandle(e.Msg);
if func then call(func,o,e); if func then call(func,o,e);
end end
procedure DoControlAlign();virtual; procedure DoControlAlign();virtual;//调整子控件位置
begin begin
end end
procedure DoControlAnchor();virtual; procedure DoControlAnchor();virtual;//调整子控件位置
begin begin
end end
procedure WndProc(TheMessage);virtual; //type_tcontrol procedure WndProc(TheMessage);virtual; //消息分发
begin begin
{** {**
@explan(说明) 消息循环 %% @explan(说明) 消息循环 %%
@ -1583,7 +1539,7 @@ type tcontrol = class(tcomponent)
@param(OnDrawItem)(function[TControl,TMDRAWITEM]) 控件绘制回调 %% @param(OnDrawItem)(function[TControl,TMDRAWITEM]) 控件绘制回调 %%
@param(Color)(integer) 背景色 %% @param(Color)(integer) 背景色 %%
**} **}
function isCustomPaint(); function isCustomPaint(); //提供给gtk使用
begin begin
return csCustomPaint in FControlState ; return csCustomPaint in FControlState ;
end end

188
funcext/tvclib/tslvcl.tsf
View File

@ -62,22 +62,9 @@ function HexFormatStrToTsl(D);
function GetTextWidthAndHeightWidthFont(s,f,mul); function GetTextWidthAndHeightWidthFont(s,f,mul);
//**********操作系统相关函数********************* //**********操作系统相关函数*********************
//////////////////////////////////// ////////////////////////////////////
type TByteData = class(TByteDataOP) type TByteData = class(TByteDataOP)
end end
///////////////////////////内存对象//////////////////////////////
//////////////////////////////////内存对象截止////////////////////////////////////////////////////
//******************常量类型********************************** //******************常量类型**********************************
/////////////////////////////////
///////////////////////////消息对象////////////////////////////////////
///////////////tmf文件转换/////////////////////// ///////////////tmf文件转换///////////////////////
type Ttfm2Component = class(TTmfParser) type Ttfm2Component = class(TTmfParser)
{** {**
@ -91,7 +78,7 @@ type Ttfm2Component = class(TTmfParser)
inherited; inherited;
if not ifarray(FComponentTypes)then FComponentTypes := array(); if not ifarray(FComponentTypes)then FComponentTypes := array();
end end
function formatpath(s); function formatpath(s);//处理windows的路径
begin begin
r := ""; r := "";
if s and ifstring(s)then if s and ifstring(s)then
@ -257,17 +244,6 @@ type Ttfm2Component = class(TTmfParser)
function Loadinherited(o);//导入 function Loadinherited(o);//导入
begin begin
return Loadinherited_sub(o); return Loadinherited_sub(o);
if not ifobj(o) then return ;
if not((o is class(TDCreateForm)) or (o is class(TDCreatePanel))) then return ;//判断类型
ci := o.classinfo;
cn := ci["classname"];
ic := ci["inherited"][0];
if ((cn<>"tdcreateform") and (cn<>"tdcreatepanel")) then
begin
Loadinherited(findclass(ic,o));
phs := static GetSourceDirs();
Loadtfmtoform(o,phs,cn);
end
end end
function Loadinherited_sub(o); function Loadinherited_sub(o);
begin begin
@ -324,7 +300,7 @@ type Ttfm2Component = class(TTmfParser)
end end
end end
end end
function GetLibPaths(); function GetLibPaths(); //获得libpath
begin begin
p := tsl_getlibpath_(); p := tsl_getlibpath_();
if not p then return array(); if not p then return array();
@ -375,7 +351,7 @@ type Ttfm2Component = class(TTmfParser)
end end
end end
type TGlobalComponentcache=class type TGlobalComponentcache=class() //窗口对象缓存句柄作为索引
{** {**
@ignore(忽略) %% @ignore(忽略) %%
@explan(说明) 窗口存储类 %% @explan(说明) 窗口存储类 %%
@ -2798,6 +2774,7 @@ type TTreeView=class(TTreeCtl)
height := 150; height := 150;
border := true; border := true;
HasLine := true; HasLine := true;
nodecreator := class(TTreeNode);
end end
function expand(item); function expand(item);
begin begin
@ -2882,11 +2859,6 @@ type TTreeView=class(TTreeCtl)
np := RootItem.HasNode(node); np := RootItem.HasNode(node);
if np then np.DeleteChildNode(node); if np then np.DeleteChildNode(node);
end end
function CreateTreeNode();override;
begin
r := new TTreeNode(self(true));
return r;
end
public public
function Recycling();override; function Recycling();override;
begin begin
@ -7324,7 +7296,7 @@ type TTipMessageButton = class(TGraphicControl)
end end
private private
type TTipImage=class type TTipImage=class()
public public
function create(); function create();
begin begin
@ -8035,7 +8007,7 @@ type TDragManager=class(TComponent)
property DragThreshold:Integer read FDragThreshold write FDragThreshold; // default 5; property DragThreshold:Integer read FDragThreshold write FDragThreshold; // default 5;
end; end;
function GetAndDispatchMessageA(hwnd,minm,maxm); function GetAndDispatchMessageA(hwnd,minm,maxm); //分发窗口消息
begin begin
{** {**
@explan(说明) 获得和分发消息 %% @explan(说明) 获得和分发消息 %%
@ -8075,48 +8047,14 @@ begin
API.DispatchMessageA(ptr);} API.DispatchMessageA(ptr);}
return r; return r;
end end
function RegisterComponentType(n,typ);//注册componet对象
function GetGdipStatus(v);
begin
{**
@explan(说明) 获得gdiflat的运行状态说明 %%
@param(v)(integer) 状态值 %%
@return(string) 状态说明 %%
**}
vs := static array(
"Ok",
"GenericError",
"InvalidParameter",
"OutOfMemory",
"ObjectBusy",
"InsufficientBuffer",
"NotImplemented",
"Win32Error",
"WrongState",
"Aborted",
"FileNotFound",
"ValueOverflow",
"AccessDenied",
"UnknownImageFormat",
"FontFamilyNotFound",
"FontStyleNotFound",
"NotTrueTypeFont",
"UnsupportedGdiplusVersion",
"GdiplusNotInitialized",
"PropertyNotFound",
"PropertyNotSupported",
"ProfileNotFound");
return vs[v];
end
function RegisterComponentType(n,typ);
begin begin
{** {**
@explan(说明) 注册component组件 %% @explan(说明) 注册component组件 %%
**} **}
class(Ttfm2Component).RegisterComponentType(n,typ); class(Ttfm2Component).RegisterComponentType(n,typ);
end end
function initializeapplication(); function initializeapplication(); //应用对象
begin begin
{** {**
@explan(说明) 初始化application %% @explan(说明) 初始化application %%
@ -8124,7 +8062,7 @@ begin
**} **}
return getapplication(); return getapplication();
end end
function getapplication(); function getapplication(); //应用对象
begin begin
{** {**
@explan(说明) 返回application对象%% @explan(说明) 返回application对象%%
@ -8174,7 +8112,7 @@ begin
return tslarraytocstructcalc(data,pack,0,ssize); return tslarraytocstructcalc(data,pack,0,ssize);
end end
function remotetslcallback(data); function remotetslcallback(data);//远程执行
begin begin
{** {**
@explan(说明) 行情订阅回调 %% @explan(说明) 行情订阅回调 %%
@ -8183,10 +8121,7 @@ begin
//return class(TQuotations)._SWINDOWS._send_(0X4400,0,data,1); //return class(TQuotations)._SWINDOWS._send_(0X4400,0,data,1);
end end
function calldatafunction();//事件回调调用
//*********字符串相关对象**************************************
function calldatafunction();
begin begin
{** {**
@explan(说明)执行函数句柄,默认第一个参数为函数句柄,后面的参数为该句柄的参数 %% @explan(说明)执行函数句柄,默认第一个参数为函数句柄,后面的参数为该句柄的参数 %%
@ -8202,7 +8137,7 @@ begin
4:return call(f,params[2],params[3],params[4]); 4:return call(f,params[2],params[3],params[4]);
end; end;
return nil; return nil;
ps := params; {ps := params;
f := ps[0]; f := ps[0];
pms := ps[1:]; pms := ps[1:];
if datatype(f)<> 7 or not(ifarray(pms))then exit; if datatype(f)<> 7 or not(ifarray(pms))then exit;
@ -8213,9 +8148,9 @@ begin
begin begin
return callinarray(f,pms); return callinarray(f,pms);
end else end else
return callinarray(f,pms[0:lpt-1]); return callinarray(f,pms[0:lpt-1]);}
end end
function NotifyComponent(Acomponent,Act,AOwner); function NotifyComponent(Acomponent,Act,AOwner);//通知控件
begin begin
{** {**
@explan(说明) 通知节点AOwner有节点Acomponent 发生了改变,通知码为act %% @explan(说明) 通知节点AOwner有节点Acomponent 发生了改变,通知码为act %%
@ -8231,7 +8166,7 @@ begin
end end
owner.Notification(Acomponent,Act); owner.Notification(Acomponent,Act);
end end
function _timeproc_(hwnd,message,wparam,lparam); //消息分发 function _timeproc_(hwnd,message,wparam,lparam); //定时器消息分发
begin begin
{** {**
@explan(说明) 消息分发预处理函数被底层调用 %% @explan(说明) 消息分发预处理函数被底层调用 %%
@ -8243,13 +8178,13 @@ begin
**} **}
return class(ttimer)._timeproc_(hwnd,message,wparam,lparam); return class(ttimer)._timeproc_(hwnd,message,wparam,lparam);
end end
function controlisCustomPaint(id); function controlisCustomPaint(id);//提供给gtk使用
begin begin
wd := class(tUIglobalData).uigetdata("TGlobalValues").getvalue(id); wd := class(tUIglobalData).uigetdata("TGlobalValues").getvalue(id);
if wd then return wd.isCustomPaint(); if wd then return wd.isCustomPaint();
return false; return false;
end end
function _twinproc_(hwnd,message,wparam,lparam); //消息分发 function _twinproc_(hwnd,message,wparam,lparam); //窗口消息分发
begin begin
{** {**
@explan(说明) 消息分发预处理函数被底层调用 %% @explan(说明) 消息分发预处理函数被底层调用 %%
@ -8272,11 +8207,6 @@ begin
("lpcreateparams","intptr",0))),lparam); ("lpcreateparams","intptr",0))),lparam);
cid := cpm._getvalue_("lpcreateparams"); cid := cpm._getvalue_("lpcreateparams");
wdobj := class(tUIglobalData).uigetdata("TGlobalValues").getvalue(cid); wdobj := class(tUIglobalData).uigetdata("TGlobalValues").getvalue(cid);
{if wdobj is class(TWincontrol) then
begin
//return wdobj.MainWndProc(hwnd,message,wparam,lparam);
//class(TGlobalComponentcache).registerhandle(hwnd,wdobj);
end }
end end
end end
r := 0; r := 0;
@ -8292,23 +8222,6 @@ begin
class(tUIglobalData).uigetdata("TGlobalComponentcache").unregisterhandle(hwnd); class(tUIglobalData).uigetdata("TGlobalComponentcache").unregisterhandle(hwnd);
end end
return r; return r;
if message in array(1,0x81)then
begin
obj := new tslcstructureobj(MemoryAlignmentCalculate(array(
("lpcreateparams","intptr",0),
("hinstance","intptr",0),
("hmenu","intptr",0),
("hwndparent","intptr",0),
("cy","int",0),
("cx","int",0),
("y","int",0),
("x","int",0),
("style","int",0),
("lpszname","intptr",0),
("lpszclass","intptr",0),
("dwexstyle","int",0))),lparam);
echo tostn(obj._getdata_);
end
end end
function _MessgeHook_a(hwnd,message,wparam,lparam); function _MessgeHook_a(hwnd,message,wparam,lparam);
begin begin
@ -8345,16 +8258,10 @@ begin
d := new TtagOFNA(lparam); d := new TtagOFNA(lparam);
end end
end end
//function GetModuleFileNameA(m:pointer;var buf:string;len:integer):integer;stdcall;external "Kernel32.dll" name "GetModuleFileNameA"; //function GetModuleFileNameA(m:pointer;var buf:string;len:integer):integer;stdcall;external "Kernel32.dll" name "GetModuleFileNameA";
//function CallWindowProcA(lpPrevWndFunc:pointer;hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):pointer;stdcall;external "User32.dll" name "CallWindowProcA"; //function CallWindowProcA(lpPrevWndFunc:pointer;hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):pointer;stdcall;external "User32.dll" name "CallWindowProcA";
//function RegisterClassExA(wc:pointer):short;stdcall;external "User32.dll" name "RegisterClassExA"; //function RegisterClassExA(wc:pointer):short;stdcall;external "User32.dll" name "RegisterClassExA";
//tsl语言中使用动态库函数
//临时文件
function TS_EndExecute(id:integer);cdecl;external "TSSVRAPI.dll" name "TS_EndExecute"; function TS_EndExecute(id:integer);cdecl;external "TSSVRAPI.dll" name "TS_EndExecute";
function TSL_ScriptGo(L:pointer;Content:string;v:pointer):integer;cdecl;external "TSSVRAPI.dll" name "TSL_ScriptGo"; function TSL_ScriptGo(L:pointer;Content:string;v:pointer):integer;cdecl;external "TSSVRAPI.dll" name "TSL_ScriptGo";
function TSL_InterpFreeLWrap(lWrap:pointer);cdecl;external "TSSVRAPI.dll" name "TSL_InterpFreeLWrap"; function TSL_InterpFreeLWrap(lWrap:pointer);cdecl;external "TSSVRAPI.dll" name "TSL_InterpFreeLWrap";
@ -8366,32 +8273,30 @@ function TSL_FreeObj(L:pointer;v:pointer);cdecl;external {$ifdef linux}"libTSSVR
//function TS_ModulePath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ModulePath"; //function TS_ModulePath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ModulePath";
//function TS_ExecPath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ExecPath"; //function TS_ExecPath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ExecPath";
//function TS_GetAppPath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ExecPath"; //function TS_GetAppPath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ExecPath";
//function TS_GetIniPath(hometype:integer; var IniName:string):string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetIniPath"; //function TS_GetIniPath(hometype:integer; var IniName:string):string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetIniPath";
function TSL_Check(func:string;funclen:integer;oResult:pointer):integer;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TSL_Check"; function TSL_Check(func:string;funclen:integer;oResult:pointer):integer;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TSL_Check";
procedure tslprocessmessages();begin {echo "\r\n processmessage";}end; procedure tslprocessmessages();begin {echo "\r\n processmessage";}end;
function TS_GetUserProfileHome(); function TS_GetUserProfileHome();
begin begin
return unit(utslvclauxiliary).TS_GetUserProfileHome(); return unit(utslvclauxiliary).TS_GetUserProfileHome();
end end
function RunWorkerThreadLoop(); function RunWorkerThreadLoop(); //执行工作线程循环
begin begin
class(TThreadWorker).dispatch(); class(TThreadWorker).dispatch();
end end
//procedure ClearScriptCache();cdecl;external "TSLInterp.dll" name "ClearScriptCache"; //procedure ClearScriptCache();cdecl;external "TSLInterp.dll" name "ClearScriptCache";
function CreateDirWithFileName(fname); function CreateDirWithFileName(fname);//确保指定文件的文件夹是存在的
begin begin
return unit(utslvclauxiliary).CreateDirWithFileName(fname); return unit(utslvclauxiliary).CreateDirWithFileName(fname);
end end
function DeleteAllFiles(path); function DeleteAllFiles(path);//删除目录所有文件
begin begin
return unit(utslvclauxiliary).DeleteAllFiles(path); return unit(utslvclauxiliary).DeleteAllFiles(path);
end end
function LoginTslServer(usr,pwd,addr,port); function LoginTslServer(usr,pwd,addr,port);//登陆服务器
begin begin
{** {**
@explan(说明) 登陆服务器 %% @explan(说明) 登陆服务器 %%
@ -8424,7 +8329,7 @@ function GetCheckStruct();
begin begin
return new TCHECK_RESULT(); return new TCHECK_RESULT();
end end
function CheckTslCode(code,err); function CheckTslCode(code,err);//检查tsl语法
begin begin
{** {**
@explan(说明) tsl语法检查 %% @explan(说明) tsl语法检查 %%
@ -8445,7 +8350,7 @@ begin
end end
return true; return true;
end end
function tslScriptGo(script); function tslScriptGo(script);//执行tsl脚本
begin begin
{** {**
@explan(说明)执行tsl脚本 %% @explan(说明)执行tsl脚本 %%
@ -8463,13 +8368,13 @@ begin
return tslScriptGo(script); return tslScriptGo(script);
**} **}
ph := gettemppath(); ph := gettemppath();
name := ph+"tslpengt.tsl"; file := ph+"tslpengt.tsl";
if ifstring(script)and script then if ifstring(script)and script then
begin begin
tsexe := SysExecName(); tsexe := SysExecName();
FileDelete("",name); FileDelete("",file);
writefile(rwraw(),"",name,0,length(script),script); writefile(rwraw(),"",file,0,length(script),script);
r := SysExec(tsexe,format('"%s" "%s"',tsexe,name),nil,0,r,nil); r := SysExec(tsexe,format('"%s" "%s"',tsexe,file),nil,0,r,nil);
end end
return r; return r;
lwrap := TSL_InterpNewLWrap(); lwrap := TSL_InterpNewLWrap();
@ -8484,7 +8389,7 @@ begin
//TSL_InterpFreeLWrap(lwrap); //TSL_InterpFreeLWrap(lwrap);
return ret; return ret;
end end
function version(); function version(); //版本
begin begin
{** {**
@explan(说明) 返回版本号 %% @explan(说明) 返回版本号 %%
@ -8494,7 +8399,7 @@ begin
//return "1.1.1.20200731_beta"; //return "1.1.1.20200731_beta";
//return "1.1.2.20210915_beta"; //return "1.1.2.20210915_beta";
//return "1.1.3.20220210_beta"; //return "1.1.3.20220210_beta";
return "1.1.4.20220310_beta"; return "1.1.4.20221010_beta";
end end
function ExitMessageLoop(); function ExitMessageLoop();
@ -8506,7 +8411,7 @@ begin
return WPI.PostQuitMessage(0); return WPI.PostQuitMessage(0);
end end
function SysExecWait(handle,exe,cmd,dir,fwait); function SysExecWait(handle,exe,cmd,dir,fwait); //等待执行
begin begin
{** {**
@explan(说明) 运行进程 %% @explan(说明) 运行进程 %%
@ -8557,7 +8462,7 @@ begin
end end
return r; return r;
end end
function MessageBoxA(txt,title,flag,wnd); function MessageBoxA(txt,title,flag,wnd);//对话框api
begin begin
{** {**
@explan(说明) 提示对话框 %% @explan(说明) 提示对话框 %%
@ -8583,7 +8488,7 @@ begin
end end
end end
end end
function CopyUsedTslDllToNewDir(npre); function CopyUsedTslDllToNewDir(npre);//windows中使用,拷贝tsl使用的动态库到指定目录
begin begin
{** {**
@explan(说明) 拷贝当前的tsl目录中使用的dll到指定目录%% @explan(说明) 拷贝当前的tsl目录中使用的dll到指定目录%%
@ -8616,19 +8521,19 @@ begin
end end
////////////////////封装已经移动到其他库的接口为了兼容/////////// ////////////////////封装已经移动到其他库的接口为了兼容///////////
function TslToHexFormatStr(tsl); function TslToHexFormatStr(tsl);//将tsl数据转换为16进制字符串
begin begin
return unit(utslvclauxiliary).TslToHexFormatStr(tsl); return unit(utslvclauxiliary).TslToHexFormatStr(tsl);
end end
function HexFormatStrToTsl(D); function HexFormatStrToTsl(D);//将16进制字符串还原为tsl数据
begin begin
return unit(utslvclauxiliary).HexFormatStrToTsl(d); return unit(utslvclauxiliary).HexFormatStrToTsl(d);
end end
function GetTextWidthAndHeightWidthFont(s,f,mul); function GetTextWidthAndHeightWidthFont(s,f,mul);//获得字体的绘制高度宽度
begin begin
return unit(utslvclgdi).GetTextWidthAndHeightWidthFont(s,f,mul); return unit(utslvclgdi).GetTextWidthAndHeightWidthFont(s,f,mul);
end end
function CallMessgeFunction(f,o,e); function CallMessgeFunction(f,o,e); //执行消息回调
begin begin
return unit(utslvclauxiliary).CallMessgeFunction(f,o,e); return unit(utslvclauxiliary).CallMessgeFunction(f,o,e);
end end
@ -8686,3 +8591,22 @@ Initialization
initlib(); initlib();
Finalization Finalization
end. end.
{
if message in array(1,0x81)then
begin
obj := new tslcstructureobj(MemoryAlignmentCalculate(array(
("lpcreateparams","intptr",0),
("hinstance","intptr",0),
("hmenu","intptr",0),
("hwndparent","intptr",0),
("cy","int",0),
("cx","int",0),
("y","int",0),
("x","int",0),
("style","int",0),
("lpszname","intptr",0),
("lpszclass","intptr",0),
("dwexstyle","int",0))),lparam);
echo tostn(obj._getdata_);
end
}

34
funcext/tvclib/utslvclgdi.tsf
View File

@ -5,9 +5,9 @@ unit utslvclgdi;
**} **}
interface interface
uses cstructurelib,utslvclmemstruct,utslvclauxiliary,utslvclbase; uses cstructurelib,utslvclmemstruct,utslvclauxiliary,utslvclbase;
function GetTextWidthAndHeightWidthFont(s,f,mul); function GetTextWidthAndHeightWidthFont(s,f,mul);
function getdrawablebitmap(w,h,bmp); function getdrawablebitmap(w,h,bmp);
function GetGdipStatus(v);
type TGdi = class(TSLUIBASE) type TGdi = class(TSLUIBASE)
private private
static GDICache; static GDICache;
@ -3019,6 +3019,38 @@ begin
return cv; return cv;
end end
end end
function GetGdipStatus(v);
begin
{**
@explan(说明) 获得gdiflat的运行状态说明 %%
@param(v)(integer) 状态值 %%
@return(string) 状态说明 %%
**}
vs := static array(
"Ok",
"GenericError",
"InvalidParameter",
"OutOfMemory",
"ObjectBusy",
"InsufficientBuffer",
"NotImplemented",
"Win32Error",
"WrongState",
"Aborted",
"FileNotFound",
"ValueOverflow",
"AccessDenied",
"UnknownImageFormat",
"FontFamilyNotFound",
"FontStyleNotFound",
"NotTrueTypeFont",
"UnsupportedGdiplusVersion",
"GdiplusNotInitialized",
"PropertyNotFound",
"PropertyNotSupported",
"ProfileNotFound");
return vs[v];
end
initialization initialization
sinitgidplus(); sinitgidplus();
class(tcustomimage).sinit(); class(tcustomimage).sinit();

17
funcext/tvclib/utslvcltree.tsf
View File

@ -1643,6 +1643,7 @@ type TcustomTreeCtl = class(TVirtualList)
FNodeHierarchyWidth := 20; FNodeHierarchyWidth := 20;
FMulSelected := false; FMulSelected := false;
FMulSelects := array(); FMulSelects := array();
fnodecreator := class(TcustomTreeCtlNode);
end end
function InsertItem(it,idx);override; function InsertItem(it,idx);override;
begin begin
@ -1773,6 +1774,7 @@ type TcustomTreeCtl = class(TVirtualList)
end} end}
function CreateTreeNode();virtual; function CreateTreeNode();virtual;
begin begin
return createobject(fnodecreator,self(true));
r := new TcustomTreeCtlNode(self(true)); r := new TcustomTreeCtlNode(self(true));
return r; return r;
end end
@ -1841,6 +1843,7 @@ type TcustomTreeCtl = class(TVirtualList)
FOnSelChanging := nil; FOnSelChanging := nil;
FonEmptyNodeExapanding := nil; FonEmptyNodeExapanding := nil;
FNodeHierarchyWidth := 20; FNodeHierarchyWidth := 20;
//fnodecreator := nil;
inherited; inherited;
end end
function GetHierarchyByHandle(h); function GetHierarchyByHandle(h);
@ -1878,6 +1881,7 @@ type TcustomTreeCtl = class(TVirtualList)
property OnSelChanged:eventhandler read FOnSelChanged write FOnSelChanged; property OnSelChanged:eventhandler read FOnSelChanged write FOnSelChanged;
property OnSelChanging:eventhandler read FOnSelChanging write FOnSelChanging; property OnSelChanging:eventhandler read FOnSelChanging write FOnSelChanging;
property onEmptyNodeExapanding read FonEmptyNodeExapanding write FonEmptyNodeExapanding; property onEmptyNodeExapanding read FonEmptyNodeExapanding write FonEmptyNodeExapanding;
property nodecreator read fnodecreator write setnodecreator;
protected protected
function GetRootNode();virtual; //»ñµÃ¸ù½Úµã function GetRootNode();virtual; //»ñµÃ¸ù½Úµã
begin begin
@ -1889,11 +1893,24 @@ type TcustomTreeCtl = class(TVirtualList)
return FRootItem; return FRootItem;
end end
private private
fnodecreator;
flockchangedcall;// flockchangedcall;//
FOnlyLeafNodeCheckMark; FOnlyLeafNodeCheckMark;
FNodeHierarchyWidth; FNodeHierarchyWidth;
FMulSelected; FMulSelected;
FMulSelects; FMulSelects;
function setnodecreator(nd);
begin
if (fnodecreator<>nd) and (nd is class(TcustomTreeCtlNode)) then
begin
fnodecreator := nd;
if FRootItem then
begin
FRootItem.Recycling();
FRootItem := nil;
end
end
end
function SetNodeHierarchyWidth(v); function SetNodeHierarchyWidth(v);
begin begin
if v >= 0 and FNodeHierarchyWidth <> v then if v >= 0 and FNodeHierarchyWidth <> v then