unit utslvcldlg;
interface
uses cstructurelib,utslvclauxiliary,utslvclmemstruct,utslvclbase,utslvclgdi,utslvclstdctl;
type TCommDlg=class(tcomponent)
    {**
    @explan(说明) 选择对话框类 %%
    **}
    private
    FChooseOk;
    [weakref]FWndOwner;
    FCaption;
    function SetParent(p);
    begin
        FWndOwner := p;
    end
    protected
    function SetCaption(v);virtual;
    begin
        FCaption := v;
    end
    public
    function create(AOwner);override;
    begin
        inherited;
    end
    function Notification(AComponent,Operation);override;
    begin
        if Operation=opRecycling then //opRemove
        begin
            if AComponent=FWndOwner then FWndOwner := nil;
        end
        inherited;
    end
    function OpenDlg();
    begin
        {**
        @explan(说明) 打开对话框 %%
        **}
        return FChooseOk := ChooseDlg();
    end
    function ChooseDlg();virtual;
    begin
        {**
        @explan(说明) 打开对话框虚函数
        **}
    end
    published
    property ChooseOk read FChooseOk;
    property WndOwner:variable read FWndOwner write FWndOwner;
    property Parent read FWndOwner write SetParent;
    property Caption:string read FCaption write SetCaption;
    {**
    @param(ChooseOk)(bool) 是否执行成功 %%
    @param(WndOwner)(TWinControl) 所属窗口 %%
    **}
end
type TcustommsgADlg=class(TCommDlg)
    {**
    @explan(说明) 消息提示框 %% 
    **}
    private
    FmbText;
    Fbtnvals;
    Ficonvals;
    Fbtnval;
    Ficonval;
    function setMbtext(v)
    begin
        if FmbText <> v then
        begin
            FmbText := v;
        end
    end
    function setcaption(v);override;
    begin
        if caption=v then exit;
        inherited;
    end
    function setmbbtnstyle(v)
    begin
        if Fbtnval <> v and(v in Fbtnvals)then
        begin
            Fbtnval := v;
        end
    end
    function setmbiconstyle(v)
    begin
        if Ficonval <> v and(v in Ficonvals)then
        begin
            Ficonval := v;
        end
    end
    public
    function create(AOwner);override;
    begin
        inherited;
        FmbText := "";
        caption := "提示";
        Fbtnval := 0;
        Ficonval := 48;
        Fbtnvals := array(0,1,2,3,4,5,6,16384);
        Ficonvals := array(48,64,32,16);
    end
    function ChooseDlg();override;
    begin
        hd := 0;
        if Parent is class(TWinControl)then hd := Parent.Handle;
        r := _wapi.MessageBoxA(hd,mbText,self.caption,Fbtnval .| Ficonval);
        return r;
    end
    {
    判断messagebox按钮是否被按下：根据 ChooseDlg()函数的返回值进行判断
    代码                值             描述   
    IDABORT    			3              "中止"按钮被选中
    IDCANCEL            2				"取消"按钮已被选中
    IDCONTINUE			11				"继续"按钮被选中
    IDIGNORE 			5				"忽略"按钮已被选中
    IDNO				7				在"NO"按钮被选中
    IDOK				1				"OK"按钮被选中
    IDRETRY				4				"重试"按钮被按下
    IDTRYAGAIN			10				"再试一次"按钮被按下
    IDYES 				6				"yes"按钮被选中			
    }
    published
    property mbText:string read FmbText write setMbtext;
    property mbbtnstyle:MBbtnstyle read Fbtnval write setmbbtnstyle;
    property mbiconstyle:MBiconstyle read Ficonval write setmbiconstyle;
    {**
    @param(mbText)(string)字符串%%
    @param(mbbtnstyle)(TMBbtnstyle)按钮样式%%
    @param(mbiconstyle)(TMBiconstyle)图标样式%%		
    **}
end
type tcustomcolordlg=class(TCommDlg)
    {**
    @explan(说明)颜色选择器 %% 
    **}
    private
    Fdlgcolor;
    function SetCustomColors(cols);
    begin
        if ifarray(cols)then
        begin
            Fdlgcolor.lpcustcolors._setvalue_(0,cols);
        end
    end
    function GetCustomColors();
    begin
        return Fdlgcolor.lpcustcolors._getdata_();
    end
    function SetResult(c);
    begin
        Fdlgcolor.rgbresult := c;
    end
    function GetResult()
    begin
        r := Fdlgcolor.rgbresult;
        return r;
    end
    public
    function create(AOwner);override;
    begin
        inherited;
        Fdlgcolor := new ttagCHOOSECOLORA();
    end
    function ChooseDlg();override;
    begin
        Fdlgcolor.flags := CC_RGBINIT .| CC_SOLIDCOLOR; //.| CC_SHOWHELP .| CC_SOLIDCOLOR;
        if WndOwner is class(TWinControl)then Fdlgcolor.hwndowner := WndOwner.Handle;
        r := _wapi.ChooseColorA(Fdlgcolor._getptr_);
        return r;
    end
    {**
    @param(CustomColors)(array of integer) 自定义颜色 %%
    @param(RgbResult)(integer) 颜色rgba值 %%
    **}
    published
    property CustomColors read GetCustomColors write SetCustomColors;
    property Result:color read GetResult write SetResult;

end
type tcustomfontdlg=class(TCommDlg)
    {**
    @explan(说明) 字体选择对话框 %%
    **}
    private
    FFontChoose;
    function SetFontInfo(v);
    begin
        FFontChoose.SetFontInfo(v);
        if ifnumber(v["color"])then FFontChoose.rgbcolors := v["color"];
    end
    function GetFontInfo();
    begin
        r := GetFont();
        if r is class(ttagLOGFONTA)then r := r._getdata_();
        if ifarray(r)then
        begin
            r["color"]:= FFontChoose.rgbcolors;
            fh := r["height"];
            if fh<0 then r["height"]:= abs(fh);
            fw := r["width"];
            if fw=0 then r["width"]:= integer(abs(fh/2));
            else if fw<0 then r["width"]:= abs(fw);
        end
        return r;
    end
    function GetFont();
    begin
        return FFontChoose.lplogfont;
    end
    function SetColor(v);
    begin
        FFontChoose.rgbcolors := V;
    end
    public
    function create(AOwner);override;
    begin
        inherited;
        FFontChoose := new ttagCHOOSEFONTA();
        FFontChoose.flags := CF_EFFECTS .| CF_INITTOLOGFONTSTRUCT; //.|CF_BOTH ;
    end
    function ChooseDlg();override;
    begin
        if WndOwner is class(TWinControl)then FFontChoose.hwndowner := WndOwner.Handle;
        return _wapi.ChooseFontA(FFontChoose._getptr_);
    end
    published
    property FontInfo:font read GetFontInfo write SetFontInfo;
    property color Write SetColor;

    {**
    @param(LogFont)(ttagLOGFONTA) 逻辑字体对象%%
    @param(FontInfo)(array) 字体信息数组 %%
    **}
