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

界面库 

初步拆分界面库
This commit is contained in:
JianjunLiu 2022-04-29 17:53:19 +08:00
parent 98c9df56dd
commit 20d268ed0d
11 changed files with 7498 additions and 7018 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
designer/tediterform.tsf
View File

@ -88,14 +88,25 @@ type TEditerForm = class(TVCform) //
end end
/////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////
Fmopen := new TMenu(self); Fmopen := new TMenu(self);
Fmopen.caption := "打开"; newaction := new TAction(self);
NewAction.ShortCut := "ctrl+O";
NewAction.caption := "打开";
NewAction.onexecute := function(o,e)
begin
return FEdter.OpenAfile();
end;
Fmopen.action := newaction;
Fmnew:= new TMenu(self); Fmnew:= new TMenu(self);
Fmnew.caption := "新建"; newaction := new TAction(self);
Fmnew.OnClick := function(o,e) NewAction.ShortCut := "ctrl+N";
NewAction.caption := "新建";
NewAction.onexecute := function(o,e)
begin begin
return FEdter.CreateAfile(); return FEdter.CreateAfile();
end end
Fmnew.action := NewAction;
FOpenOther := new TMenu(self); FOpenOther := new TMenu(self);
FOpenOther.Caption := "其他窗口打开"; FOpenOther.Caption := "其他窗口打开";
FOpenOther.OnClick := thisfunction(OpenInOtherWnd) ; FOpenOther.OnClick := thisfunction(OpenInOtherWnd) ;
@ -220,10 +231,7 @@ type TEditerForm = class(TVCform) //
//FEdter.FExecuteEditer.ShowModal(); //FEdter.FExecuteEditer.ShowModal();
FEdter.ShowExeEditer(); FEdter.ShowExeEditer();
end end
Fmopen.onclick := function(o,e)
begin
return FEdter.OpenAfile();
end;
FCloseMenu := new tmenu(self); FCloseMenu := new tmenu(self);
FCloseMenu.Caption:="关闭时最小化"; FCloseMenu.Caption:="关闭时最小化";
//FCloseMenu.Checked := true; //FCloseMenu.Checked := true;
@ -251,11 +259,24 @@ type TEditerForm = class(TVCform) //
FRunMenu := new TMenu(self); FRunMenu := new TMenu(self);
FRunMenu.caption := "运行"; FRunMenu.caption := "运行";
for i,v in array("命令行配置","tsl函数目录","执行(F9)","调试运行","远程调试","远程调试(waitattach)") do FExeaction := new TAction(self);
FExeaction.caption := "执行";
FExeaction.ShortCut := "F9";
FExeaction.onexecute := function(o,e)
begin
FEdter.ExecutePageItem(FEdter.GetCurrentItem());
end
for i,v in array("命令行配置","tsl函数目录","执行","调试运行","远程调试","远程调试(waitattach)") do
begin begin
it := new TMenu(self); it := new TMenu(self);
it.caption := v; if v = "执行" then
it.OnClick := thisfunction(clickRun); begin
it.Action := FExeaction;
end else
begin
it.caption := v;
it.OnClick := thisfunction(clickRun);
end
it.Parent := FRunMenu; it.Parent := FRunMenu;
end end
FRunMenu.Parent := m; FRunMenu.Parent := m;
@ -551,10 +572,6 @@ type TEditerForm = class(TVCform) //
begin begin
FEdter.ShowExeEditer(); FEdter.ShowExeEditer();
end end
"执行(F9)" :
begin
FEdter.ExecutePageItem(FEdter.GetCurrentItem());
end
"调试运行": "调试运行":
begin begin
FEdter.DebugPageItem(FEdter.GetCurrentItem()); FEdter.DebugPageItem(FEdter.GetCurrentItem());
@ -1465,4 +1482,7 @@ end
FPathDirPath; FPathDirPath;
FDirs; FDirs;
Fexefilepath; Fexefilepath;
/////////////////actions
FExeaction;
end end

65
designer/utslcodeeditor.tsf
View File

@ -3248,7 +3248,7 @@ F47AC96526C21CCB26FD326A2180CC21F5CAC302CA5C842B865FD9D7003D1F17B
ExecuteCommand("showeval",ev); ExecuteCommand("showeval",ev);
end end
end end
function ExecuteCommand(cmd,p); function ExecuteCommand(cmd,p);override;
begin begin
case cmd of case cmd of
"dbgstate": "dbgstate":
@ -4313,22 +4313,32 @@ end
//FPageEditer.CloseBtn := true; //FPageEditer.CloseBtn := true;
FPageEditer.Onbmpbclick := function(o,e) FPageEditer.Onbmpbclick := function(o,e)
begin begin
it := e._Tag; it := e._Tag;
if not it then return ; if not it then return ;
if JudgeItemState(it)then return; if it.fisnewfile then //单独处理新建关闭
if it.FEditer.ChangedFlag then
begin begin
mr := MessageboxA(format("ÊÇ·ñ±£´æ:%s",it.OrigScriptPath),"Ìáʾ",3,self); f := it.OrigScriptPath;
if mr=IDYES then DeletePageItem(it);
if fileexists("",f) then filedelete("",f);
end else
begin
if JudgeItemState(it)then return;
if it.FEditer.ChangedFlag then
begin begin
SavePageItem(it); mr := MessageboxA(format("是否保存:%s",it.OrigScriptPath),"提示",3,self);
end else if mr=IDYES then
if mr=IDCANCEL then begin
begin SavePageItem(it);
return; end else
if mr=IDCANCEL then
begin
return;
end
end end
DeletePageItem(it);
end end
DeletePageItem(it);
o.CallSelChanged(); o.CallSelChanged();
end end
FPageEditer.OnCloseClick := function(o,e) FPageEditer.OnCloseClick := function(o,e)
@ -4349,6 +4359,7 @@ end
end end
end end
DeletePageItem(it); DeletePageItem(it);
ECHO "==222=>>>";
end; end;
FFindWnd := new TFindWnd(self); //²éÕÒ FFindWnd := new TFindWnd(self); //²éÕÒ
FGotoLineWnd := new TGoToLineWnd(self); //¹²Í¬ FGotoLineWnd := new TGoToLineWnd(self); //¹²Í¬
@ -5761,6 +5772,23 @@ end
end end
function EditerQuckKeys(o,e);virtual; //¿ì½Ý¼ü function EditerQuckKeys(o,e);virtual; //¿ì½Ý¼ü
begin 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 if e.Result=0 and(ssAlt in e.shiftstate)then
begin begin
case e.charcode of case e.charcode of
@ -5835,7 +5863,7 @@ end
FGotoLineWnd.ShowGoto(); FGotoLineWnd.ShowGoto();
return true; return true;
end end
ord("O"): {ord("O"):
begin begin
OpenAfile(); OpenAfile();
return true; return true;
@ -5844,7 +5872,7 @@ end
begin begin
CreateAfile(); CreateAfile();
return true; return true;
end end}
ord("Z"): ord("Z"):
begin begin
UnDoCurrentEditer(); UnDoCurrentEditer();
@ -5900,16 +5928,7 @@ end
DbgNextLine(); DbgNextLine();
return true; return true;
end end
VK_F9:
begin
if ssctrl in e.ShiftState()then
begin
ShowExeEditer();
return true;
end
ExecutePageItem(GetCurrentItem());
return true;
end
VK_F3: VK_F3:
begin begin
d := FFindWnd.GetINfo(); d := FFindWnd.GetINfo();

94
funcext/tvclib/cstructurelib.tsf
View File

