6834 lines
190 KiB
Plaintext
6834 lines
190 KiB
Plaintext
unit tslvcl;
|
||
{**
|
||
@explan(说明) tsl语言可视化组件库库,支持windows以及gtk(linux)%%
|
||
@auther 天软科技 %%
|
||
@date(20220223)
|
||
**}
|
||
{
|
||
更新说明
|
||
20221111整理代码,加入版本号
|
||
20220328整理代码
|
||
20200721 修改设计器中属性的显示控制,将属性持久化和设计器分离
|
||
20200515 整理代码去掉一些不需要使用的代码
|
||
20190612 添加缓存抽象 TCacheItem,TCacheList 对象
|
||
固定listview 固定在设计模式下表头宽度
|
||
20191115 删除popup窗口句柄
|
||
}
|
||
///////////平台判断////////
|
||
{$ifdef linux}
|
||
{$define gtkpaint}
|
||
{$define linuxgtk}
|
||
{$else}
|
||
{$define gdipaint}
|
||
{$endif}
|
||
interface
|
||
uses utslvclconstant,utslvclbase,utslvclauxiliary,cstructurelib,utslvclmemstruct,utslvclevent,
|
||
UVCPropertyTypesPersistence,utslvclgdi,utslvclaction,utslvclmenu,utslvclstdctl,utslvclpage,
|
||
utslvcldlg,utslvclgrid,utslvcltree,utslvclcoolbar;
|
||
function initializeapplication(); //获得app对象
|
||
function RegisterComponentType(n,typ); //注册控件,便于通过控件名称构造控件
|
||
function GetAndDispatchMessageA(hwnd,minm,maxm); //win32 分发消息
|
||
function ExitMessageLoop(); //退出主循环
|
||
//function gettswin32api(); //win32 api
|
||
function NotifyComponent(Sender,Act,ToComponent); //notfiy
|
||
//////////////////////操作/////////////////////
|
||
Function tslcstructure(data,dsize,pack,ptr);
|
||
|
||
//function CompareRect(orect,nrect);
|
||
function calldatafunction();
|
||
function CallMessgeFunction(f,o,e);
|
||
//////////////////////执行tsl脚本代码////////////////////
|
||
//function TSL_Check(func,funclen,oResult);
|
||
function CheckTslCode(code,err); //检查tsl语法
|
||
//function SysExecWait(handle,exe,cmd,dir,fui); //执行 win32 程序
|
||
//function TS_ModulePath();
|
||
//function TS_ExecPath();
|
||
//function TS_GetAppPath();
|
||
function TS_GetUserProfileHome();
|
||
function TS_GetUserProfileHomeInstance(t:integer):string;
|
||
function TS_GetUserConfigHome(t:integer):string;
|
||
function TS_GetHomePath(t:integer):string;
|
||
function TS_ModulePath():string;
|
||
function TS_ExecPath():string;
|
||
function TS_GetAppPath():string;
|
||
function TS_GetIniPath(t:integer;iname:string):string;
|
||
//function TS_GetIniPath(hometype,IniName);
|
||
function CopyUsedTslDllToNewDir(p);
|
||
/////////////////////////////////////////////
|
||
function DeleteAllFiles(path);
|
||
function CreateDirWithFileName(fname);
|
||
//************************
|
||
//*******************************
|
||
function MessageBoxA(txt,title,flag,hd);
|
||
//function _timeproc_(hwnd,message,wparam,lparam);//win32消息分发
|
||
function _twinproc_(hwnd,message,wparam,lparam);//win32消息分发
|
||
function remotetslcallback(data);
|
||
//********其他辅助函数*******
|
||
function TslToHexFormatStr(tsl);
|
||
function HexFormatStrToTsl(D);
|
||
function GetTextWidthAndHeightWidthFont(s,f,mul);
|
||
////////////////////////////////////
|
||
//应用
|
||
type tapplication=class(tcomponent)
|
||
{**
|
||
@explan(说明) application 窗口 %%
|
||
**}
|
||
private
|
||
static FApplicationWindow;
|
||
FMessageObj;
|
||
FVisible;
|
||
FHandle; //句柄
|
||
Fmainform; //主窗口
|
||
FDebug;
|
||
Foldforminfo;
|
||
FTerminated;
|
||
static frundeep;
|
||
function SetVisible(v);
|
||
begin
|
||
FVisible := v?true:false;
|
||
if FApplicationWindow is class(TWinControl)then
|
||
begin
|
||
FApplicationWindow.visible := FVisible;
|
||
end
|
||
end
|
||
function SetMainForm(f);
|
||
begin
|
||
if not(f is class(TVCForm))then exit;
|
||
if f=Fmainform then exit;
|
||
if Fmainform then
|
||
begin
|
||
odf := Fmainform;
|
||
odf.onclose := Foldforminfo["close"];
|
||
odf.OnMinimize := Foldforminfo["minimize"];
|
||
end
|
||
Fmainform := f;
|
||
//{$ifdef linuxgtk}
|
||
//{$else}
|
||
if not(FApplicationWindow)then initialize();
|
||
if not(f.HandleAllocated())then
|
||
begin
|
||
f.parent := FApplicationWindow;
|
||
end
|
||
IC := f.FormIcon;
|
||
if(ic is class(tcustomicon))and ic.HandleAllocated then
|
||
begin
|
||
FApplicationWindow._send_(WM_SETICON,1,ic.handle,1);
|
||
end
|
||
FApplicationWindow.caption := f.caption;
|
||
//{$endif}
|
||
Foldforminfo := array("close":Fmainform.onclose,"minimize":Fmainform.OnMinimize);
|
||
Fmainform.onclose := thisfunction(mainformclose);
|
||
Fmainform.OnMinimize := thisfunction(mainformminmize);
|
||
end
|
||
function CreateHandle();
|
||
begin
|
||
if not FApplicationWindow then
|
||
begin
|
||
FApplicationWindow := new tapplicationwindow(self);
|
||
FApplicationWindow.Visible := FVisible;
|
||
end
|
||
FHandle := FApplicationWindow.Handle;
|
||
end
|
||
public
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
FTerminated := false;
|
||
FVisible := false;
|
||
frundeep := new tnumindexarray();
|
||
end
|
||
function WMACTIVATEAPP(o,e);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) active处理
|
||
**}
|
||
//echo "\r\nactiveapp:",e.wparam;
|
||
if Fmainform then
|
||
begin
|
||
if e.wparam then
|
||
begin
|
||
//_wapi.SetWindowPos(Fmainform.Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE .|SWP_NOSIZE);
|
||
Fmainform.show();
|
||
if Fmainform.HandleAllocated() then
|
||
begin
|
||
_wapi.SetForegroundWindow(Fmainform.handle);
|
||
end
|
||
end //Fmainform.Visible := true;
|
||
//else _wapi.SetWindowPos(Fmainform.Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE .|SWP_NOSIZE);
|
||
end
|
||
end
|
||
function initialize();
|
||
begin
|
||
{**
|
||
@explan(说明) 初始化 %%
|
||
**}
|
||
CreateHandle();
|
||
FApplicationWindow.bindmessage(WM_ACTIVATEAPP,thisfunction(WMACTIVATEAPP));
|
||
end
|
||
function Notification(a,op);override;
|
||
begin
|
||
if op=opclosemainwnd and a= Fmainform then
|
||
begin
|
||
FApplicationWindow._send_(WM_CLOSE,0,0);
|
||
return ;
|
||
end
|
||
if op=opRecycling then
|
||
begin
|
||
if a=Fmainform then
|
||
begin
|
||
Fmainform := nil;
|
||
end
|
||
if FApplicationWindow=a then
|
||
begin
|
||
FApplicationWindow := nil;
|
||
end
|
||
end
|
||
inherited;
|
||
end
|
||
function createform(classname,variable);
|
||
begin
|
||
{**
|
||
@explan(说明) 构造主窗口%%
|
||
@param(classname)(class of TVCForm) 主窗口类 %%
|
||
@param(variable)() tsl变量返回ClassName 构造的窗口对象 %%
|
||
**}
|
||
if paramcount<2 then exit; //变量不够
|
||
if classname is class(tcomponent)then
|
||
begin
|
||
//if not(FApplicationWindow)then
|
||
initialize();
|
||
variable := createobject(classname,FApplicationWindow);
|
||
if variable is class(TVCForm)then
|
||
begin
|
||
variable.parent := FApplicationWindow;
|
||
if not Fmainform then
|
||
begin
|
||
SetMainForm(variable);
|
||
end
|
||
end
|
||
end
|
||
end
|
||
function mainformclose(o,e);
|
||
begin
|
||
{**
|
||
@ignore(忽略) %%
|
||
**}
|
||
CallMessgeFunction(Foldforminfo["close"],o,e);
|
||
if e.skip then exit;
|
||
//FApplicationWindow._send_(WM_CLOSE,0,0);
|
||
end
|
||
function mainformminmize(o,e);
|
||
begin
|
||
{**
|
||
@ignore(忽略) %%
|
||
**}
|
||
CallMessgeFunction(Foldforminfo["minimize"],o,e);
|
||
end
|
||
function run();
|
||
begin
|
||
{**
|
||
@explan(说明) 运行主循环 %%
|
||
**}
|
||
initialize();
|
||
{$ifdef linuxgtk}
|
||
idledata := 123123+frundeep.length();
|
||
frundeep.Push(idledata);
|
||
r := _wapi.gtk_mainidle(idledata);
|
||
frundeep.pop();
|
||
exitloopdo();
|
||
return r;
|
||
{$endif}
|
||
if not FMessageObj then FMessageObj := new TTagMSG();
|
||
ptr := FMessageObj._getptr_();
|
||
while true do
|
||
begin
|
||
{if (_wapi.PeekMessageA(ptr,0,0,0,0)) then
|
||
begin
|
||
if FMessageObj.message=0x12 then return 1;
|
||
end else
|
||
begin
|
||
RunWorkerThreadLoop();
|
||
|
||
end
|
||
tslprocessmessages();
|
||
sleep(1);
|
||
}
|
||
if(_wapi.PeekMessageA(ptr,0,0,0,0x1))then
|
||
begin
|
||
if FMessageObj.message=0x12 then
|
||
begin
|
||
//return 1;
|
||
FTerminated := true;
|
||
end else
|
||
begin
|
||
_wapi.TranslateMessage(ptr);
|
||
_wapi.DispatchMessageA(ptr);
|
||
end
|
||
end else
|
||
begin
|
||
tslprocessmessages(false);
|
||
RunWorkerThreadLoop();
|
||
sleep(1);//_wapi.WaitMessage();
|
||
end
|
||
if FTerminated then break;
|
||
|
||
end
|
||
exitloopdo();
|
||
{while (_wapi.GetMessageA(ptr, 0, 0, 0)) do
|
||
begin
|
||
_wapi.TranslateMessage(ptr);
|
||
_wapi.DispatchMessageA(ptr);
|
||
end}
|
||
return 1;
|
||
end
|
||
function GetApplicationWindow();
|
||
begin
|
||
return FApplicationWindow;
|
||
end
|
||
function ShowErrorMessage(msg);
|
||
begin
|
||
{**
|
||
@explan(说明)错误提示信息 %%
|
||
**}
|
||
if FDebug and ifstring(msg)then messageboxA(msg,"错误提示",1);
|
||
end
|
||
function CloseMainForm();
|
||
begin
|
||
{**
|
||
@explan(说明) 关闭主窗口 %%
|
||
**}
|
||
if FApplicationWindow is class(TVCForm)then FApplicationWindow._send_(WM_CLOSE,0,0);
|
||
else _wapi.PostQuitMessage(0);
|
||
end
|
||
function Close();
|
||
begin
|
||
CloseMainForm();
|
||
end
|
||
function addExitMessageLoopdo(f);
|
||
begin
|
||
if f then
|
||
begin
|
||
if not fexitdolist then fexitdolist := new tnumindexarray();
|
||
fexitdolist.Push(f);
|
||
end
|
||
end
|
||
property Visible read FVisible write SetVisible;
|
||
property handle read FHandle;
|
||
property IfDebug read FDebug write FDebug;
|
||
property MainForm read Fmainform write SetMainForm;
|
||
private
|
||
fexitdolist;
|
||
function exitloopdo();
|
||
begin
|
||
if fexitdolist then
|
||
begin
|
||
for i := 0 to fexitdolist.length()-1 do
|
||
begin
|
||
f := fexitdolist[i];
|
||
if f then
|
||
begin
|
||
try
|
||
//echo tostn(f.functioninfo());
|
||
##f();
|
||
except
|
||
|
||
end ;
|
||
end
|
||
end
|
||
end
|
||
fexitdolist := nil;
|
||
end
|
||
end
|
||
|
||
type TLabel = class(TcustomLabel)
|
||
{**
|
||
@explan(说明)标签控件 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
{**
|
||
@param(TextAlign)(member of TAlignStyle9) 文字对齐 %%
|
||
**}
|
||
end
|
||
|
||
type TWinControlWraper=class(TWinControl)
|
||
{**
|
||
@explan(说明) 包裹window句柄类,继承该类,根据CreateWnd 注释的提示重写该函数
|
||
实现其他窗口库(必须含有句柄)和tslvcl库的对象兼容%%
|
||
**}
|
||
private
|
||
FWindowInfo;
|
||
protected
|
||
function WrapHandle(h);
|
||
begin
|
||
{**
|
||
@explan(说明) 包裹句柄,重写 CreateWnd中调用 %%
|
||
**}
|
||
oh := Handle;
|
||
if _wapi.IsWindow(h)and h <> oh then
|
||
begin
|
||
if oh then
|
||
begin
|
||
WMNCDESTROY(self(true),new tuieventbase(0,0,0,0));
|
||
end
|
||
_wapi.GetWindowInfo(h,FWindowInfo._getptr_);
|
||
rc := FWindowInfo.rcwindow;
|
||
FLeft := rc[0];
|
||
FTop := rc[1];
|
||
FWidth := rc[2]-rc[0];
|
||
FHeight := rc[3]-rc[1];
|
||
old := _wapi.SetWindowLongPtrA(h,GWLP_WNDPROC,_wapi.getvclwindowprocA());
|
||
FDefWndproc := old;
|
||
class(tUIglobalData).uigetdata("TGlobalComponentcache").registerhandle(h,self(true));
|
||
Handle := h;
|
||
end
|
||
end
|
||
public
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
FWindowInfo := new TWINDOWINFO();
|
||
end
|
||
function WMNCDESTROY(o,e):WM_NCDESTROY;override;
|
||
begin
|
||
if HandleAllocated()then
|
||
begin
|
||
h := Handle;
|
||
_wapi.SetWindowLongPtrA(h,GWLP_WNDPROC,FDefWndproc);
|
||
class(tUIglobalData).uigetdata("TGlobalComponentcache").unregisterhandle(h);
|
||
end
|
||
inherited;
|
||
end
|
||
function CreateWnd();override;
|
||
begin
|
||
{**
|
||
@explan(说明) 重写该函数构造句柄 包括三部分
|
||
//************获得构造参数*************************
|
||
CreateParams(p); //构造参数函数
|
||
tcc := p.Caption; //标题
|
||
stl := p.style;
|
||
x := p.x; //下边
|
||
y := p.y; //上边
|
||
w := p.width;//宽度
|
||
h := p.height; //高度
|
||
phandle := p.WndParent; //父窗口句柄
|
||
//***********构造句柄******************
|
||
//****************************************
|
||
//***********包裹句柄*************************
|
||
WrapHandle(thandle); //包裹句柄
|
||
//************初始化*************************
|
||
InitializeWnd(); //初始化
|
||
ControlCreateWnd(); //构造子窗口句柄
|
||
**}
|
||
end
|
||
end
|
||
|
||
type TScrollingWinControl = class(TCustomScrollControl)
|
||
{**
|
||
@explan(说明) 滚动条窗口 %%
|
||
**}
|
||
protected
|
||
function GetClientXCapacity();virtual; //宽度容量
|
||
begin
|
||
return integer(ClientRect[2]/GetXScrollDelta());
|
||
end
|
||
function GetClientYCapacity();virtual; //高度容量
|
||
begin
|
||
return integer(ClientRect[3]/GetYScrollDelta());
|
||
end
|
||
function GetClientXCount();virtual; //宽度间隔
|
||
begin
|
||
wd := 0;
|
||
for i := 0 to Controls.Count-1 do
|
||
begin
|
||
c := Controls[i];
|
||
if(c is class(TWinControl))and c.WsPopUp then continue; //处理
|
||
br := c.Left+c.Width;
|
||
wd := max(wd,br);
|
||
end
|
||
return integer(wd/GetXScrollDelta());
|
||
end
|
||
function GetClientYCount();virtual; //高度项
|
||
begin
|
||
h := 0;
|
||
for i := 0 to Controls.Count-1 do
|
||
begin
|
||
c := Controls[i];
|
||
if(c is class(TWinControl))and c.WsPopUp then continue; //处理
|
||
br := c.Top+c.Height;
|
||
h := max(h,br);
|
||
end
|
||
return integer(h/GetYScrollDelta());
|
||
end
|
||
function PositionChanged();virtual;
|
||
begin
|
||
dx := GetXScrollDelta()* GetDeltaXPos();
|
||
dy := GetYScrollDelta()* GetDeltaYPos();
|
||
for i := 0 to Controls.Count-1 do
|
||
begin
|
||
c := Controls[i];
|
||
if(c is class(TWinControl))and c.WsPopUp then
|
||
begin
|
||
continue;
|
||
end
|
||
c.Top -= dy;
|
||
c.Left -= dx;
|
||
end
|
||
end
|
||
public
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
function AfterConstruction();override;
|
||
begin
|
||
inherited;
|
||
ThumbTrack := TRUE;
|
||
end
|
||
function doControlALign();override;
|
||
begin
|
||
if AutoScroll then InitialScroll();
|
||
else inherited;
|
||
end
|
||
function DoControlAnchor();virtual;
|
||
begin
|
||
if AutoScroll then return;
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
type TPanel=class(TScrollingWinControl) //容器
|
||
{**
|
||
@explan(说明) 面板控件 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
function AfterConstruction();override;
|
||
begin
|
||
inherited;
|
||
caption := "panel";
|
||
height := 300;
|
||
width := 300;
|
||
AutoScroll := false;
|
||
WsDlgModalFrame := true;
|
||
//color := _wapi.GetSysColor(COLOR_MENU);
|
||
end
|
||
function CreateParams(p);override;
|
||
begin
|
||
inherited;
|
||
p.WinClassName := "tui_panel";
|
||
p.cstyle := CS_HREDRAW .| CS_VREDRAW .| CS_OWNDC .| CS_DBLCLKS;
|
||
//p.exstyle := 0x101;
|
||
end
|
||
function paint();override;
|
||
begin
|
||
inherited;
|
||
drawdesigninggrid();
|
||
end
|
||
end
|
||
//托盘
|
||
type TTray=class(TComponent)
|
||
{**
|
||
@explan(说明) 托盘类 %%
|
||
**}
|
||
private
|
||
FNid;
|
||
FTrayID;
|
||
FIcon;
|
||
FHaveadd;
|
||
FPopupMenu;
|
||
weakref
|
||
FOnclick;
|
||
FOnMouseMove;
|
||
autoref
|
||
static FSIDC; //id 构造器
|
||
FCaption;
|
||
FForm;
|
||
function SetCaption(v);
|
||
begin
|
||
if v <> FCaption then
|
||
begin
|
||
if ifstring(v)then
|
||
begin
|
||
FCaption := v;
|
||
end else
|
||
begin
|
||
FCaption := "";
|
||
end
|
||
FNid.sztip := FCaption;
|
||
if FHaveadd then
|
||
begin
|
||
_wapi.Shell_NotifyIconA(NIM_MODIFY,FNid._getptr_);
|
||
end
|
||
end
|
||
end
|
||
function seticonhandle(ic);
|
||
begin
|
||
if(ic is class(tcustomicon))and ic.HandleAllocated()and FHaveadd then
|
||
begin
|
||
Fnid.uFlags := NIF_ICON .| NIF_MESSAGE .| NIF_TIP .| NIF_INFO;
|
||
Fnid.hicon := ic.Handle;
|
||
_wapi.Shell_NotifyIconA(NIM_MODIFY,FNid._getptr_);
|
||
end
|
||
end
|
||
function SetIcon(v);
|
||
begin
|
||
if v=FIcon then exit;
|
||
FIcon := v;
|
||
seticonhandle(FIcon);
|
||
end
|
||
function SetForm(f);
|
||
begin
|
||
if FForm=f then exit;
|
||
if FHaveadd then
|
||
begin
|
||
TrayDelete();
|
||
end
|
||
FForm := f;
|
||
TrayAdd();
|
||
end
|
||
public
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
FHaveadd := false;
|
||
if not FSIDC then FSIDC := new tidcreater(1);
|
||
FTrayID := FSIDC.CreateId();
|
||
FNid := new TNOTIFYICONDATAA();
|
||
FNid.uID := FTrayID;
|
||
FNid.ucallbackmessage := WM_TRAY;
|
||
end
|
||
function ShowTrayMessage(title,text);
|
||
begin
|
||
{**
|
||
@ignore(忽略) %%
|
||
@explan(说明) 显示托盘消息 %%
|
||
@param(title)(string)标题 %%
|
||
@param(text)(string) 消息 %%
|
||
|
||
**}
|
||
if not FHaveadd then exit;
|
||
if not(ifstring(title)and ifstring(text))then exit;
|
||
if not((FForm is class(TVCForm))and FForm.HandleAllocated)then exit;
|
||
FNid.szinfotitle := title+"\0";
|
||
FNid.szinfo := text+"\0";
|
||
FNid.utimeout := 1000;
|
||
_wapi.Shell_NotifyIconA(NIM_MODIFY,FNid._getptr_);
|
||
end
|
||
function ShowPopUpMenu();
|
||
begin
|
||
if not FHaveadd then exit;
|
||
if FPopupMenu is class({TcustomPopupmenu}TcustomMenu)then
|
||
begin
|
||
ps := array(x,y);
|
||
_wapi.GetCursorPos(ps);
|
||
uf := TPM_LEFTALIGN .| TPM_TOPALIGN .| TPM_RIGHTBUTTON;
|
||
hd := FForm.Handle;
|
||
_wapi.SetForegroundWindow(hd);
|
||
_wapi.TrackPopupMenu(FPopupMenu.Handle,uf,ps[0],ps[1],0,hd,nil);
|
||
return true;
|
||
end
|
||
end
|
||
function Notification(AComponent:TComponent;Operation:TOperation);override;
|
||
begin
|
||
{**
|
||
@explan(说明) 通知消息处理 %%
|
||
**}
|
||
if Operation=opRecycling then //opRemove
|
||
begin
|
||
if FPopupMenu=AComponent then
|
||
begin
|
||
FPopupMenu := nil;
|
||
end
|
||
if FForm=AComponent then
|
||
begin
|
||
Form := nil;
|
||
end
|
||
end;
|
||
inherited;
|
||
end;
|
||
function Recycling();override;
|
||
begin
|
||
FIcon := nil;
|
||
TrayDelete();
|
||
FForm := nil;
|
||
FPopupMenu := nil;
|
||
inherited;
|
||
end
|
||
//添加到托盘栏
|
||
function TrayAdd();
|
||
begin
|
||
{**
|
||
@ignore(忽略) %%
|
||
@explan(说明) 添加 %%
|
||
**}
|
||
if FHaveadd then exit;
|
||
if(FForm is class(TVCForm))and FForm.HandleAllocated()then
|
||
begin
|
||
FNid.hWnd := FForm.Handle;
|
||
if not FIcon then FIcon := FForm.FormIcon;
|
||
if FIcon is class(tcustomicon)then
|
||
begin
|
||
FNid.hIcon := FIcon.Handle;
|
||
end
|
||
if ifstring(FCaption)then FNid.sztip := FCaption;
|
||
else FNid.sztip := FForm.Caption;
|
||
//FNid.dwInfoFlags := 1;
|
||
Fnid.uFlags := NIF_ICON .| NIF_MESSAGE .| NIF_TIP .| NIF_INFO;
|
||
_wapi.Shell_NotifyIconA(NIM_ADD,FNid._getptr_);
|
||
FHaveadd := true;
|
||
end
|
||
end
|
||
//从托盘栏删除
|
||
function TrayDelete();
|
||
begin
|
||
{**
|
||
@ignore(忽略) %%
|
||
@explan(说明) 删除 %%
|
||
**}
|
||
if FHaveadd then
|
||
begin
|
||
_wapi.Shell_NotifyIconA(nim_delete,FNid._getptr_);
|
||
FHaveadd := false;
|
||
end
|
||
end
|
||
published
|
||
property Form read FForm write SetForm;
|
||
property Caption:string read FCaption write SetCaption;
|
||
property OnClick:eventhandler read FOnclick write FOnclick;
|
||
property OnMouseMove:eventhandler read FOnMouseMove write FOnMouseMove;
|
||
property Icon:ticon read FIcon write SetIcon;
|
||
property PopupMenu:TPopUpmenu read FPopupMenu write FPopupMenu;
|
||
property TrayId read FTrayID;
|
||
end
|
||
type TVCForm = class(TScrollingWinControl)
|
||
{**
|
||
@explan(说明)主窗口类 %%
|
||
**}
|
||
private
|
||
FOnMinimize;
|
||
FMainMenu;
|
||
FTray;
|
||
FFormBorderStyle;
|
||
FMaxminbox;
|
||
FFormIcon;
|
||
function traypopmenu();
|
||
begin
|
||
if(FTray is class(TTray))then
|
||
begin
|
||
tp := FTray.PopupMenu;
|
||
if tp is class({TcustomPopupmenu}TcustomMenu)then
|
||
begin
|
||
return tp;
|
||
end
|
||
end
|
||
end
|
||
function SetTray(t);
|
||
begin
|
||
if FTray=t then exit;
|
||
FTray := t;
|
||
if csDesigning in ComponentState then
|
||
begin
|
||
return;
|
||
end
|
||
if FTray is class(TTray)then
|
||
begin
|
||
FTray.Form := self(true);
|
||
end
|
||
end
|
||
function seticonhandle();
|
||
begin
|
||
if HandleAllocated()and(FFormIcon is class(tcustomicon))and FFormIcon.HandleAllocated()then
|
||
begin
|
||
_send_(WM_SETICON,1,FFormIcon.handle,1);
|
||
end else
|
||
_send_(WM_SETICON,1,0,1);
|
||
end
|
||
function SetFormIcon(v);
|
||
begin
|
||
if v=FFormIcon then exit;
|
||
FFormIcon := v;
|
||
return seticonhandle();
|
||
if csDesigning in ComponentState then
|
||
begin
|
||
FFormIcon := v;
|
||
return;
|
||
end
|
||
if v is class(tcustombitmap)then
|
||
begin
|
||
if v.HandleAllocated()then
|
||
begin
|
||
vn := v.tovcon();
|
||
end
|
||
end
|
||
if ifarray(v)or ifarray(vn)then
|
||
begin
|
||
if not(FFormIcon is class(tcustomicon))then FFormIcon := new tcustomicon();
|
||
FFormIcon.readvcon(v?v:vn);
|
||
seticonhandle();
|
||
end //else
|
||
end
|
||
function GetFormIcon();
|
||
begin
|
||
return FFormIcon;
|
||
end
|
||
function SetMaxMinBox(v);
|
||
begin
|
||
nv := v?true:false;
|
||
if nv <> FMaxminbox then
|
||
begin
|
||
FMaxminbox := nv;
|
||
if HandleAllocated()then
|
||
begin
|
||
if nv then appendwstyle(WS_MAXIMIZEBOX .| WS_MINIMIZEBOX);
|
||
else minuswstyle(WS_MAXIMIZEBOX .| WS_MINIMIZEBOX);
|
||
end
|
||
end
|
||
end
|
||
function SetFormBorderStyle(NewStyle);
|
||
begin
|
||
//if FFormBorderStyle = NewStyle then exit;
|
||
end
|
||
function SetMainMenu(mu);
|
||
begin
|
||
if FMainMenu <> mu then
|
||
begin
|
||
OM := FMainMenu;
|
||
if OM is class(TcustomMainmenu)then
|
||
begin
|
||
OM.DestroyHandle(); //删除句柄 %%
|
||
OM.Hwnd := 0;
|
||
//if HandleAllocated() then _wapi.SetMenu(self.Handle,0); //删除窗口上面的菜单句柄
|
||
end
|
||
if(mu is class(TcustomMainmenu))then
|
||
begin
|
||
if HandleAllocated()then
|
||
begin
|
||
mu.Hwnd := handle;
|
||
//_wapi.SetMenu(self.Handle,mu.handle);
|
||
end
|
||
end
|
||
FMainMenu := mu;
|
||
end
|
||
end
|
||
function GetWsSysMenu();override;
|
||
begin
|
||
return true;
|
||
end
|
||
function SetWsSysMenu(v);override;
|
||
begin
|
||
end
|
||
function SetBorder(v);override;
|
||
begin
|
||
end
|
||
function SetWsPopUp(v);override;
|
||
begin
|
||
end
|
||
function GetWsPopUp();override;
|
||
begin
|
||
return true;
|
||
end
|
||
{
|
||
function GetWsCaption(v);override;
|
||
begin
|
||
return true;
|
||
end
|
||
function SetWsCaption(v);override;
|
||
begin
|
||
|
||
end }
|
||
public
|
||
class function MenuBarHeight();
|
||
begin
|
||
{**
|
||
@explan(说明) 获得菜单栏的高度 %%
|
||
@return(integer) 高度 %%
|
||
**}
|
||
return _wapi.GetSystemMetrics(SM_CYMENU);
|
||
end
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
function AfterConstruction();override;
|
||
begin
|
||
inherited;
|
||
FFormBorderStyle := bsNone;
|
||
caption := "tform";
|
||
rc := _wapi.GetScreenRect();
|
||
wd :=(rc[2]-rc[0])/2;
|
||
h :=(rc[3]-rc[1])/2;
|
||
FLeft := rc[0]+wd/2;
|
||
FTop := rc[1]+h/2;
|
||
FHeight := h;
|
||
FWidth := wd;
|
||
Color := 0x00FFFFFF;
|
||
cursor := IDC_ARROW; //OCR_NORMAL;
|
||
WsPopUp := true;
|
||
FMaxminbox := true;
|
||
WsCaption := true;
|
||
WSSizebox := true;
|
||
end
|
||
function WMTIMER(o,e):WM_TIMER;virtual;
|
||
begin
|
||
//echo "\r\ntimer";
|
||
end
|
||
function WMTRAY(o,e):WM_TRAY;virtual;
|
||
begin
|
||
if not(FTray is class(TTray))then exit;
|
||
case e.lParam of
|
||
WM_RBUTTONUP:
|
||
begin
|
||
//左键
|
||
FTray.ShowPopUpMenu();
|
||
end
|
||
WM_LBUTTONUP:
|
||
begin
|
||
if Visible and HandleAllocated()then _wapi.SetForegroundWindow(self.Handle);
|
||
CallMessgeFunction(FTray.OnClick,FTray,e);
|
||
end
|
||
WM_MOUSEMOVE:
|
||
begin
|
||
CallMessgeFunction(FTray.OnMouseMove,FTray,e);
|
||
end
|
||
end;
|
||
end
|
||
function Paint();override;
|
||
begin
|
||
inherited;
|
||
drawdesigninggrid();
|
||
end
|
||
function WMSYSCOMMAND(o,e):WM_SYSCOMMAND;override;
|
||
begin
|
||
{**
|
||
@explan(说明)系统菜单消息处理 %%
|
||
**}
|
||
if e.wparam=SC_MINIMIZE then
|
||
begin
|
||
CallMessgeFunction(OnMinimize,o,e);
|
||
end else
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
function WMCOMMAND(o,e):WM_COMMAND;override;
|
||
begin
|
||
{**
|
||
@explan(说明) command 消息处理
|
||
**}
|
||
if(FMainMenu is class(TcustomMainmenu))and FMainMenu.dispatch(e)then exit;
|
||
trp := traypopmenu();
|
||
if trp and trp.dispatch(e)then exit;
|
||
inherited;
|
||
end
|
||
function wmcreate(o,e):WM_CREATE;override;
|
||
begin
|
||
inherited;
|
||
//echo "\r\ncreate:",o.caption;
|
||
end
|
||
function WMMEASUREITEM(o,e):WM_MEASUREITEM;override;
|
||
begin
|
||
if e.wparam=0 and(FMainMenu is class(TcustomMainmenu))and FMainMenu.dispatch(e)then exit;
|
||
trp := traypopmenu();
|
||
if trp and trp.dispatch(e)then exit;
|
||
inherited;
|
||
end
|
||
function WMMENURBUTTONUP(o,e):WM_MENURBUTTONUP;override;
|
||
begin
|
||
if(FMainMenu is class(TcustomMainmenu))and FMainMenu.dispatch(e)then exit;
|
||
trp := traypopmenu();
|
||
if trp and trp.dispatch(e)then exit;
|
||
inherited;
|
||
end
|
||
function WMMENUSELECT(o,e):WM_MENUSELECT;override;
|
||
begin
|
||
if(FMainMenu is class(TcustomMainmenu))and FMainMenu.dispatch(e)then exit;
|
||
trp := traypopmenu();
|
||
if trp and trp.dispatch(e)then exit;
|
||
inherited;
|
||
end
|
||
function WMINITMENUPOPUP(o,e):WM_INITMENUPOPUP;override;
|
||
begin
|
||
if(FMainMenu is class(TcustomMainmenu))and FMainMenu.dispatch(e)then exit;
|
||
trp := traypopmenu();
|
||
if trp and trp.dispatch(e)then exit;
|
||
inherited;
|
||
end
|
||
function WMDRAWITEM(o,e):WM_DRAWITEM;override;
|
||
begin
|
||
if e.wparam=0 and(FMainMenu is class(TcustomMainmenu))then
|
||
begin
|
||
e.canvas := canvas;
|
||
canvas.handle := e.hdc;
|
||
r := FMainMenu.Dispatch(e);
|
||
e.canvas := nil;
|
||
if r then exit;
|
||
end
|
||
trp := traypopmenu();
|
||
if e.wparam=0 and trp then
|
||
begin
|
||
e.canvas := canvas;
|
||
canvas.handle := e.hdc;
|
||
r := trp.Dispatch(e);
|
||
e.canvas := nil;
|
||
if r then exit;
|
||
end
|
||
inherited;
|
||
end
|
||
function createparams(p);override;
|
||
begin
|
||
inherited;
|
||
p.WinClassName := "tsui_form"; //"tsui_form";
|
||
//p.style :=( p.style .| WS_TILEDWINDOW );// .& (.! ( WS_CHILD));//WS_GROUP .| WS_TABSTOP .|
|
||
p.style .|= WS_OVERLAPPED .| WS_SYSMENU .| WS_POPUP .| WS_MINIMIZEBOX .| WS_MAXIMIZEBOX;
|
||
p.style := bitcombination(p.style,WS_CHILD .| WS_GROUP .| WS_TABSTOP,2);
|
||
//P.style .|= WS_CLIPSIBLINGS;
|
||
if minmaxbox then
|
||
begin
|
||
p.style .|= WS_MAXIMIZEBOX .| WS_MINIMIZEBOX;
|
||
end else
|
||
begin
|
||
p.style := bitcombination(p.style,WS_MAXIMIZEBOX .| WS_MINIMIZEBOX,2);
|
||
end
|
||
P.ExStyle := P.ExStyle .| WS_EX_APPWINDOW;
|
||
//p.style :=0xcf0000 .| 0x0008 .| 0x02000000L .|0x04000000L ;//.| WS_VSCROLL .| WS_HSCROLL;// WS_VISIBLE .| WS_POPUP .| WS_CAPTION .| WS_CLIPSIBLINGS .| WS_SYSMENU .| WS_MINIMIZE .| WS_MAXIMIZEBOX;
|
||
p.cstyle := CS_HREDRAW .| CS_VREDRAW .| CS_OWNDC .| CS_DBLCLKS;
|
||
end
|
||
procedure FontChanged(Sender:TObject);override;
|
||
begin
|
||
return inherited;
|
||
if(HandleAllocated())then
|
||
begin
|
||
_send_(WM_SETFONT,Font.Handle,1);
|
||
end else
|
||
inherited;
|
||
end
|
||
function DestroyHandle();override;
|
||
begin
|
||
if FMainMenu is class(TcustomMainmenu)then
|
||
begin
|
||
FMainMenu.DestroyHandle();
|
||
end
|
||
if FTray is class(TTray)then
|
||
begin
|
||
FTray.TrayDelete();
|
||
end
|
||
inherited;
|
||
end
|
||
function InitializeWnd();override;
|
||
begin
|
||
if HandleAllocated()then
|
||
begin
|
||
if FMainMenu is class(TcustomMainmenu)then
|
||
begin
|
||
FMainMenu.Hwnd := handle;
|
||
end
|
||
seticonhandle();
|
||
if FTray is class(TTray)then
|
||
begin
|
||
FTray.TrayAdd();
|
||
end
|
||
end
|
||
end
|
||
function DoWMCLOSE(o,e);override;
|
||
begin
|
||
inherited;
|
||
if e.skip then exit;
|
||
else NotifyComponent(self(true),opclosemainwnd,nil);
|
||
end
|
||
function Notification(AComponent:TComponent;Operation:TOperation);override;
|
||
begin
|
||
{**
|
||
@explan(说明) 通知消息处理 %%
|
||
**}
|
||
if Operation=opRecycling then //opRemove
|
||
begin
|
||
if AComponent=FMainMenu then FMainMenu := nil;
|
||
if FTray=AComponent then
|
||
begin
|
||
FTray := nil;
|
||
end
|
||
end;
|
||
inherited;
|
||
end;
|
||
published
|
||
property OnMinimize:eventhandler read FOnMinimize write FOnMinimize;
|
||
property MainMenu:tmainmenu read FMainMenu write SetMainMenu;
|
||
property minmaxbox:bool read FMaxminbox write SetMaxMinBox;
|
||
{**
|
||
@param(MainMenu)(tmainmenu) 主菜单 %%
|
||
@param(OnMinimize)(function[self,tuieventbase]) 主菜单 %%
|
||
**}
|
||
property BorderStyle:TFormBorderStyle read FFormBorderStyle write SetFormBorderStyle;
|
||
property FormIcon:ticon read GetFormIcon write SetFormIcon;
|
||
property Tray:ttray READ FTray write SetTray;
|
||
end
|
||
type tform=class(TVCForm)
|
||
{**
|
||
@explan(说明) 可能和web全局重名不建议使用 %%
|
||
**}
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TpanelForm=class(tpanel) //设计器的面板窗口
|
||
{**
|
||
@explan(说明) 面板窗口 ,在设计器中使用 %%
|
||
**}
|
||
protected
|
||
function SetWsPopUp(v);override;
|
||
begin
|
||
if csDesigning in ComponentState then
|
||
begin
|
||
end else
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
function GetWsPopUp();override;
|
||
begin
|
||
if csDesigning in ComponentState then
|
||
begin
|
||
return true;
|
||
end else
|
||
begin
|
||
return inherited;
|
||
end
|
||
end
|
||
public
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
function AfterConstruction();override;
|
||
begin
|
||
inherited;
|
||
rc := _wapi.GetScreenRect();
|
||
wd :=(rc[2]-rc[0])/3;
|
||
h :=(rc[3]-rc[1])/3;
|
||
FLeft := rc[0]+wd/2;
|
||
FTop := rc[1]+h/2;
|
||
FHeight := h;
|
||
FWidth := wd;
|
||
wspopup := true;
|
||
end
|
||
function Paint();override;
|
||
begin
|
||
inherited;
|
||
drawdesigninggrid();
|
||
end
|
||
function SetDesigning(f,fc);override;
|
||
begin
|
||
if f then wspopup := true;
|
||
inherited;
|
||
end
|
||
end
|
||
type TDCreateForm=class(TVCForm) //设计器的窗口
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
function AfterConstruction();override;
|
||
begin
|
||
inherited;
|
||
Loader.LoadFromTfm(self(true));
|
||
end
|
||
|
||
end
|
||
type TDCreatePanel=class(TpanelForm) //设计器的面板
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
function AfterConstruction();override;
|
||
begin
|
||
inherited;
|
||
Loader.LoadFromTfm(self(true));
|
||
end
|
||
end
|
||
|
||
//按钮
|
||
type tbtn = class(tcustombtn) //按钮
|
||
{**
|
||
@explan(说明) 普通按钮 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type tcheckbtn = class(tcustomcheckbtn) //复选框
|
||
{**
|
||
@explan(说明) 复选框 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
|
||
end
|
||
type tradiobtn = class(tcustomradiobtn) //单选框
|
||
{**
|
||
@explan(说明)radiobtn单选按钮控件
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
type TPopMenuBtn=class(TBtn)
|
||
{**
|
||
@ignore(忽略) %%
|
||
@explan(说明) 弹出菜单的按钮 %%
|
||
**}
|
||
private
|
||
FInfo;
|
||
public
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
caption := "menubtn";
|
||
end
|
||
function SetInfo(info);
|
||
begin
|
||
if FInfo=info then exit;
|
||
mu := nil;
|
||
if ifarray(info)then
|
||
begin
|
||
mu := new TPopUpMenu(self);
|
||
mu.caption := info["caption"];
|
||
CreateMenu(mu,info["menus"]);
|
||
FInfo := info;
|
||
end
|
||
PopUpMenu := mu;
|
||
end
|
||
function BMCLICK(o,e):BM_CLICK;override;
|
||
begin
|
||
DoClick(o,e);
|
||
end
|
||
property PopupMenu:tpopupmenu read GetPopUpMenu write SetPopUpMenu;
|
||
private
|
||
function SetPopUpMenu(p);
|
||
begin
|
||
if p is class(TPopUpmenu)then
|
||
begin
|
||
caption := p.caption;
|
||
end
|
||
class(TBtn).PopupMenu := p;
|
||
end
|
||
function GetPopUpMenu();
|
||
begin
|
||
return class(TBtn).PoPupMenu;
|
||
end
|
||
function ContextMenu(o,e);override;
|
||
begin
|
||
e.skip := true;
|
||
end
|
||
function DoClick(o,e);
|
||
begin
|
||
xy := array(0,height+1);
|
||
xy := clienttoscreen(xy[0],xy[1]);
|
||
if PopupMenu is class(TPopUpmenu)then
|
||
begin
|
||
uf := TPM_LEFTALIGN .| TPM_TOPALIGN .| TPM_RIGHTBUTTON;
|
||
_wapi.TrackPopupMenu(PopupMenu.Handle,uf,xy[0],xy[1],0,self.Handle,nil);
|
||
end
|
||
end
|
||
function CreateMenu(o,info);
|
||
begin
|
||
if not ifarray(info) then return ;
|
||
for i,v in info do
|
||
begin
|
||
if ifarray(v)then
|
||
begin
|
||
mi := new TMenu(o);
|
||
mi.caption := v["caption"];
|
||
mi.onclick := v["onclick"];
|
||
mi.Bitmap := v["bitmap"];
|
||
mi.parent := o;
|
||
CreateMenu(mi,v["menus"]);
|
||
end
|
||
end
|
||
end
|
||
end
|
||
|
||
//edit
|
||
type tedit = class(tcustomedit) //编辑框
|
||
{**
|
||
@explan(说明) 单行文本编辑框类 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type tpassword = class(tcustompassword) //密码框
|
||
{**
|
||
@explan(说明) 密码编辑框类 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
type tmemo = class(TSynMemoNorm) //多行文本框
|
||
uses UTslMemo;
|
||
{**
|
||
@explan(说明) 多行文本控件 %%
|
||
**}
|
||
function create(aowner);
|
||
begin
|
||
inherited;
|
||
Left := 10;
|
||
Top := 10;
|
||
Width := 150;
|
||
Height := 90;
|
||
GutterCharCnt := 0;
|
||
Border := true;
|
||
end
|
||
function DoTextChanged(p);override;//文本改变
|
||
begin
|
||
inherited;
|
||
if Fonchange then
|
||
calldatafunction(Fonchange,self(true),new tuieventbase(0,0,0,0));
|
||
end
|
||
function MouseUp(o,e);override;
|
||
begin
|
||
if csDesigning in ComponentState then return ;
|
||
inherited;
|
||
end
|
||
function MouseDown(o,e);override;
|
||
begin
|
||
if csDesigning in ComponentState then return ;
|
||
inherited;
|
||
end
|
||
function getlinecount();
|
||
begin
|
||
return Lines.length();
|
||
end
|
||
function getline(i);
|
||
begin
|
||
ls := lines;
|
||
r := ls.GetStringByIndex(i-1);
|
||
if ifstring(r) then return r;
|
||
return "";
|
||
end
|
||
function Recycling();override;
|
||
begin
|
||
inherited;
|
||
Fonchange := nil;
|
||
FTabspace := nil;
|
||
FLineWrap := nil;
|
||
FonSetFocus := nil;
|
||
FonKillFocus := nil;
|
||
end
|
||
published
|
||
property onupdate read Fonchange write Fonchange;
|
||
property onchange read Fonchange write Fonchange;
|
||
property LineWrap read FLineWrap write FLineWrap;
|
||
property tabspace read FTabspace write FTabspace;
|
||
{**
|
||
@param(LineWrap)(bool)自动换行,默认为false不自动换行%%
|
||
@param(onupdate)(fpointer)文本更新回调%%
|
||
@param(onchange)(fpointer)文本改变回调%%
|
||
**}
|
||
private
|
||
Fonchange;
|
||
FLineWrap;
|
||
FTabspace;
|
||
FonSetFocus;
|
||
fonKillFocus;
|
||
end
|
||
type twrapmemo = class(TScrollingWinControl)
|
||
public
|
||
function create(aowner);
|
||
begin
|
||
ftexts := array();
|
||
fcharcount := 10;
|
||
ftext := "";
|
||
inherited;
|
||
AutoScroll := 1;
|
||
end
|
||
function doControlALign();override;
|
||
begin
|
||
formattexts();
|
||
inherited;
|
||
end
|
||
function MouseDown(o,e);override;
|
||
begin
|
||
SetFocus();
|
||
end
|
||
function KeyDown(o,e);override; //按键处理
|
||
begin
|
||
if ssCtrl in e.shiftstate then
|
||
begin
|
||
case e.charcode of
|
||
ord("C"):
|
||
begin
|
||
getclipboard().text := ftext;
|
||
end
|
||
end ;
|
||
end
|
||
end
|
||
function paint();override;
|
||
begin
|
||
ypos := GetYPos();
|
||
// 计算需要重绘的区域
|
||
ps := PAINTSTRUCT().rcPaint;
|
||
tp := ps[1];
|
||
bo := ps[3];
|
||
FirstLine := integer(max(0,yPos+(tp)/GetYScrollDelta()));
|
||
LastLine := integer(min(length(ftexts)-1,yPos+(bo)/GetYScrollDelta()));
|
||
rc := ps;
|
||
cvs := Canvas;
|
||
cvs.Font := font;
|
||
for i:= FirstLine to LastLine do
|
||
begin
|
||
s := ftexts[i];
|
||
r := RC;
|
||
r[1]:= RC[1]+FCharHeight * (i-ypos);
|
||
r[3]:= r[1]+FCharHeight;
|
||
if ifstring(s) then
|
||
begin
|
||
cvs.drawtext(s,r);
|
||
end
|
||
end
|
||
end
|
||
function FontChanged(o);override;
|
||
begin
|
||
if HandleAllocated() then doControlALign();
|
||
end
|
||
protected
|
||
function GetXScrollDelta();override; //x间隔
|
||
begin
|
||
return FCharwidth;
|
||
end
|
||
function GetYScrollDelta();override; //y 间隔
|
||
begin
|
||
return FCharHeight;
|
||
end
|
||
function GetClientXCapacity();override; //宽度容量
|
||
begin
|
||
return fcharcount+1;
|
||
end
|
||
function GetClientYCapacity();override; //高度容量
|
||
begin
|
||
r := ClientRect;
|
||
return ceil((r[3]-r[1])/GetYScrollDelta());
|
||
end
|
||
function GetClientXCount();override; //宽度间隔
|
||
begin
|
||
return fcharcount;
|
||
end
|
||
function GetClientYCount();override; //高度项
|
||
begin
|
||
h := FCharHeight * length(ftexts);
|
||
return integer(h/GetYScrollDelta());
|
||
end
|
||
function PositionChanged();override; //基准点改变
|
||
begin
|
||
InvalidateRect(nil,false);
|
||
end
|
||
published
|
||
property text:text read ftext write settext;
|
||
private
|
||
function formattexts();
|
||
begin
|
||
FCharwidth := font.Width;
|
||
FCharHeight := font.Height+4;
|
||
ss := str2array(ftext,"\n");
|
||
rec := ClientRect;
|
||
fcharcount := integer((rec[2]-rec[0])/FCharwidth);
|
||
ftexts := array();
|
||
if fcharcount>0 then
|
||
begin
|
||
for i,v in ss do
|
||
begin
|
||
cutstr(v,fcharcount,ftexts);
|
||
end
|
||
end
|
||
end
|
||
function settext(s);
|
||
begin
|
||
if ifstring(s) and s<>ftext then
|
||
begin
|
||
ftext := s;
|
||
if HandleAllocated() then
|
||
begin
|
||
doControlALign();
|
||
InvalidateRect(nil,false);
|
||
end
|
||
end
|
||
end
|
||
function getclipboard();//获得clipbord
|
||
begin
|
||
if not FCopyer then
|
||
begin
|
||
FCopyer := new TcustomClipBoard(self);
|
||
end
|
||
return FCopyer;
|
||
end
|
||
function cutstr(s,w,r);
|
||
begin
|
||
idx := length(r);
|
||
len := length(s);
|
||
i := 0;
|
||
while i<len do
|
||
begin
|
||
if i=len then break;
|
||
et := min(i+w,len);
|
||
if bytetype(s,et)=1 then
|
||
begin
|
||
et-=1;
|
||
end
|
||
r[idx++] := s[i+1:et];
|
||
i := et;
|
||
end
|
||
return ;
|
||
for i := 0 to len step w do
|
||
begin
|
||
if i=len then continue;
|
||
r[idx++] := s[i+1:min(i+w,len)];
|
||
end
|
||
end
|
||
private
|
||
FCharwidth;
|
||
fcharcount;
|
||
FCharHeight;
|
||
ftexts;
|
||
ftext;
|
||
[weakref] FCopyer;
|
||
end
|
||
type thighlighter= class(tcustomsynhighlighter) //语法高亮
|
||
uses UTslMemo;
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
//goupbox
|
||
type tgroupbox = class(tcustomgroupbox)
|
||
{**
|
||
@explan(说明) groupbox %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
type TCheckGroupBox=class(TRadioGroupBox)
|
||
{**
|
||
@explan(说明) checkgroupbox %%
|
||
@ignore(忽略) %%
|
||
**}
|
||
private
|
||
FItemIndexs;
|
||
function GetSelected();virtual;
|
||
begin
|
||
return GetItemByIndex(FItemIndexs);
|
||
end
|
||
function SetItemIndex();override;
|
||
begin
|
||
end
|
||
function GetItemIndexs();
|
||
begin
|
||
r := array();
|
||
k := 0;
|
||
for i,v in FItemIndexs do
|
||
begin
|
||
if ifstring(GetItemByIndex(v))then
|
||
begin
|
||
r[k++]:= v;
|
||
end
|
||
end
|
||
return r;
|
||
end
|
||
function SetItemIndexs(v);
|
||
begin
|
||
if v=FItemIndexs then exit;
|
||
FItemIndexs := array();
|
||
for i,vi in v do if vi >=-1 then FItemIndexs[k++]:= vi;
|
||
if Items then
|
||
begin
|
||
ReDrawItems();
|
||
end
|
||
end
|
||
public
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
caption := "check groupbox";
|
||
FItemIndexs := array();
|
||
end
|
||
function Drawbox(dc,src,idx);override;
|
||
begin
|
||
//_wapi.DrawFrameControl(dc.Handle,src,DFC_BUTTON,(idx in FItemIndexs)?DFCS_CHECKED:DFCS_BUTTONCHECK);
|
||
dc.Draw("framecontrol",array(src[0:1],src[2:3]),DFC_BUTTON,(idx in FItemIndexs)?DFCS_CHECKED:DFCS_BUTTONCHECK);
|
||
end
|
||
function GridClick(o,e);override;
|
||
begin
|
||
i := e.iitem;
|
||
j := e.isubitem;
|
||
idx := rctoindex(i,j);
|
||
it := GetItemByIndex(idx);
|
||
if not(i >= 0 and j >= 0)then exit;
|
||
if not ifstring(it)then exit;
|
||
if idx in FItemIndexs then
|
||
begin
|
||
FItemIndexs minus= array(idx);
|
||
end else
|
||
begin
|
||
FItemIndexs union=array(idx);
|
||
end
|
||
InvalidateSubItem(idx,true);
|
||
CallMessgeFunction(OnSelectionChanged,self,e);
|
||
end
|
||
published
|
||
property ItemIndexs:integers read GetItemIndexs write SetItemIndexs;
|
||
end
|
||
|
||
type TRadioGroupBox=class(TGroupbox)
|
||
{**
|
||
@explan(说明) radiogroupbox %%
|
||
@ignore(忽略) %%
|
||
**}
|
||
private
|
||
FGrid;
|
||
FItemIndex;
|
||
FColumns;
|
||
FRows;
|
||
FItems;
|
||
FSelectionChanged;
|
||
FColumnLayout;
|
||
function SetColumnLayout(v);
|
||
begin
|
||
if FColumnLayout <> V and(v in array(pstHorizontal,pstVertical))then
|
||
begin
|
||
FColumnLayout := v;
|
||
if FColumns>1 and FItems then
|
||
begin
|
||
ReDrawItems();
|
||
end
|
||
end
|
||
end
|
||
Function SetColumns(n);
|
||
begin
|
||
if n>0 and n <> FColumns then
|
||
begin
|
||
FColumns := n;
|
||
fcs := array();
|
||
for i := 1 to n do fcs[i-1]:= array("text":" ","width":100);
|
||
FGrid.Columns := fcs;
|
||
FRows := ceil(length(FItems)/FColumns);
|
||
FGrid.ItemCount := FRows;
|
||
GRIDsize(FGrid);
|
||
end
|
||
end
|
||
function SetItemIndex(idx);virtual;
|
||
begin
|
||
if idx>-2 and idx <> FItemIndex then
|
||
begin
|
||
FItemIndex := idx;
|
||
FGrid.InvalidateRect(nil,true);
|
||
end
|
||
end
|
||
function SetItems(v);
|
||
begin
|
||
its := array();
|
||
k := 0;
|
||
for i,vi in v do
|
||
begin
|
||
if ifstring(vi)then
|
||
begin
|
||
its[k++]:= vi;
|
||
end
|
||
end
|
||
if FItems=its then exit;
|
||
FItems := its;
|
||
FRows := ceil(length(its)/FColumns);
|
||
FGrid.ItemCount := FRows;
|
||
GRIDsize(FGrid);
|
||
end
|
||
protected
|
||
function GetControlFont();override;
|
||
begin
|
||
return FGrid.Font;
|
||
end
|
||
function rctoindex(i,j);
|
||
begin
|
||
if FColumnLayout=pstHorizontal then return i * Columns+j;
|
||
return idx := j * FRows+i;
|
||
end
|
||
function indextorc(idx,i,j);
|
||
begin
|
||
case FColumnLayout of
|
||
pstHorizontal:
|
||
begin
|
||
j := idx mod FColumns;
|
||
i := idx div FColumns;
|
||
end
|
||
pstVertical:
|
||
begin
|
||
i := idx mod FRows;
|
||
j := idx div FRows;
|
||
end
|
||
end;
|
||
end
|
||
function ReDrawItems();
|
||
begin
|
||
if FGrid and FGrid.HandleAllocated()and FItems then FGrid.InvalidateRect(nil,true);
|
||
end
|
||
function GetSelected();virtual;
|
||
begin
|
||
return GetItemByIndex(array(FItemIndex));
|
||
end
|
||
public
|
||
function SetItemByIndex(idx,v);
|
||
begin
|
||
if not ifstring(v)then exit;
|
||
s := GetItemByIndex(idx);
|
||
if ifstring(s)then FItems[idx]:= v;
|
||
return 1;
|
||
end
|
||
function GetItemByIndex(idx);
|
||
begin
|
||
if ifarray(idx)then
|
||
begin
|
||
r := array();
|
||
k := 0;
|
||
for i,v in idx do
|
||
begin
|
||
vi := call(thisfunction,v);
|
||
if ifstring(vi)then r[v]:= vi;
|
||
end
|
||
return r;
|
||
end else
|
||
if ifnumber(idx)then return FItems[idx];
|
||
end
|
||
function SetDesigning(f,fc);override;
|
||
begin
|
||
{**
|
||
@explan(说明) 设计器使用方法,设置为设计状态,或者解除设置状态 %%
|
||
@param(f)(bool) 状态值 %%
|
||
@param(fc)(bool) 是否修改子控件状态 %%
|
||
**}
|
||
inherited;
|
||
if not FGrid then exit;
|
||
if f then
|
||
begin
|
||
FGrid.Enabled := false;
|
||
end else
|
||
FGrid.Enabled := true;
|
||
end
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
caption := "radio groupbox";
|
||
color := _wapi.GetSysColor(COLOR_WINDOW);
|
||
FRows := 0;
|
||
FColumnLayout := pstHorizontal;
|
||
border := true;
|
||
FGrid := new TDrawGrid(self);
|
||
FGrid.ParentFont := true;
|
||
FGrid.border := false;
|
||
FGrid.ColumnHeader := false;
|
||
FGrid.GridLine := false;
|
||
FGrid.MouseSizeCell := 0;
|
||
FItems := array();
|
||
FItemIndex :=-1;
|
||
FGrid.Onclick := thisfunction(GridClick);
|
||
FGrid.parent := self;
|
||
FGrid.onsize := thisfunction(GRIDsize);
|
||
FGrid.OnDoDrawSubItem := thisfunction(DrawGrid);
|
||
SetColumns(1);
|
||
end
|
||
function DoControlAlign();override;
|
||
begin
|
||
cr := ClientRect;
|
||
cr[1]+= 20;
|
||
cr[0]+= 2;
|
||
cr[2]-= 2;
|
||
cr[3]-= 2;
|
||
if FGrid then FGrid.SetBoundsRect(cr);
|
||
end
|
||
function InitializeWnd();override;
|
||
begin
|
||
if csDesigning in ComponentState then
|
||
begin
|
||
FGrid.enabled := false;
|
||
end
|
||
end
|
||
function GRIDsize(o,e);
|
||
begin
|
||
if length(FItems)<1 then exit;
|
||
wd := floor((o.width-4)/(FColumns));
|
||
if wd<22 then exit;
|
||
for i := 0 to FColumns-1 do
|
||
begin
|
||
o.SetColumnWidth(i,wd);
|
||
end
|
||
end
|
||
function Drawbox(dc,src,idx);virtual;
|
||
begin
|
||
//_wapi.DrawFrameControl(dc.Handle,src,DFC_BUTTON,(idx=FItemIndex)?DFCS_BUTTONRADIOIMAGE:DFCS_BUTTONRADIO);
|
||
dc.Draw("framecontrol",array(src[0:1],src[2:3]),DFC_BUTTON,(idx=FItemIndex)?DFCS_BUTTONRADIOIMAGE:DFCS_BUTTONRADIO);
|
||
end
|
||
function DrawGrid(o,e);
|
||
begin
|
||
i := e.itemid;
|
||
j := e.subitemid;
|
||
idx := rctoindex(i,j);
|
||
it := FItems[idx];
|
||
if not ifstring(it)then exit;
|
||
rc := e.SubItemRect;
|
||
dc := e.canvas;
|
||
//src := array(rc[0]+1,rc[1]+1,rc[0]+18,rc[1]+18);
|
||
tp :=(rc[3]-rc[1])/2+rc[1]-7;
|
||
src := array(rc[0]+1,tp,rc[0]+15,tp+14);
|
||
Drawbox(dc,src,idx);
|
||
src := array(rc[0]+19,rc[1]+1,rc[2],rc[3]);
|
||
dc.font := o.font;
|
||
class(TLabel).CanvasDrawAlignText(dc,src,it,AL9_CENTERLEFT);
|
||
e.skip := true;
|
||
end
|
||
function InvalidateSubItem(idx,f);
|
||
begin
|
||
indextorc(idx,i,j);
|
||
rec := FGrid.GetSubItemRect(i,j);
|
||
FGrid.invalidaterect(rec,f);
|
||
end
|
||
function GridClick(o,e);virtual;
|
||
begin
|
||
i := e.iitem;
|
||
j := e.isubitem;
|
||
idx := rctoindex(i,j);
|
||
it := FItems[idx];
|
||
if not(i >= 0 and j >= 0)then exit;
|
||
if not ifstring(it)then exit;
|
||
odx := FItemIndex;
|
||
if FItemIndex=idx then
|
||
begin
|
||
exit;
|
||
end else
|
||
FItemIndex := idx;
|
||
if odx >= 0 then
|
||
begin
|
||
InvalidateSubItem(odx,false);
|
||
end
|
||
if FItemIndex >= 0 then
|
||
begin
|
||
InvalidateSubItem(FItemIndex,true);
|
||
end
|
||
CallMessgeFunction(OnSelectionChanged,self,e);
|
||
end
|
||
function SetItemText(i,c);
|
||
begin
|
||
{**
|
||
@explan(说明) 修改文字 %%
|
||
@param(i)(integer) 序号 %%
|
||
@param(c)(string) 文本 %%
|
||
**}
|
||
vi := FItems[i];
|
||
if ifstring(c)and vi <> c then
|
||
begin
|
||
FItems[i]:= c;
|
||
InvalidateSubItem(i,true);
|
||
end
|
||
end
|
||
function DeleteItem(i);
|
||
begin
|
||
vi := FItems[i];
|
||
if ifstring(vi)then
|
||
begin
|
||
nits := FItems;
|
||
reindex(nits,array(i:nil));
|
||
Items := nits;
|
||
end
|
||
end
|
||
published
|
||
property OnSelectionChanged:eventhandler read FSelectionChanged write FSelectionChanged;
|
||
property Columns:integer read FColumns write SetColumns;
|
||
property ItemIndex:integer read FItemIndex write SetItemIndex;
|
||
property Items:strings read FItems write SetItems;
|
||
property Selected read GetSelected;
|
||
property ColumnLayout:SplitterType read FColumnLayout write SetColumnLayout;
|
||
{**
|
||
@param(OnSelectionChanged)(function[TRadioGroupBox,tuieventbase]) 选择改变时回调 %%
|
||
@param(Columns)(integer) 列数 %%
|
||
@param(ItemIndex)(integer) 选中项目%%
|
||
@param(Items)(array of string) 项目标签%%
|
||
|
||
**}
|
||
end
|
||
//listbox
|
||
|
||
type TListBox = class(TcustomListBox)
|
||
{**
|
||
@explan(说明) listbox控件 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
|
||
end
|
||
type TColorbox=class(TcustomListBox)
|
||
{**
|
||
@explan(说明) color box 控件 %%
|
||
**}
|
||
public
|
||
function create(aOwner);override;
|
||
begin
|
||
inherited;
|
||
fcustomcolor := nil;
|
||
arr := array(
|
||
("value":"Custom","color":nil),
|
||
("value":"None","color":nil),
|
||
("value":"Black","color":0),
|
||
("value":"Maroon","color":128),
|
||
("value":"Green","color":32768),
|
||
("value":"Olive","color":32896),
|
||
("value":"Navy","color":8388608),
|
||
("value":"Purple","color":8388736),
|
||
("value":"Teal","color":8421376),
|
||
("value":"Gray","color":8421504),
|
||
("value":"Silver","color":12632256),
|
||
("value":"Red","color":255),
|
||
("value":"Lime","color":65280),
|
||
("value":"Yellow","color":65535),
|
||
("value":"Blue","color":16711680),
|
||
("value":"Fuchsia","color":16711935),
|
||
("value":"Aqua","color":16776960),
|
||
("value":"LtGray","color":12632256),
|
||
("value":"DkGray","color":8421504),
|
||
("value":"White","color":16777215),
|
||
("value":"MoneyGreen","color":12639424),
|
||
("value":"SkyBlue","color":15780518),
|
||
("value":"Cream","color":15793151),
|
||
("value":"MedGray","color":10789024));
|
||
setData(arr);
|
||
end
|
||
|
||
function MouseUp(o,e);override;
|
||
begin
|
||
inherited;
|
||
idx := GetIdxByYpos(e.ypos);
|
||
if idx =0 then
|
||
begin
|
||
if not FCdlg then
|
||
begin
|
||
FCdlg := new TColorChooseADlg(self);
|
||
FCdlg.parent := self;
|
||
end
|
||
if FCdlg.OpenDlg() then
|
||
begin
|
||
cl := FCdlg.result;
|
||
setcustomcolor(cl);
|
||
end
|
||
end
|
||
end
|
||
function getColor(n);
|
||
begin
|
||
{**
|
||
@explan(说明)获取指定下标颜色的值%%
|
||
@param(n)(integer)指定下标%%
|
||
@return(tcolor)颜色值%%
|
||
**}
|
||
r := FitemData[n];
|
||
if ifarray(r)then r := r["color"];
|
||
if ifnumber(r)then return r;
|
||
return nil;
|
||
end
|
||
function getColorName(n);
|
||
begin
|
||
{**
|
||
@explan(说明)获取指定下标颜色的名字%%
|
||
@param(n)(integer)指定下标%%
|
||
@return(string)颜色值%%
|
||
**}
|
||
r := FitemData[n];
|
||
if ifarray(r)then r := r["value"];
|
||
if ifstring(r)then return r;
|
||
return "";
|
||
end
|
||
function addColor(name,clr);
|
||
begin
|
||
//应输入使用rgb()函数处理的颜色值
|
||
{**
|
||
@explan(说明)在列表框尾部增加指定的颜色%%
|
||
@param(name)(string)指定颜色名%%
|
||
@param(clr)(tcolor)指定颜色值%%
|
||
**}
|
||
if ifnumber(clr)and ifstring(name)then appendItem(array("value":name,"color":clr));
|
||
end
|
||
function AppendColors(d);
|
||
begin
|
||
{**
|
||
@expaln(说明) 追加多个 颜色值 %%
|
||
@param(d)(array) 包括"value" 和 "color" 两个字段 %%
|
||
**}
|
||
appendItems(d);
|
||
end
|
||
function CheckListItem(v);override;
|
||
begin
|
||
return ifarray(v) and ifstring(v["value"]) ;//and ifnumber(v["color"]);
|
||
end
|
||
function PaintIdexText(idx,rc,cvs);override;
|
||
begin
|
||
rl := integer((rc[3]-rc[1])* 0.15);
|
||
rrect := array(rc[0]+rl,rc[1]+rl,rc[0]-rl+rc[3]-rc[1],rc[3]-rl);
|
||
cl := getColor(idx);
|
||
if cl>=0 or cl<0 then
|
||
begin
|
||
cvs.brush.color := cl;
|
||
cvs.fillrect(rrect);
|
||
end
|
||
rc[0]+= rc[3]-rc[1];
|
||
rc[1]+= 2;
|
||
cvs.drawtext(getColorName(idx),rc,DT_NOPREFIX);
|
||
end
|
||
published
|
||
property customcolor:color read fcustomcolor write setcustomcolor;
|
||
private
|
||
function setcustomcolor(cl);
|
||
begin
|
||
if fcustomcolor<>cl and (cl>=0 or cl<0) then
|
||
begin
|
||
fcustomcolor := cl;
|
||
r := FitemData[0];
|
||
r["color"] := cl;
|
||
FitemData.splice(0,1,r);
|
||
p := parent ;
|
||
if p is class(TColorCombobox) then p.Notification(self,"customcolorchanged");
|
||
end
|
||
end
|
||
fcustomcolor;
|
||
FCdlg;
|
||
multiSel;
|
||
end
|
||
|
||
//combobox
|
||
|
||
type TColorCombobox=class(TCustomComboBoxbase)
|
||
{**
|
||
@explan(说明) Tcolorcombobox 是一种颜色选择的combobox%%
|
||
**}
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
FListBox.visible := false;
|
||
FListBox.WsPopUp := true;
|
||
FListBox.onselchanged := function(o,e)
|
||
begin
|
||
if o.visible then
|
||
begin
|
||
ShowDropDown(false);
|
||
InvalidateRect(nil,false);
|
||
CallDataFunction(OnSelchanged,self(true),e);
|
||
end
|
||
end
|
||
FListBox.Parent := self;
|
||
itemindex := 0;
|
||
end
|
||
function CreateAlist();override;
|
||
begin
|
||
r := new tcolorbox(self);
|
||
return r;
|
||
end
|
||
function Paint();override;
|
||
begin
|
||
inherited;
|
||
idx := ItemIndex;
|
||
if not(idx >= 0)then return;
|
||
dc := canvas;
|
||
rc := ClientRect;
|
||
rc[2]-= BtnWidth;
|
||
FListBox.PaintIdx(idx,rc,dc);
|
||
return;
|
||
cl := getColorValue(idx);
|
||
txt := getColorName(idx);
|
||
dc.brush.Color := cl;
|
||
rc[2]-= BtnWidth;
|
||
rc2 := rc;
|
||
rc2[2]:= 20;
|
||
rc[0]+= 22;
|
||
bd := 2;
|
||
rc2[0]+= bd;
|
||
rc2[1]+= bd;
|
||
rc2[2]-= bd;
|
||
rc2[3]-= bd;
|
||
dc.Draw("rectangle",array(rc2[0:1],rc2[2:3]));
|
||
dc.DrawText(txt,rc,DT_VCENTER .| DT_SINGLELINE .| DT_NOPREFIX);
|
||
end
|
||
function addColor(name,clr);
|
||
begin
|
||
{**
|
||
@explan(说明)添加颜色%%
|
||
@param(colorName)(string)颜色名称例如"Red"%
|
||
@param(colorValue)(integer)颜色值%%
|
||
**}
|
||
FListBox.addColor(name,clr);
|
||
end
|
||
function AppendColors(d);
|
||
begin
|
||
{**
|
||
@expaln(说明) 追加多个 颜色值 %%
|
||
@param(d)(array) 包括"value" 和 "color" 两个字段 %%
|
||
**}
|
||
return FListBox.AppendColors(d);
|
||
end
|
||
function Clean();
|
||
begin
|
||
{**
|
||
@explan(说明)清空颜色值 %%
|
||
**}
|
||
FListBox.Clean();
|
||
end
|
||
function getcurrentColor();
|
||
begin
|
||
{**
|
||
@explan(说明)获得被选中的颜色名称%%
|
||
@return(integer) 颜色 %%
|
||
**}
|
||
idx := ItemIndex;
|
||
return getColorValue(idx);
|
||
end
|
||
function getColorName(id)
|
||
begin
|
||
{**
|
||
@explan(说明)获取颜色%%
|
||
@param(id)(integer)序号id%%
|
||
@return(string)返回颜色名称%%
|
||
**}
|
||
return FListBox.getColorName(id);
|
||
end
|
||
function getColorValue(id)
|
||
begin
|
||
{**
|
||
@explan(说明)获取颜色值%%
|
||
@param(id)(integer)序号id%%
|
||
@return(integer)返回颜色值%%
|
||
**}
|
||
return FListBox.getColor(id);
|
||
end
|
||
function Notification(o,op);override;
|
||
begin
|
||
if o=FListBox and op="customcolorchanged" then
|
||
begin
|
||
if onSelchanged and (FListBox.ItemIndex=0) then
|
||
begin
|
||
CallMessgeFunction(OnSelChanged,self(true),new tuieventbase(0,0,0,0));
|
||
end
|
||
return InvalidateRect(nil,false) ;
|
||
end
|
||
return inherited;
|
||
end
|
||
published
|
||
property customcolor:Color read getcustomcolor write setcustomcolor;
|
||
private
|
||
function getcustomcolor();
|
||
begin
|
||
return FListBox.customcolor;
|
||
end
|
||
function setcustomcolor(cl);
|
||
begin
|
||
FListBox.customcolor := cl;
|
||
end
|
||
function SetItemIndex(idx);override;
|
||
begin
|
||
FListBox.SetCurrentSelection(idx);
|
||
InvalidateRect(nil,false);
|
||
end
|
||
function GetItemIndex();override;
|
||
begin
|
||
return FListBox.GetCurrentSelection();
|
||
end
|
||
end
|
||
type TComboBox = class(TcustomComboBox)
|
||
{**
|
||
@explan(说明) comboBox下拉框 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
type TToolButton = class(TcustomToolButton)
|
||
{**
|
||
@explan(说明) 工具栏项 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
type TToolBar = class( TcustomToolBar)
|
||
{**
|
||
@explan(说明) 工具栏控件 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TStatusBar = class(TcustomStatusBar)
|
||
{**
|
||
@explan(说明) 状态栏 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type tcoolbar = class(tcustomcoolbar)
|
||
{**
|
||
@explan(说明) coolbar控件 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type tsplitter = class(tcustomsplitter)
|
||
{**
|
||
@explan(说明) splitter 控件 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
//树控件
|
||
type TTreeCtlNode = class( TcustomTreeCtlNode)
|
||
{**
|
||
@explan(说明) 树结点 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
|
||
type TTreeNode=class(TTreeCtlNode)
|
||
{**
|
||
@explan(说明)tree控件节点 %%
|
||
**}
|
||
public
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
function GetSibling(id);
|
||
begin
|
||
{**
|
||
@explan(说明) 获得兄弟节点%%
|
||
@param(id)(integer) 序号,自己的位置为0%%
|
||
**}
|
||
r := nil;
|
||
if id=0 then return self(true);
|
||
if not(Parent is class(TTreeNode))then return r;
|
||
if(id>-100000)and(id<100000)then
|
||
begin
|
||
idx := Parent.indexof(self);
|
||
return Parent.GetNodeByIndex(idx+id);
|
||
end
|
||
return r;
|
||
end
|
||
function deletenode(nd);override;
|
||
begin
|
||
DeleteChildNode(nd);
|
||
end
|
||
function InsertSibling(node,ifprev);
|
||
begin
|
||
{**
|
||
@explan(说明) 插入兄弟节点 %%
|
||
@param(node)(TTreeNode) 待插入节点 %%
|
||
@param(ifprev)(bool)
|
||
**}
|
||
if not(Parent is class(TTreeNode))then exit;
|
||
idx := Parent.IndexOf(self);
|
||
if ifprev then
|
||
begin
|
||
return Parent.InsertNode(node,idx);
|
||
end else
|
||
begin
|
||
return Parent.InsertNode(node,idx+1);
|
||
end
|
||
end
|
||
function Recycling();override;
|
||
begin
|
||
inherited;
|
||
end
|
||
function moveup();virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 节点上移 %%
|
||
@return(bool) 是否移动成功 %%
|
||
**}
|
||
bf := GetSibling(-1);
|
||
if not bf then return false;
|
||
ndp := parent;
|
||
nd := self(true);
|
||
if ndp then
|
||
begin
|
||
ow := Owner;
|
||
if ow then //锁定选择改变
|
||
begin
|
||
lk := ow.ExecuteCommand("addlocked",0);
|
||
end
|
||
ndp.deletenode(nd);
|
||
ndp.insertnode(nd,bf);
|
||
return true;
|
||
end
|
||
return false;
|
||
end
|
||
function movedown();virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 节点下移%%
|
||
**}
|
||
bf := GetSibling(1);
|
||
if not bf then return false;
|
||
ndp := parent;
|
||
if ndp then
|
||
begin
|
||
ow := Owner;
|
||
if ow then //锁定选择改变
|
||
begin
|
||
lk := ow.ExecuteCommand("addlocked",0);
|
||
end
|
||
nd := self(true);
|
||
ndp.deletenode(nd);
|
||
ndp.insertnode(nd,ndp.indexof(bf)+1);
|
||
end
|
||
return false;
|
||
end
|
||
function insertbefor(node,befor);
|
||
begin
|
||
{**
|
||
@ignore(忽略)
|
||
**}
|
||
insertnode(node,befor);
|
||
end
|
||
function append(node);
|
||
begin
|
||
{**
|
||
@ignore(忽略)
|
||
**}
|
||
insertnode(node,self.ItemCount);
|
||
end
|
||
function deleteAllChild();
|
||
begin
|
||
DeleteChildren();
|
||
end
|
||
function InsertNode(node,bnode);override;
|
||
begin
|
||
{**
|
||
@expaln(说明) 在子节点bnode 前面插入新的子节点node %%
|
||
@param(node)(TTreeNode) 待插入节点 %%
|
||
@param(bnode)(TTreeNode|TVI_FIRST|TVI_LAST) 基准节点 %%
|
||
**}
|
||
if ifarray(node)then return Owner.InsertNode(node,self(true),bnode);
|
||
if ifnil(bnode)then bnode := TVI_LAST;
|
||
ct := ItemCount;
|
||
if bnode=TVI_LAST then
|
||
begin
|
||
pos := ct;
|
||
end else
|
||
if bnode=TVI_FIRST then
|
||
begin
|
||
pos := 0;
|
||
end else
|
||
if bnode is class(TTreeNode)then
|
||
begin
|
||
pos := IndexOf(bnode);
|
||
if pos<0 then return 0;
|
||
end else
|
||
if bnode<ct and bnode >= 0 then
|
||
begin
|
||
pos := bnode;
|
||
end else
|
||
if bnode >= ct then
|
||
begin
|
||
pos := ct;
|
||
end else
|
||
begin
|
||
pos := ct;
|
||
end
|
||
return inherited InsertNode(node,pos);
|
||
end
|
||
function GetNodeByPosition(id);
|
||
begin
|
||
{**
|
||
@expaln(说明) 通过位置获得子节点%%
|
||
**}
|
||
return GetNodeByIndex(id);
|
||
end
|
||
function GetNodeCount();
|
||
begin
|
||
{**
|
||
@explan(说明) 获得当前节点下所有节点数量 %%
|
||
@return(integer) %%;
|
||
**}
|
||
r := 0;
|
||
ct := ItemCount;
|
||
for i := 0 to ct-1 do
|
||
begin
|
||
it := GetNodeByIndex(i);
|
||
r += it.GetNodeCount();
|
||
end
|
||
r += ct;
|
||
return r;
|
||
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控件 %%
|
||
**}
|
||
private
|
||
FBackColor;
|
||
FHaveFocus;
|
||
function SetLazyItems(v);
|
||
begin
|
||
if ifarray(v)and v["type"]="treenodes" then
|
||
begin
|
||
RootItem.RecyclingChildren();
|
||
InsertNodes(v);
|
||
end
|
||
end
|
||
function GetLazyItems();
|
||
begin
|
||
return(RootItem.toarray())["nodes"];
|
||
end
|
||
public
|
||
function hasFocus();override;
|
||
begin
|
||
return FHaveFocus;
|
||
end
|
||
function MouseDown(o,e);override;
|
||
begin
|
||
if csDesigning in ComponentState then return;
|
||
inherited;
|
||
if not FHaveFocus then
|
||
begin
|
||
SetFocus();
|
||
FHaveFocus := true;
|
||
InvalidateItem(self.CurrentNode);
|
||
end
|
||
end
|
||
function WMKILLFOCUS(o,e);override;
|
||
begin
|
||
FHaveFocus := false;
|
||
InvalidateItem(self.CurrentNode);
|
||
end
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
height := 150;
|
||
border := true;
|
||
HasLine := true;
|
||
nodecreator := class(TTreeNode);
|
||
end
|
||
function expand(item);
|
||
begin
|
||
{**
|
||
@explan(说明) 展开节点 %%
|
||
@param(item)(TTreeNode) ;
|
||
**}
|
||
if item is class(TTreeNode) then item.Expand();
|
||
end
|
||
function collapse(item);
|
||
begin
|
||
{**
|
||
@explan(说明) 收拢节点 %%
|
||
@param(item)(TTreeNode) ;
|
||
**}
|
||
if item is class(TTreeNode)then item.UnExpand();
|
||
end
|
||
function SwitchCollapse(item);
|
||
begin
|
||
{**
|
||
@explan(说明) 切换收拢或者展 %%
|
||
@param(item)(TTreeNode) ;
|
||
**}
|
||
if item is class(TTreeNode)then
|
||
begin
|
||
if Item.Expaned then Item.UnExpand();
|
||
else Item.UnExpand();
|
||
end
|
||
end
|
||
function InsertNodes(iteminfos,pnode,bnode);
|
||
begin
|
||
{**
|
||
@explan(说明) 批量插入节点 %%
|
||
**}
|
||
if ifarray(iteminfos)and iteminfos["type"]="treenodes" then
|
||
begin
|
||
its := iteminfos["items"];
|
||
for i,v in its do
|
||
begin
|
||
InsertNode(v,pnode,bnode);
|
||
end
|
||
end
|
||
end
|
||
function InsertNode(iteminfo,pnode,bnode);
|
||
begin
|
||
{**
|
||
@explan(说明)插入单个节点 %%
|
||
@param(iteminfo)(array) array("type":"treenode","caption":"","imgid":id,"nodes":array()) 节点信息
|
||
nodes字段为子节点信息 %% 包括
|
||
%%
|
||
@param(pnode)(TTreeNode) 父节点 %%
|
||
@param(bnode)(TTreeNode) 前一个节点 %%
|
||
**}
|
||
if not(pnode is class(TTreeNode))then pnode := RootItem;
|
||
if self <> pnode.Owner then return;
|
||
if iteminfo is class(TTreeNode)then
|
||
begin
|
||
return pnode.InsertNode(iteminfo,bnode);
|
||
end
|
||
if not(ifarray(iteminfo)and iteminfo)then return nil;
|
||
item := CreateTreeNode();
|
||
item.Checked := iteminfo["checked"];
|
||
item.caption := iteminfo["caption"];
|
||
item.SelImgId := iteminfo["selimgid"];
|
||
item.ImgId := iteminfo["imgid"];
|
||
item._tag := iteminfo["tag"];
|
||
pnode.InsertNode(item,bnode);
|
||
InsertNodes(iteminfo["nodes"],item);
|
||
return item;
|
||
end
|
||
function deleteitem(node);
|
||
begin
|
||
{**
|
||
@explan(说明) 删除 节点,但是节点不会销毁,请用node.recycling 销毁 %%
|
||
@param(node)(TTreeNode)
|
||
**}
|
||
return deletenode(node);
|
||
if node is class(TTreeNode)then
|
||
begin
|
||
end else
|
||
return;
|
||
np := RootItem.HasNode(node);
|
||
if np then np.DeleteChildNode(node);
|
||
end
|
||
public
|
||
function Recycling();override;
|
||
begin
|
||
inherited;
|
||
end
|
||
function Destroy();override;
|
||
begin
|
||
inherited;
|
||
end
|
||
function GetItemCount();
|
||
begin
|
||
{**
|
||
@explan(说明) 获得item的数量 %%
|
||
@return(integer) 数量 %%
|
||
**}
|
||
RootItem.GetNodeCount();
|
||
end
|
||
function clean();override;
|
||
begin
|
||
{**
|
||
@explan(说明)删除节点并销毁 %%
|
||
**}
|
||
BeginUpdate();
|
||
RootItem.RecyclingChildren();
|
||
EndUpDate();
|
||
end
|
||
published
|
||
property RootItem read GetRootNode;
|
||
property LazyItems:TreeData read GetLazyItems Write SetLazyItems;
|
||
//property OnDeleteItem read FOnDeleteItem write FOnDeleteItem;
|
||
//property OnItemExpand:eventhandler read FOnItemExpand write FOnItemExpand;
|
||
{**
|
||
@param(RootItem)(TTreeNode) 根节点 %%
|
||
@param(LazyItems)(array) 结构化数据数组 %%
|
||
**}
|
||
end
|
||
//tab控件
|
||
type TTabSheet = class(tcustomtabsheet)
|
||
{**
|
||
@explan(说明)page控件页面 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type tpagecontrol = class(tcustompagecontrol)
|
||
{**
|
||
@explan(说明)page控件 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
//二分控件
|
||
type TPairSplitterSide=class(TCustomControl)
|
||
{**
|
||
@explan(说明) 分开控件side窗口 %%
|
||
**}
|
||
Private
|
||
FPairSplitter;
|
||
public
|
||
function DesigningMove();override;
|
||
begin
|
||
return false;
|
||
end
|
||
function paint();override;
|
||
begin
|
||
inherited;
|
||
drawdesigninggrid();
|
||
end
|
||
function DesigningSizer();override;
|
||
begin
|
||
return false;
|
||
end
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
caption := "PairSplitterSide";
|
||
cursor := OCR_NORMAL;
|
||
border := true;
|
||
end
|
||
end
|
||
type TPairSplitter=class(tcustomcontrol) //
|
||
{**
|
||
@explan(说明)分割控件 %%
|
||
**}
|
||
private
|
||
FDRageimglist;
|
||
FWill_Drag;
|
||
FIs_Draging;
|
||
FPosition;
|
||
FSides;
|
||
FSplitterType;
|
||
Fhimgelist;
|
||
FEnables;
|
||
function AddSide(ASide);//添加side
|
||
begin
|
||
if not(ASide is class(TPairSplitterSide))then return -1;
|
||
FSides.Push(ASide);
|
||
end
|
||
function EnabledChild(f);//enabeld
|
||
begin
|
||
if f then
|
||
begin
|
||
for i,v in FEnables do
|
||
begin
|
||
if v then
|
||
begin
|
||
FSides[i].enabled := true;
|
||
end
|
||
end
|
||
end else
|
||
begin
|
||
FEnables := array();
|
||
for i,v in FSides.data do
|
||
begin
|
||
FEnables[i] := v.enabled;
|
||
v.enabled := false;
|
||
end
|
||
end
|
||
end
|
||
Function SetSplitterType(v);
|
||
begin
|
||
if (v in array(pstHorizontal,pstVertical)) and v <> FSplitterType then
|
||
begin
|
||
FSplitterType := v;
|
||
if FSplitterType=pstVertical then cursor := OCR_SIZENS else cursor := OCR_SIZEWE;
|
||
DoControlAlign();
|
||
end
|
||
end
|
||
function GetPosition();
|
||
begin
|
||
if ifnil(FPosition)then
|
||
begin
|
||
if FSplitterType=pstHorizontal then
|
||
begin
|
||
FPosition := Width * 0.3;
|
||
end else
|
||
begin
|
||
FPosition := Height * 0.7;
|
||
end
|
||
end
|
||
return FPosition;
|
||
end
|
||
function SetPosition(AValue);
|
||
begin
|
||
if AValue>0 and AValue <> FPosition then
|
||
begin
|
||
FPosition := integer(AValue);
|
||
DoControlAlign();
|
||
end
|
||
end
|
||
function getvisbleside(id);
|
||
begin
|
||
c := 0;
|
||
for i := 0 to fsides.length()-1 do
|
||
begin
|
||
v := fsides[i];
|
||
if v.Visible then
|
||
begin
|
||
if c = id then return v;
|
||
c++;
|
||
end
|
||
end
|
||
end
|
||
public
|
||
function ControlAppended(AControl);override;
|
||
begin
|
||
if not FSides then return ;
|
||
AddSide(AControl);
|
||
end
|
||
function ControlDeleted(AControl);override;
|
||
begin
|
||
if not FSides then return ;
|
||
for i,v in FSides.data do
|
||
begin
|
||
if v=AControl then
|
||
begin
|
||
FSides.splice(i,1);
|
||
return ;
|
||
end
|
||
end
|
||
end
|
||
function checknewchild(c);override;
|
||
begin
|
||
return c is class(TPairSplitterSide);
|
||
end
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
function AfterConstruction();override;
|
||
begin
|
||
inherited;
|
||
FSides := new tnumindexarray();
|
||
caption := "pairspliter";
|
||
width := 200;
|
||
height := 200;
|
||
Border := false;
|
||
WsDlgModalFrame := true;
|
||
FSplitterType := pstHorizontal;
|
||
cursor := OCR_SIZEWE;
|
||
FWill_Drag := true;
|
||
Color := _wapi.GetSysColor(COLOR_MENUBAR);
|
||
end
|
||
|
||
function MouseUp(o,e);override;
|
||
begin
|
||
if csDesigning in ComponentState then exit;
|
||
if e.button=mbLeft then
|
||
begin
|
||
if FIs_Draging then
|
||
begin
|
||
_wapi.ImageList_DragLeave(self.Handle);
|
||
_wapi.ImageList_EndDrag();
|
||
r := ClientRect;
|
||
if FSplitterType=pstHorizontal then
|
||
begin
|
||
x := e.xpos ;
|
||
if x<(r[0]+2) then
|
||
begin
|
||
x := r[0]+5;
|
||
end else
|
||
if x>(r[2]-2) then
|
||
begin
|
||
x := r[2]-5;
|
||
end
|
||
FPosition := x;
|
||
end else
|
||
begin
|
||
x := e.ypos;
|
||
if x<(r[1]+2) then
|
||
begin
|
||
x := r[1]+5;
|
||
end else
|
||
if x>(r[3]-2) then
|
||
begin
|
||
x := r[3]-5;
|
||
end
|
||
FPosition :=x;
|
||
end
|
||
EnabledChild(true);
|
||
FWill_Drag := true;
|
||
FIs_Draging := false;
|
||
_wapi.clipcursor(0);
|
||
DoControlAlign();
|
||
end
|
||
end
|
||
inherited;
|
||
end
|
||
function MouseDown(o,e);override;
|
||
begin
|
||
if csDesigning in ComponentState then exit;
|
||
if e.button=mbLeft then
|
||
begin
|
||
nxy := clienttowindow(e.xpos,e.ypos);
|
||
if FWill_Drag then
|
||
begin
|
||
FWill_Drag := false;
|
||
FIs_Draging := true;
|
||
if FDRageimglist then _wapi.ImageList_Destroy(FDRageimglist);
|
||
crect := clientrect;
|
||
if FSplitterType=pstHorizontal then
|
||
begin
|
||
FDRageimglist := _wapi.ImageList_Create(5,crect[3],ILC_COLOR16 .| ILC_MASK,5,1);
|
||
_wapi.ImageList_BeginDrag(FDRageimglist,0,2,nxy[1]);
|
||
end else
|
||
begin
|
||
FDRageimglist := _wapi.ImageList_Create(crect[2],5,ILC_COLOR16 .| ILC_MASK,5,1);
|
||
_wapi.ImageList_BeginDrag(FDRageimglist,0,nxy[0],2);
|
||
end
|
||
_wapi.ImageList_DragEnter(self.Handle,nxy[0],nxy[1]);
|
||
//_wapi.ImageList_DragEnter(self.Handle,e.xpos,e.ypos);
|
||
ps := array(clienttoscreen(crect[0],crect[1]),clienttoscreen(crect[2],crect[3]));
|
||
_wapi.clipcursor(ps);
|
||
EnabledChild(false);
|
||
end
|
||
end
|
||
inherited;
|
||
end
|
||
function MouseMove(o,e);override;
|
||
begin
|
||
if (csDesigning in ComponentState) then return ;
|
||
if FIs_Draging then
|
||
begin
|
||
nxy := clienttowindow(e.xpos,e.ypos);
|
||
_wapi.ImageList_DragMove(nxy[0],nxy[1]);
|
||
end else
|
||
begin
|
||
if getvisbleside(0) then
|
||
begin
|
||
if FSplitterType=pstHorizontal then
|
||
begin
|
||
cursor := OCR_SIZEWE;
|
||
end else
|
||
if FSplitterType=pstVertical then
|
||
begin
|
||
cursor := OCR_SIZENS ;
|
||
end
|
||
end else
|
||
begin
|
||
cursor := OCR_NORMAL;
|
||
end
|
||
end
|
||
inherited;
|
||
end
|
||
function DoControlAlign();override;
|
||
begin
|
||
{**
|
||
@explan(说明) 对齐调整 %%
|
||
**}
|
||
if not HandleAllocated()then return;
|
||
sd1 := getvisbleside(0);
|
||
sd2 := getvisbleside(1);
|
||
if not(sd1 or sd2)then return;
|
||
rc := GetClientRect();
|
||
pz := GetPosition();
|
||
pbdr := 0;
|
||
{$ifdef linux}
|
||
if (csDesigning in ComponentState) then
|
||
begin
|
||
pbdr := 2;
|
||
end
|
||
{$endif}
|
||
if sd1 and sd1.HandleAllocated()then
|
||
begin
|
||
if FSplitterType=pstHorizontal then sd1.setboundsrect(array(rc[0]+pbdr,rc[1]+pbdr,rc[0]+pz,rc[3]-pbdr));
|
||
else sd1.setboundsrect(array(rc[0]+pbdr,rc[1]+pbdr,rc[2]-pbdr,rc[1]+pz));
|
||
end
|
||
if sd2 and sd2.HandleAllocated()then
|
||
begin
|
||
if FSplitterType=pstHorizontal then sd2.setboundsrect(array(rc[0]+pz+4,rc[1]+pbdr,rc[2]-pbdr,rc[3]-pbdr));
|
||
else sd2.setboundsrect(array(rc[0]+pbdr,rc[1]+pz+4,rc[2]-pbdr,rc[3]-pbdr));
|
||
end
|
||
end
|
||
function paint();override;
|
||
begin
|
||
sd1 := getvisbleside(0);
|
||
sd2 := getvisbleside(1);
|
||
if not(sd1 or sd2)then return;
|
||
rc := GetClientRect();
|
||
pz := GetPosition();
|
||
dc := canvas;
|
||
if FSplitterType=pstHorizontal then
|
||
begin
|
||
x := rc[0]+pz+2;
|
||
y := integer(rc[1]+(rc[3]-rc[1])/2) ;
|
||
for i := -4 to 4 do
|
||
begin
|
||
y1 := y+i*4;
|
||
if y1>rc[1] and y1<rc[3] then
|
||
dc.SetPixel(array(x,y1),0);
|
||
end
|
||
end else
|
||
begin
|
||
y := rc[1]+pz+2;
|
||
x := integer(rc[0]+(rc[2]-rc[0])/2) ;
|
||
for i := -4 to 4 do
|
||
begin
|
||
x1 := x+i*4;
|
||
if x1>rc[0] and x1<rc[2] then
|
||
dc.SetPixel(array(x1,y),0);
|
||
end
|
||
end
|
||
end
|
||
function Recycling();override;
|
||
begin
|
||
if FDRageimglist then _wapi.ImageList_Destroy(FDRageimglist);
|
||
FSides := nil;
|
||
inherited;
|
||
end
|
||
published
|
||
property Position:integer read GetPosition write SetPosition;
|
||
property SplitterType:SplitterType read FSplitterType write SetSplitterType;
|
||
{**
|
||
@param(Position)(integer) 分割线位置 %%
|
||
@param(SplitterType)(menuber of TPairSplitterType) 分割线位置 %%
|
||
**}
|
||
end
|
||
|
||
//表格控件
|
||
type TTlvnActiveEvent=class(tuieventbase)
|
||
{**
|
||
@explan(说明) listview active 通知消息 %%
|
||
**}
|
||
public
|
||
function create(m,w,l,h);override;
|
||
begin
|
||
inherited;
|
||
FNmList := array();
|
||
end
|
||
property hdr index "hdr" read _getvalue_ write _setvalue_;
|
||
property iitem index "iitem" read _getvalue_ write _setvalue_;
|
||
property isubitem index "isubitem" read _getvalue_ write _setvalue_;
|
||
property unewstate index "unewstate" read _getvalue_ write _setvalue_;
|
||
property uoldstate index "uoldstate" read _getvalue_ write _setvalue_;
|
||
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)
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
type TGRidBase = class(TGridCtl)
|
||
{**
|
||
@explan(说明)表格基础类 %%
|
||
**}
|
||
private
|
||
FGridLine;
|
||
FColumHeader;
|
||
FonColumnClick;
|
||
FColumTexts;
|
||
private
|
||
function setcolumncount(n);override;
|
||
begin
|
||
end
|
||
function SetGridLine(v);
|
||
begin
|
||
nv := v?true:false;
|
||
if nv <> FGridLine then
|
||
begin
|
||
FGridLine := nv;
|
||
end
|
||
end
|
||
function SetColumHeader(v);
|
||
begin
|
||
nv := v?true:false;
|
||
if nv <> FColumHeader then
|
||
begin
|
||
ct := ItemCount;
|
||
FColumHeader := nv;
|
||
if nv then
|
||
begin
|
||
FixedRows := 1;
|
||
end else
|
||
FixedRows := 0;
|
||
ItemCount := ct;
|
||
end
|
||
end
|
||
|
||
function SetItemCount(r);
|
||
begin
|
||
if r >= 0 then
|
||
begin
|
||
if ColumnHeader then
|
||
begin
|
||
class(TGridCtl).ItemCount := r+1;
|
||
end else
|
||
class(TGridCtl).ItemCount := r;
|
||
end
|
||
end
|
||
function GetItemCount();
|
||
begin
|
||
if ColumnHeader then
|
||
begin
|
||
return class(TGridCtl).ItemCount-1;
|
||
end else
|
||
return class(TGridCtl).ItemCount;
|
||
end
|
||
function GetColumInfo();
|
||
begin
|
||
r := array();
|
||
for i := 0 to FColumTexts.Length()-1 do
|
||
begin
|
||
r[i,"text"]:= FColumTexts[i];
|
||
r[i,"width"]:= GetColumnWidth(i);
|
||
end
|
||
return r;
|
||
end
|
||
protected
|
||
function GetColumns();virtual;
|
||
begin
|
||
return GetColumInfo();
|
||
end
|
||
function ClickedGridItem(o,e);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明)点击时处理 %%
|
||
**}
|
||
end
|
||
function RClickedGridItem(o,e);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明)点击时处理 %%
|
||
**}
|
||
end
|
||
function CreateVclick(o,e);
|
||
begin
|
||
ne := new TTlvnActiveEvent(100,0,0,o.handle);
|
||
ne.iitem := GetRowIndexByPos(e.ypos);
|
||
ne.isubitem := GetColIndexByPos(e.xpos);
|
||
ne.ptaction := array(e.xpos,e.ypos);
|
||
return ne;
|
||
end
|
||
public
|
||
function GetRowIndexByPos(y);override;
|
||
begin
|
||
r := inherited;
|
||
if r >= 0 and FColumHeader then r--;
|
||
return r;
|
||
end
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
caption := "grid";
|
||
FixedRows := 1;
|
||
FGridLine := true;
|
||
FColumHeader := true;
|
||
ItemCount := 0;
|
||
Visible := true;
|
||
FColumTexts := new TMyarrayB();
|
||
end
|
||
function Recycling();override;
|
||
begin
|
||
onColumnClick := nil;
|
||
inherited;
|
||
end
|
||
function GetSubItemRect(i,j);override;
|
||
begin
|
||
{**
|
||
@explan(说明)获得子项的区域 %%
|
||
@return(array) array(左,上,右,下);
|
||
**}
|
||
i1 := i;
|
||
if FColumHeader then
|
||
begin
|
||
i1 := i+1;
|
||
end
|
||
r := inherited GetSubItemRect(i1,j);
|
||
if not r then return zeros(4);
|
||
return r;
|
||
end
|
||
function InvalidateItem(i);override;
|
||
begin
|
||
i1 := i;
|
||
if FColumHeader then i1++;
|
||
inherited InvalidateItem(i1);
|
||
end
|
||
function GetItemRect(id);override;
|
||
begin
|
||
{**
|
||
@explan(说明) 获得行的区域 %%
|
||
@return(array) array(左,上,右,下);
|
||
**}
|
||
i1 := id;
|
||
if FColumHeader then
|
||
begin
|
||
i1 += 1;
|
||
end
|
||
r := inherited GetItemRect(i1);
|
||
if r then return r;
|
||
return array(0,0,0,0);
|
||
end
|
||
function HitTestItem(x,y)
|
||
begin
|
||
{**
|
||
@explan(说明)位置命中 测试 %%
|
||
**}
|
||
i := GetRowIndexByPos(y);
|
||
return array(i,ifnumber(x)?GetColIndexByPos(x):0);
|
||
end
|
||
function SetColumns(cs,beg,len);override;
|
||
begin
|
||
if not cs then
|
||
begin
|
||
FColumTexts.splices(beg>0?beg:0,len >= 0?len:FColumTexts.Length(),array());
|
||
Inherited SetColumns(array(),beg,len);
|
||
return;
|
||
end
|
||
if ifarray(cs)then
|
||
begin
|
||
wds := array();
|
||
cls := array();
|
||
idx := 0;
|
||
for i,v in cs do
|
||
begin
|
||
if ifarray(v)and ifstring(v["text"])then
|
||
begin
|
||
wd := v["width"];
|
||
owd := GetColumnWidth(i);
|
||
wds[idx]:= v["width"]>= 0?v["width"]:(owd >= 0?owd:100);
|
||
cls[idx++]:= v["text"];
|
||
end
|
||
end
|
||
owds := array();
|
||
for i := 0 to ColumnCount-1 do
|
||
begin
|
||
owds[i]:= GetColumnWidth(i);
|
||
end
|
||
if(cls=FColumTexts.Data)and(owds=wds)then exit;
|
||
if ifnil(beg)and ifnil(len)then DeleteAllColumns();
|
||
FColumTexts.splices(beg>0?beg:0,len >= 0?len:FColumTexts.Length(),cls);
|
||
Inherited SetColumns(wds,beg,len);
|
||
end
|
||
end
|
||
function DeleteColumn(i);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 删除某列
|
||
**}
|
||
SetColumns(array(),i,1);
|
||
end
|
||
function InSertColumn(txt,wd,idx);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 插入列 %%
|
||
@param(txt)(string) 标题 %%
|
||
@param(wd)(integer) 宽度 %%
|
||
@param(idx)(integer) 插入在序号之前%%
|
||
**}
|
||
if not(ifstring(txt)and wd >= 0)then return-1;
|
||
if idx >= 0 then p := idx;
|
||
else p := ColumnCount;
|
||
SetColumns(array(("text":txt,"width":wd)),p,0);
|
||
end
|
||
function DeleteAllColumns();virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 删除所有列 %%
|
||
**}
|
||
DeleteAllItems();
|
||
SetColumns(array(),nil,nil);
|
||
end
|
||
function DeleteAllItems();virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 清空内容 %%
|
||
**}
|
||
ItemCount := 0;
|
||
end
|
||
function DeleteItem(i);virtual;
|
||
begin
|
||
ItemCount := ItemCount-1;
|
||
end
|
||
function InsertItem(item);virtual;
|
||
begin
|
||
ItemCount := ItemCount+1;
|
||
end
|
||
function SetColumnText(n,t);
|
||
begin
|
||
FColumTexts[n]:= t;
|
||
end
|
||
function GetColumnText(n);
|
||
begin
|
||
return FColumTexts[n];
|
||
end
|
||
function clean();
|
||
begin
|
||
{**
|
||
@explan(说明) 清空所有项目以及表头 %%
|
||
**}
|
||
DeleteAllColumns();
|
||
end
|
||
function DrawHeader(o,e);virtual;
|
||
begin
|
||
rec := e.rcitem;
|
||
cvs := e.canvas;
|
||
j := e.Subitemid;
|
||
dr := array(rec[0:1],rec[2:3]);
|
||
cvs.Draw("FrameControl",dr,DFC_BUTTON,DFCS_BUTTONPUSH);
|
||
cs := GetColumnText(j);
|
||
if ifstring(cs)then cvs.drawtext(cs,rec,DT_VCENTER .| DT_SINGLELINE .| DT_CENTER .| DT_NOPREFIX);
|
||
end
|
||
function DrawCell(cvs,rec,i,j);override; //绘制表头
|
||
begin
|
||
if not HandleAllocated()then return;
|
||
//构造消息对象
|
||
e := new TGRIDMDRAWITEM(WM_DRAWITEM,0,0,0);
|
||
e.canvas := cvs;
|
||
if FColumHeader then e.itemid := i-1;
|
||
else e.itemid := i;
|
||
e.rcitem := rec;
|
||
e.SubItemRect := rec;
|
||
e.Subitemid := j;
|
||
if FColumHeader and i=0 then
|
||
begin
|
||
return DrawHeader(self(true),e);
|
||
end
|
||
DoDrawItem(self(true),e);
|
||
end
|
||
function DoDrawItem(o,e);virtual;
|
||
begin
|
||
DoDrawSubItem(o,e);
|
||
end
|
||
function DoDrawSubItem(o,e);virtual;
|
||
begin
|
||
if FGridLine then
|
||
begin
|
||
rc := e.rcitem;
|
||
dc := e.canvas;
|
||
dc.Pen.Color := 0xc8c8c8;
|
||
dc.moveto(array(rc[2],rc[1]));
|
||
dc.LineTo(array(rc[2],rc[3]));
|
||
dc.LineTo(array(rc[0],rc[3]));
|
||
if e.Subitemid=0 then
|
||
begin
|
||
dc.LineTo(array(rc[0],rc[1]));
|
||
end
|
||
if e.itemid=0 then
|
||
begin
|
||
dc.MoveTo(array(rc[0],rc[1]));
|
||
dc.LineTo(array(rc[2],rc[1]));
|
||
end
|
||
end
|
||
end
|
||
function DoSelectChanged(o,nindex,oindex);virtual;
|
||
begin
|
||
end
|
||
function MouseDown(o,e);override;
|
||
begin
|
||
r := inherited;
|
||
if r then return r;
|
||
if e.shiftdouble()and e.button()=mbLeft then //双击
|
||
begin
|
||
ne := CreateVclick(o,e);
|
||
ClickedGridItem(o,ne);
|
||
CallMessgeFunction(ondblclick,o,ne);
|
||
end
|
||
end
|
||
function MouseUp(o,e);override;
|
||
begin
|
||
r := inherited;
|
||
if r then return r;
|
||
ne := CreateVclick(o,e);
|
||
bt := e.button();
|
||
if bt=mbRight then
|
||
begin
|
||
RClickedGridItem(o,ne);
|
||
CallMessgeFunction(onrclick,o,ne);
|
||
end else
|
||
if bt=mbLeft then
|
||
begin
|
||
if FColumHeader and(inherited GetRowIndexByPos((ne.ptaction)[1]))=0 then
|
||
begin
|
||
CallMessgeFunction(onColumnClick,o,ne);
|
||
end else
|
||
begin
|
||
ClickedGridItem(o,ne);
|
||
CallMessgeFunction(onclick,o,ne);
|
||
end
|
||
end
|
||
//e.skip := true;
|
||
//rclick
|
||
//click
|
||
//LVN_COLUMNCLICK
|
||
end
|
||
published
|
||
property GridLine:bool read FGridLine write SetGridLine;
|
||
property ColumnHeader:bool read FColumHeader write SetColumHeader;
|
||
property ItemCount:integer read GetItemCount write SetItemCount;
|
||
property onColumnClick:eventhandler read FonColumnClick write FonColumnClick;
|
||
property Columns:statusitems read GetColumns write SetColumns;
|
||
{
|
||
@param(GridLine)(bool) 是否有网格线 %%
|
||
@param(ColumnHeader)(bool) 是否有表头 %%
|
||
@param(color)(integer) 颜色 %%
|
||
@param(onColumnClick)(function[TGRidBase,TTlvnActiveEvent]) 列被点击 %%
|
||
}
|
||
end
|
||
type TDrawGrid=class(TGRidBase)
|
||
{**
|
||
@explan(说明)自绘制网格 %%
|
||
**}
|
||
Private
|
||
FOnDoDrawSubItem;
|
||
protected
|
||
public
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
function DoDrawSubItem(o,e);override;
|
||
begin
|
||
inherited;
|
||
if OnDoDrawSubItem then
|
||
CallMessgeFunction(OnDoDrawSubItem,o,e);
|
||
end
|
||
function Recycling();override;
|
||
begin
|
||
FOnDoDrawSubItem := nil;
|
||
inherited;
|
||
end
|
||
published
|
||
property OnDoDrawSubItem read FOnDoDrawSubItem write FOnDoDrawSubItem;
|
||
{**
|
||
@param(OnDoDrawSubItem)(function[tdrawgrid,TGRIDMDRAWITEM]) 子项绘制 %%
|
||
@param(ItemCount)(integer) 行数 %%
|
||
**}
|
||
end
|
||
|
||
type TListView = class(TDrawGrid)
|
||
{**
|
||
@explan(说明) listview控件 %%
|
||
**}
|
||
private
|
||
FMouseCurrentTime;
|
||
FList;
|
||
FIntAlign;
|
||
FSelected;
|
||
FMoueonItem;
|
||
FSelBkColor;
|
||
FMouseOnBkColor;
|
||
FMenus;
|
||
[weakref]FSelectedChanged;
|
||
[weakref]FOnCheckItem;
|
||
FCanSelected;
|
||
FColumnBool;
|
||
FPrevSelectedId;
|
||
Function SetIntAlign(v);
|
||
begin
|
||
if v in array(DT_CENTER,DT_LEFT,DT_RIGHT)then
|
||
begin
|
||
if v <> FIntAlign then
|
||
begin
|
||
FIntAlign := v;
|
||
InvalidateRect(nil,false);
|
||
end
|
||
end
|
||
end
|
||
function CallSelChanged();
|
||
begin
|
||
if OnSelChanged then
|
||
return calldatafunction(OnSelChanged,self(true),new tuieventbase(0,0,0,0));
|
||
end
|
||
function SetCanSelected(v);
|
||
begin
|
||
vn := v?true:false;
|
||
if FCanSelected <> vn then
|
||
begin
|
||
FCanSelected := vn;
|
||
if not UnSelected then UnSelected();
|
||
end
|
||
end
|
||
function SetSelected(id);
|
||
begin
|
||
if not FCanSelected then exit;
|
||
if id=FSelected then exit;
|
||
if id<0 then exit;
|
||
odid := FSelected;
|
||
FPrevSelectedId := odid;
|
||
FSelected := id;
|
||
if odid >= 0 then
|
||
begin
|
||
InvalidateItem(odid);
|
||
end
|
||
InvalidateItem(id);
|
||
CallSelChanged();
|
||
end
|
||
function GetSelected();
|
||
begin
|
||
if FSelected >= 0 then return FList[FSelected];
|
||
return nil;
|
||
end
|
||
|
||
function GetListValues();
|
||
begin
|
||
r := array();
|
||
for i := 0 to FList.count-1 do
|
||
begin
|
||
r[i]:= FList[i];
|
||
end
|
||
return r;
|
||
end
|
||
function CreateMenu();
|
||
begin
|
||
if FMenus then return FMenus;
|
||
createmenubyarray(menus(),FMenus);
|
||
return FMenus;
|
||
end
|
||
function createmenubyarray(ms,pm);
|
||
begin
|
||
if not(ifarray(ms)and ms)then exit;
|
||
if ms["type"]="menu" then
|
||
begin
|
||
if not pm then pm := new TPopUpmenu(FCwnd);
|
||
if ifstring(ms["caption"])then
|
||
begin
|
||
mu := new tmenu(FCwnd);
|
||
mu.caption := ms["caption"];
|
||
o := ms["onclick"];
|
||
mu.onclick := ms["onclick"];
|
||
mu.parent := pm;
|
||
call(thisfunction,ms["items"],mu);
|
||
end
|
||
end else
|
||
for i,v in ms do
|
||
begin
|
||
call(thisfunction,v,pm);
|
||
end
|
||
end
|
||
public
|
||
function menus();virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 返回菜单数组 %%
|
||
@return(array) array(("type":"menu","caption":"删除")
|
||
,("type":"menu","caption":"添加"))
|
||
**}
|
||
return array();
|
||
return array(("type":"menu","caption":"删除")
|
||
,("type":"menu","caption":"添加"));
|
||
end
|
||
function DeleteAllItems();override;
|
||
begin
|
||
{**
|
||
@explan(说明) 清空内容 %%
|
||
**}
|
||
UnSelected();
|
||
FList.clean();
|
||
inherited;
|
||
end
|
||
function GridDrawItem(id);
|
||
begin
|
||
{**
|
||
@explan(说明) 绘制第id项 %%
|
||
**}
|
||
InvalidateItem(id);
|
||
end
|
||
function SetSelectedValue(v);
|
||
begin
|
||
{**
|
||
@explan(说明) 设置选中项目 %%
|
||
**}
|
||
id := FList.indexof(v);
|
||
if id >= 0 and id<FList.Count then SetSelected(id);
|
||
end
|
||
function MouseMove(o,e);override;
|
||
begin
|
||
return inherited;
|
||
{r := inherited;
|
||
if r then return r;
|
||
t := now();
|
||
if(t-FMouseCurrentTime)<1/24/60/60/5 then return;
|
||
FMouseCurrentTime := t;
|
||
if(FMouseOnBkColor=rgb(255,255,255))or not(ifnumber(FMouseOnBkColor))then exit;
|
||
item := HitTestItem(e.xpos,e.ypos);
|
||
if not item then exit;
|
||
id := item[0];
|
||
if id >= 0 and id <> FMoueonItem then
|
||
begin
|
||
odid := FMoueonItem;
|
||
FMoueonItem := id;
|
||
if odid >= 0 and odid <> FSelected then
|
||
begin
|
||
InvalidateItem(odid);
|
||
end
|
||
if id <> FSelected then
|
||
begin
|
||
InvalidateItem(id);
|
||
end
|
||
end}
|
||
end
|
||
protected
|
||
function ClickedGridItem(o,e);override;
|
||
begin
|
||
{**
|
||
@explan(说明)点击时处理 %%
|
||
**}
|
||
id := e.iitem;
|
||
j := e.isubitem;
|
||
BJ := FColumnBool[j];
|
||
if BJ then
|
||
begin
|
||
if ifarray(BJ)and BJ[1]then
|
||
begin
|
||
it := o.GetItem(id);
|
||
if ifarray(it)then
|
||
begin
|
||
idx := mrows(it,1)[j];
|
||
if ifnumber(idx)or ifstring(idx)then
|
||
begin
|
||
tti := it[idx];
|
||
if tti=inf or tti=-inf then exit;
|
||
it[idx]:= not tti;
|
||
o.SetItem(id,it);
|
||
rec := o.GetSubItemRect(i,j);
|
||
o.InvalidateRect(rec,false);
|
||
return;
|
||
end
|
||
end
|
||
end
|
||
end
|
||
return SetSelected(id);
|
||
end
|
||
function RClickedGridItem(o,e);override;
|
||
begin
|
||
{**
|
||
@explan(说明)点击时处理 %%
|
||
**}
|
||
id := e.iitem;
|
||
return SetSelected(id);
|
||
end
|
||
public
|
||
function DoDrawItem(o,e);override; //
|
||
begin
|
||
{
|
||
@explan(说明) 绘制 %%
|
||
}
|
||
if not Visible then exit;
|
||
if FSelected=e.itemid then
|
||
begin
|
||
if ifnumber(SelBkColor)then e.canvas.brush.color := SelBkColor;
|
||
else e.canvas.brush.color := 0xffffff;//rgb(255,255,255);
|
||
end else
|
||
if FMoueonItem=e.itemid then
|
||
begin
|
||
if ifnumber(MouseOnBkColor)then e.canvas.brush.color := MouseOnBkColor;
|
||
else e.canvas.brush.color := 0xffffff;//rgb(255,255,255);
|
||
end else
|
||
begin
|
||
e.canvas.brush.color := 0xffffff;//rgb(255,255,255);
|
||
end
|
||
rec := e.rcitem;
|
||
rec[0]+= 1;
|
||
rec[1]+= 1;
|
||
rec[2]-= 1;
|
||
rec[3]-= 1;
|
||
e.canvas.fillrect(rec);
|
||
DoDrawSubItem(o,e);
|
||
end
|
||
function moveup();
|
||
begin
|
||
{**
|
||
@explan(说明) 选中项上移 %%
|
||
**}
|
||
sd := FSelected;
|
||
if sd>0 then
|
||
begin
|
||
FList.swap(sd,sd-1);
|
||
FSelected -= 1;
|
||
GridDrawItem(sd);
|
||
GridDrawItem(sd-1);
|
||
end
|
||
end
|
||
function movedown();
|
||
begin
|
||
{**
|
||
@explan(说明) 选中项下移 %%
|
||
**}
|
||
sd := FSelected;
|
||
if sd >= 0 and sd<FList.Count-1 then
|
||
begin
|
||
FList.swap(sd,sd+1);
|
||
FSelected += 1;
|
||
GridDrawItem(sd);
|
||
GridDrawItem(sd+1);
|
||
end
|
||
end
|
||
function deletebyid(id);
|
||
begin
|
||
{**
|
||
@explan(说明) 根据 序号删除项目 %%
|
||
**}
|
||
if not(id >= 0 and id<FList.Count)then exit;
|
||
SetSelected(id);
|
||
deleteselect();
|
||
end
|
||
function finditemid(v);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 根据类容查找序号 %%
|
||
@return(integer) 序号 ,没找到返回 -1
|
||
**}
|
||
r :=-1;
|
||
for i := 0 to FList.Count-1 do if v=FList[i]then return i;
|
||
return r;
|
||
end
|
||
function deletebyvalue(v);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 根据 值删除 %%
|
||
**}
|
||
deletebyid(FList.indexof(v));
|
||
end
|
||
function deleteselect();
|
||
begin
|
||
{**
|
||
@explan(说明) 删除选中项 %%
|
||
**}
|
||
sd := FSelected;
|
||
return DeleteItem(sd);
|
||
if sd >= 0 then
|
||
begin
|
||
FMoueonItem := nil;
|
||
FList.deli(sd);
|
||
ct := FList.Count-1;
|
||
if sd>ct then
|
||
begin
|
||
FPrevSelectedId := FSelected;
|
||
FSelected := ct;
|
||
CallSelChanged();
|
||
end
|
||
deleteitem(sd);
|
||
end
|
||
end
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
FMouseCurrentTime := 0;
|
||
FIntAlign := DT_RIGHT;
|
||
border := true;
|
||
FList := new TFpList();
|
||
SelBkColor := 0xface87;//0xffbf00;//0xB0E0E6; //rgb(200,200,0);
|
||
ItemHeight := 30;
|
||
//MouseOnBkColor := nil;// 0xface87;//0xF8F8FF; //rgb(0,200,200);
|
||
CreateMenu();
|
||
PopupMenu := FMenus;
|
||
FCanSelected := true;
|
||
FPrevSelectedId :=-1;
|
||
FColumnBool := array();
|
||
end
|
||
function CheckItem(v);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 检查项目 %%
|
||
**}
|
||
if iffuncptr(FOnCheckItem) then
|
||
begin
|
||
return call(FOnCheckItem,v);
|
||
end
|
||
return true;
|
||
end
|
||
function InsertItem(v,id);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 在序号id处面插入项目 %%
|
||
@param(v)() 待插入的项目 %%
|
||
@param(id)(integer) 插入位置 %%
|
||
**}
|
||
if CheckItem(v)then
|
||
begin
|
||
if id >= 0 and id <= FList.Count+1 then
|
||
begin
|
||
FList.insertafter(v,id-1);
|
||
ItemCount := FList.Count;
|
||
if FSelected >= 0 and(id-1)<FSelected then
|
||
begin
|
||
FSelected += 1;
|
||
end
|
||
end
|
||
end
|
||
end
|
||
function InsertItemAfter(v,id);virtual;
|
||
begin
|
||
{**
|
||
@ignore(忽略) %%
|
||
@explan(说明) 在序号id后面插入项目 %%
|
||
@param(v)() 待插入的项目 %%
|
||
@param(id)(integer) 插入位置 %%
|
||
**}
|
||
if CheckItem(v)then
|
||
begin
|
||
if id >= 0 and id <= FList.Count then
|
||
begin
|
||
FList.insertafter(v,id);
|
||
ItemCount := FList.Count;
|
||
if FSelected >= 0 and id<FSelected then
|
||
begin
|
||
FSelected += 1;
|
||
end
|
||
end
|
||
end
|
||
end
|
||
function AppendItem(v);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 追加项 %%
|
||
**}
|
||
if CheckItem(v)then
|
||
begin
|
||
FMoueonItem := nil;
|
||
FList.append(v);
|
||
ItemCount := FList.Count;
|
||
//inherited InsertItem(self.ItemCount);
|
||
end
|
||
end
|
||
function SetsubItem(idx,subid,v);
|
||
begin
|
||
{**
|
||
@explan(说明)设置子项 %%
|
||
@param(subid)(string|integer) 下标 %%
|
||
@param(v)(any) 值 %%
|
||
**}
|
||
it := GetItem(idx);
|
||
if not ifarray(it)then exit;
|
||
it[subid]:= v;
|
||
SetItem(idx,it);
|
||
end
|
||
function SetSubItemByIndex(idx,subidx,v);
|
||
begin
|
||
{**
|
||
@explan(说明)通过序号设置子项 %%
|
||
@param(subid)(integer) 下标 %%
|
||
@param(v)(any) 值 %%
|
||
**}
|
||
it := GetItem(idx);
|
||
if not ifarray(it)then exit;
|
||
vid := mrows(it,1)[subidx];
|
||
if ifnumber(vid)or ifstring(vid)then
|
||
begin
|
||
it[vid]:= v;
|
||
end
|
||
SetItem(idx,it);
|
||
end
|
||
function GetItem(idx);
|
||
begin
|
||
{**
|
||
@explan(说明) 获得项 %%
|
||
@param(idx)(integer) 序号 %%
|
||
@param(v)(any) 值%%
|
||
**}
|
||
idx := integer(idx);
|
||
if idx >= 0 and idx<FList.Count then
|
||
begin
|
||
return FList[idx];
|
||
end
|
||
end
|
||
function SetItem(idx,v);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 修改值 %%
|
||
@param(idx)(integer) 序号 %%
|
||
@param(v)(any) 任何数据 %%
|
||
**}
|
||
idx := integer(idx);
|
||
if idx >= 0 and idx<FList.Count then
|
||
begin
|
||
if CheckItem(V)then
|
||
begin
|
||
vi := FList[idx];
|
||
if vi <> v then
|
||
begin
|
||
FList.seti(idx,v);
|
||
if HandleAllocated()then
|
||
begin
|
||
rec := GetItemRect(idx);
|
||
InvalidateRect(rec,false);
|
||
end
|
||
end
|
||
end
|
||
end
|
||
end
|
||
function DeleteItem(i);override;
|
||
begin
|
||
sd := i;
|
||
if sd >= 0 and sd<FList.Count then
|
||
begin
|
||
FMoueonItem := nil;
|
||
FList.deli(sd);
|
||
dsf := sd=FSelected;
|
||
if sd <= FSelected then
|
||
begin
|
||
FSelected := FSelected-1;
|
||
if dsf >= 0 then FPrevSelectedId := dsf;
|
||
CallSelChanged();
|
||
end
|
||
inherited;
|
||
end
|
||
end
|
||
function AppendItems(arr);
|
||
begin
|
||
{**
|
||
@expaln(说明) 追加多个项目 %%
|
||
@param(arr)(array) 项数组 %%
|
||
**}
|
||
cv := array();
|
||
FMoueonItem := nil;
|
||
for i,v in arr do
|
||
begin
|
||
if CheckItem(v)then
|
||
begin
|
||
FList.append(v);
|
||
end
|
||
end
|
||
ItemCount := FList.Count;
|
||
end
|
||
function DoDrawSubItem(o,e);override;
|
||
begin
|
||
{**
|
||
@explan(说明) 绘制子项 %%
|
||
**}
|
||
inherited;
|
||
if e.skip then exit;
|
||
dc := e.canvas;
|
||
if not dc.Handle then exit;
|
||
i := e.itemid;
|
||
di := FList[i];
|
||
if not ifarray(di)then exit;
|
||
j := e.subitemid;
|
||
iddx := mrows(di,1)[j];
|
||
if ifnil(iddx)then exit;
|
||
dij := di[iddx];
|
||
src := e.subItemRect;
|
||
if FColumnBool[j]then
|
||
begin
|
||
//src[0] := src[2]-20-10;
|
||
//src[2]-=10;
|
||
src[1]+= 3;
|
||
src[3]-= 3;
|
||
v := List[i];
|
||
if ifarray(v)then
|
||
begin
|
||
if dij=-inf then dij := false;
|
||
else if dij=inf then dij := true;
|
||
rrx := integer(src[0]-10+(src[2]-src[0])/2);
|
||
rry := integer(src[1]-10+(src[3]-src[1])/2);
|
||
dc.Draw("framecontrol",array((rrx,rry),(rrx+18,rry+18)),DFC_BUTTON,dij?DFCS_CHECKED:DFCS_BUTTONCHECK);
|
||
//_wapi.DrawFrameControl(dc.Handle,src,DFC_BUTTON,dij?DFCS_CHECKED:DFCS_BUTTONCHECK);
|
||
end
|
||
end else
|
||
begin
|
||
if ifstring(dij)and dij then
|
||
begin
|
||
dc.font := font;
|
||
dc.DrawText(dij,src,DT_VCENTER .| DT_LEFT .| DT_SINGLELINE .| DT_NOPREFIX);
|
||
end else
|
||
if ifnumber(dij)then
|
||
begin
|
||
dc.font := font;
|
||
dc.DrawText(tostn(dij),src,DT_VCENTER .| FIntAlign .| DT_SINGLELINE .| DT_NOPREFIX);
|
||
end
|
||
end
|
||
end
|
||
function SetSelectedByValue(v);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 通过值确定选中项
|
||
**}
|
||
if ifnil(v)then UnSelected();
|
||
for i := 0 to List.Count-1 do
|
||
begin
|
||
if v=List[i]then
|
||
begin
|
||
SelectedId := i;
|
||
end
|
||
end
|
||
end
|
||
function ColumnAsBool(n,f,ce);
|
||
begin
|
||
{**
|
||
@expaln(说明) 设置某列为bool %%
|
||
@param(n)(integer) 列号 %%
|
||
@param(f)(bool) 取消或者设置,默认为true %%
|
||
@param(ce)(bool) 是否可以编辑 %%
|
||
**}
|
||
if not(n >= 0)then exit;
|
||
//if not ifarray(FColumnBool) then FColumnBool := array();
|
||
nv := ifnil(f)?:(f?true:false);
|
||
ov := FColumnBool[n];
|
||
ov := ov?true:false;
|
||
if ov <> nv then
|
||
begin
|
||
FColumnBool[n]:= array(nv,ce);
|
||
if HandleAllocated()and n<ColumnCount then
|
||
begin
|
||
InValidateRect(nil,true);
|
||
end
|
||
end
|
||
end
|
||
function Recycling();override;
|
||
begin
|
||
SelectedChanged := nil;
|
||
OnCheckItem := nil;
|
||
FMenus := nil;
|
||
DeleteAllItems();
|
||
inherited;
|
||
end
|
||
function UnSelected();
|
||
begin
|
||
{**
|
||
@explan(说明) 取消选择 %%
|
||
**}
|
||
if FSelected >= 0 then
|
||
begin
|
||
sd := FSelected;
|
||
FPrevSelectedId := sd;
|
||
Fselected :=-1;
|
||
GridDrawItem(sd);
|
||
//calldatafunction(SelectedChanged,self(true));
|
||
end
|
||
end
|
||
published
|
||
property SelectedChanged read FSelectedChanged write FSelectedChanged;
|
||
property OnSelChanged:eventhandler read FSelectedChanged write FSelectedChanged;
|
||
property List read FList;
|
||
property CanSelected read FCanSelected write SetCanSelected;
|
||
property SelectedId:integer read Fselected write SetSelected;
|
||
property PrevSelectedId read FPrevSelectedId;
|
||
property SelectedValue read GetSelected;
|
||
property SelBkColor:color read FSelBkColor write FSelBkColor;
|
||
property MouseOnBkColor:color read FMouseOnBkColor write FMouseOnBkColor;
|
||
property ListValues read GetListValues;
|
||
property OnCheckItem:eventhandler read FOnCheckItem write FOnCheckItem;
|
||
property NumberAlign read FIntAlign write SetIntAlign;
|
||
{**
|
||
@param(SelectedId)(integer) 当前选中的序号,<0表示没有选中项 %%
|
||
@param(PrevSelectedId)(integer) 选择切换前面的选中id %%
|
||
@param(onselchanged)(function[tlistview]) 选中改变回调 %%
|
||
@param(SelectedValue)(any) 选中项的值 %%
|
||
@param(SelBkColor)(integer) 颜色rgb值 %%
|
||
@param(MouseOnBkColor)(integer) 颜色rgb值 %%
|
||
@param(ListValues)(array) 数据 %%
|
||
@param(OnCheckItem)(function[any]:bool) 添加数据时的检测的回调 %%
|
||
**}
|
||
end
|
||
|
||
|
||
|
||
//其他控件
|
||
type tprogressbar = class(tcustomprogressbar)
|
||
{**
|
||
@explan(说明) 进度栏
|
||
进度栏是显示任务进行完成度的控件。进度栏的上下限是进度条位置可移动的
|
||
范围，可以通过range属性获取、修改，其默认值是array(0,100)。进度条的位置可以通过
|
||
position属性获取、修改。进度栏的步增量是其每次调用increaseByStep函数进度条
|
||
位置移动的量，可以通过step属性获取、修改，其默认值是10.
|
||
进度条默认是分段离散的，可通过修改smooth成员设置其为平滑连续的。默认是
|
||
水平从左到右移动，可通过修改vertical成员来设置其为垂直从底部到顶部移动。
|
||
**}
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type tmonthcalendar = class(TCustomControl)
|
||
{**
|
||
@explan(说明)月历控件
|
||
该控件的函数可能的返回值：
|
||
array等期望的数据/1：成功。
|
||
-1：一般是函数参数格式不正确。
|
||
nil：该项属性在控件种类正确、窗口未创建、无默认值的情况下未设置过或被重置过。
|
||
0：失败，可能的原因：
|
||
1.参数格式正确但不适用于控件的当前状态，如对多选月历设置当前选择项时项数超过其最大多选项数限制。
|
||
2.控件类型错误，如对单选月历调用设置其最大多选项数限制的函数。
|
||
3.要求控件创建后才可调用的函数在控件创建之前被调用。
|
||
4.未知错误。
|
||
**}
|
||
function create(aowner);
|
||
begin
|
||
inherited;
|
||
//TodayButton := false;
|
||
end
|
||
function AfterConstruction();override;
|
||
begin
|
||
inherited;
|
||
width := 213;
|
||
height := 175;
|
||
FCalender := new tVirtualCalender();
|
||
FCalender.ExecuteCommand("memymd",date());
|
||
FCalender.Left := 1;
|
||
FCalender.top := 1;
|
||
FCalender.host := self(true);
|
||
end
|
||
function paint();override;
|
||
begin
|
||
if FCalender then FCalender.paint();
|
||
end
|
||
function MouseUp(o,e);override;
|
||
begin
|
||
inherited;
|
||
if e.skip then return ;
|
||
if not FCalender then return ;
|
||
if e.button()= mbLeft then
|
||
begin
|
||
r := FCalender.ExecuteCommand("mestatebypos",e.pos);
|
||
if r then return ;
|
||
r := FCalender.ExecuteCommand("megetincpos",e.pos);
|
||
if r then return FCalender.ExecuteCommand("meminc",r);
|
||
std := FCalender.ExecuteCommand("mestate");
|
||
r := FCalender.ExecuteCommand("meselbypos",e.pos);
|
||
if std=3 or r="today" then
|
||
begin
|
||
if FonSelect then
|
||
CallMessgeFunction(FonSelect,self(true),new tuieventbase(0,0,0,0));
|
||
end
|
||
end
|
||
end
|
||
function getCurrentSelection();begin
|
||
{**
|
||
@explan(说明)获取当前选择的日期，该函数仅能用于单选的月历控件%%
|
||
@return(array/integer/nil)array:成功;0:失败;nil:未设置过此项。
|
||
array(2019,2,1)
|
||
**}
|
||
if FCalender then
|
||
begin
|
||
r := FCalender.ExecuteCommand("meymd");
|
||
decodedate(r,y,m,d);
|
||
return array(y,m,d);
|
||
end
|
||
return 0;
|
||
end
|
||
function setCurrentSelection(y,m,d);
|
||
begin
|
||
{**
|
||
@explan(说明)设置当前选择日期，该函数仅能用于单选的月历控件%%
|
||
@param(y)(integer)年%%
|
||
@param(m)(integer)月%%
|
||
@param(d)(integer)日%%
|
||
@return(integer)1:成功;0:失败;-1:出错%%
|
||
**}
|
||
if ifnumber(y) and ifnumber(m) or ifnumber(d) then
|
||
begin
|
||
dt := encodedate(y,m,d);
|
||
if FCalender then
|
||
begin
|
||
FCalender.ExecuteCommand("meymd",dt);
|
||
return 1;
|
||
end
|
||
end
|
||
end
|
||
function DoDatechanged();
|
||
begin
|
||
if FonSelectChange then
|
||
CallMessgeFunction(FonSelectChange,self(true),new tuieventbase(0,0,0,0));
|
||
end
|
||
function recycling();override;
|
||
begin
|
||
FCalender.recycling();
|
||
inherited;
|
||
FCalender := nil;
|
||
FonSelect := nil;
|
||
FonSelectChange := nil;
|
||
end
|
||
published
|
||
property onSelectChange read FonSelectChange write FonSelectChange;
|
||
property TodayButton:bool read getnoTodayButton write setNoTodayButton;
|
||
property onSelect:eventhandler read FonSelect write FonSelect;
|
||
property onSelChanged:eventhandler read FonSelectChange write FonSelectChange;
|
||
{**
|
||
@param(todayButton)(bool)月历显示“今日”按钮（默认开启）%%
|
||
@param(onselchanged)(function[tmonthcalendar,tuieventbase])选择日期改变%%
|
||
**}
|
||
|
||
private
|
||
function setNoTodayButton(v);
|
||
begin
|
||
if FCalender then return FCalender.ExecuteCommand("metodaybutton",v);
|
||
end
|
||
function getnoTodayButton();
|
||
begin
|
||
if FCalender then return FCalender.ExecuteCommand("metodaybutton");
|
||
end
|
||
private
|
||
FCalender;
|
||
FMousedownState;
|
||
[weakref]FonSelect;
|
||
[weakref]FonSelectChange;
|
||
end
|
||
|
||
type tdatetimepicker = class(tthreeEntry)
|
||
{**
|
||
@explan(说明) 日期选择控件 %%
|
||
**}
|
||
function create(aowner);
|
||
begin
|
||
inherited;
|
||
caption:="Date/TimePicker";
|
||
FCalender := new tmonthcalendar(self);
|
||
FCalender.border := true;
|
||
FCalender.WsPopUp := true;
|
||
FCalender.parent := self;
|
||
FCalender.Visible := false;
|
||
//FScreenRect := _wapi.GetScreenRect();
|
||
decodedate(date(),y,m,d);
|
||
setDate(y,m,d);
|
||
FCalender.onSelect := function(o,e)begin
|
||
FCalender.Visible := false;
|
||
d := FCalender.getCurrentSelection();
|
||
setDate(d[0],d[1],d[2]);
|
||
end
|
||
FCalender.OnActivate := function(o,e)begin
|
||
if e.wparam=0 then
|
||
begin
|
||
FCalender.Visible := false;
|
||
end
|
||
end
|
||
end
|
||
function btnclicked(p);override;
|
||
begin
|
||
rec := BtnRect;
|
||
if pointinrect(p,rec) then
|
||
begin
|
||
ShowDropDown(true);
|
||
return true;
|
||
end
|
||
end
|
||
|
||
function ExecuteCommand(cmd,p);override;
|
||
begin
|
||
case cmd of
|
||
"dtchanged":
|
||
begin
|
||
es := entrys;
|
||
if p = es[2] then //日
|
||
begin
|
||
pn := getenumber(p);
|
||
y := getenumber(es[0]);
|
||
m := getenumber(es[1]);
|
||
if pn<1 then p.text := inttostr(getmonthdates(y,m));
|
||
else
|
||
if pn>28 and pn>getmonthdates(y,m) then
|
||
begin
|
||
p.text := "1";
|
||
end
|
||
end else
|
||
if p = es[1] then //月
|
||
begin
|
||
y := getenumber(es[0]);
|
||
m := getenumber(es[1]);
|
||
bm := m;
|
||
if m>12 then
|
||
begin
|
||
m := 1;
|
||
end else
|
||
if m<1 then m := 12;
|
||
if bm<>m then
|
||
begin
|
||
p.text := inttostr(m);
|
||
end
|
||
d := getenumber(es[2]);
|
||
if d<1 then es[2].text := "1";
|
||
else
|
||
if d>28 then
|
||
begin
|
||
ct := getmonthdates(y,m);
|
||
if d>ct then es[2].text := inttostr(ct);
|
||
end
|
||
end else
|
||
if p = es[0] then //年
|
||
begin
|
||
y := getenumber(p);
|
||
m := getenumber(es[1]);
|
||
d := getenumber(es[2]);
|
||
if dt>28 then
|
||
begin
|
||
ct := getmonthdates(y,m);
|
||
if d>ct then es[2].text := inttostr(ct);
|
||
end
|
||
end
|
||
if Fonselectchange then
|
||
calldatafunction(Fonselectchange,self(true),new tuieventbase(0,0,0,0));
|
||
end
|
||
"dtadate":
|
||
begin
|
||
es := entrys;
|
||
if ifarray(p) and ifnumber(p[0]) and ifnumber(p[1]) and ifnumber(p[2]) then
|
||
begin
|
||
dt := encodedate(p[0],p[1],p[2]);
|
||
decodedate(dt,y,m,d);
|
||
es[0].text := inttostr(y);
|
||
es[1].text := inttostr(m);
|
||
es[2].text := inttostr(d);
|
||
if Fonselectchange then
|
||
calldatafunction(Fonselectchange,self(true),new tuieventbase(0,0,0,0));
|
||
end else
|
||
begin
|
||
y := strtointdef(es[0].text,2021);
|
||
m := strtointdef(es[1].text,1);
|
||
d := strtointdef(es[2].text,1);
|
||
return array(y,m,d);
|
||
end
|
||
|
||
end
|
||
|
||
end
|
||
end
|
||
function ShowDropDown(f);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 设置弹出框的显示区域 %%
|
||
**}
|
||
if not(FCalender ) then return ;
|
||
nv := ifnil(f)?true:(f?true:false);
|
||
if FCalender.Visible = nv then return FCalender.show(0);
|
||
rc := ClientRect;
|
||
nrc := ClientToScreen(rc[0],rc[3]);
|
||
p2 := clienttoscreen(rc[0],rc[1]+FCalender.height);
|
||
src := _wapi.GetScreenRect(nrc);
|
||
if (src[3]<p2[1]) then //由于缩放问题暂时屏蔽
|
||
begin
|
||
nrc := ClientToScreen(rc[0],rc[1]-FCalender.height);
|
||
end
|
||
FCalender.Left := nrc[0];
|
||
FCalender.top := nrc[1];
|
||
dt := getDate();
|
||
FCalender.setCurrentSelection(dt[0],dt[1],dt[2]);
|
||
FCalender.show();
|
||
end
|
||
function getDate();
|
||
begin
|
||
{**
|
||
@explan(说明) 获得日期 %%
|
||
@return(array) array(y,m,d) %%
|
||
**}
|
||
return ExecuteCommand("dtadate");
|
||
end
|
||
function setDate(y,m,d);
|
||
begin
|
||
{**
|
||
@explan(说明) 获得日期 %%
|
||
@param(y)(integer) 年 %%
|
||
@param(m)(integer) 月 %%
|
||
@param(d)(integer) 日 %%
|
||
**}
|
||
return ExecuteCommand("dtadate",array(y,m,d));
|
||
end
|
||
function recycling();override;
|
||
begin
|
||
inherited;
|
||
FCalender := nil;
|
||
Fonselectchange := nil;
|
||
end
|
||
published
|
||
property onselectchange:eventhandler read Fonselectchange write Fonselectchange;
|
||
property onselchanged:eventhandler read Fonselectchange write Fonselectchange;
|
||
{
|
||
@param(onselchanged)(function[tdatetimepicker,tuieventbase])选择日期改变%%
|
||
}
|
||
private
|
||
function getenumber(e);
|
||
begin
|
||
t := e.text;
|
||
ti := strtointdef(t,1);
|
||
return ti;
|
||
end
|
||
//FScreenRect;
|
||
FCalender;
|
||
[weakref]Fonselectchange;
|
||
end
|
||
type ttimepicker = class(tthreeEntry)
|
||
function create(aowner);
|
||
begin
|
||
inherited;
|
||
caption := "timepicker";
|
||
width := 120;
|
||
ExecuteCommand("dttime",now());
|
||
end
|
||
function ExecuteCommand(cmd,p);override;
|
||
begin
|
||
case cmd of
|
||
"dttime":
|
||
begin
|
||
if ifnumber(p) then
|
||
begin
|
||
decodedatetime(p,y,mt,d,h,m,s,ms);
|
||
ExecuteCommand("dtatime",array(h,m,s));
|
||
|
||
end else
|
||
begin
|
||
r := ExecuteCommand("dtatime");
|
||
r2 := encodedatetime(2021,1,1,r[0],r[1],r[2],0);
|
||
if ifarray(r) then
|
||
begin
|
||
return frac(r2);
|
||
end
|
||
end
|
||
end
|
||
"dtatime":
|
||
begin
|
||
es := entrys;
|
||
if ifarray(p) and ifnumber(p[0]) and ifnumber(p[1]) and ifnumber(p[1]) then
|
||
begin
|
||
es[0].text := inttostr(p[0]);
|
||
es[1].text := inttostr(p[1]);
|
||
es[2].text := inttostr(p[2]);
|
||
ExecuteCommand("dtchanged",es[2]);
|
||
end else
|
||
begin
|
||
r := array();
|
||
for i,v in es do r[i] := strtointdef(v.text,0);
|
||
return r;
|
||
end
|
||
end
|
||
"dtchanged":
|
||
begin
|
||
es := entrys;
|
||
if es[2]=p then
|
||
begin
|
||
t := p.text;
|
||
ti := strtointdef(t,0);
|
||
if ti<0 then
|
||
begin
|
||
p.text := "59";
|
||
es[1].dec();
|
||
end else
|
||
if ti>59 then
|
||
begin
|
||
p.text := "0";
|
||
es[1].inc();
|
||
end
|
||
end else
|
||
if es[1] = p then
|
||
begin
|
||
t := p.text;
|
||
ti := strtointdef(t,0);
|
||
if ti<0 then
|
||
begin
|
||
p.text := "59";
|
||
es[0].dec();
|
||
end else
|
||
if ti>59 then
|
||
begin
|
||
p.text := "0";
|
||
es[0].inc();
|
||
end
|
||
end else
|
||
if es[0] = p then
|
||
begin
|
||
t := p.text;
|
||
ti := strtointdef(t,0);
|
||
if ti<0 then p.text := "24";
|
||
else if ti>24 then p.text := "0";
|
||
end
|
||
if Fonselectchange then
|
||
calldatafunction(Fonselectchange,self(true),new tuieventbase(0,0,0,0));
|
||
end
|
||
end
|
||
end
|
||
function PaintBtn();override;
|
||
begin
|
||
if FRectUp then
|
||
begin
|
||
dc := Canvas;
|
||
dc.Draw("framecontrol",array(FRectUp[0:1],FRectUp[2:3]),DFC_SCROLL,DFCS_SCROLLUP);
|
||
dc.Draw("framecontrol",array(FRectDown[0:1],FRectDown[2:3]),DFC_SCROLL,DFCS_SCROLLDOWN);
|
||
end
|
||
end
|
||
function btnClicked(p);virtual;
|
||
begin
|
||
if pointinrect(p,FRectUp) then
|
||
begin
|
||
for i,v in entrys do
|
||
begin
|
||
if v.HasFocus then
|
||
begin
|
||
v.inc();
|
||
return 1;
|
||
end
|
||
end
|
||
|
||
end else
|
||
if pointinrect(p,FRectDown) then
|
||
begin
|
||
for i,v in entrys do
|
||
begin
|
||
if v.HasFocus then
|
||
begin
|
||
v.dec();
|
||
return 1;
|
||
end
|
||
end
|
||
|
||
end
|
||
end
|
||
function getTime();override;begin
|
||
{**
|
||
@explan(说明)获取控件当前选择的时间%%
|
||
@return(array)%%
|
||
**}
|
||
return ExecuteCommand("dtatime");
|
||
end
|
||
function setTime(h,m,s);override;begin
|
||
{**
|
||
@explan(说明)设置控件当前选择的时间%%
|
||
@param(h)(integer)时，24小时制%%
|
||
@param(m)(integer)分%%
|
||
@param(s)(integer)秒%%
|
||
**}
|
||
return ExecuteCommand("dtatime",array(h,m,s));
|
||
end
|
||
function recycling();override;
|
||
begin
|
||
inherited;
|
||
end
|
||
published
|
||
property onselectchange read Fonselectchange write Fonselectchange;
|
||
property onselchanged:eventhandler read Fonselectchange write Fonselectchange;
|
||
{
|
||
@param(onselchanged)(function[ttimepicker,tuieventbase])选择日期改变%%
|
||
}
|
||
protected
|
||
function calcCtls();override;
|
||
begin
|
||
inherited;
|
||
rec := BtnRect;
|
||
FRectUp := array(rec[0],rec[1],rec[2],integer(rec[1]+rec[3]/2));
|
||
FRectDown := array(rec[0],integer(rec[1]+rec[3]/2),rec[2],rec[3]);
|
||
end
|
||
private
|
||
function getEntryWidth(i);virtual;
|
||
begin
|
||
return 2;
|
||
end
|
||
function getSym(i);virtual;
|
||
begin
|
||
return ":";
|
||
end
|
||
FRectUp;
|
||
FRectDown;
|
||
[weakref]Fonselectchange;
|
||
end
|
||
type tipaddr = class(tcustomipaddr)
|
||
{**
|
||
@explan(说明) ip控件 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
type TSpinEdit=class(TCustomSpinEdit)
|
||
{**
|
||
@explan(说明)spinedit控件
|
||
**}
|
||
function Create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
//border := true;
|
||
end
|
||
end
|
||
|
||
type tapplicationwindow=class(TWinControl)
|
||
{**
|
||
@explan(说明) application窗口类 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
//class(TWinControl).create(AOwner);
|
||
inherited;
|
||
caption := "applicationwindow";
|
||
FLeft := 0;
|
||
FTop := 0;
|
||
FHeight := 0;
|
||
Fwidth := 0;
|
||
Visible := true;
|
||
WsPopUp := true;
|
||
WsCaption := true;
|
||
end
|
||
function createparams(p);override;
|
||
begin
|
||
inherited;
|
||
p.WinClassName := "tsui_application";
|
||
//p.style := p.style .& (.! (WS_GROUP .| WS_TABSTOP .| WS_CHILD));
|
||
//p.exstyle := WS_EX_TOOLWINDOW;
|
||
//p.style := WS_VISIBLE .| WS_POPUP .| WS_CAPTION ;//.| WS_CLIPSIBLINGS .| WS_SYSMENU;
|
||
end
|
||
function InitializeWnd();override;
|
||
begin
|
||
global g_applicaton_wnd_handle;
|
||
inherited;
|
||
g_applicaton_wnd_handle := handle;;
|
||
{echo self.Handle;
|
||
SysMeu := _wapi.GetSystemMenu(self.Handle,False);
|
||
echo "\r\nsysmenu",sysmenu;
|
||
echo "\r\ndelete:",_wapi.DeleteMenu(SysMeu,SC_MAXIMIZE,MF_BYCOMMAND);
|
||
echo "\r\ndelete:",_wapi.DeleteMenu(SysMeu,SC_SIZE,MF_BYCOMMAND);
|
||
echo "\r\ndelete:",_wapi.DeleteMenu(SysMeu,SC_MOVE,MF_BYCOMMAND);
|
||
echo "\r\nsysmenu",sysmenu;}
|
||
end
|
||
Function DoWMCLOSE(o,e);override;
|
||
begin
|
||
Recycling();
|
||
_wapi.PostQuitMessage(0);
|
||
end
|
||
function DoCnNotify(o,e);override;
|
||
begin
|
||
end
|
||
private
|
||
function setactivecontrol(ctl);virtual;
|
||
begin
|
||
|
||
end
|
||
end
|
||
|
||
type TImageListDrawStyle = class()
|
||
{**
|
||
@explan(说明) imagelist 绘制的样式选择 %%
|
||
**}
|
||
static ILD_NORMAL;static ILD_TRANSPARENT;
|
||
static ILD_MASK;static ILD_IMAGE;static ILD_ROP;
|
||
static ILD_BLEND25;static ILD_BLEND50;static ILD_OVERLAYMASK;
|
||
static ILD_PRESERVEALPHA;static ILD_SCALE;static ILD_DPISCALE;
|
||
static ILD_ASYNC;static ILD_SELECTED;static ILD_FOCUS;
|
||
static ILD_BLEND;
|
||
end
|
||
type TImageListCreateflags = class()
|
||
{**
|
||
@explan(说明) imagelist 构造的参数 %%;
|
||
**}
|
||
static ILC_MASK;static ILC_COLOR;static ILC_COLORDDB;
|
||
static ILC_COLOR4;static ILC_COLOR8;static ILC_COLOR16;
|
||
static ILC_COLOR24;static ILC_COLOR32;static ILC_PALETTE;
|
||
static ILC_MIRROR;static ILC_PERITEMMIRROR;static ILC_ORIGINALSIZE;
|
||
static ILC_HIGHQUALITYSCALE;
|
||
|
||
end
|
||
|
||
type tcontrolimagelist=class(tcustomcontrolimagelist)
|
||
{**
|
||
@explan(说明) 控件imagleit %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
|
||
type TDragImageList=class(TCustomImageList)
|
||
{**
|
||
@ignore(忽略) %%
|
||
**}
|
||
private
|
||
FDragCursor:TCursor;
|
||
FDragging:Boolean;
|
||
FDragHotspot:TPoint;
|
||
FOldCursor:TCursor;
|
||
FImageIndex:Integer;
|
||
FLastDragPos:TPoint;
|
||
FLockedWindow:HWND; // window where drag started and locked via DragLock, invalid=NoLockedWindow=High(PtrInt)
|
||
procedure SetDragCursor(AValue);
|
||
begin
|
||
if ifnumber(AValue)and FDragCursor.id <> AValue then
|
||
begin
|
||
FDragCursor.id := AValue;
|
||
end
|
||
end
|
||
protected
|
||
procedure Initialize;override;
|
||
public
|
||
function create(Owner);override;
|
||
begin
|
||
inherited;
|
||
FDragCursor := new TCursor();
|
||
end
|
||
function BeginDrag(Window:HWND;X,Y:Integer):Boolean;
|
||
begin
|
||
if not HandleAllocated()then exit;
|
||
if not FDragging then
|
||
begin
|
||
FDragCursor.show();
|
||
FDragging := true;
|
||
DragLock(Window,x,y);
|
||
FDragHotspot := array(x,y);
|
||
px := integer(Width/2);
|
||
py := integer(Height/2);
|
||
_wapi.ImageList_BeginDrag(self.Handle,FImageIndex>0?FImageIndex:0,px,py);
|
||
_wapi.ImageList_DragEnter(Window,x,y);
|
||
end else
|
||
DragMove(x,y);
|
||
end
|
||
function DragLock(Window:HWND;XPos,YPos:Integer):Boolean;
|
||
begin
|
||
FLockedWindow := HWND;
|
||
end
|
||
function DragMove(X,Y:Integer):Boolean;
|
||
begin
|
||
if FDragging then
|
||
begin
|
||
_wapi.ImageList_DragMove(x,y);
|
||
end
|
||
end
|
||
procedure DragUnlock;
|
||
function EndDrag:
|
||
Boolean;
|
||
begin
|
||
if FDragging then
|
||
begin
|
||
_wapi.ImageList_DragLeave(FLockedWindow);
|
||
_wapi.ImageList_EndDrag();
|
||
FDragging := false;
|
||
end
|
||
end
|
||
function GetHotSpot:
|
||
TPoint;
|
||
override;
|
||
begin
|
||
return FDragHotspot;
|
||
end
|
||
procedure HideDragImage;
|
||
function SetDragImage(Index,HotSpotX,HotSpotY:Integer):Boolean;
|
||
//procedure ShowDragImage;
|
||
published
|
||
property DragCursor:TCursor read FDragCursor write SetDragCursor;
|
||
property DragHotspot:TPoint read FDragHotspot write FDragHotspot;
|
||
property Dragging:Boolean read FDragging;
|
||
property ImageIndex read FImageIndex write FImageIndex;
|
||
end
|
||
type TImage = class(tcustomimage)
|
||
function create();
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TBitmap = class(tcustombitmap)
|
||
|
||
function create();override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TIcon = class(tcustomicon)
|
||
function create();override;
|
||
begin
|
||
inherited;
|
||
end
|
||
|
||
end
|
||
type tcursor = class(tcustomcursor)
|
||
function create();override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
type TFont = class(tcustomfont)
|
||
function create();override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
type tpen = class(tcustompen)
|
||
function create();override;
|
||
begin
|
||
inherited;
|
||
end
|
||
|
||
end
|
||
|
||
type TBrush = class(tcustombrush)
|
||
function create();override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TCanvas = class(TCustomcanvas)
|
||
function create();override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TTimer = class(TCustomTimer)
|
||
{**
|
||
@explan(说明)定时器类,间隔是以毫秒为最小单位 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
//******action 相关*****************************************
|
||
|
||
|
||
type TAction=class(TCustomAction)
|
||
{**
|
||
@explan(说明) action / command 类 对外接口,参考 TCustomAction 类 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type tactionlist =class(TCustomactionlist)
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
|
||
//*****************************
|
||
type TMessageboxADlg = class(TcustommsgADlg)
|
||
{**
|
||
@explan(说明) 消息提示框 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TColorChooseADlg = class(tcustomcolordlg)
|
||
{**
|
||
@explan(说明)颜色选择器 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TFontChooseADlg = class(tcustomfontdlg)
|
||
{**
|
||
@explan(说明) 字体选择对话框 %%
|
||
**}
|
||
function Create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TSavefileADlg = class(tcustomfsdlg)
|
||
{**
|
||
@explan(说明) 保存文件,获得文件名 %%
|
||
@param(FFileTag)(TtagOFNA)openfile 对象 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
|
||
end
|
||
type TOpenFileADlg=class(tcustomfsdlg)
|
||
{**
|
||
@explan(说明) 打开文件对话框类 %%
|
||
**}
|
||
private
|
||
function OpenFileDlg();virtual;
|
||
begin
|
||
r := _wapi.GetOpenFileNameA(FFileTag._getptr_);
|
||
return r;
|
||
end
|
||
protected
|
||
function dlgType();virtual;
|
||
begin
|
||
return 2;
|
||
end
|
||
public
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TFolderChooseADlg = class(tcustomfolderdlg)
|
||
{**
|
||
@explan(说明) 文件夹路径选择对话框 %%
|
||
**}
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
//菜单
|
||
type TMenu = class(TcustomMenu)
|
||
{**
|
||
@explan(说明) 菜单 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TPopupmenu=class(TcustomPopupmenu)
|
||
{**
|
||
@explan(说明) 弹出菜单 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TMainmenu = class(TcustomMainmenu)
|
||
{**
|
||
@explan(说明) 主窗口菜单 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
type TApplicationProperties=class(TComponent)
|
||
{**
|
||
|
||
@ignore(忽略) %%
|
||
@explan(说明)应用属性设置 %%
|
||
**}
|
||
private
|
||
FApplication;
|
||
FTrayData;
|
||
function SetShowTray();
|
||
begin
|
||
end
|
||
function SetPopupMenu();
|
||
begin
|
||
end
|
||
public
|
||
function Create(AOwner);
|
||
begin
|
||
inherited;
|
||
FApplication := getapplication();
|
||
FTrayData := new TNOTIFYICONDATAA();
|
||
end
|
||
published
|
||
//屏蔽避免错误
|
||
//property TrayMenu:tpopupmenu read FPopupMenu write SetPopupMenu;
|
||
//property TrayIcon:icondata read FTrayIcon write FTrayIcon;
|
||
//property ShowTray:bool read FShowTray write SetShowTray;
|
||
end
|
||
|
||
type TClipBoard = class(TcustomClipBoard)
|
||
{**
|
||
@explan(说明) 剪切板类 %%
|
||
**}
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
//线程
|
||
type TThreadWorker =class(TCustomThreadworker)
|
||
{**
|
||
@explan(说明) 工作线程 %%
|
||
**}
|
||
uses uvclthreadworker;
|
||
function create(s);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type tworkerctl =class(tcomponent) //工作线程封装
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
function terminate();
|
||
begin
|
||
if fworker then fworker.terminate();
|
||
fworker := nil;
|
||
end
|
||
function start();
|
||
begin
|
||
if csDesigning in ComponentState then return 0;
|
||
if fworker then return true;
|
||
if ifstring(FScript) and FScript then
|
||
begin
|
||
fworker := new TThreadWorker(FScript);
|
||
fworker.componet := self(true);
|
||
fworker.OnMessage := FOnMessage;
|
||
fworker.onerror := FOnError;
|
||
end
|
||
end
|
||
function PostMessage(d);
|
||
begin
|
||
if fworker then return fworker.PostMessage(d);
|
||
end
|
||
function isstarted();
|
||
begin
|
||
return fworker?true:false;
|
||
end
|
||
published
|
||
property script:text read FScript write Setscript;
|
||
property OnMessage:eventhandler read fOnMessage write setOnMessage;
|
||
property onerror:eventhandler read FOnError write setOnError;
|
||
private
|
||
fworker;
|
||
FScript;
|
||
[weakref]FOnError;
|
||
[weakref]FOnMessage;
|
||
function setOnMessage(f);
|
||
begin
|
||
fOnMessage := f;
|
||
if fworker then fworker.OnMessage := f;
|
||
end
|
||
function setOnError(f);
|
||
begin
|
||
FOnError := f;
|
||
if fworker then fworker.OnError := f;
|
||
end
|
||
function Setscript(s);
|
||
begin
|
||
if s <> FScript and ifstring(s) and s then
|
||
begin
|
||
FScript := s;
|
||
end
|
||
end
|
||
end
|
||
//注册表操作类
|
||
type TRegKey = class
|
||
{**
|
||
@explan(说明) windows注册表操作类 %%
|
||
**}
|
||
static const HKEY_CLASSES_ROOT = 0x80000000;
|
||
static const HKEY_CURRENT_USER = 0x80000001;
|
||
static const HKEY_LOCAL_MACHINE = 0x80000002;
|
||
static const HKEY_USERS = 0x80000003;
|
||
static const HKEY_PERFORMANCE_DATA = 0x80000004;
|
||
static const HKEY_PERFORMANCE_TEXT = 0x80000050;
|
||
static const HKEY_PERFORMANCE_NLSTEXT = 0x80000060;
|
||
static const KEY_WOW64_32KEY = 0x0200;
|
||
static const KEY_WOW64_64KEY = 0x0100;
|
||
static const REG_NONE = 0;// No value type
|
||
static const REG_SZ = 1;// Unicode nul terminated string
|
||
static const REG_EXPAND_SZ = 2;// Unicode nul terminated string(with environment variable references)
|
||
static const REG_BINARY = 3;// Free form binary
|
||
static const REG_DWORD = 4;// 32-bit number
|
||
static const REG_DWORD_LITTLE_ENDIAN = 4;// 32-bit number (same as REG_DWORD)
|
||
static const REG_DWORD_BIG_ENDIAN = 5;// 32-bit number
|
||
static const REG_LINK = 6;// Symbolic Link (unicode)
|
||
static const REG_MULTI_SZ = 7;// Multiple Unicode strings
|
||
static const REG_RESOURCE_LIST = 8;// Resource list in the resource map
|
||
static const REG_FULL_RESOURCE_DESCRIPTOR = 9;// Resource list in the hardware description
|
||
static const REG_RESOURCE_REQUIREMENTS_LIST = 10;// Multiple Unicode strings
|
||
static const REG_QWORD = 11;// 64-bit number
|
||
static const REG_QWORD_LITTLE_ENDIAN = 11;// 64-bit number (same as REG_QWORD)
|
||
|
||
static const KEY_ALL_ACCESS = 0xF003F;
|
||
static const KEY_CREATE_LINK = 0x0020;
|
||
static const KEY_CREATE_SUB_KEY = 0x0004;
|
||
static const KEY_ENUMERATE_SUB_KEYS =0x0008;
|
||
static const KEY_EXECUTE = 0x20019;
|
||
static const KEY_NOTIFY = 0x0010;
|
||
static const KEY_QUERY_VALUE = 0x0001;
|
||
static const KEY_READ = 0x20019;
|
||
static const KEY_SET_VALUE = 0x0002;
|
||
static const KEY_WRITE = 0x20006;
|
||
|
||
static const ERROR_MORE_DATA = 234L ; // dderror
|
||
static const REG_OPTION_RESERVED = (0x00000000L) ; // Parameter is reserved
|
||
|
||
static const REG_OPTION_NON_VOLATILE =0x00000000L; // Key is preserved
|
||
// when system is rebooted
|
||
|
||
static const REG_OPTION_VOLATILE = (0x00000001L); // Key is not preserved
|
||
// when system is rebooted
|
||
|
||
static const REG_OPTION_CREATE_LINK=(0x00000002L) ; // Created key is a
|
||
// symbolic link
|
||
|
||
static const REG_OPTION_BACKUP_RESTORE=(0x00000004L); // open for backup or restore
|
||
// special access rules
|
||
// privilege required
|
||
static const REG_OPTION_OPEN_LINK=(0x00000008L); // Open symbolic link
|
||
|
||
static const REG_OPTION_DONT_VIRTUALIZE=(0x00000010L) ; // Disable Open/Read/Write
|
||
// virtualization for this
|
||
// open and the resulting
|
||
// handle.
|
||
|
||
{$ifdef linux}
|
||
class function RegEnumValueA(hKey:pointer;dwIndex:integer;var lpValueName:string;var lpcchValueName:integer;lpReserved:pointer;lpType:pointer;lpData:pointer;lpcbData:pointer):integer;
|
||
class function RegEnumKeyA(hKey:pointer;dwindex:integer;var lpName:string;ccname:integer):integer;
|
||
class function RegQueryValueExA(hKey:pointer;lpValueName:string;lpReserved:integer;var lpType:integer;var lpData:string;var lpcbData:integer):integer;
|
||
class function RegSetValueExA(hkey:pointer;keyValueName:string;lpReserved:integer;lpType:integer;data:string;len:integer):integer;
|
||
class function RegOpenKeyA(Key:pointer;lpSubKey:string;var phkResult:pointer):integer;
|
||
class function RegCloseKey(hKey:pointer):integer;
|
||
class function RegOpenKeyExA(Key:pointer;lpSubKey:string;rs:integer;ac:integer;var phkResult:pointer):integer;
|
||
class function RegCreateKeyExA(hKey:pointer;lpSubKey:string;Reserved:integer;lpClass:string;dwOptions:integer;samDesired:integer;lpSecurityAttributes:pointer;var phkResult:pointer;var lpdwDisposition:integer):integer;
|
||
class function RegDeleteKeyExA(hKey:pointer;lpSubKey:string;samDesired:integer;Reserved:integer):integer;
|
||
class function RegDeleteKeyA(hKey:pointer;lpSubKey:string):integer;
|
||
class function RegDeleteValueA(hKey:pointer;lpValueName:string):integer;
|
||
class function RegDeleteKeyValueA(hKey:pointer;lpSubKey:string;lpValueName:string):integer;
|
||
class function RegDeleteTreeA(hKey:pointer;lpSubKey:string):integer;
|
||
class function FormatMessageA(dwFlags:integer;lpSource:pointer;dwMessageId:integer;dwLanguageId:integer;var pBuffer:string;nSize:integer;):integer;
|
||
{$else}
|
||
class function RegEnumValueA(hKey:pointer;dwIndex:integer;var lpValueName:string;var lpcchValueName:integer;lpReserved:pointer;lpType:pointer;lpData:pointer;lpcbData:pointer):integer;stdcall;external "Advapi32.dll" name "RegEnumValueA";
|
||
class function RegEnumKeyA(hKey:pointer;dwindex:integer;var lpName:string;ccname:integer):integer;stdcall;external "Advapi32.dll" name "RegEnumKeyA";
|
||
class function RegQueryValueExA(hKey:pointer;lpValueName:string;lpReserved:integer;var lpType:integer;var lpData:string;var lpcbData:integer):integer;stdcall;external "Advapi32.dll" name "RegQueryValueExA";
|
||
class function RegSetValueExA(hkey:pointer;keyValueName:string;lpReserved:integer;lpType:integer;data:string;len:integer):integer;stdcall;external "Advapi32.dll" name "RegSetValueExA";
|
||
class function RegOpenKeyA(Key:pointer;lpSubKey:string;var phkResult:pointer):integer;stdcall;external "Advapi32.dll" name "RegOpenKeyA";
|
||
class function RegCloseKey(hKey:pointer):integer;stdcall;external "Advapi32.dll" name "RegCloseKey";
|
||
class function RegOpenKeyExA(Key:pointer;lpSubKey:string;rs:integer;ac:integer;var phkResult:pointer):integer;stdcall;external "Advapi32.dll" name "RegOpenKeyExA";
|
||
class function RegCreateKeyExA(hKey:pointer;lpSubKey:string;Reserved:integer;lpClass:string;dwOptions:integer;samDesired:integer;lpSecurityAttributes:pointer;var phkResult:pointer;var lpdwDisposition:integer):integer;stdcall;external "Advapi32.dll" name "RegCreateKeyExA";
|
||
class function RegDeleteKeyExA(hKey:pointer;lpSubKey:string;samDesired:integer;Reserved:integer):integer;stdcall;external "Advapi32.dll" name "RegDeleteKeyExA";
|
||
class function RegDeleteKeyA(hKey:pointer;lpSubKey:string):integer;stdcall;external "Advapi32.dll" name "RegDeleteKeyA";
|
||
class function RegDeleteValueA(hKey:pointer;lpValueName:string):integer;stdcall;external "Advapi32.dll" name "RegDeleteValueA";
|
||
class function RegDeleteKeyValueA(hKey:pointer;lpSubKey:string;lpValueName:string):integer;stdcall;external "Advapi32.dll" name "RegDeleteKeyValueA";
|
||
class function RegDeleteTreeA(hKey:pointer;lpSubKey:string):integer;stdcall;external "Advapi32.dll" name "RegDeleteTreeA";
|
||
class function FormatMessageA(dwFlags:integer;lpSource:pointer;dwMessageId:integer;dwLanguageId:integer;var pBuffer:string;nSize:integer;):integer;stdcall;external "Kernel32.dll" name "FormatMessageA";
|
||
{$endif}
|
||
class function GetRegKeyRoot();
|
||
begin
|
||
{**
|
||
@explan(说明) 获得HKEY_CLASSES_ROOT的key %%
|
||
@return(TRegKey|integer) 如果成功返回 key 对象 %%
|
||
**}
|
||
return new TRegKey(HKEY_CLASSES_ROOT);
|
||
end
|
||
class function GetRegKeyUser();
|
||
begin
|
||
{**
|
||
@explan(说明) 获得HKEY_CURRENT_USER的key %%
|
||
@return(TRegKey|integer) 如果成功返回 key 对象 %%
|
||
**}
|
||
return new TRegKey(HKEY_CURRENT_USER);
|
||
end
|
||
class function GetRegKeyMachine();
|
||
begin
|
||
{**
|
||
@explan(说明) 获得HKEY_LOCAL_MACHINE的key %%
|
||
@return(TRegKey|integer) 如果成功返回 key 对象 %%
|
||
**}
|
||
return new TRegKey(HKEY_LOCAL_MACHINE);
|
||
end
|
||
class function GetEnviromentKey();
|
||
begin
|
||
{**
|
||
@explan(说明) 获得环境变量的key %%
|
||
@return(TRegKey|integer) 如果成功返回 key 对象 %%
|
||
**}
|
||
k1 := new TRegKey(HKEY_LOCAL_MACHINE);
|
||
return k1.openKeyA("SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment");
|
||
end
|
||
class function EnvironmentPath(k2);
|
||
begin
|
||
{**
|
||
@explan(说明) 获得环境路径的所有值%%
|
||
@return(array of string) 环境路径数组 %%
|
||
**}
|
||
if ifnil(k2)then k2 := GetEnviromentKey();
|
||
if not ifobj(k2)then return nil;
|
||
r := str2array(k2.GetValueA("path"),";");
|
||
rt := array();
|
||
for i,v in r do
|
||
begin
|
||
vi := trim(v);
|
||
if vi then rt[length(rt)]:= lowercase(vi);
|
||
end
|
||
return rt;
|
||
end
|
||
private
|
||
FHandle;
|
||
FResult;
|
||
function CloseRegKey();
|
||
begin
|
||
if ifnumber(FHandle)and not(FHandle in array(HKEY_CLASSES_ROOT,HKEY_CURRENT_USER,HKEY_LOCAL_MACHINE,HKEY_USERS,HKEY_PERFORMANCE_DATA,HKEY_PERFORMANCE_TEXT,HKEY_PERFORMANCE_NLSTEXT))then
|
||
RegCloseKey(FHandle);
|
||
end
|
||
function SetHandle(h);
|
||
begin
|
||
if h <> FHandle then
|
||
begin
|
||
CloseRegKey();
|
||
FHandle := h;
|
||
end
|
||
end
|
||
public
|
||
function create(h);
|
||
begin
|
||
SetHandle(h);
|
||
end
|
||
function Destroy();
|
||
begin
|
||
CloseRegKey();
|
||
end
|
||
function openKeyA(vn,exist);
|
||
begin
|
||
{**
|
||
@explan(说明) 打开或者新建 key%%
|
||
@param(vn)(string) value 名字 %%
|
||
@param(exist)(bool) 只打开存在的 %%
|
||
@return(TRegKey) 值 %%
|
||
**}
|
||
if not FHandle then return -1;
|
||
if not(ifstring(vn)and vn)then return -1;
|
||
|
||
if exist>0 then
|
||
begin
|
||
ac := 0;
|
||
if (exist .& 2) then //写
|
||
begin
|
||
ac .|=KEY_CREATE_LINK;
|
||
ac .|=KEY_CREATE_SUB_KEY;
|
||
ac .|=KEY_SET_VALUE;
|
||
ac .|=KEY_WRITE;
|
||
end
|
||
if (exist .& 1) then //读
|
||
begin
|
||
ac .|= KEY_QUERY_VALUE;
|
||
ac .|= KEY_ENUMERATE_SUB_KEYS;
|
||
ac .|= KEY_READ;
|
||
end
|
||
end else
|
||
begin
|
||
ac := KEY_ALL_ACCESS;
|
||
end
|
||
h2 := 0;
|
||
rr := RegOpenKeyExA(FHandle,vn,REG_OPTION_OPEN_LINK,ac,h2);
|
||
if 0=rr then
|
||
begin
|
||
r := new TRegKey(h2);
|
||
return r;
|
||
end
|
||
if exist then return rr;
|
||
state := 0;
|
||
hk2 := 0;
|
||
rr := RegCreateKeyExA(FHandle,vn,0,"",REG_OPTION_NON_VOLATILE,0,0,hk2,state);
|
||
if rr=0 then
|
||
begin
|
||
RegCloseKey(hk2);
|
||
//r := new TRegKey(hk2); //openKeyA(vn,exist); //
|
||
//return r;
|
||
return openKeyA(vn,3);
|
||
end
|
||
return rr;
|
||
end
|
||
function GetValueA(vn,vt);
|
||
begin
|
||
{**
|
||
@explan(说明) 获得value值%%
|
||
@param(vn)(string) value 名字 %%
|
||
@param(vt)(integer) 类型 %%
|
||
@return(string|number) 值 | err %%
|
||
**}
|
||
if not FHandle then return-1;
|
||
if not(ifstring(vn)or ifnil(vn))then return-1;
|
||
if not ifnumber(vt)then vt := 0;
|
||
n := 512;
|
||
d := "";
|
||
setlength(d,n);
|
||
len := n-1;
|
||
rr := RegQueryValueExA(FHandle,vn,0,vt,d,len);
|
||
while rr=ERROR_MORE_DATA do
|
||
begin
|
||
n+=512;
|
||
setlength(d,n);
|
||
len := n-1;
|
||
rr := RegQueryValueExA(FHandle,vn,0,vt,d,len);
|
||
end
|
||
if 0=rr then
|
||
begin
|
||
return d[1:len-1];
|
||
end
|
||
return rr;
|
||
end
|
||
function SetValueStringA(vn,v);
|
||
begin
|
||
{**
|
||
@explan(说明) 设置value值%%
|
||
@param(vn)(string) value 名字,nil为默认值%%
|
||
@param(v)(string) 值 %%
|
||
**}
|
||
if not FHandle then return -1;
|
||
if not(ifstring(vn)or ifnil(vn))then return -1;
|
||
rs := 0;
|
||
tp := 1;
|
||
return RegSetValueExA(FHandle,vn,rs,tp,v,length(v));
|
||
end
|
||
function setvalueA(vn,v,tp);
|
||
begin
|
||
{**
|
||
@explan(说明) 设置value值%%
|
||
@param(vn)(string) value 名字,nil为默认值%%
|
||
@param(v)(string) 值 %%
|
||
@param(tp)(Number) 类型 默认字符串类型 %%
|
||
**}
|
||
if not FHandle then return -1;
|
||
if not(ifstring(vn)or ifnil(vn))then return -1;
|
||
rs := 0;
|
||
if not(tp>=0 ) then tp := 1;
|
||
return RegSetValueExA(FHandle,vn,rs,tp,v,length(v));
|
||
end
|
||
|
||
function DeleteValueA(vn);
|
||
begin
|
||
{**
|
||
@explan(说明) 删除value %%
|
||
@param(vn)(string) value 名字 %%
|
||
**}
|
||
if not FHandle then return -1;
|
||
if not(ifstring(vn) or ifnil(vn))then return -1;
|
||
return RegDeleteValueA(FHandle,vn);
|
||
end
|
||
function DeleteKeyA(vn);
|
||
begin
|
||
{**
|
||
@explan(说明) key %%
|
||
@param(vn)(string) key %%
|
||
**}
|
||
if not FHandle then return -1;
|
||
if not(ifstring(vn))then return -1;
|
||
return RegDeleteKeyExA(FHandle,vn,0x0100,0);
|
||
end
|
||
function DeleteTreeA(vn);
|
||
begin
|
||
{**
|
||
@explan(说明) 删除目录 %%
|
||
@param(vn)(string) 目录名 %%
|
||
**}
|
||
if not FHandle then return-1;
|
||
if not(ifstring(vn))then return-1;
|
||
return RegDeleteTreeA(FHandle,vn);
|
||
end
|
||
function GetValueNames();
|
||
begin
|
||
{**
|
||
@explan(说明) 获得value的名称 %%
|
||
@return(array of string) 所有名称 %%
|
||
**}
|
||
r := array();
|
||
if FHandle then
|
||
begin
|
||
s := "";
|
||
ls := 1024;
|
||
setlength(s,1024);
|
||
idx := 0;
|
||
while true do
|
||
begin
|
||
ls := 1024;
|
||
sc := RegEnumValueA(FHandle,idx,s,ls,0,0,0,0);
|
||
if sc=0 and (ls>0) then
|
||
begin
|
||
r[idx]:= s[1:ls];
|
||
idx++;
|
||
end else
|
||
break;
|
||
end
|
||
end
|
||
return r;
|
||
end
|
||
function GetSubKeyNames();
|
||
begin
|
||
{**
|
||
@explan(说明) 获得子项的名称 %%
|
||
@return(array of string) 所有名称 %%
|
||
**}
|
||
r := array();
|
||
if FHandle then
|
||
begin
|
||
s := "";
|
||
ls := 1024;
|
||
setlength(s,1024);
|
||
idx := 0;
|
||
while true do
|
||
begin
|
||
sc := RegEnumKeyA(FHandle,idx,s,ls);
|
||
if sc=0 then
|
||
begin
|
||
for i := 1 to 1024 do
|
||
begin
|
||
if (s[i]="\0") and (i>2) then
|
||
begin
|
||
r[idx]:= s[1:(i-1)];
|
||
break;
|
||
end
|
||
end
|
||
idx++;
|
||
end else
|
||
break;
|
||
end
|
||
end
|
||
return r;
|
||
end
|
||
property Handle read FHandle write SetHandle;
|
||
{**
|
||
@param(Handle)(pointer) regkey句柄 %%
|
||
**}
|
||
private
|
||
end
|
||
type TWinEnviroment=class()
|
||
{**
|
||
@explan(说明) windows环境变量操作 %%
|
||
**}
|
||
function Create();
|
||
begin
|
||
FRegkey := class(TRegKey).GetEnviromentKey();
|
||
if not(ifobj(FRegkey))then raise "非管理员不能操作环境变量!";
|
||
end
|
||
function GetPaths();
|
||
begin
|
||
{**
|
||
@explan(说明) 获得环境路径 %%
|
||
@return(array of string) 路径 %%
|
||
**}
|
||
PathInPaths("===",r);
|
||
return r;
|
||
end
|
||
function AppendPath(p);
|
||
begin
|
||
{**
|
||
@explan(说明) 追加环境路径 %%
|
||
@param(p)(string) 路径 %%
|
||
@return(bool) true 成功 false 失败 %%
|
||
**}
|
||
if not(PathOk(p))then return false;
|
||
if not PathInPaths(p,paths)then
|
||
begin
|
||
return 0=FRegkey.SetValueStringA("path",array2str(paths,";")+";"+p);
|
||
end
|
||
end
|
||
function RemovePath(p);
|
||
begin
|
||
{**
|
||
@explan(说明) 移除环境路径 %%
|
||
@param(p)(string) 路径 %%
|
||
@return(bool)true 成功 false 失败 %%
|
||
**}
|
||
if not PathOk(p)then return false;
|
||
if PathInPaths(p,paths)then
|
||
begin
|
||
return 0=FRegkey.SetValueStringA("path",array2str(paths,";"));
|
||
end
|
||
end
|
||
private
|
||
function PathOk(p);
|
||
begin
|
||
if not(ifstring(p)and p)then return false;
|
||
for i,v in array(";","?",'"',"|","*") do
|
||
begin
|
||
if pos(v,p)then return false;
|
||
end
|
||
return true;
|
||
end
|
||
function PathInPaths(p,paths);
|
||
begin
|
||
pv := lowercase(RegularPath(p));
|
||
if not pv then return 0;
|
||
d := FRegkey.GetValueA("path");
|
||
nothavepath := false;
|
||
paths := array();
|
||
LP := 0;
|
||
for i,v in str2array(d,";") do
|
||
begin
|
||
vi := RegularPath(v);
|
||
if not vi then continue;
|
||
if lowercase(vi)=pv then
|
||
begin
|
||
nothavepath := true;
|
||
continue;
|
||
end
|
||
paths[LP++]:= v;
|
||
end
|
||
return nothavepath;
|
||
end
|
||
function RegularPath(p);
|
||
begin
|
||
{**
|
||
@explan(说明) 规则化数据 %%
|
||
**}
|
||
r := "";
|
||
if p and ifstring(p)then
|
||
begin
|
||
r := trim(p);
|
||
len := length(r);
|
||
if r[len]="\\" and len>1 then return r[1:(len-1)];
|
||
end
|
||
return r;
|
||
end
|
||
FRegkey;
|
||
end
|
||
|
||
type TQuotations=class(tcomponent)
|
||
{**
|
||
@explan(说明) 行情订阅以及远程执行类 %%
|
||
**}
|
||
private
|
||
static FSQuotations;
|
||
static const RE_ERROR=0;
|
||
static const RE_FUNCRESULT=0x0201;
|
||
static const RE_FUNCSTATE=0x0301;
|
||
static const RE_ECHO=0x0401;
|
||
static const RE_QUERY=0x0402;
|
||
[weakref]FOncallBack; //回调函数
|
||
FChannel; //通道
|
||
FData; //返回数据
|
||
FIds;
|
||
FSUbs;
|
||
FScript;
|
||
FGlobalVariable;
|
||
function EndRemoteExecute();
|
||
begin
|
||
if FChannel then
|
||
begin
|
||
EndExecute(FChannel);
|
||
reindex(FSQuotations,array(FChannel:nil));
|
||
FChannel := 0;
|
||
FData := array();
|
||
end
|
||
end
|
||
protected
|
||
class function sinit();override;
|
||
begin
|
||
inherited;
|
||
if not ifarray(FSQuotations)then
|
||
begin
|
||
FSQuotations := array();
|
||
end
|
||
end
|
||
function RemoteCallBack(d);virtual;
|
||
begin
|
||
{**
|
||
@explan(说明) 回调执行 %%
|
||
**}
|
||
if not ifarray(d)then exit;
|
||
FData := d;
|
||
calldatafunction(FOncallBack,self(true));
|
||
end
|
||
public
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
FData := array();
|
||
FIds := array();
|
||
FGlobalVariable := array();
|
||
FSUbs := array();
|
||
FScript := "";
|
||
end
|
||
function RemoteExecute();
|
||
begin
|
||
{**
|
||
@explan(说明) 远程执行代码 %%
|
||
@return(integer) channel %%
|
||
**}
|
||
if not ifstring(FScript)then return 0;
|
||
if not ifarray(FGlobalVariable)then sysp := array();
|
||
else sysp := FGlobalVariable;
|
||
EndRemoteExecute();
|
||
FChannel := SendExecute(FScript,sysp,"return unit(tslvcl).remotetslcallback(sysparams);",1);
|
||
if not FChannel then return 0;
|
||
FSQuotations[FChannel]:= self(true);
|
||
return FChannel;
|
||
end
|
||
function MarketSubscription();
|
||
begin
|
||
{**
|
||
@explan(说明) 构造行情订阅 %%
|
||
@return(integer) channel %%
|
||
**}
|
||
EndRemoteExecute();
|
||
if not(FIds and ifarray(FIds)and FSUbs and ifarray(FSUbs))then
|
||
begin
|
||
return 0;
|
||
end
|
||
qts := array("Type":1);
|
||
qts["IDs"]:= FIds;
|
||
qts["SUBs"]:= FSUbs;
|
||
FChannel := SendExecute("",qts,"return unit(tslvcl).remotetslcallback(sysparams);",0);
|
||
if not FChannel then return 0;
|
||
FSQuotations[FChannel]:= self(true);
|
||
return FChannel;
|
||
end
|
||
function Recycling();override;
|
||
begin
|
||
EndRemoteExecute();
|
||
FOncallBack := nil;
|
||
inherited;
|
||
end
|
||
function destroy();override;
|
||
begin
|
||
inherited;
|
||
end
|
||
class function Dispatch(dt);
|
||
begin
|
||
{**
|
||
@explan(说明) 消息分发 %%
|
||
**}
|
||
if ifarray(dt)then
|
||
begin
|
||
// 0:错误通知
|
||
// 0x0201:执行函数返回
|
||
// 0x0301:提交委托函数的状态返回
|
||
// 0x0401:Echo
|
||
// 0x0402:RunningData返回/订阅行情的结果集
|
||
o := FSQuotations[dt["channel"]];
|
||
if ifobj(o)then o.RemoteCallBack(dt);
|
||
end
|
||
end
|
||
function echodata();
|
||
begin
|
||
{**
|
||
@explan(说明) 获取echo 的信息 %%
|
||
@return(string|nil) 非echo 类型返回nil%%
|
||
**}
|
||
if FData["recvtype"]=RE_ECHO then
|
||
begin
|
||
return FData["errmsg"];
|
||
end
|
||
return nil;
|
||
end
|
||
function errormessage();
|
||
begin
|
||
{**
|
||
@explan(说明) 获取错误的信息 %%
|
||
@return(string|nil) 无错误返回nil%%
|
||
**}
|
||
if FData["recvtype"]=RE_ERROR then
|
||
begin
|
||
return FData["errmsg"];
|
||
end
|
||
return nil;
|
||
end
|
||
function result();
|
||
begin
|
||
{**
|
||
@explan(说明) 获取执行结果 %%
|
||
**}
|
||
if FData["recvtype"]in array(RE_FUNCRESULT,RE_QUERY)then
|
||
begin
|
||
return FData["result"];
|
||
end
|
||
return nil;
|
||
end
|
||
published
|
||
property OnCallBack:eventhandler read FOncallBack write FOncallBack;
|
||
property Ids:strings read FIds write FIds;
|
||
property SUBs:strings read FSUbs write FSUbs;
|
||
property GlobalVariable:tsldata read FGlobalVariable write FGlobalVariable;
|
||
property Script:text read FScript write FScript;
|
||
{**
|
||
@param(OnCallBack)(function[TQuotations]) 执行回调 %%
|
||
@param(ids)(array of stockid) 证券代码数组 array("SZ000001","SZ000002") %%
|
||
@param(SUBs)(array of string) 订阅字段数组 array("StockName", "date","price", "open") %%
|
||
**}
|
||
end
|
||
|
||
type tlogincontrol=class(tpanel)
|
||
{**
|
||
@explan(说明) 登陆控件 %%
|
||
**}
|
||
private
|
||
FserverEdit;
|
||
FserverLabel;
|
||
FuserLabel;
|
||
FpwdLabel;
|
||
Fstatus;
|
||
FportEdit;
|
||
FpwdEdit;
|
||
FlogoutBtn;
|
||
FloginBtn;
|
||
FuserEdit;
|
||
FCacheFile;
|
||
FOnLogined;
|
||
function LoadCacheData(); //导出缓存
|
||
begin
|
||
importfile(ftStream(),"",FCacheFile,configinfos);
|
||
if ifarray(configinfos)then
|
||
begin
|
||
FserverEdit.text := configinfos["server"];
|
||
FportEdit.text := configinfos["port"];
|
||
FuserEdit.text := configinfos["user"];
|
||
FpwdEdit.text := configinfos["pwd"];
|
||
end
|
||
end
|
||
function SaveCacheData() //保存缓存
|
||
begin
|
||
exportfile(ftStream(),"",FCacheFile,array("server":FserverEdit.text,"port":FportEdit.text,"user":FuserEdit.text,"pwd":FpwdEdit.text));
|
||
end
|
||
function closelogin(); //关闭登陆窗口
|
||
begin
|
||
SaveCacheData();
|
||
if Parent then EndModal();
|
||
else show(0);
|
||
end
|
||
function setsatus(s);
|
||
begin
|
||
if ifstring(s)then Fstatus.setitemtext(s,1);
|
||
end
|
||
function clklogin(o,e);
|
||
begin
|
||
clklogin2(o,e);
|
||
CallMessgeFunction(FOnLogined,self,e);
|
||
end
|
||
function clklogin2(o,e); //登陆按钮
|
||
begin
|
||
//登陆 设置状态
|
||
//参考 函数 LoginTslServer
|
||
setsatus("正在登陆...");
|
||
logintext := FuserEdit.text;
|
||
loginpwd := FpwdEdit.text;
|
||
loginserve := FserverEdit.text+":"+FportEdit.text;
|
||
if(CheckConnected()or(ConnectServer(FserverEdit.text,StrToFloatDef(FportEdit.text,443))=0))then
|
||
begin
|
||
msg := "";
|
||
setlength(msg,200);
|
||
if(CheckLogined()or LoginServer(logintext,loginpwd,msg)=0)then
|
||
begin
|
||
setsatus("登陆成功");
|
||
FloginBtn.enabled := false;
|
||
FlogoutBtn.enabled := true;
|
||
hidenwindow();
|
||
return 0;
|
||
end else
|
||
begin
|
||
setsatus("登陆失败");
|
||
messageboxA(msg,"登陆失败",1);
|
||
return 1;
|
||
end
|
||
end else
|
||
begin
|
||
setsatus("连接服务器失败");
|
||
messageboxA("连接服务器失败","提示",1);
|
||
return 2;
|
||
end
|
||
return-1;
|
||
end
|
||
function clklogout(o,e); //退出登陆按钮
|
||
begin
|
||
//退出登陆设置状态
|
||
setsatus("与服务器断开连接");
|
||
FloginBtn.enabled := true;
|
||
FlogoutBtn.enabled := false;
|
||
DisconnectServer();
|
||
end
|
||
function hidenwindow(o,e); //关闭按钮
|
||
begin
|
||
//e.skip := true;
|
||
closelogin();
|
||
end
|
||
function GetUsrName();
|
||
begin
|
||
return FuserEdit.text;
|
||
end
|
||
function SetUsrName(v);
|
||
begin
|
||
FuserEdit.text := v;
|
||
end
|
||
function GetPort();
|
||
begin
|
||
return FportEdit.text;
|
||
end
|
||
function SetPort(v);
|
||
begin
|
||
FportEdit.text := v;
|
||
end
|
||
function SetIp(v);
|
||
begin
|
||
FserverEdit.text := v;
|
||
end
|
||
function GetIp();
|
||
begin
|
||
return FserverEdit.text;
|
||
end
|
||
public
|
||
function create(AOwner);override;
|
||
begin
|
||
inherited;
|
||
visible := false;
|
||
FCacheFile := temppath()+ioFileseparator()+"loginer.stm";
|
||
self.caption := "TinySoftLogin";
|
||
rc := _wapi.GetScreenRect();
|
||
self.height := 306;
|
||
self.left :=(rc[2]-rc[0])/2-350;
|
||
self.top :=(rc[3]-rc[1])/2-210;
|
||
self.width := 428;
|
||
self.wscaption := true;
|
||
self.wspopup := true;
|
||
self.wssizebox := true;
|
||
self.wssysmenu := true;
|
||
FserverEdit := new tedit(self);
|
||
FserverEdit.parent := self;
|
||
FserverEdit.height := 25;
|
||
FserverEdit.left := 106;
|
||
FserverEdit.text := "tsl.tinysoft.com.cn";
|
||
FserverEdit.top := 26;
|
||
FserverEdit.width := 179;
|
||
FserverLabel := new tlabel(self);
|
||
FserverLabel.parent := self;
|
||
FserverLabel.left := 22;
|
||
FserverLabel.top := 23;
|
||
FserverLabel.width := 60;
|
||
FserverLabel.height := 25;
|
||
FserverLabel.caption := "服务器";
|
||
FuserLabel := new tlabel(self);
|
||
FuserLabel.parent := self;
|
||
FuserLabel.left := 22;
|
||
FuserLabel.top := 68;
|
||
FuserLabel.width := 59;
|
||
FuserLabel.height := 25;
|
||
FuserLabel.caption := "用户名";
|
||
FpwdLabel := new tlabel(self);
|
||
FpwdLabel.parent := self;
|
||
FpwdLabel.caption := "密码";
|
||
FpwdLabel.left := 21;
|
||
FpwdLabel.top := 112;
|
||
FpwdLabel.width := 57;
|
||
FpwdLabel.height := 25;
|
||
Fstatus := new tstatusbar(self);
|
||
Fstatus.parent := self;
|
||
Fstatus.left := 0;
|
||
Fstatus.top := 244;
|
||
Fstatus.Items := array(("text":"状态","width":40),("text":"","width":200));
|
||
FportEdit := new tedit(self);
|
||
FportEdit.parent := self;
|
||
FportEdit.height := 25;
|
||
FportEdit.left := 298;
|
||
FportEdit.text := "443";
|
||
FportEdit.top := 25;
|
||
FportEdit.width := 80;
|
||
FlogoutBtn := new tbtn(self);
|
||
FlogoutBtn.parent := self;
|
||
FlogoutBtn.caption := "退出";
|
||
FlogoutBtn.height := 31;
|
||
FlogoutBtn.left := 80;
|
||
FlogoutBtn.top := 173;
|
||
FlogoutBtn.width := 94;
|
||
FloginBtn := new tbtn(self);
|
||
FloginBtn.parent := self;
|
||
FloginBtn.caption := "登陆";
|
||
FloginBtn.height := 31;
|
||
FloginBtn.left := 226;
|
||
FloginBtn.top := 173;
|
||
FloginBtn.width := 94;
|
||
FuserEdit := new tedit(self);
|
||
FuserEdit.parent := self;
|
||
FuserEdit.height := 25;
|
||
FuserEdit.left := 107;
|
||
FuserEdit.top := 68;
|
||
FuserEdit.width := 177;
|
||
FpwdEdit := new tpassword(self);
|
||
FpwdEdit.parent := self;
|
||
FpwdEdit.height := 25;
|
||
FpwdEdit.left := 107;
|
||
FpwdEdit.top := 114;
|
||
FpwdEdit.width := 174;
|
||
FloginBtn.onclick := thisfunction(clklogin);
|
||
FlogoutBtn.onclick := thisfunction(clklogout);
|
||
self.onclose := thisfunction(hidenwindow);
|
||
FlogoutBtn.enabled := false;
|
||
end
|
||
function openlogin() //打开登录窗口
|
||
begin
|
||
LoadCacheData();
|
||
if getloginstatus()then
|
||
begin
|
||
setsatus("登陆成功");
|
||
end else
|
||
setsatus("未登录");
|
||
if Parent then ShowModal();
|
||
else show();
|
||
end
|
||
function getloginstatus(); //获得状态
|
||
begin
|
||
{**
|
||
@explan(说明) 获得登陆状态 %%
|
||
@return(bool) true 已经登陆 false 未登陆
|
||
**}
|
||
if CheckLogined()then return true;
|
||
else return false;
|
||
end
|
||
published
|
||
property Port:string read GetPort write SetPort;
|
||
property Ip:string read GetIp write SetIp;
|
||
property UsrName:string read GetUsrName write SetUsrName;
|
||
property OnLogined:eventhandler read FOnLogined write FOnLogined;
|
||
{**
|
||
@param(port)(string) 端口号%%
|
||
@param(ip)(string) 天软服务器 %%
|
||
@param(UsrName)(string) 天软用户名 %%
|
||
@param(OnLogined)(function[tlogincontrol,tuieventbase]) 登陆回调 %%
|
||
**}
|
||
end
|
||
|
||
|
||
type TIniFileExta=class(TIniFileExter)
|
||
{**
|
||
@explan(说明) ini文件读写封装 %%
|
||
**}
|
||
function create(al,Fname);
|
||
begin
|
||
{**
|
||
@explan(说明) 构造函数 %%
|
||
@param(al)(string) 别名 %%
|
||
@param(name)(string) 文件名 %%
|
||
**}
|
||
inherited create();
|
||
filename := fname;
|
||
Alias := al;
|
||
end
|
||
end
|
||
|
||
type TMyArrayA = class(tstrindexarray)
|
||
{**
|
||
@explan(数组类型) 忽略字符串下标的大小写%%
|
||
**}
|
||
function create();
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TMyArrayB = class(tnumindexarray)
|
||
{**
|
||
@explan(说明) 数字下标数组对象 %%
|
||
**}
|
||
function create();
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
type TTipMessageButton = class(TcustomTipMessageButton)
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
|
||
|
||
|
||
type TInPutQuerys = class(TcustomInPutQuerys)
|
||
function create(AOwner);
|
||
begin
|
||
inherited;
|
||
end
|
||
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
|
||
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
|
||
invoke(obj,n,1,d);
|
||
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,o,cn);
|
||
begin
|
||
for i,v in phs do
|
||
begin
|
||
ph := v+cn+".tfm";
|
||
if fileexists("",ph) then
|
||
begin
|
||
size := filesize("",ph);
|
||
if readFile(rwraw(),"",ph,0,size,data)=1 then
|
||
begin
|
||
LoadFromTfmScript(o,data);
|
||
return true;
|
||
end
|
||
end
|
||
end
|
||
end
|
||
function hastfmresource(o,cn);
|
||
begin
|
||
data := get_resource_by_name(cn+".tfm");
|
||
if data then
|
||
begin
|
||
LoadFromTfmScript(o,data);
|
||
return true;
|
||
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 hastfmresource(o,cn) then return ;
|
||
if hastfmfile(phs,o,cn) then return ;
|
||
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
|
||
unit(utssvr_api_c).get_tssvr_api_c();
|
||
p := sysgettsllibpath();
|
||
if not p then return array();
|
||
wapi := gettswin32api();
|
||
FCurrentp := wapi.get_current_directory();
|
||
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;
|
||
FDragThreshold:Integer;
|
||
protected //input capture
|
||
procedure KeyUp(var Key:Word;Shift:TShiftState);virtual;
|
||
procedure KeyDown(var Key:Word;Shift:TShiftState);virtual;
|
||
procedure CaptureChanged(OldCaptureControl:TControl);virtual;
|
||
procedure MouseMove(Shift:TShiftState;X,Y:Integer);virtual;
|
||
procedure MouseUp(Button:TMouseButton;Shift:TShiftState;X,Y:Integer);virtual;
|
||
procedure MouseDown(Button:TMouseButton;Shift:TShiftState;X,Y:Integer);virtual;
|
||
public
|
||
function Create(TheOwner:TComponent);override;
|
||
function IsDragging():boolean;virtual;
|
||
function Dragging(AControl:TControl):boolean;virtual;
|
||
procedure RegisterDockSite(Site:TWinControl;DoRegister:Boolean);virtual;
|
||
procedure DragStart(AControl:TControl;AImmediate:Boolean;AThreshold:Integer);virtual;
|
||
procedure DragMove(APosition:TPoint);virtual;
|
||
procedure DragStop(ADrop:Boolean);virtual;
|
||
property DragImmediate:Boolean read FDragImmediate write FDragImmediate; // default True;
|
||
property DragThreshold:Integer read FDragThreshold write FDragThreshold; // default 5;
|
||
end;
|
||
|
||
function GetAndDispatchMessageA(hwnd,minm,maxm); //分发窗口消息
|
||
begin
|
||
{**
|
||
@explan(说明) 获得和分发消息 %%
|
||
@param(hwnd)(pointer) 窗口句柄 默认为0 %%
|
||
@param(minm)(integer) 最小消息值 默认为空 %%
|
||
@param(maxm)(integer) 最大消息值 默认为空 %%
|
||
@return(integer)0表示WM_QUIT ,-1表示错误,其他返回大于0 %%
|
||
**}
|
||
API := gettswin32api();
|
||
{$ifdef linux}
|
||
dg := API.g_main_context_default();
|
||
if dg then
|
||
begin
|
||
ct := 5;
|
||
while ct>0 do
|
||
begin
|
||
if API.g_main_context_pending(dg) and ct>0 then
|
||
begin
|
||
API.g_main_context_iteration(dg,false);
|
||
end
|
||
ct--;
|
||
end
|
||
end
|
||
tslprocessmessages(false);
|
||
RunWorkerThreadLoop();
|
||
return;
|
||
{$endif}
|
||
|
||
FMSG := new TTagMSG();
|
||
ptr := FMSG._getptr_();
|
||
|
||
///////////////////////////////////////////////
|
||
ct:=5;
|
||
if(API.PeekMessageA(ptr,0,0,0,0x1)) and ct>0 then
|
||
begin
|
||
if FMSG.message=0x12 then
|
||
begin
|
||
return 0;
|
||
end else
|
||
begin
|
||
API.TranslateMessage(ptr);
|
||
API.DispatchMessageA(ptr);
|
||
end
|
||
ct--;
|
||
end else
|
||
begin
|
||
if ct>3 then
|
||
begin
|
||
tslprocessmessages(false);
|
||
RunWorkerThreadLoop();
|
||
sleep(1);//API.WaitMessage();
|
||
end
|
||
end
|
||
return -1;
|
||
//////////////////////////////////////////////////////
|
||
{r := API.GetMessageA(ptr, hwnd>0?hwnd:0, minm>0?minm:0, maxm>0?maxm:0);
|
||
if r=0 then
|
||
begin
|
||
return r;
|
||
end
|
||
API.TranslateMessage(ptr);
|
||
API.DispatchMessageA(ptr);}
|
||
return r;
|
||
end
|
||
function RegisterComponentType(n,typ);//注册componet对象
|
||
begin
|
||
{**
|
||
@explan(说明) 注册component组件 %%
|
||
**}
|
||
class(Ttfm2Component).RegisterComponentType(n,typ);
|
||
end
|
||
function initializeapplication(); //应用对象
|
||
begin
|
||
{**
|
||
@explan(说明) 初始化application %%
|
||
@return(tapplication) 窗口程序管理对象 %%
|
||
**}
|
||
return getapplication();
|
||
end
|
||
function getapplication(); //应用对象
|
||
begin
|
||
{**
|
||
@explan(说明) 返回application对象%%
|
||
@return(tapplication) 应用对象 %%
|
||
**}
|
||
r := class(tUIglobalData).uigetdata("tuiapplication");
|
||
if not(r)then
|
||
begin
|
||
r := new tapplication();
|
||
class(tUIglobalData).uisetdata("tuiapplication",r);
|
||
end
|
||
return r;
|
||
//return static new tapplication();
|
||
end
|
||
function gettswin32api(); //win32 api
|
||
begin
|
||
{**
|
||
@explan(说明) 返回win32api对象
|
||
**}
|
||
global G_O_TSWIN32API_;
|
||
if not G_O_TSWIN32API_ then G_O_TSWIN32API_ := new tswin32api();
|
||
return G_O_TSWIN32API_;
|
||
end
|
||
Function tslcstructure(data,dsize,pack,ptr);
|
||
Begin
|
||
{**
|
||
@explan(说明) 结构体排布计算 %%
|
||
@param(data)(array) 结构体信息数组,参考 cstructurelib中 tslarraytocstructcalc %%
|
||
@param(ssize)(integer) 大小 忽略%%
|
||
@param(pack)(integer) 对其方式 忽略%%
|
||
@return(tslcstructureobj) 内存分布对象 %%
|
||
**}
|
||
dt := unit(cstructurelib).MemoryAlignmentCalculate(data,1,dsize,pack);
|
||
r := new tslcstructureobj(dt,ptr);
|
||
return r;
|
||
End;
|
||
|
||
function tslcstructure_calc(data,baselen,ssize,pack);
|
||
begin
|
||
{**
|
||
@explan(说明) 结构体排布计算 %%
|
||
@param(data)(array) 结构体信息数组,参考 cstructurelib中 tslarraytocstructcalc %%
|
||
@param(baselen)(integer) 基准长度%%
|
||
@param(ssize)(integer) 大小 %%
|
||
@param(pack)(integer) 对其方式 %%
|
||
**}
|
||
return tslarraytocstructcalc(data,pack,0,ssize);
|
||
end
|
||
|
||
function remotetslcallback(data);//远程执行
|
||
begin
|
||
{**
|
||
@explan(说明) 行情订阅回调 %%
|
||
**}
|
||
class(TQuotations).Dispatch(data);
|
||
//return class(TQuotations)._SWINDOWS._send_(0X4400,0,data,1);
|
||
end
|
||
|
||
function calldatafunction();//事件回调调用
|
||
begin
|
||
{**
|
||
@explan(说明)执行函数句柄,默认第一个参数为函数句柄,后面的参数为该句柄的参数 %%
|
||
**}
|
||
pc := paramcount;
|
||
if pc<1 then return nil;
|
||
f := params[1];
|
||
if not iffuncptr(f) then return nil;
|
||
case pc of
|
||
1:return call(f);
|
||
2:return call(f,params[2]);
|
||
3:return call(f,params[2],params[3]);
|
||
4:return call(f,params[2],params[3],params[4]);
|
||
end;
|
||
return nil;
|
||
end
|
||
function NotifyComponent(Acomponent,Act,AOwner);//通知控件
|
||
begin
|
||
{**
|
||
@explan(说明) 通知节点AOwner有节点Acomponent 发生了改变,通知码为act %%
|
||
@param(Acomponent)(tcomponent) 改变的节点 %%
|
||
@param(Act)(member of TOperation) 通知码 %%
|
||
@param(AOwner)(tcomponent|nil) 被通知的节点,默认采用application 对象 %%
|
||
**}
|
||
if not(Acomponent is class(tcomponent))then exit;
|
||
owner := AOwner;
|
||
if not(owner is class(tcomponent))then
|
||
begin
|
||
owner := getapplication();
|
||
end
|
||
owner.Notification(Acomponent,Act);
|
||
end
|
||
function _timeproc_(hwnd,message,wparam,lparam); //定时器消息分发
|
||
begin
|
||
{**
|
||
@explan(说明) 消息分发预处理函数被底层调用 %%
|
||
@param(hwnd)(integer) 窗口句柄 %%
|
||
@param(message)(integer) 消息id %%
|
||
@param(lparam)(integer) 消息参数2 %%
|
||
@param(wparam)(integer) 消息参数1 %%
|
||
|
||
**}
|
||
return class(ttimer)._timeproc_(hwnd,message,wparam,lparam);
|
||
end
|
||
function controlisCustomPaint(id);//提供给gtk使用
|
||
begin
|
||
wd := class(tUIglobalData).uigetdata("TGlobalValues").getvalue(id);
|
||
if wd then return wd.isCustomPaint();
|
||
return false;
|
||
end
|
||
function _twinproc_(hwnd,message,wparam,lparam); //窗口消息分发
|
||
begin
|
||
{**
|
||
@explan(说明) 消息分发预处理函数被底层调用 %%
|
||
@param(hwnd)(integer) 窗口句柄 %%
|
||
@param(message)(integer) 消息id %%
|
||
@param(lparam)(integer) 消息参数2 %%
|
||
@param(wparam)(integer) 消息参数1 %%
|
||
|
||
**}
|
||
//return gettswin32api().DefWindowProcA(hwnd,message,wparam,lparam);
|
||
//echo format("\r\n%x\t%x\t%x\t%x",hwnd,message,wparam,lparam);
|
||
//wdobj := class(TGlobalComponentcache).getwndbyhwnd(hwnd);
|
||
//wdobj := uigetdata("TGlobalComponentcache").getwndbyhwnd(hwnd);
|
||
wdobj := class(tUIglobalData).uigetdata("TGlobalComponentcache").getwndbyhwnd(hwnd);
|
||
if ifnil(wdobj)then //没有注册
|
||
begin
|
||
if message=0x81 then //如果为 WM_CREATE WM_NCCREATE 就注册
|
||
begin
|
||
cpm := new tslcstructureobj(MemoryAlignmentCalculate(array(
|
||
("lpcreateparams","intptr",0))),lparam);
|
||
cid := cpm._getvalue_("lpcreateparams");
|
||
wdobj := class(tUIglobalData).uigetdata("TGlobalValues").getvalue(cid);
|
||
end
|
||
end
|
||
r := 0;
|
||
if wdobj then
|
||
begin
|
||
r := wdobj.MainWndProc(hwnd,message,wparam,lparam);
|
||
end else
|
||
begin
|
||
//echo format("\r\n%x,%d,%x,%x",hwnd,message,wparam,lparam);
|
||
end
|
||
if message=0x82 then
|
||
begin
|
||
class(tUIglobalData).uigetdata("TGlobalComponentcache").unregisterhandle(hwnd);
|
||
end
|
||
return r;
|
||
end
|
||
//function GetModuleFileNameA(m:pointer;var buf:string;len:integer):integer;stdcall;external "Kernel32.dll" name "GetModuleFileNameA";
|
||
//function CallWindowProcA(lpPrevWndFunc:pointer;hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):pointer;stdcall;external "User32.dll" name "CallWindowProcA";
|
||
//function RegisterClassExA(wc:pointer):short;stdcall;external "User32.dll" name "RegisterClassExA";
|
||
//tsl语言中使用动态库函数
|
||
function TS_EndExecute(id:integer);cdecl;external "TSSVRAPI.dll" name "TS_EndExecute";
|
||
function TSL_ScriptGo(L:pointer;Content:string;v:pointer):integer;cdecl;external "TSSVRAPI.dll" name "TSL_ScriptGo";
|
||
function TSL_InterpFreeLWrap(lWrap:pointer);cdecl;external "TSSVRAPI.dll" name "TSL_InterpFreeLWrap";
|
||
function TSL_InterpNewLWrap():pointer;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TSL_InterpNewLWrap";
|
||
function TSL_NewObject():pointer;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TSL_NewObject";
|
||
function TSL_InterpGetLFromWrap(L:pointer):pointer;cdecl;external "TSSVRAPI.dll" name "TSL_InterpGetLFromWrap";
|
||
function TS_GetGlobalL():pointer;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetGlobalL";
|
||
function TSL_FreeObj(L:pointer;v:pointer);cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TSL_FreeObj";
|
||
//function TS_ModulePath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ModulePath";
|
||
//function TS_ExecPath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ExecPath";
|
||
//function TS_GetAppPath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ExecPath";
|
||
//function TS_GetIniPath(hometype:integer; var IniName:string):string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetIniPath";
|
||
function TSL_Check(func:string;funclen:integer;oResult:pointer):integer;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TSL_Check";
|
||
procedure tslprocessmessages();begin {echo "\r\n processmessage";}end;
|
||
function TS_GetUserProfileHome();
|
||
begin
|
||
return unit(utslvclauxiliary).TS_GetUserProfileHome();
|
||
end
|
||
function RunWorkerThreadLoop(); //执行工作线程循环
|
||
begin
|
||
class(TThreadWorker).dispatch();
|
||
end
|
||
//procedure ClearScriptCache();cdecl;external "TSLInterp.dll" name "ClearScriptCache";
|
||
|
||
function CreateDirWithFileName(fname);//确保指定文件的文件夹是存在的
|
||
begin
|
||
return unit(utslvclauxiliary).CreateDirWithFileName(fname);
|
||
end
|
||
function TS_GetUserProfileHomeInstance(t:integer):string;
|
||
begin
|
||
return unit(utslvclauxiliary).TS_GetUserProfileHomeInstance(t);
|
||
end
|
||
function TS_GetUserConfigHome(t:integer):string;
|
||
begin
|
||
return unit(utslvclauxiliary).TS_GetUserConfigHome(t);
|
||
end
|
||
function TS_GetHomePath(t:integer):string;
|
||
begin
|
||
return unit(utslvclauxiliary).TS_GetHomePath();
|
||
end
|
||
function TS_ModulePath():string;
|
||
begin
|
||
return unit(utslvclauxiliary).TS_ModulePath();
|
||
end
|
||
function TS_ExecPath():string;
|
||
begin
|
||
return unit(utslvclauxiliary).TS_ExecPath();
|
||
end
|
||
function TS_GetAppPath():string;
|
||
begin
|
||
return unit(utslvclauxiliary).TS_GetAppPath();
|
||
end
|
||
function TS_GetIniPath(t:integer;iname:string):string;
|
||
begin
|
||
return unit(utslvclauxiliary).TS_GetIniPath(t,iname);
|
||
end
|
||
|
||
function DeleteAllFiles(path);//删除目录所有文件
|
||
begin
|
||
return unit(utslvclauxiliary).DeleteAllFiles(path);
|
||
end
|
||
|
||
function LoginTslServer(usr,pwd,addr,port);//登陆服务器
|
||
begin
|
||
{**
|
||
@explan(说明) 登陆服务器 %%
|
||
@param(usr)(string) 用户名 %%
|
||
@param(pwd)(string) 密码 %%
|
||
@return(int) 1 成功 0 失败 %%
|
||
**}
|
||
if not(port>0)then port := 443;
|
||
if not(ifstring(addr))then addr := "tsl.tinysoft.com.cn";
|
||
if(CheckConnected()or(ConnectServer(addr,port)=0))then
|
||
begin
|
||
msg := "";
|
||
setlength(msg,200);
|
||
if(CheckLogined()or LoginServer(usr,pwd,msg)=0)then
|
||
begin
|
||
//messagebox("进入管理界面","登陆成功",1);
|
||
return 1;
|
||
end;
|
||
messageboxA(msg,"登陆失败",1);
|
||
return 0;
|
||
end else
|
||
begin
|
||
messageboxA("连接服务器失败","提示",1);
|
||
return 0;
|
||
end
|
||
return 0;
|
||
end
|
||
|
||
function GetCheckStruct();
|
||
begin
|
||
return new TCHECK_RESULT();
|
||
end
|
||
function CheckTslCode(code,err);//检查tsl语法
|
||
begin
|
||
{**
|
||
@explan(说明) tsl语法检查 %%
|
||
@param(code)(string) tsl代码 %%
|
||
@param(err)(string) 错误信息 %%
|
||
@return(bool)成功返回true %%
|
||
**}
|
||
if not ifstring(code)then
|
||
begin
|
||
err := "非字符串";
|
||
return false;
|
||
end
|
||
CheckInfo := static GetCheckStruct();
|
||
if TSL_Check(code,length(code),CheckInfo._getptr_)<> 1 then
|
||
begin
|
||
err := CheckInfo.errmsg;
|
||
return false;
|
||
end
|
||
return true;
|
||
end
|
||
function tslScriptGo(script);//执行tsl脚本
|
||
begin
|
||
{**
|
||
@explan(说明)执行tsl脚本 %%
|
||
@param(script)(string) tsl语句 %%
|
||
@return(bool) 1表示成功; 1 失败 %%
|
||
@example(scriptgo-范例)
|
||
script := "
|
||
a := testabc();
|
||
echo a;
|
||
function testabc();
|
||
begin
|
||
return 10;
|
||
end
|
||
";
|
||
return tslScriptGo(script);
|
||
**}
|
||
ph := gettemppath();
|
||
file := ph+"tslpengt.tsl";
|
||
if ifstring(script)and script then
|
||
begin
|
||
tsexe := SysExecName();
|
||
FileDelete("",file);
|
||
writefile(rwraw(),"",file,0,length(script),script);
|
||
r := SysExec(tsexe,format('"%s" "%s"',tsexe,file),nil,0,r,nil);
|
||
end
|
||
return r;
|
||
lwrap := TSL_InterpNewLWrap();
|
||
L := TSL_InterpGetLFromWrap(lwrap);
|
||
//L := TS_GetGlobalL();
|
||
if ifstring(script)then
|
||
begin
|
||
v := TSL_NewObject();
|
||
ret := TSL_ScriptGo(L,script,v);
|
||
TSL_FreeObj(L,v);
|
||
end
|
||
//TSL_InterpFreeLWrap(lwrap);
|
||
return ret;
|
||
end
|
||
function version(); //版本
|
||
begin
|
||
{**
|
||
@explan(说明) 返回版本号 %%
|
||
@return(string) "主版本号.次版本号.修订号.日期版本号 "
|
||
**}
|
||
//return "1.1.0.20190929_beta";
|
||
//return "1.1.1.20200731_beta";
|
||
//return "1.1.2.20210915_beta";
|
||
//return "1.1.3.20220210_beta";
|
||
return "1.1.4.20221111";
|
||
end
|
||
function ExitMessageLoop();
|
||
begin
|
||
{**
|
||
@expaln(说明)退出消息循环 %%
|
||
**}
|
||
WPI := gettswin32api();
|
||
return WPI.PostQuitMessage(0);
|
||
end
|
||
|
||
function SysExecWait(handle,exe,cmd,dir,fwait); //等待执行
|
||
begin
|
||
{**
|
||
@explan(说明) 运行进程 %%
|
||
@param(handle)(pointer) 返回进程句柄,作为返回值 %%
|
||
@param(exe)(string) 执行程序 %%
|
||
@param(cmd)(string) 命令行参数 %%
|
||
@param(dir)(string) 目录 %%
|
||
@param(fwait)(bool) 是否强行等待,默认为false %%
|
||
**}
|
||
if fwait then
|
||
begin
|
||
handle := SysExec(exe,cmd,dir,1,r);
|
||
return r;
|
||
end
|
||
handle := SysExec(exe,cmd,dir,0,r);
|
||
FMSG := new TTagMSG();
|
||
msg := FMSG._getptr_;
|
||
WPI := gettswin32api();
|
||
while(handle) do
|
||
begin
|
||
{if (not WPI.GetMessageA(msg, 0, 0, 0)) then break;
|
||
WPI.TranslateMessage(msg);
|
||
WPI.DispatchMessageA(msg);}
|
||
//////////////////////////////////////////////////////
|
||
if(WPI.PeekMessageA(msg,0,0,0,0x1))then
|
||
begin
|
||
if FMSG.message=0x12 then
|
||
begin
|
||
break;
|
||
end else
|
||
begin
|
||
WPI.TranslateMessage(msg);
|
||
WPI.DispatchMessageA(msg);
|
||
end
|
||
end else
|
||
begin
|
||
tslprocessmessages(false);
|
||
RunWorkerThreadLoop();
|
||
sleep(1);//WPI.WaitMessage();
|
||
end
|
||
////////////////////////////////////////////////
|
||
if not handle then break;
|
||
if not SysWaitForSingleObject(handle,5)then
|
||
begin
|
||
handle := 0;
|
||
return r;
|
||
end
|
||
end
|
||
return r;
|
||
end
|
||
function MessageBoxA(txt,title,flag,wnd);//对话框api
|
||
begin
|
||
{**
|
||
@explan(说明) 提示对话框 %%
|
||
@param(txt)(string) 文本 %%
|
||
@param(title)(string) 标题 %%
|
||
@param(flag)(integer) 按钮类型 %%
|
||
@param(wnd)(twinControl) 父窗口 %%
|
||
@return(integer) 值 %%
|
||
**}
|
||
hd := 0;
|
||
if(wnd is class(TWincontrol))and wnd.HandleAllocated()then hd := wnd.Handle;
|
||
else if ifnumber(wnd)then hd := wnd;
|
||
api := gettswin32api();
|
||
api.clipcursor(0);
|
||
return api.MessageBoxA(hd,ifstring(txt)?txt:"",ifstring(title)?title:"",flag >= 0?flag:0);
|
||
end
|
||
function GetCurrentTslDir(); //获得tsl目录以\结尾
|
||
begin
|
||
p := pluginpath();iofp := ioFileseparator();
|
||
for i:= length(p)-1 downto 1 do
|
||
begin
|
||
if p[i]=iofp then
|
||
begin
|
||
return p[1:i];
|
||
end
|
||
end
|
||
end
|
||
function CopyUsedTslDllToNewDir(npre);//windows中使用,拷贝tsl使用的动态库到指定目录
|
||
begin
|
||
{**
|
||
@explan(说明) 拷贝当前的tsl目录中使用的dll到指定目录%%
|
||
@param(npre)(string) 新的指定目录 %%
|
||
**}
|
||
if not ifstring(npre) then return false;
|
||
if not (length(npre)>2) then return false;
|
||
bpre := npre;
|
||
if npre[length(npre)]=ioFileseparator() then
|
||
begin
|
||
npre := npre[1:length(npre)-1];
|
||
end
|
||
pre1 := pre := GetCurrentTslDir();
|
||
lpre := length(pre);
|
||
app :=initializeapplication();
|
||
d := app._wapi.Toolhelp32Snapshotmodule();
|
||
pre := pre1;
|
||
for i,v in d do
|
||
begin
|
||
vi := v["szexepath"];
|
||
if pos(pre,vi) then
|
||
begin
|
||
fn := npre+vi[lpre:];
|
||
CreateDirWithFileName(fn);
|
||
FileCopy("",vi,"",fn,0);
|
||
end
|
||
end
|
||
npre := bpre;
|
||
return true;
|
||
end
|
||
|
||
////////////////////封装已经移动到其他库的接口为了兼容///////////
|
||
function TslToHexFormatStr(tsl);//将tsl数据转换为16进制字符串
|
||
begin
|
||
return unit(utslvclauxiliary).TslToHexFormatStr(tsl);
|
||
end
|
||
function HexFormatStrToTsl(D);//将16进制字符串还原为tsl数据
|
||
begin
|
||
return unit(utslvclauxiliary).HexFormatStrToTsl(d);
|
||
end
|
||
function GetTextWidthAndHeightWidthFont(s,f,mul);//获得字体的绘制高度宽度
|
||
begin
|
||
return unit(utslvclgdi).GetTextWidthAndHeightWidthFont(s,f,mul);
|
||
end
|
||
function CallMessgeFunction(f,o,e); //执行消息回调
|
||
begin
|
||
return unit(utslvclauxiliary).CallMessgeFunction(f,o,e);
|
||
end
|
||
/////////////////////////初始化////////////////////////////////////
|
||
function initallib();
|
||
begin
|
||
class(tUIglobalData).uisetdata("G_F_CONTROL_IS_CUSTOMPAINT",thisfunction(controlisCustomPaint));
|
||
class(tUIglobalData).uisetdata("G_F_TWIN_PROC_",thisfunction(_twinproc_));
|
||
class(tUIglobalData).uisetdata("G_F_TIME_PROC_",thisfunction(_timeproc_));
|
||
class(tUIglobalData).uisetdata("G_T_TVCFORM_",class(TVCForm));
|
||
class(tUIglobalData).uisetdata("G_T_TTFM2COMPONET_",class(Ttfm2Component));
|
||
class(tUIglobalData).uisetdata("TGlobalComponentcache",class(TGlobalComponentcache));
|
||
class(tUIglobalData).uisetdata("TGlobalValues",class(TGlobalValues));
|
||
//导入注册的componet
|
||
vclini := pluginpath()+"tslvcl.ini";
|
||
if fileexists("",vclini) then
|
||
begin
|
||
ini := new TIniFileExta("",vclini);
|
||
ini.LowerKey := true;
|
||
for i,v in ini.ReadSectionValues("components") do //控件
|
||
begin
|
||
if v then
|
||
begin
|
||
cv := findclass(v);
|
||
if cv then
|
||
begin
|
||
RegisterComponentType(i,cv);
|
||
end
|
||
end
|
||
end
|
||
for i,v in ini.ReadSectionValues("propertys") do //属性
|
||
begin
|
||
if v then
|
||
begin
|
||
cv := findclass(v);
|
||
if cv then
|
||
begin
|
||
RegComponentPropertyType(createobject(cv));
|
||
end
|
||
end
|
||
end
|
||
end
|
||
|
||
end
|
||
function initlib();
|
||
begin
|
||
{**
|
||
@explan(说明) 初始化lib %%
|
||
**}
|
||
a := static initallib();
|
||
end
|
||
|
||
Initialization
|
||
initlib();
|
||
Finalization
|
||
end.
|
||
|
||
//if message in array(1,0x81)then
|
||
//begin
|
||
// obj := new tslcstructureobj(MemoryAlignmentCalculate(array(
|
||
// ("lpcreateparams","intptr",0),
|
||
// ("hinstance","intptr",0),
|
||
// ("hmenu","intptr",0),
|
||
// ("hwndparent","intptr",0),
|
||
// ("cy","int",0),
|
||
// ("cx","int",0),
|
||
// ("y","int",0),
|
||
// ("x","int",0),
|
||
// ("style","int",0),
|
||
// ("lpszname","intptr",0),
|
||
// ("lpszclass","intptr",0),
|
||
// ("dwexstyle","int",0))),lparam);
|
||
// echo tostn(obj._getdata_);
|
||
//end
|
||
//窗口
|
||
//type TSysControl=class(TWincontrol)
|
||
// {**
|
||
// @explan(说明) 系统绘制窗口,屏蔽绘制和背景处理,加快速度 %%
|
||
// **}
|
||
// function Create(AOwner);override;
|
||
// begin
|
||
// inherited;
|
||
// end
|
||
// function WMPAINT(o,e):WM_PAINT;override;
|
||
// begin
|
||
// if not Font.HandleAllocated()then
|
||
// begin
|
||
// FontChanged();
|
||
// end
|
||
// end
|
||
// function WMERASEBKGND(o,e):WM_ERASEBKGND;override;
|
||
// begin
|
||
// end
|
||
//end |