end
type tcustomfolderdlg=class(TCommDlg)
    {**
    @explan(说明) 文件夹路径选择对话框 %%
    **}
    private
    FBrowse;
    FFolder;
    FRootFold;
    FRootStr;
    FEditBox;
    FDefaultDirstr;
    FDefaultDir;
    function SetDefaultDir(d);
    begin
        if ifstring(d)and d <> FDefaultDirstr then
        begin
            FDefaultDirstr := d;
            FDefaultDir.setv(d);
        end
    end
    function freeil();
    begin
        if FRootFold then _wapi.ILFree(FRootFold);
        FRootFold := nil;
        FRootStr := nil;
    end
    function SetEditBox(v);
    begin
        nv := v?true:false;
        if FEditBox <> nv then
        begin
            FEditBox := nv;
        end
    end
    function SetRootFold(p);
    begin
        if ifnil(p)then freeil();
        if not(p and ifstring(p))then exit;
        if FRootStr=p then exit;
        freeil();
        FRootFold := _wapi.ILCreateFromPathA(p);
        if FRootFold then FRootStr := p;
    end
    public
    function create(AOwner);override;
    begin
        inherited;
        FEditBox := true;
        FDefaultDir := new tcstring(1024);
        FBrowse := new TBrowseinfoA();
    end
    function ChooseDlg();override;
    begin
        if WndOwner is class(TWinControl)then FBrowse.hwndowner := WndOwner.Handle;
        if FRootFold then FBrowse.pidlroot := FRootFold;
        flg := 0x8;
        if FEditBox then flg .|= 0x00000010;
        //if FNewFolder then  flg .|=  0x00000040 .| 0x00000100 .| 0x00000080;
        FBrowse.ulflags := flg;
        if FDefaultDirstr then
        begin
            FBrowse.lparam := FDefaultDir.ptr;
            FBrowse.lpfn := getdlgcall(0x11);
        end
        ft := _wapi.SHBrowseForFolderA(FBrowse._getptr_);
        if not ft then return 0;
        s := s1 := "";
        setlength(s1,1024);
        f := _wapi.SHGetPathFromIDListA(ft,s1);
        if not f then return 0;
        for i := 1 to length(s1) do
        begin
            ts := s1[i];
            if ts="\0" then break;
            s += ts;
        end
        FFolder := s;
        return true;
    end
    published
    property DefaultDir read FDefaultDirstr write SetDefaultDir;
    property RootFolder:directory read FRootStr write SetRootFold;
    property Folder read FFolder;
    property EditBox:bool read FEditBox write SetEditBox;
    {**
    @param(Folder)(string) 文件夹路径 %%
    **}
