home *** CD-ROM | disk | FTP | other *** search
/ Delphi Anthology / aDELPHI.iso / Runimage / Delphi50 / Source / Vcl / ctlpanel.pas < prev    next >
Pascal/Delphi Source File  |  1999-08-11  |  12KB  |  418 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       Borland Delphi Visual Component Library         }
  4. {                                                       }
  5. {       Copyright (c) 1995,99 Inprise Corporation       }
  6. {                                                       }
  7. {*******************************************************}
  8.  
  9. unit CtlPanel;
  10.  
  11. interface
  12.  
  13. uses
  14.   SysUtils, Classes, Forms, Windows, Graphics, cpl, Dialogs;
  15.  
  16. type
  17.   EAppletException = class(Exception);
  18.  
  19.   TInitEvent = procedure (Sender: TObject; var AppInitOK: Boolean) of object;
  20.   TCountEvent = procedure (Sender: TObject; var AppCount: Integer) of object;
  21.   TExitEvent = TNotifyEvent;
  22.   TSetupEvent = TNotifyEvent;
  23.  
  24.   TActivateEvent     = procedure (Sender: TObject; Data: LongInt) of object;
  25.   TStopEvent         = procedure (Sender: TObject; Data: LongInt) of object;
  26.   TInquireEvent      = procedure (Sender: TObject; var idIcon: Integer; var idName: Integer;
  27.                                   var idInfo: Integer; var lData: Integer) of object;
  28.   TNewInquireEvent   = procedure (Sender: TObject; var lData: Integer; var hIcon: HICON;
  29.                                   var AppletName: string; var AppletInfo: string) of object; 
  30.   TStartWParmsEvent  = procedure (Sender: TObject; Params: string) of object;
  31.  
  32.   TAppletModule = class(TDataModule)
  33.   private
  34.     FOnActivate: TActivateEvent;
  35.     FOnStop: TStopEvent;
  36.     FOnInquire: TInquireEvent;
  37.     FOnNewInquire: TNewInquireEvent;
  38.     FOnStartWParms: TStartWParmsEvent;
  39.     FData: LongInt;
  40.     FResidIcon: Integer;
  41.     FResidName: Integer;
  42.     FResidInfo: Integer;
  43.     FAppletIcon: TIcon;
  44.     FCaption: string;
  45.     FHelp: string;
  46.     procedure SetData(const Value: LongInt);
  47.     procedure SetResidIcon(const Value: Integer);
  48.     procedure SetResidInfo(const Value: Integer);
  49.     procedure SetResidName(const Value: Integer);
  50.     procedure SetAppletIcon(const Value: TIcon);
  51.     procedure SetCaption(const Value: string);
  52.     procedure SetHelp(const Value: string);
  53.     function GetCaption: string;
  54.   protected
  55.     procedure DoStop(Data: LongInt); dynamic;
  56.     procedure DoActivate(Data: LongInt); dynamic;
  57.     procedure DoInquire(var ACPLInfo: TCPLInfo); dynamic;
  58.     procedure DoNewInquire(var ANewCPLInfo: TNewCPLInfo); dynamic;
  59.     procedure DoStartWParms(Params: string); dynamic;
  60.   public
  61.     constructor Create(AOwner: TComponent); override;
  62.     destructor Destroy; override;
  63.     property Data: LongInt read FData write SetData;
  64.   published
  65.     property OnStop: TStopEvent read FOnStop write FOnStop;
  66.     property OnActivate: TActivateEvent read FOnActivate write FOnActivate;
  67.     property OnInquire: TInquireEvent read FOnInquire write FOnInquire;
  68.     property OnNewInquire: TNewInquireEvent read FOnNewInquire write FOnNewInquire;
  69.     property OnStartWParms: TStartWParmsEvent read FOnStartWParms write FOnStartWParms;
  70.     property Caption: string read GetCaption write SetCaption;
  71.     property AppletIcon: TIcon read FAppletIcon write SetAppletIcon;
  72.     property Help: string read FHelp write SetHelp;
  73.     property ResidIcon: Integer read FResidIcon write SetResidIcon;
  74.     property ResidName: Integer read FResidName write SetResidName;
  75.     property ResidInfo: Integer read FResidInfo write SetResidInfo;
  76.   end;
  77.  
  78.   TAppletModuleClass = class of TAppletModule;
  79.   TCPLAppletClass = class of TAppletModule;
  80.   TDataModuleClass = class of TDataModule;
  81.  
  82.   TAppletApplication = class(TComponent)
  83.   private
  84.     FComponentClass: TComponentClass;
  85.     FControlPanelHandle: THandle;
  86.     FModules: TList;
  87.     FOnInit: TInitEvent;
  88.     FOnCount: TCountEvent;
  89.     FOnExit: TExitEvent;
  90.     FOnSetup: TSetupEvent;
  91.     FModuleCount: Integer;
  92.     procedure OnExceptionHandler(Sender: TObject; E: Exception);
  93.     function GetModules(Index: Integer): TAppletModule;
  94.     procedure SetModules(Index: Integer; const Value: TAppletModule);
  95.     procedure SetModuleCount(const Value: Integer);
  96.     function GetModuleCount: Integer;
  97.   protected
  98.     procedure DoHandleException(E: Exception); dynamic;
  99.     procedure DoInit(var AppInitOK: Boolean); dynamic;
  100.     procedure DoCount(var AppCount: Integer); dynamic;
  101.     procedure DoExit; dynamic;
  102.     procedure DoSetup; dynamic;
  103.   public
  104.     constructor Create(AOwner: TComponent); override;
  105.     destructor Destroy; override;
  106.     procedure CreateForm(InstanceClass: TComponentClass; var Reference); virtual;
  107.     procedure Initialize; virtual;
  108.     procedure Run; virtual;
  109.     property Modules[Index: Integer]: TAppletModule read GetModules write SetModules;
  110.     property ModuleCount: Integer read GetModuleCount write SetModuleCount;
  111.     property ControlPanelHandle: THandle read FControlPanelHandle;
  112.     property OnInit: TInitEvent read FOnInit write FOnInit;
  113.     property OnCount: TCountEvent read FOnCount write FOnCount;
  114.     property OnExit: TExitEvent read FOnExit write FOnExit;
  115.     property OnSetup: TSetupEvent read FOnSetup write FOnSetup;
  116.   end;
  117.  
  118. function CPlApplet(hwndCPl: THandle; uMsg: DWORD;
  119.                    lParam1, lParam2: Longint): Longint; stdcall;
  120.  
  121. var
  122.   Application: TAppletApplication = nil;
  123.  
  124. implementation
  125.  
  126. { TAppletApp }
  127.  
  128. resourcestring
  129.   sInvalidClassReference = 'Invalid class reference for TAppletApplication';
  130.  
  131. constructor TAppletApplication.Create(AOwner: TComponent);
  132. begin
  133.   inherited Create(AOwner);
  134.   FModules := TList.Create;
  135. end;
  136.  
  137. procedure TAppletApplication.CreateForm(InstanceClass: TComponentClass;
  138.   var Reference);
  139. begin
  140.   if InstanceClass.InheritsFrom(TCustomForm) or InstanceClass.InheritsFrom(TDataModule) then
  141.   begin
  142.     if (FComponentClass = nil) or (FComponentClass <> InstanceClass) then
  143.       FComponentClass := TComponentClass(InstanceClass);
  144.     TComponent(Reference) := FComponentClass.Create(Self);
  145.   end
  146.   else
  147.     raise Exception.CreateRes(@sInvalidClassReference);
  148. end;
  149.  
  150. destructor TAppletApplication.Destroy;
  151. begin
  152.   while FModules.Count > 0 do
  153.     TObject(FModules[0]).Free;
  154.  
  155.   FModules.Free;
  156.   Forms.Application.OnException := nil;
  157.   inherited Destroy;
  158. end;
  159.  
  160. procedure TAppletApplication.DoCount(var AppCount: Integer);
  161. begin
  162.   if assigned(FOnCount) then
  163.     FOnCount(Self, AppCount);
  164. end;
  165.  
  166. procedure TAppletApplication.DoExit;
  167. begin
  168.   if assigned(FOnExit) then
  169.     FOnExit(Self);
  170. end;
  171.  
  172. procedure TAppletApplication.DoHandleException(E: Exception);
  173. begin
  174. end;
  175.  
  176. procedure TAppletApplication.DoInit(var AppInitOK: Boolean);
  177. begin
  178.   if assigned(FOnInit) then
  179.     FOnInit(Self, AppInitOK);
  180. end;
  181.  
  182. procedure TAppletApplication.DoSetup;
  183. begin
  184.   if assigned(FOnSetup) then
  185.     FOnSetup(Self);
  186. end;
  187.  
  188. function TAppletApplication.GetModuleCount: Integer;
  189. begin
  190.   Result := FModules.Count;
  191. end;
  192.  
  193. function TAppletApplication.GetModules(Index: Integer): TAppletModule;
  194. begin
  195.   Result := FModules[Index];
  196. end;
  197.  
  198. procedure TAppletApplication.Initialize;
  199. begin
  200. end;
  201.  
  202. procedure TAppletApplication.OnExceptionHandler(Sender: TObject; E: Exception);
  203. begin
  204.   DoHandleException(E);
  205. end;
  206.  
  207. procedure TAppletApplication.Run;
  208. begin
  209.   Forms.Application.OnException := OnExceptionHandler;
  210. end;
  211.  
  212. procedure InitApplication;
  213. begin
  214.   Application := TAppletApplication.Create(nil);
  215. end;
  216.  
  217. procedure DoneApplication;
  218. begin
  219.   Application.Free;
  220.   Application := nil;
  221. end;
  222.  
  223. function CPlApplet(hwndCPl: THandle; uMsg: DWORD; lParam1, lParam2: Longint): Longint;
  224. var
  225.   Temp: Boolean;
  226.   
  227. begin
  228.   Result := 0;
  229.   Temp := True;
  230.  
  231.   with Application, Application.Modules[lParam1] do
  232.   begin
  233.     FControlPanelHandle := hwndCPl;
  234.  
  235.     case (umsg) of
  236.       CPL_INIT : DoInit(Temp);
  237.       CPL_GETCOUNT:
  238.       begin
  239.         Result := ModuleCount;
  240.         DoCount(Result);
  241.         Exit;
  242.       end;
  243.       CPL_INQUIRE     : DoInquire(PCplInfo(lParam2)^);
  244.       CPL_NEWINQUIRE  : DoNewInquire(PNewCPLInfo(lParam2)^);
  245.       CPL_DBLCLK      : DoActivate(LongInt(lParam2));
  246.       CPL_STOP        : DoStop(LongInt(LParam2));
  247.       CPL_EXIT        : DoExit;
  248.       CPL_STARTWPARMS : DoStartWParms(PChar(LParam2));
  249.       CPL_SETUP       : DoSetup;
  250.     end;
  251.   end;
  252.  
  253.   Result := Integer(Temp);
  254. end;
  255.  
  256. constructor TAppletModule.Create(AOwner: TComponent);
  257. begin
  258.   FAppletIcon := TIcon.Create;
  259.   inherited Create(AOwner);
  260.   Application.FModules.Add(Self);
  261. end;
  262.  
  263. destructor TAppletModule.Destroy;
  264. begin
  265.   FAppletIcon.Free;
  266.   Application.FModules.Delete(Application.FModules.IndexOf(Self));
  267.   inherited Destroy;
  268. end;
  269.  
  270. function TAppletModule.GetCaption: string;
  271. begin
  272.   if FCaption <> '' then
  273.     Result := FCaption
  274.   else
  275.     Result := Name;
  276. end;
  277.  
  278. procedure TAppletModule.DoActivate(Data: Integer);
  279. begin
  280.   if assigned(FOnActivate) then
  281.     FOnActivate(Self, Data);
  282. end;
  283.  
  284. procedure TAppletModule.DoInquire(var ACPLInfo: TCPLInfo);
  285. begin
  286.   with ACPLInfo do
  287.   begin
  288.     idIcon := FResidIcon;
  289.     idName := FResidName;
  290.     idInfo := FResidInfo;
  291.     lData := FData;
  292.   end;
  293.  
  294.   if assigned(FOnInquire) then
  295.     with ACPLInfo do
  296.       FOnInquire(Self, idIcon, idName, idInfo, lData);
  297. end;
  298.  
  299. procedure TAppletModule.DoNewInquire(var ANewCPLInfo: TNewCPLInfo);
  300. begin
  301.   with ANewCPLInfo do
  302.   begin
  303.     dwSize := SizeOf(TNewCPLInfo);
  304.     lData := FData;
  305.     if (FResidIcon = CPL_DYNAMIC_RES) then
  306.       hIcon := FAppletIcon.Handle
  307.     else
  308.       hIcon := LoadIcon(hInstance, MakeIntResource(FResidIcon));
  309.   end;
  310.  
  311.   if assigned(fOnNewInquire) then
  312.     with ANewCPLInfo do
  313.       FOnNewInquire(Self, lData, hIcon, FCaption, FHelp);
  314.  
  315.   if (FResidName = CPL_DYNAMIC_RES) then
  316.     StrLCopy(ANewCPLInfo.szName, PChar(FCaption), SizeOf(ANewCPLInfo.szName))
  317.   else
  318.     LoadString(hInstance, FResidName, ANewCPLInfo.szName, SizeOf(ANewCPLInfo.szName));
  319.  
  320.   if (FResidInfo = CPL_DYNAMIC_RES) then
  321.     StrLCopy(ANewCPLInfo.szInfo, PChar(FHelp), SizeOf(ANewCPLInfo.szInfo))
  322.   else
  323.     LoadString(hInstance, FResidInfo, ANewCPLInfo.szInfo, SizeOf(ANewCPLInfo.szInfo));
  324. end;
  325.  
  326. procedure TAppletModule.DoStartWParms(Params: string);
  327. begin
  328.   if assigned(FOnStartWParms) then
  329.     FOnStartWParms(Self, Params);
  330. end;
  331.  
  332. procedure TAppletModule.DoStop(Data: Integer);
  333. begin
  334.   if assigned(FOnStop) then
  335.     FOnStop(Self, Data);
  336. end;
  337.  
  338. procedure TAppletModule.SetAppletIcon(const Value: TIcon);
  339. begin
  340.   if FAppletIcon <> Value then
  341.   begin
  342.     FAppletIcon.Assign(Value);
  343.     ResidIcon := CPL_DYNAMIC_RES;
  344.   end;
  345. end;
  346.  
  347. procedure TAppletModule.SetCaption(const Value: string);
  348. begin
  349.   if FCaption <> Value then
  350.   begin
  351.     if Value = '' then
  352.       FCaption := Name
  353.     else
  354.       FCaption := Value;
  355.     FResidName := CPL_DYNAMIC_RES;
  356.   end;
  357. end;
  358.  
  359. procedure TAppletModule.SetData(const Value: Integer);
  360. begin
  361.   if FData <> Value then
  362.     FData := Value;
  363. end;
  364.  
  365. procedure TAppletModule.SetHelp(const Value: string);
  366. begin
  367.   if FHelp <> Value then
  368.   begin
  369.     FHelp := Value;
  370.     FResidInfo := CPL_DYNAMIC_RES;
  371.   end;
  372. end;
  373.  
  374. procedure TAppletModule.SetResidIcon(const Value: Integer);
  375. begin
  376.   if FResidIcon <> Value then
  377.     FResidIcon := Value;
  378. end;
  379.  
  380. procedure TAppletModule.SetResidInfo(const Value: Integer);
  381. begin
  382.   if FResidInfo <> Value then
  383.   begin
  384.     FResidInfo := Value;
  385.     FHelp := '';
  386.   end;
  387. end;
  388.  
  389. procedure TAppletModule.SetResidName(const Value: Integer);
  390. begin
  391.   if FResidName <> Value then
  392.   begin
  393.     FResidName := Value;
  394.     FCaption := '';
  395.   end;
  396. end;
  397.  
  398. procedure TAppletApplication.SetModuleCount(const Value: Integer);
  399. begin
  400.   if FModuleCount <> Value then
  401.     FModuleCount := Value;
  402. end;
  403.  
  404. procedure TAppletApplication.SetModules(Index: Integer;
  405.   const Value: TAppletModule);
  406. begin
  407.   if FModules[Index] <> Value then
  408.     FModules[Index] := Value;
  409. end;
  410.  
  411. initialization
  412.   InitApplication;
  413.  
  414. finalization
  415.   DoneApplication;
  416.  
  417. end.
  418.