@ -23,7 +23,7 @@ Unit cstructurelib;
例1: 例1:
data := " data := "
typedef struct tagNMTBHOTITEM { typedef struct tagNMTBHOTITEM {
NMHDR hdr; double hdr;
int idOld; int idOld;
int idNew; int idNew;
DWORD dwFlags; DWORD dwFlags;
@ -1345,6 +1345,7 @@ type tcstruct= class
raise "类型不存在"; raise "类型不存在";
return ret; return ret;
end end
function tslarraytocstructcalcs(data,alim,ssize,maxitem); //计算对其长度 function tslarraytocstructcalcs(data,alim,ssize,maxitem); //计算对其长度
begin begin
{** {**
@ -1359,37 +1360,12 @@ type tcstruct= class
alim := 8; alim := 8;
{$endif} {$endif}
end end
fmaxitem := function(d,alim) //计算对其长度 if preddata(data)=-1 then raise functionname()+"结构体数据错误!";
begin
ret := array();
for i,v in d do
begin
vt := v["t"];
vo := v["tfo"];
typedeal(vt,vo);
end
return ret;
end;
preddata := function(data)
begin
if not ifarray(data)then return-1;
cols := array(0,1,mcols(data,1))->(mcols(data)-1);
masthave := array("n","t");
for i,v in masthave do
begin
if ifnil(cols[v])then return-1;
end
for i := 0 to length(data)-1 do
begin
data[i,"tfo"]:= new typeclass();
end
end
if call(preddata,data)=-1 then raise functionname()+"结构体数据错误!";
npoint := 0; //开始位置 npoint := 0; //开始位置
names := data[:,"n"]; names := data[:,"n"];
len1 := length(names); len1 := length(names);
if(len1>length(names union2 array()))then raise functionname()+"结构体变量名重复"; if(len1>length(names union2 array()))then raise functionname()+"结构体变量名重复";
call(fmaxitem,data,alim); //对其长度 fmaxitem(data,alim); //对其长度
maxitem := 0; maxitem := 0;
for i,vi in data do for i,vi in data do
begin begin
@ -1449,6 +1425,32 @@ type tcstruct= class
if ifnumber(ptr)then ret := ptr+_size; if ifnumber(ptr)then ret := ptr+_size;
return ret; return ret;
end end
private
function preddata(data);
begin
if not ifarray(data)then return-1;
cols := array(0,1,mcols(data,1))->(mcols(data)-1);
masthave := array("n","t");
for i,v in masthave do
begin
if ifnil(cols[v])then return-1;
end
for i := 0 to length(data)-1 do
begin
data[i,"tfo"]:= new typeclass();
end
end
function fmaxitem(d,alim) //计算对其长度
begin
ret := array();
for i,v in d do
begin
vt := v["t"];
vo := v["tfo"];
typedeal(vt,vo);
end
return ret;
end;
end end
//新的内存管理类 //新的内存管理类
@ -2161,23 +2163,6 @@ begin
{$endif} {$endif}
end end
if not ifnumber(bsi)then bsi := 0; if not ifnumber(bsi)then bsi := 0;
fmaxitem := function(d,cl) //计算对其长度
begin
ret := array();
for i,v in d do
begin
vt := v[1];
{ctrl := "\\w+[*]?";
ParseRegExpr(ctrl,vt,"",result,MPos,Mlen);
vt := result[0,0];}
parserctypestr(vt,tt,len);
vt := tt;
//echo tt,"\r\n";
if vt="user" then ret[i]:= maxvalue(call(thisfunction,v[2],cl));
else ret[i]:= cl[vt];
end
return ret;
end;
if ifnumber(data)then return data; //如果为整数 if ifnumber(data)then return data; //如果为整数
if not ifarray(data)then raise functionname()+"结构体数据错误!"; if not ifarray(data)then raise functionname()+"结构体数据错误!";
if mcols(data)<1 then raise functionname()+"结构体数据错误"; if mcols(data)<1 then raise functionname()+"结构体数据错误";
@ -2189,7 +2174,7 @@ begin
ctypebytes := static getctypesize(); ctypebytes := static getctypesize();
ctypebytes["user*"]:= ctypebytes["intptr"]; ctypebytes["user*"]:= ctypebytes["intptr"];
ctypenames := mrows(ctypebytes,1); ctypenames := mrows(ctypebytes,1);
itemslen := call(fmaxitem,data,ctypebytes); //对其长度 itemslen := calcalimsizeA(data,ctypebytes);//对其长度
for i,vi in data do for i,vi in data do
begin begin
name := vi[0]; //变量名 name := vi[0]; //变量名
@ -2266,6 +2251,23 @@ begin
ret[length(ret)-1,4]+=(ssize-st); ret[length(ret)-1,4]+=(ssize-st);
return ret; return ret;
end end
function calcalimsizeA(d,cl) //计算对其长度
begin
ret := array();
for i,v in d do
begin
vt := v[1];
{ctrl := "\\w+[*]?";
ParseRegExpr(ctrl,vt,"",result,MPos,Mlen);
vt := result[0,0];}
parserctypestr(vt,tt,len);
vt := tt;
//echo tt,"\r\n";
if vt="user" then ret[i]:= maxvalue(calcalimsizeA(v[2],cl));
else ret[i]:= cl[vt];
end
return ret;
end;
function parserctypestr(ts,t,s,n); function parserctypestr(ts,t,s,n);
begin begin
{** {**

321
funcext/tvclib/lpseudointerface.tsl
View File

@ -1,187 +1,184 @@
unit UTslVclFackInterface; unit UTslVclFackInterface;
interface interface
{** {**
@nickname(底层伪接口) %% @nickname(底层伪接口) %%
@explan(说明) @explan(说明)
该文件提供底层接口的说明无具体实现 该文件提供底层接口的说明无具体实现
该单元中的类型和函数可以直接使用 %% 该单元中的类型和函数可以直接使用 %%
**} **}
function getsenderdatabyid(); function getsenderdatabyid();
function gettslvariableptr(obj); function gettslvariableptr(obj);
function getctypesize(); function getctypesize();
function getwinprocptr(f); function getwinprocptr(f);
type aefclassobj_ = class type aefclassobj_=class
{** {**
@nickname(内存管理对象) %% @nickname(内存管理对象) %%
@explan(说明)内存操作底层接口伪类 %% @explan(说明)内存操作底层接口伪类 %%
**} **}
function tmalloc(sz); function tmalloc(sz);
begin begin
{** {**
@explan(说明)内存分配 %% @explan(说明)内存分配 %%
@param(sz)(integer)大小 %% @param(sz)(integer)大小 %%
@return(pointer)分配的内存的句柄 %% @return(pointer)分配的内存的句柄 %%
**} **}
end end
function trealloc(p,sz); function trealloc(p,sz);
begin begin
{** {**
@explan(说明)重新内存分配 %% @explan(说明)重新内存分配 %%
@param(sz)(integer)大小 %% @param(sz)(integer)大小 %%
@param(p)(pointer)内存地址 %% @param(p)(pointer)内存地址 %%
@return(pointer)新的内存地址 %% @return(pointer)新的内存地址 %%
**} **}
end end
function tfree(p); function tfree(p);
begin begin
{** {**
@explan(说明) 释放内存 %% @explan(说明) 释放内存 %%
@param(p)(pointer)内存地址 %% @param(p)(pointer)内存地址 %%
**} **}
end end
function tmcopy(); function tmcopy();
begin begin
end
end function tmset(p,sz);
function tmset(p,sz); begin
begin {**
{** @explan(说明) 初始化内存 %%
@explan(说明) 初始化内存 %% @param(sz)(integer)大小 %%
@param(sz)(integer)大小 %% @param(p)(pointer)内存地址 %%
@param(p)(pointer)内存地址 %% **}
**} end
end function readbyte(p);
function readbyte(p); begin
begin {**
{** @explan(说明) 读取一个byte %%
@explan(说明) 读取一个byte %% @param(p)(pointer)内存地址 %%
@param(p)(pointer)内存地址 %% **}
**} end
end function writebyte(p,v);
function writebyte(p,v); begin
begin {**
{** @explan(说明) 写入一个beyte %%
@explan(说明) 写入一个beyte %% @param(p)(pointer)内存地址 %%
@param(p)(pointer)内存地址 %% @param(v)(integer)值 %%
@param(v)(integer)值 %% **}
**} end
end function readint();
function readint(); begin
begin {**
{** @explan(说明) 读取一个byte %%
@explan(说明) 读取一个byte %% @param(p)(pointer)内存地址 %%
@param(p)(pointer)内存地址 %% **}
**} end
end function writeint(p,v);
function writeint(p,v); begin
begin end
function writedouble(p,v);
end begin
function writedouble(p,v); {**
begin @explan(说明) 读取一个double %%
{** @param(p)(pointer)内存地址 %%
@explan(说明) 读取一个double %% **}
@param(p)(pointer)内存地址 %% end
**} function readdouble(p);
end begin
function readdouble(p); {**
begin @explan(说明) 读取一个double %%
{** @param(p)(pointer)内存地址 %%
@explan(说明) 读取一个double %% **}
@param(p)(pointer)内存地址 %% end
**} function writellong(p,v);
end begin
function writellong(p,v); {**
begin @explan(说明) 写入一个long%%
{** @param(p)(pointer)内存地址 %%
@explan(说明) 写入一个long%% **}
@param(p)(pointer)内存地址 %% end
**} function readlong(p);
end begin
function readlong(p); {**
begin @explan(说明) 读取一个long %%
{** @param(p)(pointer)内存地址 %%
@explan(说明) 读取一个long %% **}
@param(p)(pointer)内存地址 %% end
**} function writeshort(p,v);
end begin
function writeshort(p,v); {**
begin @explan(说明) 写入一个short%%
{** @param(p)(pointer)内存地址 %%
@explan(说明) 写入一个short%% **}
@param(p)(pointer)内存地址 %% end
**} function readshort();
end begin
function readshort(); {**
begin @explan(说明) 读取一个short %%
{** @param(p)(pointer)内存地址 %%
@explan(说明) 读取一个short %% **}
@param(p)(pointer)内存地址 %% end
**} function writebytes(p,sz,v);
end begin
function writebytes(p,sz,v); {**
begin @explan(说明) 写入一组short %%
{** @param(p)(pointer)内存地址 %%
@explan(说明) 写入一组short %% **}
@param(p)(pointer)内存地址 %% end
**} function readbytes(p,sz);
end begin
function readbytes(p,sz); {**
begin @explan(说明) 读取一组byte %%
{** @param(p)(pointer)内存地址 %%
@explan(说明) 读取一组byte %% @param(sz)(pointer)大小 %%
@param(p)(pointer)内存地址 %% **}
@param(sz)(pointer)大小 %% end
**} function writeshorts(p,sz,v);
end begin
function writeshorts(p,sz,v); {**
begin @explan(说明) 写入一组short %%
{** @param(p)(pointer)内存地址 %%
@explan(说明) 写入一组short %% **}
@param(p)(pointer)内存地址 %% end
**} function readshorts(p,sz);
end begin
function readshorts(p,sz); {**
begin @explan(说明) 读取一组short %%
{** @param(p)(pointer)内存地址 %%
@explan(说明) 读取一组short %% @param(sz)(pointer)大小 %%
@param(p)(pointer)内存地址 %% **}
@param(sz)(pointer)大小 %% end
**}
end
end end
Implementation Implementation
function gettslvariableptr(obj); function gettslvariableptr(obj);
begin begin
{** {**
@explan(说明) 获取变量的地址,在send消息使用 %% @explan(说明) 获取变量的地址,在send消息使用 %%
@param(obj)(obj) tsl变量 %% @param(obj)(obj) tsl变量 %%
@return(integer) 变量地址 %% @return(integer) 变量地址 %%
**} **}
end end
function getwinprocptr(f); function getwinprocptr(f);
begin begin
{** {**
@explan(说明) 获取winProc函数句柄 %% @explan(说明) 获取winProc函数句柄 %%
@param(f)(integer|nil) 1表示DefWindowProcA ,0 表示timeproc nil表示twinproc %% @param(f)(integer|nil) 1表示DefWindowProcA ,0 表示timeproc nil表示twinproc %%
@return(integer) 消息函数句柄 %% @return(integer) 消息函数句柄 %%
**} **}
end end
function getctypesize(); function getctypesize();
begin begin
{** {**
@explan(说明) 获取类型占用内存大小 %% @explan(说明) 获取类型占用内存大小 %%
@return(array) 以类型字符串为下标的数字数组,数字表示该类型的内存大小 %% @return(array) 以类型字符串为下标的数字数组,数字表示该类型的内存大小 %%
**} **}
end end
function getsenderdatabyid(); function getsenderdatabyid();
begin begin
{** {**
@explan(说明) 获取变量的地址,在send消息使用 %% @explan(说明) 获取变量的地址,在send消息使用 %%
@return(obj) tsl变量 %% @return(obj) tsl变量 %%
**} **}
end end
end. end.

7162
funcext/tvclib/tslvcl.tsf
View File

File diff suppressed because it is too large Load Diff

171
funcext/tvclib/ugtkinterface.tsf
View File

@ -4,7 +4,7 @@ interface
20220128-0900 稳定接口 20220128-0900 稳定接口
20210902-0308 稍微整理 20210902-0308 稍微整理
} }
uses cstructurelib; uses cstructurelib,utslvclmemstruct;
function _gtkeventcall_();//gtk消息分发 function _gtkeventcall_();//gtk消息分发
function _gtkidledo_(); //gtk idle消息分发 function _gtkidledo_(); //gtk idle消息分发
function _gtk_add_time_msg_(h,m,w,l); function _gtk_add_time_msg_(h,m,w,l);
@ -426,16 +426,15 @@ type tgtkapis = class() //gtk
end end
function execsystem(s:string):integer;cdecl;external './plugin/libTSLUIL.so';
function openresourcemanager(p); //打开资源管理器 function openresourcemanager(p); //打开资源管理器
begin begin
if ifstring(p) then if ifstring(p) then
return execsystem(format('nautilus "%s" &',p)); return tsl_gtk_execsystem(format('nautilus "%s" &',p));
end end
/////////////////////////////pipe process///////////执行程序相关///////////////////////////// /////////////////////////////pipe process///////////执行程序相关/////////////////////////////
function tsl_gtk_closehandle(p:pointer):integer;cdecl;external "plugin/libTSLUIL.so"; //function tsl_gtk_closehandle(p:pointer):integer;cdecl;external "plugin/libTSLUIL.so";
function tsl_gtk_pipread(p:pointer;var msg:string;ct:integer):integer;cdecl;external "plugin/libTSLUIL.so"; function tsl_gtk_pipread(p:pointer;var msg:string;ct:integer):integer;cdecl;external "plugin/libTSLUIL.so";
function tsl_gtk_kill(p:pointer;sig:integer):integer;cdecl;external "plugin/libTSLUIL.so"; //function tsl_gtk_kill(p:pointer;sig:integer):integer;cdecl;external "plugin/libTSLUIL.so";
function tsl_gtk_createprocessa(exe:string; cmd : array of string; ev : array of string;var pw:pointer):pointer;cdecl;external "plugin/libTSLUIL.so"; function tsl_gtk_createprocessa(exe:string; cmd : array of string; ev : array of string;var pw:pointer):pointer;cdecl;external "plugin/libTSLUIL.so";
/////////////////////////////////timer/////////////////////////////// /////////////////////////////////timer///////////////////////////////
@ -452,8 +451,6 @@ type tgtkapis = class() //gtk
function gtk_main_iteration_do(f:integer):integer;cdecl;external 'libgtk-3.so'; function gtk_main_iteration_do(f:integer):integer;cdecl;external 'libgtk-3.so';
function gtk_main_iteration():integer ;cdecl;external 'libgtk-3.so'; function gtk_main_iteration():integer ;cdecl;external 'libgtk-3.so';
/////////////////////////////////////////////////////// ///////////////////////////////////////////////////////
function tsl_gtk_idle_interface(p:pointer):integer;cdecl;external "./plugin/libTSLUIL.so";
function tsl_gtk_color_selection_property(w:pointer):pointer;cdecl;external "./plugin/libTSLUIL.so";
function g_idle_remove_by_data(p:pointer):integer;cdecl;external 'libgtk-3.so'; function g_idle_remove_by_data(p:pointer):integer;cdecl;external 'libgtk-3.so';
//////////////// ////////////////
@ -685,7 +682,7 @@ type tgtkapis = class() //gtk
procedure cairo_paint_with_alpha(c:pointer;alpah:double);cdecl;external 'libgtk-3.so'; procedure cairo_paint_with_alpha(c:pointer;alpah:double);cdecl;external 'libgtk-3.so';
procedure cairo_paint(c:pointer);cdecl;external 'libgtk-3.so'; procedure cairo_paint(c:pointer);cdecl;external 'libgtk-3.so';
function cairo_applay_pen_style(dc); function cairo_applay_pen_style(dc);
begin begin
pt := gtk_object_get_data(dc,"pen.style"); pt := gtk_object_get_data(dc,"pen.style");
if pt=0x2 then if pt=0x2 then
@ -756,7 +753,7 @@ type tgtkapis = class() //gtk
procedure gtk_window_set_resizable(p:pointer;f:integer);cdecl;external 'libgtk-3.so'; procedure gtk_window_set_resizable(p:pointer;f:integer);cdecl;external 'libgtk-3.so';
function gtk_window_get_resizable(p:pointer):integer;cdecl;external 'libgtk-3.so'; function gtk_window_get_resizable(p:pointer):integer;cdecl;external 'libgtk-3.so';
procedure gtk_window_set_decorated(w:pointer;f:integer);cdecl;external 'libgtk-3.so'; procedure gtk_window_set_decorated(w:pointer;f:integer);cdecl;external 'libgtk-3.so';
function gtk_window_get_decorated(w:pointer):integer;cdecl;external 'libgtk-3.so'; function gtk_window_get_decorated(w:pointer):integer;cdecl;external 'libgtk-3.so';
procedure gtk_window_set_title(w:pointer;t:string);cdecl;external 'libgtk-3.so'; procedure gtk_window_set_title(w:pointer;t:string);cdecl;external 'libgtk-3.so';
procedure gtk_window_set_geometry_hints (window:pointer; procedure gtk_window_set_geometry_hints (window:pointer;
eometry_widget:pointer; eometry_widget:pointer;
@ -836,10 +833,10 @@ type tgtkapis = class() //gtk
/////////////////////////// adjust scroll ///////////////////////////////// /////////////////////////// adjust scroll /////////////////////////////////
function gtk_adjustment_get_type():pointer; cdecl;external 'libgtk-3.so'; function gtk_adjustment_get_type():pointer; cdecl;external 'libgtk-3.so';
function GTK_ADJUSTMENT(w); function GTK_ADJUSTMENT(w);
begin begin
return g_type_check_instance_cast(w,gtk_adjustment_get_type()); return g_type_check_instance_cast(w,gtk_adjustment_get_type());
end end
function gtk_adjustment_new(v:double; function gtk_adjustment_new(v:double;
lower:double; lower:double;
@ -911,30 +908,30 @@ type tgtkapis = class() //gtk
////////////////////////// dialog /////////////////////////////////////////////////////////// ////////////////////////// dialog ///////////////////////////////////////////////////////////
function gtk_dialog_run(d:pointer):integer; cdecl;external 'libgtk-3.so'; function gtk_dialog_run(d:pointer):integer; cdecl;external 'libgtk-3.so';
procedure gtk_dialog_response(w:pointer;id:integer); cdecl;external 'libgtk-3.so'; procedure gtk_dialog_response(w:pointer;id:integer); cdecl;external 'libgtk-3.so';
function gtk_file_chooser_dialog_new(t:string;p:pointer;act:integer;bstring1:string;bvalue1:integer;bstring2:string;bvalue2:integer;pend:pointer):pointer ; cdecl;external 'libgtk-3.so'; function gtk_file_chooser_dialog_new(t:string;p:pointer;act:integer;bstring1:string;bvalue1:integer;bstring2:string;bvalue2:integer;pend:pointer):pointer ; cdecl;external 'libgtk-3.so';
function gtk_file_chooser_get_filename(p:pointer):string;cdecl;external 'libgtk-3.so'; function gtk_file_chooser_get_filename(p:pointer):string;cdecl;external 'libgtk-3.so';
function gtk_file_chooser_set_filename(p:pointer;n:string):integer;cdecl;external 'libgtk-3.so'; function gtk_file_chooser_set_filename(p:pointer;n:string):integer;cdecl;external 'libgtk-3.so';
procedure gtk_file_chooser_set_select_multiple(p:pointer;m:integer);cdecl;external 'libgtk-3.so'; procedure gtk_file_chooser_set_select_multiple(p:pointer;m:integer);cdecl;external 'libgtk-3.so';
function gtk_file_chooser_get_filenames(p:pointer):pointer ;cdecl;external 'libgtk-3.so'; function gtk_file_chooser_get_filenames(p:pointer):pointer ;cdecl;external 'libgtk-3.so';
function gtk_font_chooser_dialog_new(t:string;p:pointer):pointer;cdecl;external 'libgtk-3.so'; function gtk_font_chooser_dialog_new(t:string;p:pointer):pointer;cdecl;external 'libgtk-3.so';
function gtk_font_selection_dialog_new(t:string):pointer;cdecl;external 'libgtk-3.so'; function gtk_font_selection_dialog_new(t:string):pointer;cdecl;external 'libgtk-3.so';
function gtk_font_selection_dialog_get_font_name(d:pointer):string;cdecl;external 'libgtk-3.so'; function gtk_font_selection_dialog_get_font_name(d:pointer):string;cdecl;external 'libgtk-3.so';
function gtk_font_selection_dialog_get_preview_text(p:pointer):string;cdecl;external 'libgtk-3.so'; function gtk_font_selection_dialog_get_preview_text(p:pointer):string;cdecl;external 'libgtk-3.so';
procedure gtk_font_selection_dialog_set_preview_text(p:pointer;t:string); cdecl;external 'libgtk-3.so'; procedure gtk_font_selection_dialog_set_preview_text(p:pointer;t:string); cdecl;external 'libgtk-3.so';
function gtk_font_selection_dialog_set_font_name(p:pointer;f:string):integer; cdecl;external 'libgtk-3.so'; function gtk_font_selection_dialog_set_font_name(p:pointer;f:string):integer; cdecl;external 'libgtk-3.so';
procedure gtk_widget_modify_font(w:pointer;p:pointer); cdecl;external 'libgtk-3.so'; procedure gtk_widget_modify_font(w:pointer;p:pointer); cdecl;external 'libgtk-3.so';
function gtk_color_selection_dialog_get_type():pointer;cdecl;external 'libgtk-3.so'; function gtk_color_selection_dialog_get_type():pointer;cdecl;external 'libgtk-3.so';
procedure gtk_color_selection_set_current_color(w:pointer;c:pointer);cdecl;external 'libgtk-3.so'; procedure gtk_color_selection_set_current_color(w:pointer;c:pointer);cdecl;external 'libgtk-3.so';
procedure gtk_color_selection_get_current_color(w:pointer;c:pointer);cdecl;external 'libgtk-3.so'; procedure gtk_color_selection_get_current_color(w:pointer;c:pointer);cdecl;external 'libgtk-3.so';
function gdk_color_parse(cs:string;c:pointer):integer;cdecl;external 'libgtk-3.so'; function gdk_color_parse(cs:string;c:pointer):integer;cdecl;external 'libgtk-3.so';
////////////////// evntbox //////////////////////////// ////////////////// evntbox ////////////////////////////
function gtk_event_box_new():pointer;cdecl;external 'libgtk-3.so'; function gtk_event_box_new():pointer;cdecl;external 'libgtk-3.so';
//获得image //获得image
function GTK_WIDGET(w); //gtkwidget function GTK_WIDGET(w); //gtkwidget
begin begin
wt := static gtk_widget_get_type(); wt := static gtk_widget_get_type();
return g_type_check_instance_cast(w,wt); return g_type_check_instance_cast(w,wt);
@ -959,7 +956,7 @@ type tgtkapis = class() //gtk
return w; return w;
end end
function GTK_COLOR_SELECTION_DIALOG(W); function GTK_COLOR_SELECTION_DIALOG(W);
begin begin
return g_type_check_instance_cast(w,gtk_color_selection_dialog_get_type()); return g_type_check_instance_cast(w,gtk_color_selection_dialog_get_type());
end end
@ -978,9 +975,9 @@ type tgtkapis = class() //gtk
function g_main_context_default():pointer;cdecl;external 'libgtk-3.so'; function g_main_context_default():pointer;cdecl;external 'libgtk-3.so';
function g_main_context_get_poll_func(d:pointer):pointer;cdecl;external 'libgtk-3.so'; function g_main_context_get_poll_func(d:pointer):pointer;cdecl;external 'libgtk-3.so';
function gtk_main_level():integer;external 'libgtk-3.so'; function gtk_main_level():integer;external 'libgtk-3.so';
function g_signal_connect_data(instance:pointer; detailed_signal:string; c_handler:pointer;data:pointer;dd:pointer;f:integer):integer;cdecl;external 'libgtk-3.so'; function g_signal_connect_data(instance:pointer; detailed_signal:string; c_handler:pointer;data:pointer;dd:pointer;f:integer):integer;cdecl;external 'libgtk-3.so';
function g_signal_new(signal_name:string; function g_signal_new(signal_name:string;
itype:pointer; itype:pointer;
signal_flags:integer; signal_flags:integer;
class_offset:integer; class_offset:integer;
@ -1057,7 +1054,7 @@ type _cairo_matrix_t = class(tslcstructureobj)
property yy index "yy" read _getvalue_ write _setvalue_; property yy index "yy" read _getvalue_ write _setvalue_;
property x0 index "x0" read _getvalue_ write _setvalue_; property x0 index "x0" read _getvalue_ write _setvalue_;
property y0 index "y0" read _getvalue_ write _setvalue_; property y0 index "y0" read _getvalue_ write _setvalue_;
end end
type _cairo_text_extents_t = class(tslcstructureobj) type _cairo_text_extents_t = class(tslcstructureobj)
private private
static SSTRUCT; static SSTRUCT;
@ -1114,7 +1111,7 @@ type _cairo_font_extents_t = class(tslcstructureobj)
property height index "height" read _getvalue_ write _setvalue_; property height index "height" read _getvalue_ write _setvalue_;
property max_x_advance index "max_x_advance" read _getvalue_ write _setvalue_; property max_x_advance index "max_x_advance" read _getvalue_ write _setvalue_;
property max_y_advance index "max_y_advance" read _getvalue_ write _setvalue_; property max_y_advance index "max_y_advance" read _getvalue_ write _setvalue_;
end end
type _dlgwidgets = class(tslcstructureobj) type _dlgwidgets = class(tslcstructureobj)
private private
@ -1737,85 +1734,9 @@ type tagNMSELCHANGE=class(tslcstructureobj)
end end
end end
type TSTYLESTRUCT = class(tslcstructureobj)
private
static SSTRUCT;
function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(
array(
("styleold","int",0),
("stylenew","int",0)));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
property styleold index "styleold" read _getvalue_ write _setvalue_ ;
property stylenew index "stylenew" read _getvalue_ write _setvalue_ ;
end
type TCREATESTRUCT = class(tslcstructureobj)
private
static SSTRUCT;
function getstruct()
begin
if not SSTRUCT then SSTRUCT := 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)));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
property style index "style" read _getvalue_ write _setvalue_;
property dwexstyle index "dwexstyle" read _getvalue_ write _setvalue_;
end
type TScrollinfo = class(tslcstructureobj)
private
static SSTRUCT;
function getstruct()
begin
if not SSTRUCT then SSTRUCT :=
MemoryAlignmentCalculate(
array(
("cbsize","int",0),
("fmask","int",0),
("nmin","int",0),
("nmax","int",0),
("npage","int",0),
("npos","int",0),
("ntrackpos","int",0)));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
cbsize := _size_();
end
property cbsize:integer index "cbsize" read _getvalue_ write _setvalue_;
property fmask:integer index "fmask" read _getvalue_ write _setvalue_;
property nmin:integer index "nmin" read _getvalue_ write _setvalue_;
property nmax:integer index "nmax" read _getvalue_ write _setvalue_;
property npage:integer index "npage" read _getvalue_ write _setvalue_;
property npos:integer index "npos" read _getvalue_ write _setvalue_;
property ntrackpos:integer index "ntrackpos" read _getvalue_ write _setvalue_;
end
/////////////////////////////////额外定义的结构体 为了适应windows api/////////////////////////////////////////// /////////////////////////////////额外定义的结构体 为了适应windows api///////////////////////////////////////////
type _gslist =class(tslcstructureobj) type _gslist =class(tslcstructureobj)
static classstruct; static classstruct;
@ -2408,10 +2329,13 @@ type tgtk_ctl_object = class(_gtkeventtype)
ah := a.handle; ah := a.handle;
if not _wapi.gtk_widget_is_toplevel(ah) then return true ; if not _wapi.gtk_widget_is_toplevel(ah) then return true ;
fcsctl := _wapi.gtk_window_get_focus(ah); fcsctl := _wapi.gtk_window_get_focus(ah);
if not fcsctl then return true; if not fcsctl then
begin
fcsctl := unit(tslvcl).initializeapplication().handle; //用主窗口的
if not fcsctl then return true;
end
fcsctl := TGtkObjects[inttostr(fcsctl)] ; fcsctl := TGtkObjects[inttostr(fcsctl)] ;
if not fcsctl then return true; if not fcsctl then return true;
if (kud = 8) and (kv<>65505 or kv<>65506) then if (kud = 8) and (kv<>65505 or kv<>65506) then
begin begin
@ -3034,7 +2958,6 @@ type tgtk_ctl_object = class(_gtkeventtype)
private private
FHandle; FHandle;
class function gtk_widget_get_type():pointer;cdecl;external 'libgtk-3.so'; class function gtk_widget_get_type():pointer;cdecl;external 'libgtk-3.so';
class function gettslvcleventhandler(n:string):pointer;cdecl;external "./plugin/libTSLUIL.so" name "gettslvcleventhandler";
class procedure g_signal_handler_disconnect(instance:pointer;id:integer);cdecl;external 'libgtk-3.so'; class procedure g_signal_handler_disconnect(instance:pointer;id:integer);cdecl;external 'libgtk-3.so';
class function g_signal_connect_data(instance:pointer; detailed_signal:string; c_handler:pointer;data:pointer;dd:pointer;f:integer):pointer;cdecl;external 'libgtk-3.so'; class function g_signal_connect_data(instance:pointer; detailed_signal:string; c_handler:pointer;data:pointer;dd:pointer;f:integer):pointer;cdecl;external 'libgtk-3.so';
class function g_signal_new(signal_name:string; class function g_signal_new(signal_name:string;
@ -4134,6 +4057,15 @@ begin
if ifarray(d) then if ifarray(d) then
begin begin
//echo "\r\n>>",d[0],"==",d[1],"===",d[4],">>>",datetimetostr(now()); //echo "\r\n>>",d[0],"==",d[1],"===",d[4],">>>",datetimetostr(now());
{if d[1] = 0x007B then
begin
r := class(tgtk_ctl_object).CallGtkWinProc(d[0],d[1],d[2],d[3]);
if not r then //右键菜单上传
begin
end
return r;
end }
if d[4]=0x113 and d[0]=0 then //定时 if d[4]=0x113 and d[0]=0 then //定时
begin begin
unit(tslvcl)._timeproc_(d[0],d[1],d[2],d[3]); unit(tslvcl)._timeproc_(d[0],d[1],d[2],d[3]);
@ -4141,6 +4073,17 @@ begin
if d[0] then if d[0] then
begin begin
r := class(tgtk_ctl_object).CallGtkWinProc(d[0],d[1],d[2],d[3]); 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();
h := _wapi.GetParent(d[0]);
if h then
begin
AddMessageToGtkMessageQueue(h,d[1],h,d[3],true);
end
return 1;
end
return r; return r;
end end
else else

2
funcext/tvclib/utslmemo.tsf
View File

@ -1231,7 +1231,7 @@ type TCustomMemo = class(TCustomScrollControl,TCustomMemoCmd)
begin begin
if not ReadOnly then return InsertChars(c); if not ReadOnly then return InsertChars(c);
end end
function ExecuteCommand(cmd,data);virtual; function ExecuteCommand(cmd,data);override;
begin begin
{** {**
@explan(说明) 执行操作 %% @explan(说明) 执行操作 %%

814
funcext/tvclib/utslvclauxiliary.tsf Normal file
View File

@ -0,0 +1,814 @@
unit utslvclauxiliary;
{**
@explan(说明) tslvcl 辅助库 %%
**}
interface
type TCharDiscrimi=class
static CD_SMA;
static CD_BGA;
static CD_SMZ;
static CD_BGZ;
static CD_UDL;
static CD_NIN;
static CD_ZER;
static CD_ISOK;
class function sinit();virtual;
begin
if not CD_ISOK then
begin
K := 1;
CD_SMA := ord("a");
CD_BGA := ord("A");
CD_SMZ := ord("z");
CD_BGZ := ord("Z");
CD_UDL := ord("_");
CD_NIN := ord("9");
CD_ZER := ord("0");
CD_ISOK := 1;
end
end
class function IsLetter(cc);
begin
return IsUppercaseLetter(CC)OR IsLowercaseLetter(cc);
end
class function IsLowercaseLetter(cc);
begin
return(cc >= CD_SMA)and(cc <= CD_SMZ);
end
class function IsUppercaseLetter(cc);
begin
return(cc >= CD_BGA)and(cc <= CD_BGZ);
end
class function IsNumber(cc);
begin
return(cc >= CD_ZER)and(cc <= CD_NIN);
end
class function IsVariableName(s);
begin
if ifstring(s)and length(s)>= 1 then
begin
cc := ord(s[1]);
if IsLetter(cc)or cc=CD_UDL then
begin
for i := 2 To length(s) do
begin
cc := ord(s[i]);
if not(IsLetter(cc)or IsNumber(cc)or(cc=CD_UDL))then
begin
return false;
end
end
return true;
end
end
return 0;
end
function create();
begin
sinit();
end
end
type TByteDataOP=class() //位操作类
{**
@explan(说明) 位操作封装
**}
{**
@example(范例:byte数组转整数)
oa := new TByteDataOP();
echo tostn(oa.bytesasint(array(1,1,1,1)));
**}
{**
@example(范例:整数转byte数组)
oa := new TByteDataOP();
echo tostn(oa.intasbytes(235);
**}
class function BytesAsInt(a);
begin
{**
@explan(说明) 四个byte转换为integer %%
@param(a)(array) 正式表示的四字节 %%
@return(integer) 组装好的整数 %%
**}
uu := a[0];
ul := a[1];
lu := a[2];
ll := a[3];
l := makelong(ll,lu,8);
u := makelong(ul,uu,8);
return makelong(l,u);
end
class function IntAsBytes(v);
begin
{**
@explan(说明) 整数转换为byte 数组(整数数组模拟) %%
@param(v)(integer) %%
@return(array) 模拟的byte数组 %%
**}
lowuperdword(v,l,u);
lowuperdword(l,ll,lu);
lowuperdword(u,ul,uu);
return array(uu,ul,lu,ll);
end
class function ShortsToInt(a);
begin
{**
@explan(说明) 两个short转换为一个int %%
@param(a)(array) 两个元素的数组 %%
@return(integer) 整数 %%
**}
l := a[1];
u := a[0];
return makelong(l,u);
end
class function IntToShorts(v);
begin
{**
@explan(说明) 整数转换为两个short 数组(整数数组模拟) %%
@param(v)(integer) %%
@return(array) 模拟的short数组 %%
**}
lowuperdword(v,l,u);
return array(l,u);
end
class function StrAsBytes(s);
begin
{**
@explan(说明) 字符串转换为byte数组 %%
@param(s)(string) 字符串 %%
@return(array) 模拟的byte数组 %%
**}
r := array();
for i := 0 to length(s) do r[i]:= ord(s[i]);
return r;
end
class function BytesAsStr(b);
begin
{**
@explan(说明) byte数组转字符串 %%
@param(b)(array) byte数组 %%
@return(string) 字符串
**}
r := "";
for i := 0 to length(b)-1 do r += chr(b[i]);
return r;
end
end
//**************************数组链表类******************************************
type tarray1dlk=class //从0开始
private
_len;
FCompareValue;
protected _data; //数据
public
{**
@explan(说明) 一维链表类 %%
@param(_len)(integer) 长度 %%
@param(_data)(array) 数据 %%
@param(CompareValue)(fpointer) 回调函数 function(v1,v2)begin return v1 = v2 ; end %%
**}
function setdata(data);
begin
{**
@explan(说明) 一次性设置数据 %%
@param(data)(array) 数据 %%
**}
_data := data;
_len := length(data);
end
function clean();
begin
{**
@explan(说明) 清空 %%
**}
_data := array();
_len := 0;
end
function create(); //构造
begin
{**
@explan(说明) 构造 %%
**}
_data := array();
_len := 0;
end
function CallCompare(v1,v2,f);
begin
if datatype(f)=7 then return call(f,v1,v2);
if datatype(FCompareValue)=7 then return call(FCompareValue,v1,v2);
return v1=v2;
end
function append(v) //追加
begin
{**
@explan(说明) 追加 %%
@param(v)() tsl数据 %%
**}
_data[_len++]:= v;
end;
function geti(i); //获取
begin
{**
@explan(说明) 获得 %%
@param(i)(integer) id %%
**}
return _data[i];
end
function seti(i,v); //设置值
begin
{**
@explan(说明) 设置值 %%
@param(i)(integer) id %%
@param(v)() tsl数据 %%
**}
if i >= 0 and i<_len then
begin
_data[i]:= v;
end
end
function deli(i); //删除
begin
{**
@explan(说明) 删除 %%
@param(i)(integer) id %%
**}
//len := length(_data)-1;
if i<0 or i >= _len then return-1;
_len -= 1;
return deleteindex(_data,i,1);
end
function delis(i);
begin
{**
@explan(说明) 批量删除 %%
@param(i)(array) 删除的id %%
**}
dels := getdels(i);
for ii,v in dels do deli(v);
end
function getdels(i); //删除多行
begin
{**
@ignore (忽略) %%
@explan(说明) 批量删除 %%
@param(i)(array) 删除的id %%
**}
ii := sselect thisrow from(i union2 array())where(thisrow >= 0 and thisrow<_len)order by thisrow end;
dels := array();
ix := 0;
for iv in ii do
begin
dels[iv]:= ii[iv]-ix;
ix++;
end
return dels;
end
function insertbefor(v,i); //之前插入
begin
{**
@explan(说明) 在i之前插入 %%
@param(v)() 插入数据 %%
@param(i)(integer) id %%
**}
if not ifnumber(i)then return;
if i >= _len then return append(v);
else if i <= 0 then
begin
_data := array(v)union _data;
end else
begin
_data := _data[0:(i-1)]union array(v)union _data[i:];
end
_len++;
end
function insertafter(v,i); //之后插入
begin
{**
@explan(说明) 在i之后插入 %%
@param(v)() 插入数据 %%
@param(i)(integer) id %%
**}
if not ifnumber(i)then return;
if i >= _len then return append(v);
else if i<0 then
begin
_data := array(v)union _data;
end else
begin
_data := _data[0:i]union array(v)union _data[i+1:];
end
_len++;
end
function findvid(v1,func,lx); //查找序号,func通过送入的比较函数
begin
{**
@explan(说明) 查找序号和v1 匹配的id %%
@param(v1)(any) tsl数据 %%
@param(lx)(bool) 逆序查找 %%
@param(func)(fpointer) 比较函数 第一个参数为 数组中对象,第二个参数为输入判断条件 %%
**}
ret :=-1;
if lx then
begin
for i := length(_data)downto 0 do
begin
if CallCompare(_data[i],v1,func)then return i;
end
return ret;
end
for i,v in _data do
begin
if CallCompare(v,v1,func)then
begin
return i;
end
end
return ret;
end
function getprev(v1); //获得上一个
begin
{**
@explan(说明) 获得上一个 匹配的id %%
@param(v1)() tsl数据 %%
**}
if _len<2 then return nil;
id :=-1;
for i,v in _data do
begin
if CallCompare(v,v1)then
begin
id := i;
break;
end
end
return _data[id-1];
end
function getnext(v1); //获得下一个
begin
{**
@explan(说明) 获得下一个 匹配的id %%
@param(v1)() tsl数据 %%
**}
if _len<2 then return nil;
id := _len;
for i,v in _data do
begin
if CallCompare(v,v1)then
begin
id := i;
break;
end
end
return _data[id+1];
end
function ergodic(f); //循环处理
begin
{**
@explan(说明) 循环所有数据 %%
@param(f)(fpointer) 处理函数 function(id,v) begin end %%
**}
if(datatype(f)<> 7)then return nil;
for i,v in _data do
begin
ret := call(f,i,v); //## f(i,v);
if ret=-1 then break;
end
return 1;
end
function data(); //数组数据
begin
{**
@explan(说明) 返回所有数据 %%
**}
return _data;
end
function replace(i,v) //替换
begin
{**
@explan(说明) 替换 %%
@param(i)(integer) 序号 %%
@param(v)() tsl数据 %%
**}
if i >= 0 and i<_len then
begin
ret := _data[i];
_data[i]:= v;
return ret;
end else
return nil;
end
function len(); //大小
begin
{**
@explan(说明) 长度 %%
**}
//return length(_data);
return _len;
end
function setorder(i,j);
begin
{**
@explan(说明) 设置元素位置 %%
@param(i)(integer)原始位置 %%
@param(j)(integer) 移动后的位置
**}
if j>_len-1 then j := _len-1;
if j<0 then j := 0;
if i=j or(i<0 and i>_len)then exit;
sl := createserial(i,j);
for ii := 0 to length(sl)-2 do
begin
SwapNoCheck(sl[ii],sl[ii+1]);
end
end
function swap(i,j); //交换
begin
{**
@explan(说明) 交换 %%
@param(i)(integer) 序号 %%
@param(j)(integer) 序号 %%
**}
if ifnumber(i)and ifnumber(j)and i <> j and i >= 0 and j >= 0 and i<_len and j<_len then
begin
SwapNoCheck(i,j);
//vi := _data[i];
//_data[i]:=_data[j];
//_data[j] := vi;
end
end
property CompareValue read FCompareValue write FCompareValue;
private
function SwapNoCheck(i,j);
begin
vi := _data[i];
_data[i]:= _data[j];
_data[j]:= vi;
end
function createserial(i,j);
begin
if j>i then return i -> j;
r := array();
kk := 0;
for ii := i downto j do r[kk++]:= ii;
return r;
end
function moveto(i,j); //将i移动到j前面
begin
{**
@ignore 忽略%%
@explan(说明) 将i移动到j前面 %%
@param(i)(integer) 序号 %%
@param(j)(integer) 序号 %%
**}
if not(ifnumber(i)and i >= 0 and i<_len)then return-1;
if ifnil(j)then j := 0;
if i=j then return-1;
vi := geti(i);
insertbefor(vi,j);
if i>j then
begin
deli(i+1);
end else
begin
deli(i);
end
end
end
type tstrindexarray = class
{**
@explan(数组类型) 忽略字符串下标的大小写%%
**}
function create();
begin
FData := array();
FRows := array();
end
function DeleteIndex(idx);
begin
{**
@explan(说明) 删除指定下标 %%
**}
if ifnil(idx)or ifobj(idx)then return 0;
if ifstring(idx)then
begin
lidx := lowercase(idx);
::deleteindex(FData,lidx,0);
return ::deleteindex(FRows,lidx,0);
end
::deleteindex(FData,idx,0);
return ::deleteindex(FRows,idx,0);
end
function Operator[1](index,value);
begin
if ifstring(index)then
begin
li := lowercase(index);
end else
li := index;
if ifnone(value)then
begin
r := FData[li];
if r then return r;
r := new tstrindexarray();
FData[li]:= r;
FRows[li]:= index;
return r;
end
FRows[li]:= index;
if ifarray(value)and value then
begin
r := new tstrindexarray();
FData[li]:= r;
for i,v in value do
begin
r[i]:= v;
end
return;
end
FData[li]:= value;
end
function Operator[](index);
begin
if ifstring(index)then r := FData[lowercase(index)];
else r := FData[index];
//if ifnil(r) then return NeW tstrindexarray();
return r;
end
function Size();
begin
{**
@explan(说明) 获得长度 %%
**}
return Length(FData);
end
function toarray(n);
begin
{**
@explan(说明) 获得tsl array %%
@param(n)(bool) false 返回小写下标，true 返回原始下标 %%
**}
r := array();
for i,v in FData do
begin
if v is class(tstrindexarray)then
begin
r[n?i:FRows[i]]:= v.toarray(n);
end else
r[n?i:FRows[i]]:= v;
end
return r;
end
function IndexNames();
begin
{**
@explan(说明) 获得 所有下标 %%
**}
return FRows;
end
function HaveIndex();
begin
{**
@explan(说明) 判断是否有某个下标 %%
**}
o := self(true);
for i := 1 to Paramcount do
begin
if not(o is class(tstrindexarray))then return false;
id := params[i];
if ifnil(o.TrueIndex(id))then return false;
o := o[id];
end
return true;
end
function TrueIndex(n);
begin
{**
@explan(说明) 获得对应下标 %%
**}
if ifstring(n)then idx := lowercase(n);
else idx := n;
return FRows[idx];
end
property Data write SetData;
function destroy();
begin
FData := nil;
FRows := nil;
end
private
function SetData(d);
begin
if not ifarray(d)then return false;
FRows := array();
FData := array();
si := self(true);
for i,v in d do
begin
si[i]:= v;
end
return true;
end
FData;
FRows;
end
type tnumindexarray = Class
{**
@explan(说明) 数字下标数组对象 %%
**}
private
FData;
public
function Create();virtual;
begin
{**
@explan(说明) 构造函数 %%
**}
FData := array();
end
function Operator[1](idx,v);
begin
{**
@explan(说明)通过下标设置元素 %%
**}
return SetValueByIndex(idx,v);
end
function Operator[](idx);
begin
{**
@explan(说明) 通过下标获取元素 %%
**}
return GetValueByIndex(idx);
end
function length();
begin
{**
@explan(说明) 获得数据长度 %%
@return(integer) 长度 %%
**}
return length(FData);
end
function Push({value1,value2,....});
begin
{**
@explan(说明) 在末尾追加元素,参数个数不定 %%
**}
r := length(FData);
r1 := r;
for i := 0 to ParamCount-1 do
begin
FData[r]:= Params[i+1];
r++;
end
if r1 <> r then LengthChanged(r1-r);
return r;
end
function Pop();
begin
{**
@explan(说明) 弹出末尾的元素 %%
**}
if FData then
begin
id := length(FData)-1;
r := FData[id];
deleteindex(FData,id);
LengthChanged(-1);
return r;
end
return nil;
end
function IndexOf(v);
begin
for i,vi in FData do
begin
if vi=v then return i;
end
return-1;
end
function LastIndexOf(v);
begin
for i := length(FData)-1 downto 0 do
begin
if v=FData[i]then return i;
end
return-1;
end
function GetValueByIndex(idx);virtual;
begin
return FData[idx];
end
function SetValueByIndex(idx,v);virtual;
begin
len := length(FData);
if idx<0 then return nil;
if idx <= len then
begin
FData[idx]:= v;
end else
begin
for i := len to idx do FData[i]:= nil;
FData[idx]:= v;
return v;
end
end
function splice({startid,sellength,value1,valfue2,....});
begin
{**
@explan(说明) 替换元素,第一个参数为开始位置,第二个为替换的个数,以后的参数为用来替换的值,返回被替换的值%%
**}
p := params;
st := p[0];
sl := p[1];
sl := ifnil(sl)?inf:sl;
sl := sl<0?0:sl;
len := length(FData);
st := st<0?0:st;
st := st >= len?(len):st;
et := st+sl;
et := et >= len?(len):et;
r := array();
idx := 0;
for i := st to et-1 do
begin
r[idx++]:= FData[i];
end
r1 := FData[0:st-1];
r2 := FData[et:len-1];
FData := r1 union p[2:]union r2;
if len <> length(FData)then LengthChanged(length(FData)-len);
return r;
end
function shift();
begin
{**
@explan(说明) 弹出头部元素 %%
**}
r := nil;
len := length(FData);
if len>0 then
begin
deleteindex(FData,0);
LengthChanged(-1);
end
return len<1?(len):(len-1);
end
function unshift({value1,value2,....});
begin
{**
@explan(说明) 在数据头部加入元素,个数待定 %%
**}
p := Params;
if p then
begin
FData := p union FData;
LengthChanged(1);
end
return length(FData);
end
function swap(i,j);
begin
{**
@explan(说明) 交换下标中的值 %%
**}
if i=j then return false;
len := length(FData);
if i >= 0 and i<len and j >= 0 and j<len then
begin
t := FData[i];
FData[i]:= FData[j];
FData[j]:= t;
return true;
end
return false;
end
function pushs(vs);
begin
return callinarray(thisfunction(push),vs);
end
function unshifts(vs);
begin
return callinarray(thisfunction(unshift),vs);
end
function splices(startid,sellength,vs);
begin
if ifarray(vs)then return callinarray(thisfunction(splice),array(startid,sellength)union vs);
return array();
end
function LengthChanged(n);virtual;
begin
end
property Data read FData;
{**
@param(Data)(array) 数据 %%
**}
end
implementation
initialization
end.

5498
funcext/tvclib/utslvclconstant.tsf Normal file
View File

File diff suppressed because it is too large Load Diff

287
funcext/tvclib/utslvclmemstruct.tsf Normal file
View File

@ -0,0 +1,287 @@
unit utslvclmemstruct;
{**
@explan(说明) 接口内存管理类 %%
@date(20220429) %%
**}
interface
uses cstructurelib;
type TCREATESTRUCT=class(tslcstructureobj)
private
static SSTRUCT;
function getstruct()
begin
if not SSTRUCT then SSTRUCT := 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","char*",100),
("lpszclass","char*",100),
("dwexstyle","int",0)));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
property lpcreateparams index "lpcreateparams" read _getvalue_ write _setvalue_;
property hinstance index "hinstance" read _getvalue_ write _setvalue_;
property hmenu index "hmenu" read _getvalue_ write _setvalue_;
property hwndparent index "hwndparent" read _getvalue_ write _setvalue_;
property cy index "cy" read _getvalue_ write _setvalue_;
property cx index "cx" read _getvalue_ write _setvalue_;
property y index "y" read _getvalue_ write _setvalue_;
property x index "x" read _getvalue_ write _setvalue_;
property style index "style" read _getvalue_ write _setvalue_;
property lpszname index "lpszname" read _getvalue_ write _setvalue_;
property lpszclass index "lpszclass" read _getvalue_ write _setvalue_;
property dwexstyle index "dwexstyle" read _getvalue_ write _setvalue_;
end
type TScrollinfo = class(tslcstructureobj) //滚动条
private
static SSTRUCT;
function getstruct()
begin
if not SSTRUCT then SSTRUCT :=
MemoryAlignmentCalculate(
array(
("cbsize","int",0),
("fmask","int",0),
("nmin","int",0),
("nmax","int",0),
("npage","int",0),
("npos","int",0),
("ntrackpos","int",0)));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
cbsize := _size_();
end
property cbsize:integer index "cbsize" read _getvalue_ write _setvalue_;
property fmask:integer index "fmask" read _getvalue_ write _setvalue_;
property nmin:integer index "nmin" read _getvalue_ write _setvalue_;
property nmax:integer index "nmax" read _getvalue_ write _setvalue_;
property npage:integer index "npage" read _getvalue_ write _setvalue_;
property npos:integer index "npos" read _getvalue_ write _setvalue_;
property ntrackpos:integer index "ntrackpos" read _getvalue_ write _setvalue_;
end
type Ttagdrawtextparams=class(tslcstructureobj)
private
static SSTRUCT;
class function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(("cbsize","int",0)
,("itablength","int",4)
,("ileftmargin","int",0)
,("irightmargin","int",0)
,("uilengthdrawn","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 itablength index "itablength" read _getvalue_ write _setvalue_;
property ileftmargin index "ileftmargin" read _getvalue_ write _setvalue_;
property irightmargin index "irightmargin" read _getvalue_ write _setvalue_;
property uilengthdrawn index "uilengthdrawn" read _getvalue_ write _setvalue_;
end
type TSTYLESTRUCT = class(tslcstructureobj) //样式相关
private
static SSTRUCT;
function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(
array(
("styleold","int",0),
("stylenew","int",0)));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
property styleold index "styleold" read _getvalue_ write _setvalue_ ;
property stylenew index "stylenew" read _getvalue_ write _setvalue_ ;
end
type tvclwindowpos_class= class(tslcstructureobj) //窗口位置信息
private
static SSTRUCT;
function getstruct();
begin
if not SSTRUCT then
begin
SSTRUCT := MemoryAlignmentCalculate(
array(("hwndinsertafter","intptr",0),
("hwnd","intptr",0),
("x","int",0),
("y","int",0),
("cx","int",0),
("cy","int",0),
("flags","int",0)));
end
return SSTRUCT;
end
public
function create(ptr);override;
begin
inherited create(getstruct(),ptr);
end
property x:integer index "x" read _getvalue_ write _setvalue_;
property y:integer index "y" read _getvalue_ write _setvalue_;
property cx:integer index "cx" read _getvalue_ write _setvalue_;
property cy:integer index "cy" read _getvalue_ write _setvalue_;
property flags:integer index "flags" read _getvalue_ write _setvalue_;
property hwndinsertafter:integer index "hwndinsertafter" read _getvalue_ write _setvalue_;
property hwnd:integer index "hwnd" read _getvalue_ write _setvalue_;
end
type Ttagminmaxinfo=class(tslcstructureobj) //窗口大小相关
private
static SSTRUCT;
class function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("ptreserved","int[2]",
(0,0)),
("ptmaxsize","int[2]",
(0,0)),
("ptmaxposition","int[2]",
(0,0)),
("ptmintracksize","int[2]",
(0,0)),
("ptmaxtracksize","int[2]",
(0,0))));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
property ptreserved index "ptreserved" read _getvalue_ write _setvalue_;
property ptmaxsize index "ptmaxsize" read _getvalue_ write _setvalue_;
property ptmaxposition index "ptmaxposition" read _getvalue_ write _setvalue_;
property ptmintracksize index "ptmintracksize" read _getvalue_ write _setvalue_;
property ptmaxtracksize index "ptmaxtracksize" read _getvalue_ write _setvalue_;
end
/////////////////////////////windows进程相关结构体//////////
type T_startupinfoa=class(tslcstructureobj)
private
static SSTRUCT;
class function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("cb","int",0),
("lpreserved","intptr",0),
("lpdesktop","intptr",0),
("lptitle","intptr",0),
("dwx","int",0),
("dwy","int",0),
("dwxsize","int",0),
("dwysize","int",0),
("dwxcountchars","int",0),
("dwycountchars","int",0),
("dwfillattribute","int",0),
("dwflags","int",0),
("wshowwindow","short",0),
("cbreserved2","short",0),
("lpreserved2","intptr",0),
("hstdinput","intptr",0),
("hstdoutput","intptr",0),
("hstderror","intptr",0)));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
cb := _size_();
end
property cb index "cb" read _getvalue_ write _setvalue_;
property lpreserved index "lpreserved" read _getvalue_ write _setvalue_;
property lpdesktop index "lpdesktop" read _getvalue_ write _setvalue_;
property lptitle index "lptitle" read _getvalue_ write _setvalue_;
property dwx index "dwx" read _getvalue_ write _setvalue_;
property dwy index "dwy" read _getvalue_ write _setvalue_;
property dwxsize index "dwxsize" read _getvalue_ write _setvalue_;
property dwysize index "dwysize" read _getvalue_ write _setvalue_;
property dwxcountchars index "dwxcountchars" read _getvalue_ write _setvalue_;
property dwycountchars index "dwycountchars" read _getvalue_ write _setvalue_;
property dwfillattribute index "dwfillattribute" read _getvalue_ write _setvalue_;
property dwflags index "dwflags" read _getvalue_ write _setvalue_;
property wshowwindow index "wshowwindow" read _getvalue_ write _setvalue_;
property cbreserved2 index "cbreserved2" read _getvalue_ write _setvalue_;
property lpreserved2 index "lpreserved2" read _getvalue_ write _setvalue_;
property hstdinput index "hstdinput" read _getvalue_ write _setvalue_;
property hstdoutput index "hstdoutput" read _getvalue_ write _setvalue_;
property hstderror index "hstderror" read _getvalue_ write _setvalue_;
end
type T_process_information=class(tslcstructureobj)
private
static SSTRUCT;
class function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("hprocess","intptr",0),
("hthread","intptr",0),
("dwprocessid","int",0),
("dwthreadid","int",0)));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
property hprocess index "hprocess" read _getvalue_ write _setvalue_;
property hthread index "hthread" read _getvalue_ write _setvalue_;
property dwprocessid index "dwprocessid" read _getvalue_ write _setvalue_;
property dwthreadid index "dwthreadid" read _getvalue_ write _setvalue_;
end
type T_security_attributes=class(tslcstructureobj)
private
static SSTRUCT;
class function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("nlength","int",0),
("lpsecuritydescriptor","intptr",0),
("binherithandle","int",0)));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
nlength := _size_();
end
property nlength index "nlength" read _getvalue_ write _setvalue_;
property lpsecuritydescriptor index "lpsecuritydescriptor" read _getvalue_ write _setvalue_;
property binherithandle index "binherithandle" read _getvalue_ write _setvalue_;
end
implementation
initialization
end.

2
funcext/tvclib/uvcpropertytypespersistence.tsf
View File

@ -1,6 +1,6 @@
Unit UVCPropertyTypesPersistence; Unit UVCPropertyTypesPersistence;
interface interface
uses tslvcl; uses utslvclauxiliary,tslvcl;
{** {**
@explan(说明) 可视控件属性处理库 %% @explan(说明) 可视控件属性处理库 %%
**} **}