end
type tcustomfsdlg = class(TCommDlg)
    {**
    @explan(说明) 保存文件,获得文件名 %%
    @param(FFileTag)(TtagOFNA)openfile 对象 %%
    **}
    protected 
    FFileTag;
    function dlgType();virtual;
    begin
        //对话框类型：0x1：保存为窗口。0x2：打开窗口。
        return 1;
    end
    function setCaption(s);override;
    begin
        if ifstring(s)then
        begin
            inherited;
            FFileTag.lpstrtitle := s;
        end
    end
    private
    FFilter;
    Ffilterindex;
    fIsShowHidden;
    fIsMultiselected;
    fIsOverwritePrompt;
    fIsLinkFilePath;
    fIsCreatePrompt;
    fIsFileMustExist;
    finitialdir;
    function setFlagsBit(b,m,n);
    begin
        //b：要设置的位的值，m：要设置的位的值的保存成员，n：要设置的位。
        if xor(b,m)then
        begin
            if b then FFileTag.Flags .|= n;
            else FFileTag.Flags :=.!((.!FFileTag.Flags).| n);
            m := b;
        end
    end
    function setShowHidden(b);
    begin
        setFlagsBit(b,fIsShowHidden,0x10000000);
    end
    function setMultiSelected(b);
    begin
        tb := fIsMultiselected;
        setFlagsBit(b,fIsMultiselected,0x200);
        if b and tb <> fIsMultiselected then
        begin
            s := "";
            setlength(s,1024 * 16);
            FFileTag.lpstrfile := s;
        end
    end
    function setOverwritePrompt(b);
    begin
        setFlagsBit(b,fIsOverwritePrompt,0x2);
    end
    function setLinkFilePath(b);
    begin
        setFlagsBit(b,fIsLinkFilePath,0x100000);
    end
    function setCreatePrompt(b);
    begin
        setFlagsBit(b,fIsCreatePrompt,0x2000);
    end
    function setFileMustExist(b);
    begin
        //FFileTag.SetValue();
        setFlagsBit(b,fIsFileMustExist,0x1000);
    end
    function GetResult();
    begin
        return FFileTag.lpstrfile;
    end
    function setfilter(f);
    begin
        {**
        @explan(说明)设置筛选条件%%
        @param(f)(array)筛选条件采用字符串下标的字符串数组,下标作为显示,值作为筛选条件 
        array("所有文件":"*.*","tsl流文件":"*.stm")
        %%
        **}
        if FFilter=f then exit;
        s := "";
        rf := array();
        if ifarray(f)then
        begin
            for i,v in f do
            begin
                if v and ifstring(v)and ifstring(i)then
                begin
                    s += i+"\0"+v+"\0";
                    rf[i]:= v;
                end
            end
        end
        if length(s)then
        begin
            s += "\0";
            FFileTag.lpstrfilter := s;
            FFilter := rf;
        end
        Ffilterindex := 1;
    end
    function OpenFileDlg();virtual;
    begin
        r := _wapi.GetSaveFileNameA(FFileTag._getptr_);
        return r;
    end
    function setDefaultFileExtension(s);
    begin
        if ifstring(s)then FFileTag.lpstrdefext := s;
    end
    function getDefaultFileExtension();
    begin
        return FFileTag.lpstrdefext;
    end
    function setInitialDir(s);
    begin
        if ifstring(s)and s <> "" then
        begin
            finitialdir.setv(s);
            FfileTag.lpstrinitialdir := finitialdir.ptr;
        end else
        FfileTag.lpstrinitialdir := 0;
    end
    function getInitialDir();
    begin
        if FFileTag.lpstrinitialdir=finitialdir.ptr then return finitialdir.getv();
        else return "";
    end
    public
    function create(AOwner);override;
    begin
        inherited;
        FFileTag := new TtagOFNA();
        FFileTag.Flags .|= 0x80000; // .|  OFN_ENABLEHOOK;
        //FFileTag.hinstance := happ;
        //FFileTag.lpfnHook := getwinprocptr(0x10);			
        finitialdir := new tcstring(512);
        //FFileTag.lcustdata := finitialdir._getptr_;// 0x178;
        //echo tostn(FFileTag._getdata_);
    end
    function getSelectedItemName();
    begin
        {**
        @explan(说明)获取所选择文件的文件名%%
        @return(string)当选择不止一个文件时，该函数返回首文件名。%%
        **}
        return FFileTag.lpstrfiletitle;
    end
    function ChooseDlg();override;
    begin
        {**
        @explan(说明)打开一个对话框以使用户选择将要打开或保存的文件的路径%%
        @return(bool)是否选择了有效的文件路径%%
        **}
        if WndOwner is class(TWinControl)then FFileTag.hwndowner := WndOwner.Handle;
        if Ffilterindex>0 and FFilter then FFileTag.nfilterindex := Ffilterindex;
        FFileTag.lpstrfile := "\0\0";
        FFileTag.lpstrfiletitle := "";
        r := OpenFileDlg();
        if FFilter then Ffilterindex := FFileTag.nfilterindex;
        return r;
    end
    function getResults();
    begin //r2
        {**
        @explan(说明)获取所选择文件的完整路径%%
        @return(array)所选择文件路径的数组%%
        **}
        s := FFileTag._getvalue_("lpstrfile",FFileTag.nmaxfile);
        r := array();
        i := 0;
        l := length(s);
        while i <= l and s[++i]<> '\0' do;
        if not i then return r;
        t := s[1:i-1];
        if not Multiselected or(i<l and s[i+1]='\0')then return array(t);
        t += ioFileseparator(); // '\\';
        b := i;
        while++i <> l do if s[i]='\0' then
        begin
            r[j++]:= t+s[b+1:i-1];
            if s[i+1]='\0' then break;
            b := i;
        end
        return r;
    end
    published
    property filter:filefilter read FFilter write setfilter;
    property filterindex read Ffilterindex write Ffilterindex;
    property FileName read GetResult;
    // property struct read FFileTag write FFileTag;
    property DefaultFileExtension:string read getDefaultFileExtension write setDefaultFileExtension;
    property initialDir:filename read getInitialDir write setInitialDir;
    property ShowHidden:bool read fIsShowHidden write setShowHidden;
    property Multiselected:bool read fIsMultiselected write setMultiselected;
    property OverwritePrompt read fIsOverwritePrompt write setOverwritePrompt;
    property LinkFilePath read fIsLinkFilePath write setLinkFilePath;
    property FileMustExist:bool read fIsFileMustExist write setFileMustExist;
    property CreatePrompt read fIsCreatePrompt write setCreatePrompt;
    
    {**
    @param(filter)(array) array("所有文件":"*.*","tsl流文件":"*.stm")%%
    @param(FileName)(string) 文件名,不成功返回上一次的结果。 %%
    @param(DefaultFileExtension)(string) 默认扩展名，当文件名输入框中未指定扩展名且未选择保存类型时将使用该扩展名，用于保存对话框。 %%
    @param(initialDir)(string) 默认打开路径 %%
    @param(caption)(string) 对话框名称。%%
    @param(ShowHidden)(bool) 是否强制显示隐藏文件。 %%
    @param(Multiselected)(bool) 可多选，用于打开对话框。 %%
    @param(OverwritePrompt)(bool) 开启覆盖保存提醒，用于保存对话框。 %%
    @param(LinkFilePath)(bool) 若所选为快捷方式文件则返回该文件本身路径；默认返回其指向文件的路径。 %%
    @param(CreatePrompt)(bool) 若在文件名输入框中输入不存在的文件名则提示是否创建；默认则不提示而直接返回路径，用于打开对话框。 %%
    @param(FileMustExist)(bool) 若在文件名输入框中输入不存在的文件名则提示文件名不存在；默认则不提示而直接返回路径，用于打开对话框。 %%
    **}
