exportconnection.pas

实达企业在线EOL源码

unit ExportConnection;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  sconnect,mconnect,db;

type
  TExportConnection = class(TComponent)
  private
    FPackageList  :TStrings;
    FFunctionList :TStrings;

    FCustConnect  :TSocketConnection;

    function GetAddress: string;
    function GetAfterConnect: TNotifyEvent;
    function GetAfterDisconnect: TNotifyEvent;
    function GetBeforeConnect: TNotifyEvent;
    function GetBeforeDisconnect: TNotifyEvent;
    function GetConnected: Boolean;
    function GetInterceptGUID: string;
    function GetLoginPrompty: Boolean;
    function GetObjectBroker: TCustomObjectBroker;
    function GetOnGetUsername: TGetUsernameEvent;
    function GetOnLogin: TLoginEvent;
    function GetPort: Integer;
    function GetServerGUID: string;
    function GetServerName: string;
    function GetSupportCallbacks: Boolean;
    procedure SetAddress(const Value: string);
    procedure SetAfterConnect(const Value: TNotifyEvent);
    procedure SetAfterDisconnect(const Value: TNotifyEvent);
    procedure SetBeforeConnect(const Value: TNotifyEvent);
    procedure SetBeforeDisconnect(const Value: TNotifyEvent);
    procedure SetConnected(const Value: Boolean);
    procedure SetHost(const Value: string);
    procedure SetInterceptGUID(const Value: string);
    procedure SetLoginPrompty(const Value: Boolean);
    procedure SetObjectBroker(const Value: TCustomObjectBroker);
    procedure SetOnGetUsername(const Value: TGetUsernameEvent);
    procedure SetOnLogin(const Value: TLoginEvent);
    procedure SetPort(const Value: Integer);
    procedure SetServerGUID(const Value: string);
    procedure SetServerName(const Value: string);
    procedure SetSupportCallbacks(const Value: Boolean);
    function GetHost: string;
  protected
    function  FilePath  :string;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function  GetPackageText :string;
    function  GetFuctionText :string;

    function ExceuteFunction(FunctionName  :string):TForm;
  published
    property Address: string read GetAddress write SetAddress;
    property Host: string read GetHost write SetHost;
    property InterceptGUID: string read GetInterceptGUID write SetInterceptGUID;
    property Port: Integer read GetPort write SetPort;
    property SupportCallbacks: Boolean read GetSupportCallbacks write SetSupportCallbacks;
    property ObjectBroker: TCustomObjectBroker read GetObjectBroker write SetObjectBroker;
    property Connected: Boolean read GetConnected write SetConnected;
    property LoginPrompt: Boolean read GetLoginPrompty write SetLoginPrompty;
    property ServerGUID: string read GetServerGUID write SetServerGUID;
    property ServerName: string read GetServerName write SetServerName;
    property AfterConnect: TNotifyEvent read GetAfterConnect write SetAfterConnect;
    property BeforeConnect: TNotifyEvent read GetBeforeConnect write SetBeforeConnect;
    property AfterDisconnect: TNotifyEvent read GetAfterDisconnect write SetAfterDisconnect;
    property BeforeDisconnect: TNotifyEvent read GetBeforeDisconnect write SetBeforeDisconnect;
    property OnLogin: TLoginEvent read GetOnLogin write SetOnLogin;
    property OnGetUsername: TGetUsernameEvent read GetOnGetUsername write SetOnGetUsername;
  end;

procedure Register;

implementation
uses ReportData;

procedure Register;
begin
  RegisterComponents('EOL', [TExportConnection]);
end;

{ TExportConnection }

constructor TExportConnection.Create(AOwner: TComponent);
type
  TGetFunctionNames =procedure(var FunxtionNams :PChar);stdcall;
  procedure DisStr(Str  :string;Index :integer);
  var
    Pst :string;
    LastPot :integer;
  begin
    Pst :=str;
    LastPot :=LastDelimiter(';',Pst);
    while LastPot>0 do
    begin
      FFunctionList.AddObject(Copy(Pst,LastPot+1,length(Pst)-LastPot),TObject(Index));
      delete(Pst,LastPot,length(Pst)-LastPot+1);
      LastPot :=LastDelimiter(';',Pst)
    end;
    if Length(Pst) >0 then FFunctionList.AddObject(Pst,TObject(Index));
  end;
