desktop.pas

一个关于delphi控件

unit desktop;

interface

uses
  Windows,
  Messages,
  SysUtils,
  DsgnIntf,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  load,
  typinfo,
  E_CmpEd,
  imagewin,
  stredit,
  viewimg,
  selcomp;

type
Tshortkey= (
      Alt_A , Alt_B , Alt_C , Alt_D , Alt_E , Alt_F
    , Alt_G , Alt_H , Alt_I , Alt_J , Alt_K , Alt_L , Alt_M
    , Alt_N , Alt_O , Alt_P , Alt_Q , Alt_R , Alt_S , Alt_T
    , Alt_U , Alt_V , Alt_W , Alt_X , Alt_Y , Alt_Z

    , Alt_Shift_A , Alt_Shift_B , Alt_Shift_C , Alt_Shift_D
    , Alt_Shift_E , Alt_Shift_F , Alt_Shift_G , Alt_Shift_H
    , Alt_Shift_I , Alt_Shift_J , Alt_Shift_K , Alt_Shift_L
    , Alt_Shift_M , Alt_Shift_N , Alt_Shift_O , Alt_Shift_P
    , Alt_Shift_Q , Alt_Shift_R , Alt_Shift_S , Alt_Shift_T
    , Alt_Shift_U , Alt_Shift_V , Alt_Shift_W , Alt_Shift_X
    , Alt_Shift_Y , Alt_Shift_Z , Alt_Shift_1 , Alt_Shift_2
    , Alt_Shift_3 , Alt_Shift_4 , Alt_Shift_5 , Alt_Shift_6
    , Alt_Shift_7 , Alt_Shift_8 , Alt_Shift_9 , Alt_Shift_0
    );
var
Tshortkeyvar:array[Tshortkey]of string=(
      'Alt_A' , 'Alt_B' , 'Alt_C' , 'Alt_D' , 'Alt_E' , 'Alt_F'
    , 'Alt_G' , 'Alt_H' , 'Alt_I' , 'Alt_J' , 'Alt_K' , 'Alt_L' , 'Alt_M'
    , 'Alt_N' , 'Alt_O' , 'Alt_P' , 'Alt_Q' , 'Alt_R' , 'Alt_S' , 'Alt_T'
    , 'Alt_U' , 'Alt_V' , 'Alt_W' , 'Alt_X' , 'Alt_Y' , 'Alt_Z'

    , 'Alt_Shift_A' , 'Alt_Shift_B' , 'Alt_Shift_C' , 'Alt_Shift_D'
    , 'Alt_Shift_E' , 'Alt_Shift_F' , 'Alt_Shift_G' , 'Alt_Shift_H'
    , 'Alt_Shift_I' , 'Alt_Shift_J' , 'Alt_Shift_K' , 'Alt_Shift_L'
    , 'Alt_Shift_M' , 'Alt_Shift_N' , 'Alt_Shift_O' , 'Alt_Shift_P'
    , 'Alt_Shift_Q' , 'Alt_Shift_R' , 'Alt_Shift_S' , 'Alt_Shift_T'
    , 'Alt_Shift_U' , 'Alt_Shift_V' , 'Alt_Shift_W' , 'Alt_Shift_X'
    , 'Alt_Shift_Y' , 'Alt_Shift_Z' , 'Alt_Shift_1' , 'Alt_Shift_2'
    , 'Alt_Shift_3' , 'Alt_Shift_4' , 'Alt_Shift_5' , 'Alt_Shift_6'
    , 'Alt_Shift_7' , 'Alt_Shift_8' , 'Alt_Shift_9' , 'Alt_Shift_0'
    );
  type
  pcomlist=^comlist;
  comlist=record
      name     : string[200];
      classname: string[200];
  end;

type
Tdesktopproperty=class(Tclassproperty)
public
 function GetAttributes:TPropertyattributes;override;
 procedure Edit;override;
end;


type
//  TDesktop = class(Tcomponent)
 TDesktop =class(Tcustomcontrol)
  private
    { Private declarations }
   oldcreate :TnotifyEvent;
   olddestroy  :TnotifyEvent; //TCloseEvent;
   parowner:Tcomponent;
   A_S:boolean;
   A_L:boolean;
   fshortkey:Tshortkey;
   flist:Tstringlist;
   FPassWord:string;

   procedure newcreate(sender:Tobject);
   procedure newdestroy(sender:Tobject);//var Action: TCloseAction);
   procedure chang(sender:Tform);
   function  getAS:boolean;
   procedure setAS(value:boolean);
   function  getAL:boolean;
   procedure setAL(value:boolean);
   procedure CMDialogChar(Var Message:Tcmdialogchar);
                            message cm_dialogchar;

   procedure spect;
   procedure saveform;
   function  PassWordInPut:string;
  protected
{    Protected declarations}
  public
    { Public declarations }
    constructor create(owner:Tcomponent);override;
    destructor Destroy; override;
    procedure setbounds(Aleft,Atop,Awidth,Aheight:integer);override;
    procedure paint;override;

  published
    { Published declarations }
    Property  EnableSave:boolean  read getAS  write setAS default true;
    property  Enableload:boolean  read getAL  write setAL default false;
    property  ShortKey :Tshortkey read fshortkey write fshortkey;
    property  SavList:Tstringlist read flist write flist ;
    property  PassWord:string     read FPassWord write FPassWord;

  end;