end
type TcustomTipMessageButton = class(TGraphicControl)
{**
    @ignore(忽略) %%
    @explan(说明) 提示按钮 %%
**}
    public
    function Create(AOwner);override;
    begin
        inherited;
        height := 18;
        width := 18;
        caption := "提示信息";
        fmessageCaption := nil;
        fmessageText := nil;
        fimageType := 0;
        fmessagebox := new TcustommsgADlg(AOwner);
        setMessageCaption("提示");
    end
    function MouseUp(o,e);override;
    begin
        inherited;
        if e.skip then return;
        if not fmessagebox.parent then fmessagebox.parent := parent;
        if fmessageText=nil then fmessagebox.mbText := caption;
        fmessagebox.ChooseDlg();
    end
    procedure Paint();override;
    begin
        {**
        @explan(说明)控件绘制调用 ,使用Canvas属性和PAINTSTRUCT结构体 绘制控件 %%
        **}
        reset_tn();
        Canvas.StretchDraw(array(0,iconTop,iconSidelength,iconSidelength+iconTop),ftipImage.getImage(fimageType));
        if iconSidelength<width then
        begin
            canvas.font := font;
            canvas.drawtext(caption,array(iconSidelength,0,width,height),36);
        end
    end
    function setIconSize(l);
    begin
        {**
        @explan(说明) 设置提示图标的边长，设置之后图标大小就不会根据控件大小变化而变化。%%
        @param(l)(integer)要设置的长度，以像素为单位，为nil时取消设置%%
        **}
        if l <> nil then
        begin
            isConstIconSize := 1;
            iconSidelength := l;
        end else
        isConstIconSize := 0;
    end
    function getIconSize();
    begin
        {**
        @explan(说明) 获取提示图标的边长%%
        @return(integer)边长%%
        **}
        if isConstIconSize then return iconSidelength;
        reset_tn();
        return iconSidelength;
    end
    function setIconType(i);
    begin
        {**
        @explan(说明) 设置显示的提示图标类型%%
        @param(l)(integer)0:疑问，默认
        1：错误
        2：消息
        3：警告%%
        **}
        if(ifint(i)or ifint64(i))and i >= 0 and i<5 then
        begin
            if fimageType <> i then
            begin
                fimageType := i;
                if parent then invalidateRect(nil,1);
            end
            return 1;
        end
        return 0;
    end
    published
    property messageText:string read fmessageText write setMessageText;
    property messageCaption:string read fmessageCaption write setMessageCaption;
    property showInfomationIcon:bool read isInfomationIcon write setInfomationIcon;
    {**
    @param(messageText)(string)要显示的提示对话框的文字%%
    @param(messageCaption)(string)要显示的提示对话框的标题%%
    @param(showInfomationIcon)(bool)提示对话框内是否显示一个消息图标%%
    **}
    protected
    class function Sinit();override;
    begin
        inherited;
        if not ftipImage then ftipImage := new TTipImage();
    end

    private
    type TTipImage=class()
        public
        function create();
        begin
            init();
        end
        function getImage(n);
        begin
            return imageData[n];
        end
        private
        {
        0:state_unknown		○?
        1:state_error		○!
        2:state_hint		○i
        3:state_warning		△!
        4:state_infomation	□
        }
        function init();
        begin
            imageData := array();
            imageData[0]:= "0502000000060400000074797065000203000000696D670006040000006461746
100026502000089504E470D0A1A0A0000000D4948445200000010000000100806
0000001FF3FF61000000017352474200AECE1CE90000000467414D410000B18F0
BFC6105000000097048597300000EC300000EC301C76FA864000001FA49444154
384FA590C16BD37014C7FD63A617118F3B78F0A6C2849D062AEEB08322E261301
0E7CDE1C58975177187ECB0218A8843F0302C8C6DB0D16DD0DAAEB16BBB68D3AD
59D3C43499499A768D7ECD7BD01FCD7612BFF08197F7BEDF6F48CEE03F75AAC07
4427C5CF1F1447270FFB9C5D04C3BBA9D54AC6035ED623CA1E1CD928DEFB56304
9D3F0CCDB4A31B79FA250A92290B77A68A500E5A08C310DD6E3706EDE8461EF2F
6C40587668091896D942ABFD06EB71104012E8DAEC5D8CC36F8461EF2524614CC
2CEC627A4E86EFFB705D97997D5F661E25BEE2C2F067CCCCE7794F9E6792CC195
170FD5E12E96F061CC71198A6095555F142DAC4C0950F989C5E462693412EB783
D594C21951707EE8132CDB43B3D9846118D8DB5322631ED2DB14CE5E5DC4AD893
528CA0F64B33BCC6EB1C2195170713809ABE941D3EA2814CA90E52273EEDA1253
A91C881D51285639230A46C6B3D14F32502E57512AA902CB3A62FA77C4F27A953
3A2E0D5BB46F41335ECEF1BD1DBEA82C19B05A67FA7AA3A9EBEAE724614D4CD2E
6E3CD491CEBBD16738A8D56CE6F298C6F49E8954DA662F654401E9CB4607A3933
6327280462380AE07F0BC90A19976DBB9166E471EF2F6240A485CF2D8C1CB053F
321F43AB87D00E436CE53A48CC7B51D8898549B10292FEF337A4C516EE4E1D61E
881CDD04C3BBA9DD4A9827F13F017E5DF89FE289AB2290000000049454E44AE42
608200";
            imageData[1]:= "0502000000060400000074797065000203000000696D670006040000006461746
10002C502000089504E470D0A1A0A0000000D4948445200000010000000100806
0000001FF3FF61000000017352474200AECE1CE90000000467414D410000B18F0
BFC6105000000097048597300000EC300000EC301C76FA8640000025A49444154
384FA592FB4B53611CC6FB63C2B40B2111843F686988D9C598E6A5EDB09B735B2
DA78C4CCAA9BB485B91E8424C22B6650E85A0A00B545A1121116194457431529B
6B37DBDCA6672B787ADF77E76C893F450FBC3F7D9FCFF3BD9CB309FFA90D01BFF
B4E2063D7236DD562AD578354B71A892E25E267E5F87986135C79AD0BC8823A2C
DB5A91F4B9C0DFF5B097F00D2268D6216C6A42B0BD5E7067950B48DB74E02D2D8
80FDBF16B6A02FCE805AC3A4FB2C75F772233398E88AB07DF0D122CE86B044A08
E02D5AACF668101BB631386555B3272AD1AD246B28907EE043E8D2397C6DAEC66
75515ABB100BA67C462C8C3161592BD2A66A0A2FBC73AC90D3A38F0F7C630D7C6
E10357C16A2C801AE89EBCD7C140B1A3280A2E9B6488B44911BF6C45E48A136F1
B4B598D05443BA4E0EF7B91B46B1928761445C170EB71840CE4884639E2E35731
535BC26A2C20D8DE80B53B1EAC90CF268E4A3B663ECE3213057FE81B11D036206
0E0101F1BC1CB9ADDACC602FCA72488B9FB911CB1E746A51DE3D70690B8E563E0
92A61E7ED531849D660406FB305D5D9C0F98D71DC13793824C7123372AED288A8
28BCA3A2CC86BB132E1C61BE5513CABDCC16A2CE08BFA003E292AB1E4E844EAF6
68AE63D4E524DFDEC1C0794EC2E039B3114FF76FC3E3F2A27C00D57B5939669BC
AB0683F8DE44D2F2217C94FA39561B1458AD07933391C81BB8C78525184A97D5B
04EAAF00AAD775257825D98377CD120406C83D3C4388BA87E0EFB761863B44C04
23C2A2B10DC59AD0BA07A717817A60F16E379D54EB2E77632EE56326E2126F716
E061E966C195D786807F13F007E8743A916FA8D5250000000049454E44AE42608
200";
            imageData[2]:= "0502000000060400000074797065000203000000696D670006040000006461746