var
  sr: TSearchRec;
  FileAttrs: Integer;

  FileHandle  :HINST;
  i :integer;

  FGetFunctionNames :TGetFunctionNames;
  Str  :PChar;

  CurrFile  :string;
begin
  inherited Create(AOwner);
  FCustConnect  :=TPubReportData.AddObject.ReportConnect;

  FPackageList  :=TStringList.Create ;
  FFunctionList :=TStringList.Create ;

  if not (csDesigning in ComponentState) then
  begin
    FileAttrs :=$00000001+$00000002+$00000004+$00000020	+$0000003F;
    if FindFirst(FilePath+'*.BPL', FileAttrs, sr) = 0 then
    begin
      FPackageList.AddObject(sr.Name ,TObject(0));
      while FindNext(sr) = 0 do FPackageList.AddObject(sr.Name ,TObject(0));
      FindClose(sr);
    end;
    i :=0;
    while i < FPackageList.Count do
    begin
      CurrFile  :=FilePath+FPackageList.Strings[i];
      FileHandle  :=LoadLibrary(Pchar(CurrFile));
      if FileHandle <>0 then
      begin
        @FGetFunctionNames  :=GetProcAddress(FileHandle,'GetFunctionNames');
        if @FGetFunctionNames <>nil then
        begin
          FGetFunctionNames(Str);
          DisStr(Str,i);
          i :=i+1;
        end
        else FPackageList.Delete(i);
        FreeLibrary(FileHandle);
      end
      else FPackageList.Delete(i);
    end;
  end;
end;

destructor TExportConnection.Destroy;
var
  i,j :integer;
begin
  if not (csDesigning in ComponentState) then
  for i :=FPackageList.Count-1 downto 0 do
  begin
    if integer(FPackageList.Objects[i]) <>0 then
    begin
      for j :=Application.ComponentCount -1 downto 0 do
      begin
        if integer(Application.Components[1].ClassInfo) =integer(FPackageList.Objects[i]) then
          Application.Components[j].Free ;
      end;
      FreeLibrary(integer(FPackageList.Objects[i]));
      FPackageList.Objects[i] :=TObject(0);
    end;
  end;

  FFunctionList.Free ;
  FPackageList.Free ;
  TPubReportData.ReleaseObject ;
  inherited;
end;

function TExportConnection.ExceuteFunction(FunctionName: string):TForm;
  function GetHandleByIndex(index :integer):HINST;
  begin
    if index >=FPackageList.Count then Raise Exception.Create('未提供该功能！');
    if integer(FPackageList.Objects[index]) =0 then
      FPackageList.Objects[index] :=TObject(LoadLibrary(PChar(FilePath+FPackageList.Strings[index])));
    Result  :=integer(FPackageList.Objects[index]);
  end;
type
  TExceuteFunction  =function:TForm;stdcall;
var
  s_i :integer;

  AppHandle :HINST;

  s_Func  :TExceuteFunction;
begin
  Result  :=nil;
  s_i :=FFunctionList.IndexOf(FunctionName);
  if s_i >=0 then
  begin
    AppHandle :=GetHandleByIndex(integer(FFunctionList.Objects[s_i]));
    if AppHandle <> 0 then
    begin
      @s_Func :=GetProcAddress(AppHandle,Pchar(FunctionName));
      if @s_Func <>nil then Result  :=s_Func
      else Raise Exception.Create('未提供该功能！');
    end
    else Raise Exception.Create('未提供该功能！');
  end
  else Raise Exception.Create('未提供该功能！');
end;

function TExportConnection.FilePath: string;
begin
  Result :=ExtractFilePath(Application.ExeName )+'BPL\';
end;

function TExportConnection.GetAddress: string;
begin
  Result  :=FCustConnect.Address ;
end;

function TExportConnection.GetAfterConnect: TNotifyEvent;
begin
  Result :=FCustConnect.AfterConnect ;
end;

function TExportConnection.GetAfterDisconnect: TNotifyEvent;
begin
  Result :=FCustConnect.AfterDisconnect ;
end;

function TExportConnection.GetBeforeConnect: TNotifyEvent;
begin
  Result :=FCustConnect.BeforeConnect ;
