unit TLibDemo_TLB;
interface
uses ActiveX, Classes, Graphics, OleServer, StdVCL, Variants, Windows;
const
TLibDemoMajorVersion = 1;
TLibDemoMinorVersion = 0;
LIBID_TLibDemo: TGUID = '{89855B41-8EFE-11D0-98D0-444553540000}';
IID_IFirstServer: TGUID = '{89855B42-8EFE-11D0-98D0-444553540000}';
CLASS_FirstServer: TGUID = '{89855B43-8EFE-11D0-98D0-444553540000}';
type
IFirstServer = interface;
IFirstServerDisp = dispinterface;
FirstServer = IFirstServer;
IFirstServer = interface(IDispatch)
['{89855B42-8EFE-11D0-98D0-444553540000}']
procedure ChangeColor; safecall;
function Get_Value: Integer; safecall;
procedure Set_Value(Value: Integer); safecall;
property Value: Integer read Get_Value write Set_Value;
end;
IFirstServerDisp = dispinterface
['{89855B42-8EFE-11D0-98D0-444553540000}']
procedure ChangeColor; dispid 1;
property Value: Integer dispid 2;
end;
CoFirstServer = class
class function Create: IFirstServer;
class function CreateRemote(const MachineName: string): IFirstServer;
end;
TFirstServerProperties= class;
TFirstServer = class(TOleServer)
private
FIntf: IFirstServer;
FProps: TFirstServerProperties;
function GetServerProperties: TFirstServerProperties;
function GetDefaultInterface: IFirstServer;
protected
procedure InitServerData; override;
function Get_Value: Integer;
procedure Set_Value(Value: Integer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Connect; override;
procedure ConnectTo(svrIntf: IFirstServer);
procedure Disconnect; override;
procedure ChangeColor;
property DefaultInterface: IFirstServer read GetDefaultInterface;
property Value: Integer read Get_Value write Set_Value;
published
property Server: TFirstServerProperties read GetServerProperties;
end;
TFirstServerProperties = class(TPersistent)
private
FServer: TFirstServer;
function GetDefaultInterface: IFirstServer;
constructor Create(AServer: TFirstServer);
protected
function Get_Value: Integer;
procedure Set_Value(Value: Integer);
public
property DefaultInterface: IFirstServer read GetDefaultInterface;
published
property Value: Integer read Get_Value write Set_Value;
end;
procedure Register;
resourcestring
dtlServerPage = 'ActiveX';
implementation
uses ComObj;
class function CoFirstServer.Create: IFirstServer;
begin
Result := CreateComObject(CLASS_FirstServer) as IFirstServer;
end;
class function CoFirstServer.CreateRemote(const MachineName: string): IFirstServer;
begin
Result := CreateRemoteComObject(MachineName, CLASS_FirstServer) as IFirstServer;
end;
procedure TFirstServer.InitServerData;
const
CServerData: TServerData = (
ClassID: '{89855B43-8EFE-11D0-98D0-444553540000}';
IntfIID: '{89855B42-8EFE-11D0-98D0-444553540000}';
EventIID: '';
LicenseKey: nil;
Version: 500);
begin
ServerData := @CServerData;
end;
procedure TFirstServer.Connect;
var
punk: IUnknown;
begin
if FIntf = nil then
begin
punk := GetServer;
Fintf:= punk as IFirstServer;
end;
end;
procedure TFirstServer.ConnectTo(svrIntf: IFirstServer);
begin
Disconnect;
FIntf := svrIntf;
end;
procedure TFirstServer.DisConnect;
begin
if Fintf <> nil then
begin
FIntf := nil;
end;
end;
function TFirstServer.GetDefaultInterface: IFirstServer;
begin
if FIntf = nil then
Connect;
Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation');
Result := FIntf;
end;
constructor TFirstServer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FProps := TFirstServerProperties.Create(Self);
end;
destructor TFirstServer.Destroy;
begin
FProps.Free;
inherited Destroy;
end;
function TFirstServer.GetServerProperties: TFirstServerProperties;
begin
Result := FProps;
end;
function TFirstServer.Get_Value: Integer;
begin
Result := DefaultInterface.Value;
end;
procedure TFirstServer.Set_Value(Value: Integer);
begin
DefaultInterface.Value := Value;
end;
procedure TFirstServer.ChangeColor;
begin
DefaultInterface.ChangeColor;
end;
constructor TFirstServerProperties.Create(AServer: TFirstServer);
begin
inherited Create;
FServer := AServer;
end;
function TFirstServerProperties.GetDefaultInterface: IFirstServer;
begin
Result := FServer.DefaultInterface;
end;
function TFirstServerProperties.Get_Value: Integer;
begin
Result := DefaultInterface.Value;
end;
procedure TFirstServerProperties.Set_Value(Value: Integer);
begin
DefaultInterface.Value := Value;
end;
procedure Register;
begin
RegisterComponents(dtlServerPage, [TFirstServer]);
end;
end.
|