100026F01000089504E470D0A1A0A0000000D4948445200000010000000100806
0000001FF3FF61000000017352474200AECE1CE90000000467414D410000B18F0
BFC6105000000097048597300000EC300000EC301C76FA8640000010449444154
384FC590CD4EC24014467D4C1FC23720AE890FC082858961876B6358E24A59904
0F83102024A2920CA6F202632F7F3DEA197D0306D349A709259F44ECF99764EF0
47FE2F709ACCFD6A29A140F6AE81AF8D09266E6E0A9D50C406746088305B13460
B823F277853C2CB84D07E2734DF0C5ABC84C4D5FD61E02C95B783218BFE8CD063
B9FB41780EE4C7A141CDDF062EAE8BD1813ECBAF7CAA95C784C6682B57592E7B3
10159F20BF2F91D3EB535367862B93E30A8B05C62B9EC6DAC749E7908070419C8
254A641FF99A52CFD8B0E0BC444187FBEB32570B7681E9F2D33EEB9EB20BB8901
707939553542203F272FAB61A292ACE804A71A212FB0B3FE1D801E01BC7E9AA1F
1B492A780000000049454E44AE42608200";
    imageData[3]:= "0502000000060400000074797065000203000000696D670006040000006461746
100029B02000089504E470D0A1A0A0000000D4948445200000010000000100806
0000001FF3FF61000000017352474200AECE1CE90000000467414D410000B18F0
BFC6105000000097048597300000EC300000EC301C76FA8640000023049444154
384FA5924B68135114860342C1858208BA1041B42A528A146BADA5ED4A70272AD
5048D2EA48B2E74D195B85044280A165D3488A216DA8A521F68D5FAC65402DAE2
BBCD63F268A3C699BC6D329919F398CCEF99C9A531A45D883FFC309C7BFEEF70C
F5C13FE530B0212F636C45FB522F6A2059167DB59B55A0B02F470DAD983D4D733
088F6E63D56ACD0BD0C3519A5CCCA7919F754178B8153FEF6F61A7959A17107DD
E0291B3415333D0F261A4A62E2274B7819D56AA0AA087234F9B81620EB9A80DF9
783F4112F83EBC19DF6ED6B3AEB2AA007A580A0E533E09F750BB61557622ED19C
4CC501DEB2AAB021079D28CE47837A0E520050EC335D86E58F25AA11592E05F76
C17F6D03EB2E690EA08785C74DF81D1BA7E509907C87E01A68332C7ACC5033EF2
085C6E0BD520BEED25A96FA0B203C6A426AB29726C590156C04B0627A642703EC
87ECB7A2989D4178EC249C1756B31403E8617EA491C2191444079480D50028C14
EC4DF9B21BAF741F676201BB6A12085F0E5EC4A7C3CBDBC0CE01F34D292AED3E2
C2C8F2E7A1F80F10E060F90AEE0EC8DC5E48EEDD50150EBCFD1C264E2C2D01F47
0C47E84FEB9448F6614B2CF6238C3D1648F85C2165AA299007B20797641F1512F
5D73B26F071CC76A600ADD6B801C7A6D00B4C22CF957C92A7DEB9EAB259913541
711FF74076FBA16C1F4E3363D905BF508DEA8C3F4C02604FA37C277753DBC97D7
C1DDB70653BDABF0B967053E9C5A8689E34BF0B67B311C476B8CB0BDD354F90EF
E5DC01F26687F1D27F303B60000000049454E44AE42608200";
            imageData[4]:= "0502000000060400000074797065000203000000696D670006040000006461746