end;

function TExportConnection.GetBeforeDisconnect: TNotifyEvent;
begin
  Result  :=FCustConnect.BeforeDisconnect ;
end;

function TExportConnection.GetConnected: Boolean;
begin
  Result  :=FCustConnect.Connected ;
end;

function TExportConnection.GetFuctionText: string;
begin
  Result :=FFunctionList.Text ; 
end;

function TExportConnection.GetHost: string;
begin
  Result  :=FCustConnect.Host ;
end;

function TExportConnection.GetInterceptGUID: string;
begin
  Result  :=FCustConnect.InterceptGUID ;
end;

function TExportConnection.GetLoginPrompty: Boolean;
begin
  Result :=FCustConnect.LoginPrompt ;
end;

function TExportConnection.GetObjectBroker: TCustomObjectBroker;
begin
  Result :=FCustConnect.ObjectBroker ;
end;

function TExportConnection.GetOnGetUsername: TGetUsernameEvent;
begin
  Result :=FCustConnect.OnGetUsername ;
end;

function TExportConnection.GetOnLogin: TLoginEvent;
begin
  Result :=FCustConnect.OnLogin ;
end;

function TExportConnection.GetPackageText: string;
begin
  Result  :=FPackageList.Text ; 
end;

function TExportConnection.GetPort: Integer;
begin
  Result :=FCustConnect.Port ;
end;

function TExportConnection.GetServerGUID: string;
begin
  Result :=FCustConnect.ServerGUID ;
end;

function TExportConnection.GetServerName: string;
begin
  Result :=FCustConnect.ServerName ;
end;

function TExportConnection.GetSupportCallbacks: Boolean;
begin
  Result  :=FCustConnect.SupportCallbacks ;
end;

procedure TExportConnection.SetAddress(const Value: string);
begin
  FCustConnect.Address :=Value;
end;

procedure TExportConnection.SetAfterConnect(const Value: TNotifyEvent);
begin
  FCustConnect.AfterConnect :=Value;
end;

procedure TExportConnection.SetAfterDisconnect(const Value: TNotifyEvent);
begin
  FCustConnect.AfterDisconnect :=Value;
end;

procedure TExportConnection.SetBeforeConnect(const Value: TNotifyEvent);
begin
  FCustConnect.BeforeConnect :=Value;
end;

procedure TExportConnection.SetBeforeDisconnect(const Value: TNotifyEvent);
begin
  FCustConnect.BeforeDisconnect :=Value;
end;

procedure TExportConnection.SetConnected(const Value: Boolean);
begin
  FCustConnect.Connected :=Value;
end;

procedure TExportConnection.SetHost(const Value: string);
begin
  FCustConnect.Host :=Value;
end;

procedure TExportConnection.SetInterceptGUID(const Value: string);
begin
  FCustConnect.InterceptGUID :=Value;
end;

procedure TExportConnection.SetLoginPrompty(const Value: Boolean);
begin
  FCustConnect.LoginPrompt :=Value;
end;

procedure TExportConnection.SetObjectBroker(
  const Value: TCustomObjectBroker);
begin
  FCustConnect.ObjectBroker :=Value;
end;

procedure TExportConnection.SetOnGetUsername(
  const Value: TGetUsernameEvent);
begin
  FCustConnect.OnGetUsername :=Value;
end;

procedure TExportConnection.SetOnLogin(const Value: TLoginEvent);
begin
  FCustConnect.OnLogin :=Value;
end;

procedure TExportConnection.SetPort(const Value: Integer);
begin
  FCustConnect.Port :=Value;
end;

procedure TExportConnection.SetServerGUID(const Value: string);
begin
  FCustConnect.ServerGUID :=Value;
  if ServerName <>FCustConnect.ServerName then ServerName :=FCustConnect.ServerName;  
end;

procedure TExportConnection.SetServerName(const Value: string);
begin
  FCustConnect.ServerName :=Value;
  if ServerGUID <>FCustConnect.ServerGUID then ServerGUID :=FCustConnect.ServerGUID;
end;

procedure TExportConnection.SetSupportCallbacks(const Value: Boolean);
begin
  FCustConnect.SupportCallbacks :=Value;
end;

end.