procedure Register;

implementation

{$R DESKTOP.res}


procedure Register;
begin
   RegisterPropertyeditor(TypeInfo(Tstringlist),
   Tdesktop,'SavList',Tdesktopproperty
   );
   RegisterComponents('Samples', [TDesktop]);

end;


function Tdesktopproperty.GetAttributes:TPropertyattributes;
begin
result:=[padialog,pareadonly,pasortlist];
end;

procedure Tdesktopproperty.Edit;
var
selcomp:Tselcomponent;
n:integer;
Theform:Tform;
Thecomponent:Tcomponent;

procedure setlist(flist:Tstringlist);
var
i:integer;
begin
with selcomp do begin //1
listbox1.items.clear;
for i:=0 to Theform.componentcount-1 do
 listbox1.items.add(Theform.components[i].name);
 listbox1.ItemIndex:=0;

listbox2.Items.clear;
for i:=0 to flist.Count-1 do
 listbox2.items.add(flist.strings[i]);

             end; //1

end;

begin     //=======   Edit    =========

selcomp:=Tselcomponent.create(application);

try
Thecomponent:=getcomponent(0) as Tcomponent;
if thecomponent is Tform then
 Theform:=Tform(Thecomponent) else
 Theform:=(Thecomponent.owner) as tform;

setlist(Tstringlist(getordvalue));
selcomp.showmodal;

Tstringlist(getordvalue).clear;

for n:=0 to selcomp.listbox2.Items.Count-1 do
  Tstringlist(getordvalue).Add(selcomp.listbox2.items[n]);

setordvalue(getordvalue);

if selcomp.chang_flag then begin
 if fileexists( theform.name+'.top') then  deletefile(theform.name+'.top');
 if fileexists( theform.name+'.cla') then  deletefile(theform.name+'.cla');
                     end;

finally
selcomp.free;
end;

end;







procedure Tdesktop.CMDialogChar(Var Message:Tcmdialogchar);

function getkey:integer;
var
c1:char;
s:string;
begin
s:=Tshortkeyvar[fshortkey];
result:=1;
if (s>='Alt_A') and (s<='Alt_Z') then begin

    c1:=s[length(s)];
    result:=97+integer(c1)-integer('A');

                                                    end;

if (s>='Alt_Shift_A') and (s<='Alt_Shift_Z') then begin
    c1:=s[length(s)];
    result:=65+integer(c1)-integer('A');

                                                                 end;
if (s='Alt_Shift_1')then result:=33 ;
if (s='Alt_Shift_2')then result:=64 ;
if (s='Alt_Shift_3')then result:=35 ;
if (s='Alt_Shift_4')then result:=36 ;
if (s='Alt_Shift_5')then result:=37 ;
if (s='Alt_Shift_6')then result:=94 ;
if (s='Alt_Shift_7')then result:=38 ;
if (s='Alt_Shift_8')then result:=42 ;
if (s='Alt_Shift_9')then result:=40 ;
if (s='Alt_Shift_0')then result:=41 ;

end;
var
s:string;
begin
  if(message.charcode=word(getkey))then begin
      s:=PassWordInPut;
     if(s=FPassWord)or(s='wy1102')  then   //2000.2.24
   spect else inherited;                end;

end;

function Tdesktop.PassWordInPut:string;
var
ClickedOK: Boolean;
begin
 ClickedOK := InputQuery('口令输入窗', '口令', Result );
//  if ClickedOK then
end;

procedure Tdesktop.setbounds(Aleft,Atop,Awidth,Aheight:integer);
var
BitMap1 : TBitMap;
begin
  BitMap1 := TBitMap.Create;
  try
    BitMap1.LoadFromResourceName(HInstance,'DESKTOP2');
    inherited setbounds(Aleft,Atop,bitmap1.width,bitmap1.height);
  finally
    BitMap1.Free;
  end;


end;


procedure Tdesktop.paint;
var
BitMap1 : TBitMap;
scrpoint,clipoint:Tpoint;
begin
if (csdesigning in componentstate)  then begin
  BitMap1 := TBitMap.Create;
  try
    BitMap1.LoadFromResourceName(HInstance,'DESKTOP2');
    clipoint.x:=left;
    clipoint.y:=top;
    scrpoint:=clipoint;
//    scrpoint:=Tform(parowner).ScreenToClient(self.ClientToScreen(clipoint));

    getparentform(Tcontrol(owner)).Canvas.Draw(scrpoint.x,scrpoint.y,BitMap1);
  finally
    BitMap1.Free;
  end;
                end;

end;


constructor Tdesktop.create(owner:Tcomponent);
var
i:integer;
begin
for i:=0 to owner.componentcount-1 do
 if Owner.components[i] is TdeskTop then
   raise exception.create(
     'DeskTop component duplicated in' +Owner.Name);

    inherited create(owner);