10002F002000089504E470D0A1A0A0000000D4948445200000010000000100806
0000001FF3FF61000000017352474200AECE1CE90000000467414D410000B18F0
BFC6105000000097048597300000EC300000EC301C76FA8640000028549444154
384FA591CB4F136114C5FD9F9C71634C646188090644C18588A60852C028442D6
2202A1429EFB6D08729050BC8A3CAAB552A9456DA0E15C7D287057948DA8AC1C4
44571A8D28C73BD3490B61653CC959CD3DBF7BCF7C87F09F3A00C835ACE2942E8
A2C4D04275A03C868E171BC6591ECC7B1079C3495D63E40B67E0527D56194F585
D0E78E638CDB12DDEB8C41A67F05B6760E6C9D539A4E2A0510B666B605D13AB50
647601B3D337128ADEF707F64056ADB1AAC9E041AC7A260CB27C15E9B94521220
4B1B4166FB9218B6BDDE462D856E0F8631ECFB80616F02B72C212806C2B0CC6D4
2F92404B6C40AB678240DC8542FA1D414809DFF849AC1281454E1863988EF3F77
44579A7954F6F0503C0A60F0650CE79B5F802918480332DA79EA1987D6B6819B7
D41549903A834F1E8776FC2422E3772491B7C542B0CFDCC2AD87C731A7054C961
62F1236AFA43B4E90D2A1EFA6938F9C777C9729D17A55DF3640FAE1ABCB072313
067BAC5EF2280AD7363DCBF2576153695E97D14F2211AFF8A6F3F7650D2E94671
870B97C9728D0BA30B04C8D1EC053861726E40F5741915063FE4DD5E5CD1CEE36
DEC0B017EA1A8651645D45BD6EC40750F07AD2302F674E71E40B503856A37863D
7154E838C8D51E38F8047EFFD9152B84DE7F46A1D24EB6C1F82C8AFC3B6304E81
0A212E0FA3858B915F74683B038D751A27641D63A838BAA691436D870A17E1205
F513681B0DD0F32ED0F92AB0E4144010231BC2E1BC5ED40ED18BCCAE4261F2D2C
9CF71A9D18E2A9D0B7A5B188A7E0E6C76432A2C280510C4E4F782C933E2DCDD29
68A797F1D8BB415E47A73D82DC1A2B98EC460A3749D349ED030862CFEAE989BAC
0E46AE8D4660A35891B051FC96990A6D23A00F837017F01AE4B3263C856875900
00000049454E44AE42608200";
            for i := 0 to length(imageData)-1 do
            begin
                t := new tcustombitmap();
                t.Readvcon(HexFormatStrToTsl(imageData[i]));
                imageData[i]:= t;
            end
        end
        imageData;
    end
    function setMessageText(str);
    begin
        fmessageText := str;
        fmessagebox.mbText := str;
    end
    function setMessageCaption(str);
    begin
        fmessageCaption := str;
        fmessagebox.Caption := str;
    end
    function setInfomationIcon(b);
    begin
        isInfomationIcon := b?1:0;
        fmessagebox.mbiconstyle := isInfomationIcon?0x40:0;
    end
    function reset_tn();
    begin
        //重新计算图标的边长及位置
        if not isConstIconSize then iconSidelength := height<width?height:width;
        iconTop :=(height-iconSidelength)/2;
        if iconTop<0 then iconTop := 0;
    end
    isConstIconSize;//控件显示的图标尺寸是否不变
    iconSidelength;//控件图标边长
    iconTop;//控件图标位置
    fmessageCaption;//对话框标题
    fmessageText;//对话框内容
    isInfomationIcon;
    fimageType;//控件图标类型
    fmessagebox;
    static ftipImage;
end	 

type TcustomInPutQuerys= class(tcustomscrollcontrol)
    {**
    @ignore(忽略) %%
    @explan(说明) 输入 %%
    **}
    {**
    @example(输入范例) 
    wd := new TInPutQuerys();
    d := array(("name":"A","value":100,"Comment":"年龄","readonly":0),
    ("Name":"b","value":10,"caption":"工作年限","readonly":1));
    wd.SetData(d);
    if wd.ShowDlg(r,"get") then echo tostn(r);
    **}
    protected
    class Function Sinit();override;
    begin
        inherited;
        if not SHashInited then
        begin
            SHashInited := 1;
            RegisterInputType(array(class(TInputString),class(TInputInteger),
                             class(TInputFile),class(TInputPath),class(TInputPassWord),
                             class(TInputBool)));
        end
    end
    public
    function Create(AOwner);
    begin
        inherited;
        caption := "input";
        visible := false;
        wspopup := true;
        wscaption := true;
        FBOk := new TInputBtn(self);
        FBOk.caption := "确定";
        FBOk.onclick := thisfunction(OnOkClk);
        FBOk.parent := self;
        FTips := array();
        FBCancel := new TInputBtn(self);
        FBOk.NextCtrl := FBCancel;
        FBCancel.caption := "取消";
        FBCancel.onclick := thisfunction(OnCancelClk);
        FBCancel.parent := self;
        FLabels := FEdits := array();
        height := 150;
        width := 400;
    end
    function SetData(d);
    begin
        {**
        @explan(说明) 输入框 %%
        @param(d)(array) 二维表,列标为 name ,value ,caption %%
        **}
        if FSetData=d then return;
        FSetData := d;
        r := RegularData(d);
        FInfoa := r;
        return RebuildInput();
    end
    function ShowDlg(result,c);
    begin
        {**
        @explan(说明) 显示输入框 %%
        @param(result)(array) 返回值 %%
        @param(c)(string) 标题 ,可以忽略%%
        **}
        if ifstring(c)then caption := c;
        if ShowModal()then
        begin
            for i,v in FLabels do
            begin
                FInfo[FInfoa[i,"name"]]:= FEdits[i].value;
            end
            result := FInfo.ToArray();
            return true;
        end
    end
    function ShowQuerys(result,t);
    begin
        {**
        @explan(说明) 根据位置显示输入框 %%
        @param(result)(array) 返回值 %%
        @param(t)(string) 标题,可以忽略 %%
        **}
        c := array(200,200);
        _wapi.GetCursorPos(c);
        Left := c[0]>50?(c[0]-50):100;
        top := c[1]>50?(c[1]-50):100;
        return ShowDlg(result,t);
    end
    function OnOkClk();
    begin
        EndModal(1);
    end
    function OnCancelClk();
    begin
        EndModal(0);
    end
    function DoWMSIZE(o,e);override;
    begin
        h := clientrect;
        ht := h[3]-h[1];
        wd := h[2]-h[0];
        FBOk.Left := wd/2-50;
        FBOK.top := ht-33;
        FBCancel.Left := FBOk.Left+FBOK.Width+20;
        FBCancel.top := ht-33;
    end
    class function RegisterInputType(t);
    begin
        {**
        @explan(说明) 注册input类型 %%
        @param(t)(TInputEditor) 编辑类 %%
        **}
        if t is class(TInputEditor)then
        begin
            if not SFInputType then SFInputType := new tstrindexarray();
            return SFInputType[t.classtype]:= t;
        end else
        if ifarray(t)then
        begin
            for i,v in t do RegisterInputType(v);
        end
    end
    class function GetInputType(n);
    begin
        {**
        @explan(说明) 获得注册类型 %%
        **}
        if SFInputType and ifstring(n)then return SFInputType[n];
    end
    function Recycling();override;
    begin
        inherited;
        FSetData := nil;
        FInfoa := nil;
        FInfo := nil;
        FBOk := nil;
        FBCancel := nil;
        FLabels := nil;
        FEdits := nil;
        FTips := nil;
    end
    private
    function RebuildInput();
    begin
        ld := length(FInfoa);
        lb := length(FLabels);
        lp := length(FTips);
        for i := 0 to lp-1 do FTips[i].Recycling();
        for i := 0 to lb-1 do
        begin
            FLabels[i].Recycling();
            FEdits[i].Recycling();
        end
        FLabels := array();
        FEdits := array();
        for i := 0 to ld-1 do
        begin
            FLabels[i]:= new TcustomLabel(self);
            tp := FInfoa[i]["type"];
            if ifstring(tp)then
            begin
                tp := GetInputType(tp);
            end
            if ifobj(tp)then FEdits[i]:= createobject(tp,self);
            else FEdits[i]:= new TInputString(self);
            syg := FEdits[i-1];
            if syg then
            begin
                syg.NextCtrl := FEdits[i];
            end
            if i=ld-1 then FEdits[i].NextCtrl := FBOk;
        end
        sp := 5;
        for i,v in FInfoa do
        begin
            lb := FLabels[i];
            le := FEdits[i];
            lb.caption := v["caption"];
            lb.left := 20;
            vtp := v["tip"];
            if ifstring(vtp)and vtp then
            begin
                tp := new TcustomTipMessageButton(self);
                tp.caption := vtp;
                tp.left := 2;
                tp.top := sp+3;
                FTips[length(FTips)]:= tp;
                tp.parent := self;
            end
            lb.top := sp;
            lb.width := length(v["caption"])* 8+3;
            le.value := v["value"];
            le.top := lb.top;
            le.left := lb.width+lb.left;
            if v["readonly"]then
            begin
                if le is class(tcustomedit)then le.readonly := true;
                else le.Enabled := false;
            end else
            begin
                if le is class(tcustomedit)then le.readonly := false;
                else le.Enabled := true;
            end
            wd := max(le.left+le.width+10,wd);
            sp += max(lb.height,le.height);
            sp += 4;
            le.SetInfo(v);
            le.parent := self;
            lb.parent := self;
        end
        width := wd+10;
        height := sp+60+10;
        //echo "\r\nin thisf function:",wd,"===",(sp+60);
        //echo "\r\nin thisf function:",width,"===",height;
    end
    function Tostr(v);
    begin
        if not ifstring(v)then return tostn(v);
        return v;
    end
    function RegularData(d);
    begin
        r := array();
        FInfo := New tstrindexarray();
        v := new tstrindexarray();
        for i in d do
        begin
            vi := d[i];
            if not ifarray(vi)then continue;
            v.Data := vi;
            vn := v["name"];
            //if not ifstring(vn) then continue;
            if FInfo[vn]then continue;
            FInfo[vn]:= 1;
            r[idx,"name"]:= vn;
            r[idx,"caption"]:= v["caption"]?:(v["Comment"]?: wn);
            for j in v.IndexNames() do
            begin
                if j in array("caption","name")then continue;
                vj := v[j];
                r[idx,j]:= vj;
            end
            idx++;
        end
        return r;
    end
    FSetData;
    FInfoa;
    FInfo;
    FBOk;
    FBCancel;
    [weakref]FLabels;
    [weakref]FEdits;
    FTips;
    static SFInputType;
    static SHashInited;
