diff --git a/Help/tslvclhelp.CHM b/Help/tslvclhelp.CHM index c63a5ce..8ab2650 100644 Binary files a/Help/tslvclhelp.CHM and b/Help/tslvclhelp.CHM differ diff --git a/designer/utslvcldcomponents.tsf b/designer/utslvcldcomponents.tsf index bb9de7f..2ce7154 100644 --- a/designer/utslvcldcomponents.tsf +++ b/designer/utslvcldcomponents.tsf @@ -2104,28 +2104,7 @@ type TPopUpMenuWindow = class(TDVirutalWindow) return GetPopUpMenuBitmapInfo(); end end -type TSocketServerWindow = class(TDVirutalWindow) - function Create(AOwner);override; - begin - inherited; - BindComp := new TSocketServer(self); - end - function bitmapinfo();override; - begin - return GetServerBitmapInfo(); - end -end -type TSocketClientWindow = class(TDVirutalWindow) - function Create(AOwner);override; - begin - inherited; - BindComp := new TSocketClient(self); - end - function bitmapinfo();override; - begin - return GetClientBitmapInfo(); - end -end + type TClipBordWindow = class(TDVirutalWindow) function Create(AOwner);override; begin @@ -2282,74 +2261,7 @@ type TDtlogincontrol = class(TDRootComponent) end -//*************Server************************* -type TDSocketServer = class(TDRootComponent) -{** - @explan(说明) 弹出菜单控件 %% -**} - function HitTip();override; - begin - return "socket服务端"; - end - function classification();override; - begin - return "天软"; - end - function ComponentClass();override; - begin - return class(TSocketServer); - end - function bitmapinfo();override; - begin - return GetServerBitmapInfo(); - end - function WndClass();override; - begin - return Class(TSocketServerWindow); - end - function Create(AOwner);override; - begin - inherited; - fiscontainerdcmp := false; - end - -end - -//*************client********************** - -type TDSocketClient = class(TDRootComponent) -{** - @explan(说明) 弹出菜单控件 %% -**} - function HitTip();override; - begin - return "socket客户端"; - end - function classification();override; - begin - return "天软"; - end - function ComponentClass();override; - begin - return class(TSocketClient); - end - function bitmapinfo();override; - begin - return GetClientBitmapInfo(); - end - - function WndClass();override; - begin - return Class(TSocketClientWindow); - end - function Create(AOwner);override; - begin - inherited; - fiscontainerdcmp := false; - end - -end //*************TTreeView*************************** type TDTreeView = class (TDComponent) diff --git a/funcext/tvclib/tslvcl.tsf b/funcext/tvclib/tslvcl.tsf index bad7bf3..9b1227e 100644 --- a/funcext/tvclib/tslvcl.tsf +++ b/funcext/tvclib/tslvcl.tsf @@ -61,361 +61,9 @@ function remotetslcallback(data); function TslToHexFormatStr(tsl); function HexFormatStrToTsl(D); function GetTextWidthAndHeightWidthFont(s,f,mul); -//**********操作系统相关函数********************* //////////////////////////////////// -type TByteData = class(TByteDataOP) -end -//******************常量类型********************************** -///////////////tmf文件转换/////////////////////// -type Ttfm2Component = class(TTmfParser) - {** - @explan(说明) tfm数据到组件转换 %% - **} - private - static FComponentTypes; - protected - class function sinit();override; - begin - inherited; - if not ifarray(FComponentTypes)then FComponentTypes := array(); - end - function formatpath(s);//处理windows的路径 - begin - r := ""; - if s and ifstring(s)then - begin - for i := 1 to length(s) do - begin - vi := s[i]; - if vi="/" then r += "\\"; - else r += vi; - end - end - return r; - end - function GetExeScriptPath(); - begin - {$ifdef linux} - p := tsl_getcurrentdir_(); - return p+ioFileseparator()+SysParamstr(0); - {$endif} - pth2 := formatpath(sysparamstr(0)); - if pth2[2]=":" then return pth2; - s := ""; - setlength(s,1024); - N := GetCurrentDirectoryA(1023,s); - return s[1:N]+ioFileseparator()+SysParamstr(0); - end - public - class function RegisterComponentType(n,typ); - begin - if ifstring(n)and n and(typ is class(TComponent))then - begin - if not ifarray(FComponentTypes)then FComponentTypes := array(); - FComponentTypes[lowercase(n)]:= typ; - end - end - class function GetComponentType(n); - begin - if(ifstring(n)and n)and ifarray(FComponentTypes)then - begin - nn := lowercase(n); - r := FComponentTypes[nn]; - if r then return r; - return findclass(nn); - end - end - function SetTfmData(owner,obj,data,lazydata); - begin - u1 := obj.GetPublishproperties(); - u2 := obj.GetPublishEvents(); - if not ifarray(u1)then u1 := array(); - if not ifarray(u2)then u2 := array(); - pubs := u1 union u2; - dprop := data["property"]; - ddp := array(); - for i,v in dprop do - begin - ddp[v["name"]]:= v; - end - for i,v in pubs do - begin - n := i; - ddpv := ddp[n]; - if not ifarray(ddpv)then continue; - cls := v["class"]; - et := GetComponentPropertyType(cls);//owner.GetPropertyType(cls); - if not et then continue; - td := SampleValue(ddpv); - if et.LazyProperty()then - begin - if not ifarray(lazydata)then lazydata := array(); - lazydata[length(lazydata)]:= array("et":et,"owner":owner,"ownerp":td, - "obj":obj,"objp":n); - continue; - end - d := et.ReadTMF(td,owner); - if ifnil(d)then continue; - try - pbs := obj.publishs(); - if(n in pbs)then - begin - //echo "\r\n====",n,"****",d; - invoke(obj,n,1,d); - end else - begin - //echo "pbs:",tostn(pbs); - end - except - //echo obj.classinfo()["classname"],"错误 \r\n"; - end; - end - for i,v in data["object"] do - begin - n := v["name"]; - cls := v["class"]; - cobj := GetComponentType(cls); - if cobj then - begin - nobj := createobject(cobj,owner); - try - if(nobj is class(TToolBar))then - begin - for iii,iiiv in v["property"] do - begin - if(iiiv["name"]="align")and(iiiv["value"]="alnone")then - begin - nobj.Align := nobj.alNone; - break; - end - end - end - nobj.parent := obj; - invoke(owner,n,1,nobj); - except - end; - call(thisfunction,owner,nobj,v,lazydata); - end - end - end - function Create();override; - begin - inherited; - end - function LoadFromTfmScript(owner,s); - begin - if s and ifstring(s)then - begin - self.Script := s; - lazydata := array(); - //lazydata[0] := array(); - darray := gettree2(); - SetTfmData(owner,owner,darray,lazydata); - for i,v in lazydata do - begin - try - dd := v["et"].ReadTMF(v["ownerp"],v["owner"]); - invoke(v["obj"],v["objp"],1,dd); - except - end; - end - end - end - function LoadFromTfm(owner); - begin - {** - @explan(说明) 从默认路径导入tfm文件信息 %% - **} - Loadinherited(owner); //导入 - end - private - function hastfmfile(phs,cn); - begin - for i,v in phs do - begin - pi := v+cn+".tfm"; - if fileexists("",pi) then - begin - return true; - end - end - end - function Loadtfmtoform(o,phs,cn); - begin - for i,v in phs do - begin - pi := v+cn+".tfm"; - size := filesize("",pi); //获取文件大小 - if readFile(rwraw(),"",pi,0,size,data)=1 then - begin - LoadFromTfmScript(o,data); - return true; - end - end - end - function Loadinherited(o);//导入 - begin - return Loadinherited_sub(o); - end - function Loadinherited_sub(o); - begin - if not ifobj(o) then return ; - if not((o is class(TDCreateForm)) or (o is class(TDCreatePanel))) then return ;//判断类型 - o2 := o; - phs := static GetSourceDirs(); - objs := array(); - fssourdirs := phs; - while true do - begin - ci := o2.classinfo(); - cn := ci["classname"]; - if cn="tdcreateform" or cn="tdcreatepanel" then return ; - if hastfmfile(phs,cn) then - begin - Loadtfmtoform(o2,phs,cn); - return ; - end - ic := ci["inherited"][0]; - if ic then - o2 := findclass(ic,o2); - else return ; - end - end - function GetSourceDirs(); - begin - lps := GetLibPaths(); - lps[length(lps)] := static GetCurrentTslDir()+"funcext"+ioFileseparator(); - lps union2=array(); - r := array(); - for i,v in lps do - begin - GetReSourcetfmdir(v,r); - end - return r; - end - function GetReSourcetfmdir(p,rp); - begin - if not ifarray(rp) then rp := array(); - iofp := ioFileseparator(); - for ii,vv in filelist("",p+"*") do - begin - fn := vv["FileName"]; - if fn="." or fn=".." then continue; - if Pos("D",vv["Attr"]) then - begin - if lowercase(fn)="resource.tfm" then - begin - rp[length(rp)] := p+"resource.tfm"+iofp; - end else - begin - GetReSourcetfmdir(p+fn+iofp,rp); - end - end - end - end - function GetLibPaths(); //获得libpath - begin - p := tsl_getlibpath_(); - if not p then return array(); - FCurrentp := ""; - {$ifdef linux} - FCurrentp := tsl_getcurrentdir_(); - {$else} - s := ""; - setlength(s,1024); - wapi := gettswin32api(); - N := wapi.GetCurrentDirectoryA(1023,s); - FCurrentp := s[1:N]; - {$endif} - FCurrentp1 := ""; - iofp := ioFileseparator(); - for i:= length(FCurrentp)-1 downto 1 do - begin - if FCurrentp[i] = iofp then - begin - FCurrentp1 := FCurrentp[1:i-1]; - break; - end - end - ri := 0; - r := array(); - iofp2 := "."+iofp; - iofp3 := ".."+iofp; - for i,v in str2array(p,";") do - begin - vi := trim(v); - if not vi then continue; - if vi[length(vi)]<>iofp then continue; - if pos(iofp2,vi)=1 then - begin - r[ri] := FCurrentp+vi[2:]; - end else - if pos(iofp3,vi)=1 then - begin - r[ri] := FCurrentp1+vi[3:]; - end - else - begin - r[ri] := vi; - end - ri++; - end - return r; - end -end - -type TGlobalComponentcache=class() //窗口对象缓存句柄作为索引 - {** - @ignore(忽略) %% - @explan(说明) 窗口存储类 %% - @param(FWidowhandes)(array) 组件全局存储类 %% - **} - STATIC FWidowhandes; - class function getwndbyhwnd(hwnd); - begin - {** - @explan(说明) 根据id查找组件 %% - **} - sinit(); - if ifnumber(hwnd)then return FWidowhandes[inttostr(hwnd)]; - end - class function registerhandle(handle,o); - begin - {** - @explan(说明)保存组件对象 %% - **} - sinit(); - if o is class(tcomponent)then - begin - //o.handle := handle; - if ifnumber(handle)then FWidowhandes[inttostr(handle)]:= o; - end - end - class function unregisterhandle(handle); - begin - {** - @explan(说明)删除组件对象 %% - **} - sinit(); - if ifnumber(handle)then - begin - reindex(FWidowhandes,array(inttostr(handle):nil)); - end - end - class function sinit(); - begin - {** - @ignore(忽略) 忽略 %% - @explan(说明)初始化 %% - **} - if not ifarray(FWidowhandes)then - begin - FWidowhandes := array(); - end - end -end - - +{type TByteData = class(TByteDataOP) +end } //应用 type tapplication=class(tcomponent) {** @@ -646,7 +294,7 @@ end type TLabel = class(TcustomLabel) {** @explan(说明)标签控件 %% - **} + **} function create(AOwner);override; begin inherited; @@ -1434,7 +1082,7 @@ type tform=class(TVCForm) inherited; end end -type TpanelForm=class(tpanel) +type TpanelForm=class(tpanel) //设计器的面板窗口 {** @explan(说明) 面板窗口 ,在设计器中使用 %% **} @@ -1486,7 +1134,7 @@ type TpanelForm=class(tpanel) inherited; end end -type TDCreateForm=class(TVCForm) +type TDCreateForm=class(TVCForm) //设计器的窗口 function Create(AOwner);override; begin inherited; @@ -1505,7 +1153,7 @@ type TDCreateForm=class(TVCForm) end end -type TDCreatePanel=class(TpanelForm) +type TDCreatePanel=class(TpanelForm) //设计器的面板 function Create(AOwner);override; begin inherited; @@ -1526,7 +1174,7 @@ type TDCreatePanel=class(TpanelForm) end //按钮 -type tbtn = class(tcustombtn) +type tbtn = class(tcustombtn) //按钮 {** @explan(说明) 普通按钮 %% **} @@ -1542,7 +1190,7 @@ type tbtn = class(tcustombtn) end end -type tcheckbtn = class(tcustomcheckbtn) +type tcheckbtn = class(tcustomcheckbtn) //复选框 {** @explan(说明) 复选框 %% **} @@ -1558,7 +1206,7 @@ type tcheckbtn = class(tcustomcheckbtn) end end -type tradiobtn = class(tcustomradiobtn) +type tradiobtn = class(tcustomradiobtn) //单选框 {** @explan(说明)radiobtn单选按钮控件 **} @@ -1651,7 +1299,7 @@ type TPopMenuBtn=class(TBtn) end //edit -type tedit = class(tcustomedit) +type tedit = class(tcustomedit) //编辑框 {** @explan(说明) 单行文本编辑框类 %% **} @@ -1666,7 +1314,7 @@ type tedit = class(tcustomedit) ,"onkeydown","onkeypress","onmaxtext","onkillfocus","onsetfocus","onchange","onnotification"); end end -type tpassword = class(tcustompassword) +type tpassword = class(tcustompassword) //密码框 {** @explan(说明) 密码编辑框类 %% **} @@ -1688,7 +1336,7 @@ type tpassword = class(tcustompassword) end end -type tmemo = class(TSynMemoNorm) +type tmemo = class(TSynMemoNorm) //多行文本框 uses UTslMemo; {** @explan(说明) 多行文本控件 %% @@ -2515,15 +2163,7 @@ type TTreeCtlNode = class( TcustomTreeCtlNode) inherited; end end -type TTreeCtl = class(TcustomTreeCtl) - {** - @explan(说明) 树控件 %% - **} - function create(AOwner);override; - begin - inherited; - end -end + type TTreeNode=class(TTreeCtlNode) {** @@ -2631,20 +2271,6 @@ type TTreeNode=class(TTreeCtlNode) begin DeleteChildren(); end - (*function HandleAllocated(); - begin - {** - @explan(说明)是否句柄有效%% - @return(bool) - **} - return true; - end - function CreateHandle();virtual; - begin - {** - @explan(说明) 构建句柄 %% - **} - end *) function InsertNode(node,bnode);override; begin {** @@ -2706,6 +2332,15 @@ type TTreeNode=class(TTreeCtlNode) end property items read Gitems; end +type TTreeCtl = class(TcustomTreeCtl) + {** + @explan(说明) 树控件 %% + **} + function create(AOwner);override; + begin + inherited; + end +end type TTreeView=class(TTreeCtl) {** @explan(说明) tree控件 %% @@ -2725,22 +2360,6 @@ type TTreeView=class(TTreeCtl) begin return(RootItem.toarray())["nodes"]; end - protected - function GetitemByCursorPos(); - begin - ps := array(x,y); - _wapi.GetCursorPos(ps); - pt := ScreentoClient(ps[0],ps[1]); - return TvHittest(pt[0],pt[1]); - end - function TvHittest(x,y,flag); - begin - {** - @explan(说明) 获取指定位置的item %% - **} - id := GetItemIndexByYpos(y); - if id >= 0 then return GetItemByIndex(id); - end public function hasFocus();override; begin @@ -2757,7 +2376,7 @@ type TTreeView=class(TTreeCtl) InvalidateItem(self.CurrentNode); end end - function WMKILLFOCUS(o,e):WM_KILLFOCUS;override; + function WMKILLFOCUS(o,e);override; begin FHaveFocus := false; InvalidateItem(self.CurrentNode); @@ -2776,7 +2395,7 @@ type TTreeView=class(TTreeCtl) @explan(说明) 展开节点 %% @param(item)(TTreeNode) ; **} - if item is class(TTreeNode)then item.Expand(); + if item is class(TTreeNode) then item.Expand(); end function collapse(item); begin @@ -2899,8 +2518,7 @@ end type TTabSheet = class(tcustomtabsheet) {** @explan(说明)page控件页面 %% - **} - + **} function create(AOwner); begin inherited; @@ -3266,18 +2884,6 @@ type TTlvnActiveEvent=class(tuieventbase) {** @explan(说明) listview active 通知消息 %% **} - private - FNmList; - function _getvalue_(n); - begin - //return FNmList._getvalue_(n); - return FNmList[n]; - end - function _setvalue_(n,v); - begin - //return FNmList._setvalue_(n,v); - FNmList[n] := v; - end public function create(m,w,l,h);override; begin @@ -3292,6 +2898,16 @@ type TTlvnActiveEvent=class(tuieventbase) property uchanged index "uchanged" read _getvalue_ write _setvalue_; property ptaction index "ptaction" read _getvalue_ write _setvalue_; property lparam index "lparam" read _getvalue_ write _setvalue_; + private + FNmList; + function _getvalue_(n); + begin + return FNmList[n]; + end + function _setvalue_(n,v); + begin + FNmList[n] := v; + end end type TGridCtl = class(TcustomGridCtl) @@ -3680,7 +3296,8 @@ type TDrawGrid=class(TGRidBase) function DoDrawSubItem(o,e);override; begin inherited; - CallMessgeFunction(OnDoDrawSubItem,o,e); + if OnDoDrawSubItem then + CallMessgeFunction(OnDoDrawSubItem,o,e); end function Recycling();override; begin @@ -4339,11 +3956,11 @@ type tprogressbar = class(tcustomprogressbar) end function publishs();override; begin - return array("name", + return array("name","border", "align","anchors", "popupmenu","color","visible","enabled","parnetcolor", "height","width","left","top", - "vertical","range","position","barcolor","onmousemove","onpopupmenu", + "vertical","smooth","range","position","barcolor","onmousemove","onpopupmenu", "onmousedown","onmouseup","onnotification"); end @@ -4363,8 +3980,7 @@ type tmonthcalendar = class(TCustomControl) **} function create(aowner); begin - inherited; - + inherited; //TodayButton := false; end function AfterConstruction();override; @@ -4448,22 +4064,22 @@ type tmonthcalendar = class(TCustomControl) FonSelect := nil; FonSelectChange := nil; end + property onSelectChange read FonSelectChange write FonSelectChange; property TodayButton:bool read getnoTodayButton write setNoTodayButton; property onSelect:eventhandler read FonSelect write FonSelect; - property onSelectChange:eventhandler read FonSelectChange write FonSelectChange; + property onSelChanged:eventhandler read FonSelectChange write FonSelectChange; function publishs();override; begin return array("name","caption","anchors","enabled","color", "popupmenu","visible","parentcolor", "height","width","left","top","border","onmousemove","onpopupmenu", - "onmousedown","onmouseup","onselect","onselectchange"); + "onmousedown","onmouseup","onselchanged"); end {** @param(todayButton)(bool)月历显示“今日”按钮（默认开启）%% - @param(onSelect)(function[tmonthcalendar,tuieventbase])显式选择日期%% - @param(onSelectChange)(function[tmonthcalendar,tuieventbase])选择日期改变%% + @param(onselchanged)(function[tmonthcalendar,tuieventbase])选择日期改变%% **} - + private function setNoTodayButton(v); begin @@ -4646,11 +4262,12 @@ type tdatetimepicker = class(tthreeEntry) return array("name","caption","anchors","enabled","font","color", "popupmenu","visible","parentcolor","parentfont", "height","width","left","top","border","onmousemove","onpopupmenu", - "onmousedown","onmouseup","onselectchange","onnotification"); + "onmousedown","onmouseup","onselchanged","onnotification"); end property onselectchange:eventhandler read Fonselectchange write Fonselectchange; + property onselchanged:eventhandler read Fonselectchange write Fonselectchange; { - @param(onSelectChange)(function[tmonthcalendar,tuieventbase])选择日期改变%% + @param(onselchanged)(function[tdatetimepicker,tuieventbase])选择日期改变%% } private function getenumber(e); @@ -4813,11 +4430,12 @@ type ttimepicker = class(tthreeEntry) return array("name","align","anchors","caption","enabled","font","color", "popupmenu","visible","parentcolor","parentfont", "height","width","left","top","border","onmousemove","onpopupmenu", - "onmousedown","onmouseup","onkeyup","onkeydown","onselectchange","onnotification"); + "onmousedown","onmouseup","onkeyup","onkeydown","onselchanged","onnotification"); end - property onselectchange:eventhandler read Fonselectchange write Fonselectchange; + property onselectchange read Fonselectchange write Fonselectchange; + property onselchanged:eventhandler read Fonselectchange write Fonselectchange; { - @param(onSelectChange)(function[tmonthcalendar,tuieventbase])选择日期改变%% + @param(onselchanged)(function[ttimepicker,tuieventbase])选择日期改变%% } protected function calcCtls();override; @@ -4851,7 +4469,7 @@ type tipaddr = class(tcustomipaddr) function publishs();override; begin return array("name","align","anchors","font","color","caption","visible","parentcolor","parentfont","height","width","left","top", - "ipaddr","HasPort","onAddrChange","border","wsdlgmodalframe","onnotification"); + "ipaddr","hasport","onaddrchanged","border","wsdlgmodalframe","onnotification"); end end @@ -4918,7 +4536,7 @@ type tapplicationwindow=class(TWinControl) end end -type TImageListDrawStyle = class +type TImageListDrawStyle = class() {** @explan(说明) imagelist 绘制的样式选择 %% **} @@ -4929,7 +4547,7 @@ type TImageListDrawStyle = class static ILD_ASYNC;static ILD_SELECTED;static ILD_FOCUS; static ILD_BLEND; end -type TImageListCreateflags = class +type TImageListCreateflags = class() {** @explan(说明) imagelist 构造的参数 %%; **} @@ -5049,7 +4667,7 @@ type TIcon = class(tcustomicon) begin inherited; end - + end type tcursor = class(tcustomcursor) function create();override; @@ -5298,583 +4916,6 @@ type TApplicationProperties=class(TComponent) property ShowTray:bool read FShowTray write SetShowTray; end - - //windoes socket通信类 -type TSocketInterface=class(TComponent) - {** - @explan(说明) windows socket 接口类 %% - **} - private - FPort; - FIp; - FHandle; - FCSocket; - FIPproto; - //******************* - FOnRead; - FOnConnect; - FOnWrite; - FOnAccept; - FOnError; - FOnClose; - FCache; - FErrorId; - //********************** - static FNetWindow; //窗口 - static FRootSocket; //socket - static FWSDATA; //结构体 - function SetIPproto(V);virtual; - begin - if v in array(IPPROTO_TCP,IPPROTO_UDP)and v <> FIPproto then - begin - FIPproto := v; - if HandleAllocated()then CloseSocket(); - end - end - protected - class function sinit();override; - begin - inherited; - if not FNetWindow then - begin - FNetWindow := new TCustomControl(getapplication()); - FNetWindow.visible := false; - FNetWindow.WSPopUp := true; - FNetWindow.bindmessage(WM_SOCKET,thisfunction(WMSOCKET)); - FWSDATA := new TWSADATA(); - _wapi.WSAStartup(2^9+1,FWSDATA._getptr_); - FRootSocket := array(); - end - end - class function BindSoketEvents(sk,flag); - begin - {** - @expaln(说明)绑定事件 %% - **} - if sk is class(TSocketInterface)then - begin - if not(ifnumber(flag))then flag := FD_ALL_EVENTS; - if flag=0 then - begin - reindex(FRootSocket,array(inttostr(sk.Handle):nil)); - _wapi.WSAAsyncSelect(sk.Handle,FNetWindow.Handle,0,0); - end else - begin - _wapi.WSAAsyncSelect(sk.Handle,FNetWindow.Handle,WM_SOCKET,(FD_READ .| FD_WRITE .| FD_CONNECT .| FD_CLOSE .| FD_ACCEPT //flag - )); - FRootSocket[inttostr(sk.Handle)]:= sk; - end - end - end - class function GetSocket(id); - begin - {** - @param(id)(pointer) 句柄 %% - **} - return FRootSocket[inttostr(id)]; - end - class function WMSOCKET(o,e); - begin - gw := _wapi; - sk := GetSocket(e.wparam); - if not sk then exit; - if e.hilparam then //错误 - begin - FErrorId := e.hilparam; - return sk.DoError(); - end - FErrorId := 0; - case e.lolparam of - FD_ACCEPT: - begin - sk.DoAccept(); - end - FD_CLOSE: - begin - sk.CloseSocket(); - sk.DoClose(); - end - FD_WRITE: - begin - sk.DoWrite(); - end - FD_READ: - begin - sk.DoRead(); - end - FD_CONNECT: - begin - sk.DoConnected(); - end - end - end - type TSocketCache=class - {** - @explan(说明) 缓存 %% - **} - FData; - FBottom; - FTop; - function create(); - begin - init(); - end - function size(); - begin - return FTop-FBottom; - end - function init(); - begin - FData := array(); - FTop := FBottom := 0; - end - function GetBottom(); - begin - if FBottom0 then - begin - FBottom--; - if v then - begin - FData[FBottom]:= v; - end - end - end - function add(v); // - begin - if v then - begin - FData[FTop++]:= v; - end - end - end - function GetHandle(); - begin - if not HandleAllocated()then CreateHandle(); - return FHandle; - end - function InitCSocket();virtual; - begin - adr := _wapi.inet_addr(FIp); - FCSocket.sin_family := AF_INET; - FCSocket.sin_addr := adr; - FCSocket.sin_port := _wapi.htons(FPort); - return adr=INADDR_NONE; - end - function CreateInitialStr(n); - begin - {** - @explan(说明) 初始化字符串 %% - @param(n)(integer) 字符串长度 %% - @return(string) %% - **} - ret := "\0"; - if n>0 then - begin - setlength(ret,n); - for i := 1 to n-1 do - begin - ret[i]:= "\0"; - end - end - return ret; - end - function CreateHandle();virtual; - begin - if csDesigning in ComponentState then exit; - if not HandleAllocated()then FHandle := _wapi.socket(AF_INET,SOCK_STREAM,IPPROTO_TCP); - MD := 1; - //_wapi.ioctlsocket(FHandle,FIONBIO,MD); - BindSoketEvents(self(true),nil); - end - function SetIp(v);virtual; - begin - if v <> FIp and ifstring(v)then - begin - FIp := v; - end - end - function SetPort(v);virtual; - begin - if v <> FProt and v>0 then - begin - FPort := v; - end - end - public - function HandleAllocated(); - begin - return ifnumber(FHandle)and FHandle <> 0 and INVALID_SOCKET <> FHandle; - end - function create(AOwner);override; - begin - inherited; - FCSocket := new tsockaddr_in(); - FCache := new TSocketCache(); - FIPproto := IPPROTO_TCP; - FIp := "127.0.0.1"; - FPort := 1025; - end - function CloseSocket();virtual; - begin - if not HandleAllocated()then exit; - _wapi.ShutDown(FHandle,SD_BOTH); - rt := _wapi.closesocket(FHandle); - BindSoketEvents(self,0); - FHandle := 0; - if rt=0 then FHandle := 0; - else - begin - end - return rt; - end - function Recycling();override; - begin - CloseSocket(); - FOnRead := nil; - FOnConnect := nil; - FOnWrite := nil; - FOnAccept := nil; - FOnError := nil; - FOnClose := nil; - FCache := array(); - inherited; - end - function DoRead();virtual; - begin - calldatafunction(FOnRead,self(true)); - end - function DoAccept();virtual; - begin - calldatafunction(FOnAccept,self(true)); - end - function DoWrite();virtual; - begin - WriteData(); - calldatafunction(FOnWrite,self(true)); - end - function DoError();virtual; - begin - calldatafunction(FOnError,self(true)); - end - function DoConnected();virtual; - begin - calldatafunction(FOnConnect,self(true)); - end - function DoClose();virtual; - begin - calldatafunction(FOnClose,self(true)); - end - function writeData(data);virtual; - begin - if data then FCache.add(data); - while FCache.size() do - begin - d := FCache.GetBottom(); - if not(d and ifstring(d))then continue; - len := length(d); - ret := _wapi.send(FHandle,d,len,0); - if ret=WSAEWOULDBLOCK then - begin - return FCache.back(); - end else - if ret0 then - begin - FCache.back(d[(ret+1):]); - end - end - end - function ReceiveDataLen(); - begin - {** - @explan(说明) 数据长度 %% - @return(integer) 长度 %% - **} - len := 0; - if HandleAllocated()then ret := _wapi.ioctlsocket(self.Handle,FIONREAD,len); - return len; - end - function ReadData(len);virtual; - begin - {** - @explan(说明) 读数据 %% - @param(len)(integer) 读取长度 %% - @return(string) 数据 %% - **} - if not ifnumber(len)then len := ReceiveDataLen(); - if len<1 then return ""; - dt := CreateInitialStr(len); - if HandleAllocated()then r := _wapi.recv(self.Handle,dt,length(dt),0); - return dt; - end - property Handle read GetHandle write FHandle; - property IP:string read FIp write SetIp; - property Port:integer read FPort write SetPort; - property CSocket read FCSocket; - property OnClose:eventhandler read FOnClose write FOnClose; - property OnConnected:eventhandler read FOnConnect write FOnConnect; - property OnRead:eventhandler read FOnRead write FOnRead; - property OnWrite:eventhandler read FOnWrite write FOnWrite; - property OnAccept:eventhandler read FOnAccept write FOnAccept; - property OnError:eventhandler read FOnError write FOnError; - property IPPROTO read FIPproto write SetIPproto; - property ErrorId read FErrorId; - {** - @param(ErrorId)(integer) 错误信息 %% - **} -end - -type TSocketClient=class(TSocketInterface) - {** - @explan(说明) windows socket客户端 %% - **} - private - FConnected; - protected - function SetIp(v);override; - begin - t := self.ip; - inherited; - if csDesigning in ComponentState then exit; - t1 := self.ip; - if t <> t1 and FConnected then - begin - CloseSocket(); - end - end - function SetPort(v);override; - begin - t := self.Port; - inherited; - if csDesigning in ComponentState then exit; - t1 := self.Port; - if t <> t1 and FConnected then - begin - CloseSocket(); - end - end - public - function Create(AOwner);override; - begin - inherited; - FConnected := false; - end - function CloseSocket();override; - begin - inherited; - FConnected := false; - end - function DoClose();override; - begin - FConnected := false; - inherited; - end - function DoConnected();override; - begin - FConnected := true; - inherited; - end - function connect(); - begin - {** - @explan(说明) 连接服务器 %% - **} - if csDesigning in ComponentState then exit; - if InitCSocket()then return-1; - if not FConnected then - begin - r := _wapi.Connect(self.Handle,CSocket._getptr_(),CSocket._size_()); - end - return r; - end - function publishs();override; - begin - return array("name","handle","ip","port","ipproto", - "onclose","onconnected","onread","onwrite","onaccept","onerror","onnotification"); - end -end -type TSocketAccept=class(TSocketInterface) - {** - @explan(说明) windows socket 服务socket连接 %% - **} - private - FServer; - function DeleteFromServer(); - begin - if FServer then - begin - FServer.DeleteNode(self); - end - end - function SetIPproto(V);override; - begin - end - public - function Create(server);override; - begin - inherited; - FServer := server; - if(FServer is class(TSocketServer))and(FServer.HandleAllocated)then - begin - Handle := _wapi.accept(server.Handle,CSocket._getptr_(),CSocket._size_()); - self.OnRead := server.OnRead; - self.OnWrite := server.OnWrite; - self.OnClose := Server.OnClose; - self.onerror := Server.OnError; - if Handle then - begin - BindSoketEvents(self(true),nil); - end - end - end - function CreateHandle();override; - begin - end; - function DoClose(sk);override; - begin - inherited; - DeleteFromServer(); - end - function CloseSocket();override; - begin - inherited; - DeleteFromServer(); - end - property Server read FServer write FServer; - function publishs();override; - begin - return array("name","handle","ip","port","ipproto", - "onread","onwrite","onaccept","onerror","onnotification"); - end -end -type TSocketServer=class(TSocketInterface) - {** - @explan(说明) windows socket 服务端 - **} - private - FChildren; - FBinded; - FAccept; - FListenCount; - function SetListenCount(v); - begin - if v >= 0 and v <> FListenCount then - begin - FListenCount := v; - end - end - function SetIp(v);override; - begin - t := self.ip; - inherited; - t1 := self.ip; - if t <> t1 and FBinded then - begin - CloseSocket(); - end - end - function SetPort(v);override; - begin - t := self.Port; - inherited; - t1 := self.Port; - if t <> t1 and FBinded then - begin - CloseSocket(); - end - end - public - function CreateHandle();override; - begin - inherited; - FAccept := false; - end - function DoAccept();override; - begin - FAccept := true; - r := new TSocketAccept(self(true)); - FChildren[length(FChildren)]:= r; - inherited; - end - function Create(AOwner);override; - begin - inherited; - FListenCount := 100; - FChildren := array(); - FConnected := false; - FBinded := false; - end - function CloseSocket();override; - begin - len := length(FChildren); - while len>0 do - begin - vi := FChildren[len-1]; - vi.CloseSocket(); - len := length(FChildren); - end - FBinded := false; - FAccept := false; - return inherited; - end - function DeleteNode(acp); - begin - {** - @explan(说明) 删除节点 %% - **} - idx :=-1; - if acp.HandleAllocated()then return acp.CloseSocket(); - for i,v in FChildren do - begin - if acp=V then - begin - idx := i; - end - end - if idx>-0.5 then - begin - acp.Server := nil; - DeleteIndex(FChildren,idx,true); - end - end - function listen(); - begin - {** - @explan(说明)监听 %% - **} - if FBinded then exit; - lsn := FListenCount; - if InitCSocket()then return-1; - r := _wapi.bind(self.Handle,CSocket._getptr_(),CSocket._size_()); - if r=0 then - begin - FBinded := true; - if ifnil(lsn)then lsn := 10; - r := _wapi.listen(self.Handle,lsn); - return r; - end else - begin - return-1; - end - return r; - end - property ListenCount:integer read FListenCount write SetListenCount; - function publishs();override; - begin - return array("name","handle","ip","port","ipproto", - "onclose","onconnected","onread","onwrite","onaccept","onerror","onnotification"); - end -end type TClipBoard = class(TcustomClipBoard) {** @explan(说明) 剪切板类 %% @@ -6095,8 +5136,8 @@ type TRegKey = class @explan(说明) 删除value %% @param(vn)(string) value 名字 %% **} - if not FHandle then return-1; - if not(ifstring(vn))then return-1; + if not FHandle then return -1; + if not(ifstring(vn))then return -1; return RegDeleteValueA(FHandle,vn); end function DeleteKeyA(vn); @@ -6293,8 +5334,6 @@ type TWinEnviroment=class() FRegkey; end -//剪切板类 - type TQuotations=class(tcomponent) {** @explan(说明) 行情订阅以及远程执行类 %% @@ -7092,6 +6131,355 @@ type TInPutQuerys = class(TcustomInPutQuerys) end implementation +///////////////tmf文件转换/////////////////////// +type Ttfm2Component = class(TTmfParser) + {** + @explan(说明) tfm数据到组件转换 %% + **} + private + static FComponentTypes; + protected + class function sinit();override; + begin + inherited; + if not ifarray(FComponentTypes)then FComponentTypes := array(); + end + function formatpath(s);//处理windows的路径 + begin + r := ""; + if s and ifstring(s)then + begin + for i := 1 to length(s) do + begin + vi := s[i]; + if vi="/" then r += "\\"; + else r += vi; + end + end + return r; + end + function GetExeScriptPath(); + begin + {$ifdef linux} + p := tsl_getcurrentdir_(); + return p+ioFileseparator()+SysParamstr(0); + {$endif} + pth2 := formatpath(sysparamstr(0)); + if pth2[2]=":" then return pth2; + s := ""; + setlength(s,1024); + N := GetCurrentDirectoryA(1023,s); + return s[1:N]+ioFileseparator()+SysParamstr(0); + end + public + class function RegisterComponentType(n,typ); + begin + if ifstring(n)and n and(typ is class(TComponent))then + begin + if not ifarray(FComponentTypes)then FComponentTypes := array(); + FComponentTypes[lowercase(n)]:= typ; + end + end + class function GetComponentType(n); + begin + if(ifstring(n)and n)and ifarray(FComponentTypes)then + begin + nn := lowercase(n); + r := FComponentTypes[nn]; + if r then return r; + return findclass(nn); + end + end + function SetTfmData(owner,obj,data,lazydata); + begin + u1 := obj.GetPublishproperties(); + u2 := obj.GetPublishEvents(); + if not ifarray(u1)then u1 := array(); + if not ifarray(u2)then u2 := array(); + pubs := u1 union u2; + dprop := data["property"]; + ddp := array(); + for i,v in dprop do + begin + ddp[v["name"]]:= v; + end + for i,v in pubs do + begin + n := i; + ddpv := ddp[n]; + if not ifarray(ddpv)then continue; + cls := v["class"]; + et := GetComponentPropertyType(cls);//owner.GetPropertyType(cls); + if not et then continue; + td := SampleValue(ddpv); + if et.LazyProperty()then + begin + if not ifarray(lazydata)then lazydata := array(); + lazydata[length(lazydata)]:= array("et":et,"owner":owner,"ownerp":td, + "obj":obj,"objp":n); + continue; + end + d := et.ReadTMF(td,owner); + if ifnil(d)then continue; + try + pbs := obj.publishs(); + if(n in pbs)then + begin + //echo "\r\n====",n,"****",d; + invoke(obj,n,1,d); + end else + begin + //echo "pbs:",tostn(pbs); + end + except + //echo obj.classinfo()["classname"],"错误 \r\n"; + end; + end + for i,v in data["object"] do + begin + n := v["name"]; + cls := v["class"]; + cobj := GetComponentType(cls); + if cobj then + begin + nobj := createobject(cobj,owner); + try + if(nobj is class(TToolBar))then + begin + for iii,iiiv in v["property"] do + begin + if(iiiv["name"]="align")and(iiiv["value"]="alnone")then + begin + nobj.Align := nobj.alNone; + break; + end + end + end + nobj.parent := obj; + invoke(owner,n,1,nobj); + except + end; + call(thisfunction,owner,nobj,v,lazydata); + end + end + end + function Create();override; + begin + inherited; + end + function LoadFromTfmScript(owner,s); + begin + if s and ifstring(s)then + begin + self.Script := s; + lazydata := array(); + //lazydata[0] := array(); + darray := gettree2(); + SetTfmData(owner,owner,darray,lazydata); + for i,v in lazydata do + begin + try + dd := v["et"].ReadTMF(v["ownerp"],v["owner"]); + invoke(v["obj"],v["objp"],1,dd); + except + end; + end + end + end + function LoadFromTfm(owner); + begin + {** + @explan(说明) 从默认路径导入tfm文件信息 %% + **} + Loadinherited(owner); //导入 + end + private + function hastfmfile(phs,cn); + begin + for i,v in phs do + begin + pi := v+cn+".tfm"; + if fileexists("",pi) then + begin + return true; + end + end + end + function Loadtfmtoform(o,phs,cn); + begin + for i,v in phs do + begin + pi := v+cn+".tfm"; + size := filesize("",pi); //获取文件大小 + if readFile(rwraw(),"",pi,0,size,data)=1 then + begin + LoadFromTfmScript(o,data); + return true; + end + end + end + function Loadinherited(o);//导入 + begin + return Loadinherited_sub(o); + end + function Loadinherited_sub(o); + begin + if not ifobj(o) then return ; + if not((o is class(TDCreateForm)) or (o is class(TDCreatePanel))) then return ;//判断类型 + o2 := o; + phs := static GetSourceDirs(); + objs := array(); + fssourdirs := phs; + while true do + begin + ci := o2.classinfo(); + cn := ci["classname"]; + if cn="tdcreateform" or cn="tdcreatepanel" then return ; + if hastfmfile(phs,cn) then + begin + Loadtfmtoform(o2,phs,cn); + return ; + end + ic := ci["inherited"][0]; + if ic then + o2 := findclass(ic,o2); + else return ; + end + end + function GetSourceDirs(); + begin + lps := GetLibPaths(); + lps[length(lps)] := static GetCurrentTslDir()+"funcext"+ioFileseparator(); + lps union2=array(); + r := array(); + for i,v in lps do + begin + GetReSourcetfmdir(v,r); + end + return r; + end + function GetReSourcetfmdir(p,rp); + begin + if not ifarray(rp) then rp := array(); + iofp := ioFileseparator(); + for ii,vv in filelist("",p+"*") do + begin + fn := vv["FileName"]; + if fn="." or fn=".." then continue; + if Pos("D",vv["Attr"]) then + begin + if lowercase(fn)="resource.tfm" then + begin + rp[length(rp)] := p+"resource.tfm"+iofp; + end else + begin + GetReSourcetfmdir(p+fn+iofp,rp); + end + end + end + end + function GetLibPaths(); //获得libpath + begin + p := tsl_getlibpath_(); + if not p then return array(); + FCurrentp := ""; + {$ifdef linux} + FCurrentp := tsl_getcurrentdir_(); + {$else} + s := ""; + setlength(s,1024); + wapi := gettswin32api(); + N := wapi.GetCurrentDirectoryA(1023,s); + FCurrentp := s[1:N]; + {$endif} + FCurrentp1 := ""; + iofp := ioFileseparator(); + for i:= length(FCurrentp)-1 downto 1 do + begin + if FCurrentp[i] = iofp then + begin + FCurrentp1 := FCurrentp[1:i-1]; + break; + end + end + ri := 0; + r := array(); + iofp2 := "."+iofp; + iofp3 := ".."+iofp; + for i,v in str2array(p,";") do + begin + vi := trim(v); + if not vi then continue; + if vi[length(vi)]<>iofp then continue; + if pos(iofp2,vi)=1 then + begin + r[ri] := FCurrentp+vi[2:]; + end else + if pos(iofp3,vi)=1 then + begin + r[ri] := FCurrentp1+vi[3:]; + end + else + begin + r[ri] := vi; + end + ri++; + end + return r; + end +end + +type TGlobalComponentcache=class() //窗口对象缓存句柄作为索引 + {** + @ignore(忽略) %% + @explan(说明) 窗口存储类 %% + @param(FWidowhandes)(array) 组件全局存储类 %% + **} + STATIC FWidowhandes; + class function getwndbyhwnd(hwnd); + begin + {** + @explan(说明) 根据id查找组件 %% + **} + sinit(); + if ifnumber(hwnd)then return FWidowhandes[inttostr(hwnd)]; + end + class function registerhandle(handle,o); + begin + {** + @explan(说明)保存组件对象 %% + **} + sinit(); + if o is class(tcomponent)then + begin + //o.handle := handle; + if ifnumber(handle)then FWidowhandes[inttostr(handle)]:= o; + end + end + class function unregisterhandle(handle); + begin + {** + @explan(说明)删除组件对象 %% + **} + sinit(); + if ifnumber(handle)then + begin + reindex(FWidowhandes,array(inttostr(handle):nil)); + end + end + class function sinit(); + begin + {** + @ignore(忽略) 忽略 %% + @explan(说明)初始化 %% + **} + if not ifarray(FWidowhandes)then + begin + FWidowhandes := array(); + end + end +end + type TDragManager=class(TComponent) private FDragImmediate:Boolean; diff --git a/funcext/tvclib/utslvclstdctl.tsf b/funcext/tvclib/utslvclstdctl.tsf index c975961..1c9874c 100644 --- a/funcext/tvclib/utslvclstdctl.tsf +++ b/funcext/tvclib/utslvclstdctl.tsf @@ -5935,14 +5935,44 @@ type tcustomprogressbar=class(TCustomControl) if Fvertical then begin d := rt *h; - br[0] +=(h-d); + br[1] +=(h-d); end else begin d := floor(rt*w); br[2] := br[0]+d; end dc.brush.color := FbarColor; - dc.FillRect(br); + dc.FillRect(br); + if not Fsmooth then + begin + pc := dc.pen.Color; + pw := dc.pen.Width; + dc.pen.Color := color; + dc.pen.Width := 2; + sp := 18; + if Fvertical then + begin + p := br[3]-sp; + while p>br[1] do + begin + dc.moveto(array(r[0],p)); + dc.LineTo(array(r[2],p)); + p-=sp; + + end + end else + begin + p := sp ; + while pnv then begin - FHasPort := nv; - + FHasPort := nv; calcportsize(); FPort.Visible := nv; InvalidateRect(nil,false); @@ -6496,9 +6525,7 @@ type tcustomipaddr = class(TCustomControl) Fsynrects[3,0] := ":"; Fsynrects[3,1] := rc1; end - end - implementation type TtoolbuttonActionLink=class(TControlActionLink) {**