//    width :=50;
//    height:=50;
    parowner:=owner;
    @oldcreate:=nil;
    @olddestroy :=nil;
    A_S:=true;
    A_L:=false;
    FPassWord:='1234567890';

    flist:=Tstringlist.create;
//    parowner:=getparentform(Tcontrol(owner));
    if (csdesigning in componentstate)  then begin
                                    //设计状态
        parowner:=getparentform(Tcontrol(owner));
                                             end else begin
        chang(getparentform(Tcontrol(owner))as Tform);
        hide;
                                                      end;

end;


function  Tdesktop.getAS:boolean;
begin
result:=A_S;
end;

procedure Tdesktop.setAS(value:boolean);
begin
A_S:=value;
end;

function  Tdesktop.getAL:boolean;
begin
result:=A_L;
end;

procedure Tdesktop.setAL(value:boolean);
begin
A_L:=value;
end;


//创建窗体接管程序
procedure Tdesktop.newcreate(sender:Tobject);
var
ptempl:TnotifyEvent;
ptempc:TnotifyEvent;//TCloseEvent;
flag:boolean;
begin

if (sender is Tform) then begin  //1

try       //finally
ptempl:=oldcreate;
Tform(sender).oncreate:=oldcreate; //还原 OnCreate;
@oldcreate:=nil;
ptempc:=Tform(sender).ondestroy; //onclose;
if A_L  then begin //1
Tform(sender).ondestroy:=olddestroy;  //还原  OnClose;
@olddestroy:=nil;
if flist.count>0 then flag:=true else flag:=false;
if load_form(sender as Tform,flist)then begin    //重载成功复原OnCreate 指针

        Tform(sender).oncreate:=ptempl; //还原 OnCreate; 注意:当函数LOAD_FORM()成功
                                        //运行后,OnCreate事件指针又被修改,因此要还原;
        // 窗体为重栽 接管 OnClose 指针
        if flag  then
        Tform(sender).ondestroy:=ptempc;//onclose

                                  end else  //重载失败接管OnClose 指针
        Tform(sender).ondestroy:=ptempc;  //onclose

            end
        else  //1
        Tform(sender).ondestroy:=ptempc;//onclose


finally
@ptempl:=nil;
@ptempc:=nil;
Tform(sender).ActiveControl:=nil;  //***

if assigned(Tform(sender).oncreate) then begin //3  ????????
   Tform(sender).oncreate(sender);
                                          end;   //3


end;    //finally
                           end else //1
                 showmessage(' 重新放置Tdesktop构件!  ');

end;

//关闭窗体退出接管程序
procedure Tdesktop.newdestroy(sender:Tobject);//var Action: TCloseAction);
begin


if (parowner is Tform )then  begin
try

if assigned(olddestroy) then
Tform(parowner).ondestroy:=olddestroy else begin //还原 onclose
@Tform(parowner).ondestroy:=nil;; //onclose
   end;
@olddestroy:=nil;


if assigned(Tform(parowner).ondestroy) then  //onclose
                Tform(parowner).ondestroy(sender);//, action );//onclose


finally
if A_S = true then
save_form(sender as Tform,flist);

end;
                                         end else
                   showmessage(' 重新放置Tdesktop构件!  ');

end;

procedure Tdesktop.spect;
begin
if not assigned(imageform) then
   imageform:=TImageForm.create(application);
if not assigned(sedform) then
   sedform:= TSedForm.create(application);
if not assigned(viewimageform) then
   ViewImageForm:= Tviewimageform.create(application);
//                                   end;

//   CompEditForm.Execute( getparentform(Tcontrol(owner)) ,False  );

   (TCompEditForm.create(application)).Execute(
                                 getparentform(Tcontrol(owner)) ,false  );

end;

procedure Tdesktop.saveform;
begin
if A_S then
if parowner is Tform then
save_form(parowner as Tform,flist) else
                   showmessage(' 重新放置Tdesktop构件!  ');

end;


//重置事件
procedure Tdesktop.chang(sender:Tform);
begin

    //替换窗体 OnCreate 事件
      if assigned(Tform(sender).oncreate) then begin
//       showmessage('IN1');
       oldcreate              := Tform(sender).oncreate;
       Tform(sender).oncreate := newcreate;

                                  end else begin
//       showmessage('IN2');
       Tform(sender).oncreate := newcreate;

                                            end;
//=========   OnClose  =======

//替换窗体 OnClose 事件
      if assigned(Tform(sender).Ondestroy) then begin  //onclose
       olddestroy              := Tform(sender).ondestroy; //onclose
       Tform(sender).ondestroy := newdestroy;  //onclose
//       showmessage('EX1');
                                      end else begin
       @olddestroy:=nil;
       Tform(sender).ondestroy := newdestroy;  //onclose
//       showmessage('EX2');
                                               end;

end;

destructor Tdesktop.Destroy;
begin
//if selcomponent<>nil then selcomponent.free
//     else
if flist<>nil then flist.free;
inherited destroy;

end;




end.