end 
type TInputEditor=class()
    {**
    @ignore(忽略) %%
    @explan(说明)输入框注册控件基类 %%
    **}
    class function ClassType();
    begin
        {**
        @explan(说明) 类型名字 %%
        @return(string) 名字 %%
        **}
        return "";
    end
    function OnNextKeyPress(o,e);virtual;
    begin
        {**
        @explan(说明) key值判断 %%
        **}
        if e.CharCode=0x9 then FocusNext();
    end
    function FocusNext();virtual;
    begin
        {**
        @explan(说明) 设置下一个获得焦点 %%
        **}
        if NextCtrl is class(TWinControl)then
        begin
            NextCtrl.SetFocus();
        end
    end
    function SetInfo(info);virtual;
    begin
        {**
        @explan(说明) 设置额外信息 %%
        @param(info)(array) 信息 %%
        **}
    end
    published
    property NextCtrl read FNextCtrl Write FNextCtrl;
    property Value read GetValue write SetValue;
    {**
    @param(NextCtrl)(TInputEditor) 下一个控件 %%
    @param(Value)(any) 值 %%
    **}
    private
    function GetValue();virtual;
    begin
    end
    function SetValue();virtual;
    begin
    end
    FNextCtrl;
end
implementation
type tinputbool=class(tcustomcheckbtn,TInputEditor)
    {**
    @explan(说明) 输入框 %%
    **}
    class function ClassType();override;
    begin
        return "bool";
    end
    function Create(AOwner);override;
    begin
        inherited;
        width := 16;
        height := 17;
        OnKeyPress := thisfunction(OnNextKeyPress);
    end
    function Recycling();override;
    begin
        NextCtrl := nil;
        inherited;
    end
    private
    function GetValue();virtual;
    begin
        return Checked;
    end
    function SetValue(v);virtual;
    begin
        Checked := v;
    end
end
type TInputString=class(tcustomedit,TInputEditor)
    {**
    @explan(说明) 输入框 %%
    **}
    class function ClassType();override;
    begin
        return "string";
    end
    function Create(AOwner);override;
    begin
        inherited;
        width := 300;
        OnKeyPress := thisfunction(OnNextKeyPress);
    end
    function Recycling();override;
    begin
        NextCtrl := nil;
        inherited;
    end
    private
    function GetValue();virtual;
    begin
        return text;
    end
    function SetValue(v);virtual;
    begin
        text := v;
    end
end
type TInputPassWord=class(tcustompassword,TInputEditor)
    {**
    @explan(说明) 输入框 %%
    **}
    class function ClassType();override;
    begin
        return "password";
    end
    function Create(AOwner);override;
    begin
        inherited;
        width := 300;
        OnKeyPress := thisfunction(OnNextKeyPress);
    end
    function Recycling();override;
    begin
        NextCtrl := nil;
        inherited;
    end
    private
    function GetValue();virtual;
    begin
        return text;
    end
    function SetValue(v);virtual;
    begin
        text := v;
    end
end
type TInputInteger=class(TInputString)
    class function ClassType();override;
    begin
        return "integer";
    end
    function Create(AOwner);override;
    begin
        inherited;
        OnKeyPress := thisfunction(InPutChar);
    end
    function InPutChar(o,e);
    begin
        cd := e.CharCode;
        if cd=VK_BACK or cd=VK_DELETE then return;
        if cd=VK_TAB then OnNextKeyPress(o,e);
        else
        begin
            if not(cd >= ord("0")and cd <= ord("9"))then
            begin
                e.skip := true;
            end
        end
    end
    private
    function GetValue();override;
    begin
        return StrToIntDef(self.Text,0);
    end
    function SetValue(v);override;
    begin
        if ifnumber(v)then Text := IntToStr(v);
    end
end
type TInputBtn=class(tcustombtn,TInputEditor)
    {**
    @explan(说明) 按钮 %%
    **}
    function Create(AOwner);override;
    begin
        inherited;
        height := 25;
        OnKeyPress := thisfunction(OnNextKeyPress);
    end
    function Recycling();override;
    begin
        NextCtrl := nil;
        inherited;
    end
end
type TEditAndBtnUni=class(tcustomcontrol)
    {**
    @explan(说明)  edit button 组合 %%
    **}
    private
    FBtn;
    FText;
    public
    function BtnClick(o,e);virtual;
    function WMSETFOCUS(o,e):WM_SETFOCUS;override;
    begin
        if FBtn then FBtn.SetFocus();
    end
    function Create(AOwner);override;
    begin
        inherited;
        Height := 22;
        FBtn := new tcustombtn(self);
        FBtn.caption := "..";
        FText := new tcustomedit(self);
        //FText.Border := true;
        FText.caption := "";
        FBtn.Parent := self;
        FText.Parent := self;
        FBtn.OnClick := thisfunction(BtnClick);
        FText.OnKeyUP := function(o,e)
        begin
            if e.CharCode=VK_TAB then
            begin
                self.parent._send_(WM_USER,3,self.Handle);
            end
        end
    end
    function DoControlAlign();override;
    begin
        c := clientRect;
        FBtn.SetBoundsRect(array(C[2]-18,1,C[2]-3,c[3]-2));
        FText.SetBoundsRect(array(c[0]+1,c[1]+1,c[2]-22,c[3]-2));
    end
    published
    property Text read GetText Write SetText;
    private
    function GetText();
    begin
        return FText.Text;
    end
    function SetText(v);
    begin
        FText.Text := v;
    end
end
type TInputFile=class(TEditAndBtnUni,TInputEditor)
    class function ClassType();override;
    begin
        return "file";
    end
    function Create(AOwner);override;
    begin
        inherited;
        width := 300;
        height := 30;
    end
    function BtnClick(o,e);override;
    begin
        if not FFile then
        begin
            FFile := new tcustomfsdlg(self);
            FFile.parent := self;
        end
        if FFile.ChooseDlg()then
        begin
            text := FFile.FileName;
        end
    end
    private
    function GetValue();override;
    begin
        return text;
    end
    function SetValue(v);override;
    begin
        text := v;
    end
    FFile;
end
type TInputPath=class(TEditAndBtnUni,TInputEditor)
    class function ClassType();override;
    begin
        return "path";
    end
    function Create(AOwner);override;
    begin
        inherited;
        width := 300;
        height := 30;
    end
    function BtnClick(o,e);override;
    begin
        if not FFile then
        begin
            FFile := new tcustomfolderdlg(self);
            FFile.parent := self;
        end
        if FFile.ChooseDlg()then
        begin
            text := FFile.Folder;
        end
    end
    private
    function GetValue();override;
    begin
        return text;
    end
    function SetValue(v);override;
    begin
        text := v;
    end
    FFile;
end
function xor(a,b);
begin
    {**
    @explan(说明) 异或 运算 %%
    @return(bool)	
    **}
    return(a and not(b))or(b and not(a));
end
function SendMessageA(hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):pointer;stdcall;external "User32.dll"  name "SendMessageA";
function folderdlgcall(hwnd:pointer;message:integer;wparam:pointer;lparam:pointer):pointer;stdcall;
begin
    {**
    @ignore(忽略)
    @explan(说明) 文件夹对话框回调函数,系统调用%%
    **}
    {
    // messages to browser
    0x0400
    #define BFFM_SETSTATUSTEXTA     (WM_USER + 100)
    #define BFFM_ENABLEOK           (WM_USER + 101)
    #define BFFM_SETSELECTIONA      (WM_USER + 102)
    #define BFFM_SETSELECTIONW      (WM_USER + 103)
    #define BFFM_SETSTATUSTEXTW     (WM_USER + 104)
    #define BFFM_SETOKTEXT          (WM_USER + 105) // Unicode only
    #define BFFM_SETEXPANDED        (WM_USER + 106) // Unicode only
	
    #define BFFM_INITIALIZED        1
    #define BFFM_SELCHANGED         2
    #define BFFM_VALIDATEFAILEDA    3   // lParam:szPath ret:1(cont),0(EndDialog)
    #define BFFM_VALIDATEFAILEDW    4   // lParam:wzPath ret:1(cont),0(EndDialog)
    #define BFFM_IUNKNOWN           5   // provides IUnknown to client. lParam: IUnknown*
    }
    //echo "\r\nhook",tostn(array(format("0x%x",hwnd),format("0x%x",message),format("0x%x",wparam),format("0x%x",lparam)));
    if message=1 then
    begin
        SendMessageA(hwnd,0x0400+102,TRUE,lparam);
    end
    return 0;
    if message=0x110 then //如果为 WM_CREATE WM_NCCREATE 就注册 
    begin
        //s := array(format("0x%x",hwnd),format("0x%x",message),format("0x%x",wparam),format("0x%x",lparam));
        //d := new TtagOFNA(lparam);
    end
end 
function getdlgcall();
begin
{$ifdef linux}
    return 0;
{$endif}
    global g_dlg_call_back;
    if not g_dlg_call_back then 
    begin
        g_dlg_call_back := makeinstance(weakref_get( thisfunction(folderdlgcall)));    
    end 
    return g_dlg_call_back;
end 
function uninit();
begin
    global g_dlg_call_back;
    if g_dlg_call_back then 
    begin
        deleteinstance(g_dlg_call_back);
        g_dlg_call_back := nil;
    end         
end 
initialization
finalization
uninit();
end.