ddeman.pas

这是不可多得的源代码

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{                                                       }
{  Copyright (c) 1995-2001 Borland Software Corporation }
{                                                       }
{*******************************************************}

unit DdeMan;

{$R-,T-,H+,X+}

interface

uses
  Windows, Classes, Forms, Controls, DDEml;

type
  TDataMode = (ddeAutomatic, ddeManual);
  TDdeServerConv = class;

  TMacroEvent = procedure(Sender: TObject; Msg: TStrings) of object;

  TDdeClientItem = class;

{ TDdeClientConv }

  TDdeClientConv = class(TComponent)
  private
    FDdeService: string;
    FDdeTopic: string;
    FConv: HConv;
    FCnvInfo: TConvInfo;
    FItems: TList;
    FHszApp: HSZ;
    FHszTopic: HSZ;
    FDdeFmt: Integer;
    FOnClose: TNotifyEvent;
    FOnOpen: TNotifyEvent;
    FAppName: string;
    FDataMode: TDataMode;
    FConnectMode: TDataMode;
    FWaitStat: Boolean;
    FFormatChars: Boolean;
    procedure SetDdeService(const Value: string);
    procedure SetDdeTopic(const Value: string);
    procedure SetService(const Value: string);
    procedure SetTopic(const Value: string);
    procedure SetConnectMode(NewMode: TDataMode);
    procedure SetFormatChars(NewFmt: Boolean);
    procedure XactComplete;
    procedure SrvrDisconnect;
    procedure DataChange(DdeDat: HDDEData; hszIt: HSZ);
  protected
    function CreateDdeConv(FHszApp: HSZ; FHszTopic: HSZ): Boolean;
    function GetCliItemByName(const ItemName: string): TPersistent;
    function GetCliItemByCtrl(ACtrl: TDdeClientItem): TPersistent;
    procedure Loaded; override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure ReadLinkInfo(Reader: TReader);
    procedure WriteLinkInfo(Writer: TWriter);
    function OnSetItem(aCtrl: TDdeClientItem; const S: string): Boolean;
    procedure OnAttach(aCtrl: TDdeClientItem);
    procedure OnDetach(aCtrl: TDdeClientItem);
    procedure Close; dynamic;
    procedure Open; dynamic;
    function ChangeLink(const App, Topic, Item: string): Boolean;
    procedure ClearItems;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function PasteLink: Boolean;
    function OpenLink: Boolean;
    function SetLink(const Service, Topic: string): Boolean;
    procedure CloseLink;
    function StartAdvise: Boolean;
    function PokeDataLines(const Item: string; Data: TStrings): Boolean;
    function PokeData(const Item: string; Data: PChar): Boolean;
    function ExecuteMacroLines(Cmd: TStrings; waitFlg: Boolean): Boolean;
    function ExecuteMacro(Cmd: PChar; waitFlg: Boolean): Boolean;
    function RequestData(const Item: string): PChar;
    property DdeFmt: Integer read FDdeFmt;
    property WaitStat: Boolean read FWaitStat;
    property Conv: HConv read FConv;
    property DataMode: TDataMode read FDataMode write FDataMode;
  published
    property ServiceApplication: string read FAppName write FAppName;
    property DdeService: string read FDdeService write SetDdeService;
    property DdeTopic: string read FDdeTopic write SetDdeTopic;
    property ConnectMode: TDataMode read FConnectMode write SetConnectMode default ddeAutomatic;
    property FormatChars: Boolean read FFormatChars write SetFormatChars default False;
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
    property OnOpen: TNotifyEvent read FOnOpen write FOnOpen;
  end;

{ TDdeClientItem }

  TDdeClientItem = class(TComponent)
  private
    FLines: TStrings;
    FDdeClientConv: TDdeClientConv;
    FDdeClientItem: string;
    FOnChange: TNotifyEvent;
    function GetText: string;
    procedure SetDdeClientItem(const Val: string);
    procedure SetDdeClientConv(Val: TDdeClientConv);
    procedure SetText(const S: string);
    procedure SetLines(L: TStrings);
    procedure OnAdvise;
  protected
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Text: string read GetText write SetText;
    property Lines: TStrings read FLines write SetLines;
    property DdeConv: TDdeClientConv read FDdeClientConv write SetDdeClientConv;
    property DdeItem: string read FDdeClientItem write SetDdeClientItem;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

{ TDdeServerConv }

  TDdeServerConv = class(TComponent)
  private
    FOnOpen: TNotifyEvent;
    FOnClose: TNotifyEvent;
    FOnExecuteMacro: TMacroEvent;
  protected
    procedure Connect; dynamic;
    procedure Disconnect; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ExecuteMacro(Data: HDdeData): LongInt;
  published
    property OnOpen: TNotifyEvent read FOnOpen write FOnOpen;
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
    property OnExecuteMacro: TMacroEvent read FOnExecuteMacro write FOnExecuteMacro;
  end;

{ TDdeServerItem }

  TDdeServerItem = class(TComponent)
  private
    FLines: TStrings;
    FServerConv: TDdeServerConv;
    FOnChange: TNotifyEvent;
    FOnPokeData: TNotifyEvent;
    FFmt: Integer;
    procedure ValueChanged;
  protected
    function GetText: string;
    procedure SetText(const Item: string);
    procedure SetLines(Value: TStrings);
    procedure SetServerConv(SConv: TDdeServerConv);
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function PokeData(Data: HDdeData): LongInt;
    procedure CopyToClipboard;
    procedure Change; dynamic;
    property Fmt: Integer read FFmt;
  published
    property ServerConv: TDdeServerConv read FServerConv write SetServerConv;
    property Text: string read GetText write SetText;
    property Lines: TStrings read FLines write SetLines;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnPokeData: TNotifyEvent read FOnPokeData write FOnPokeData;
  end;

{ TDdeMgr }

  TDdeMgr = class(TComponent)
  private
    FAppName: string;
    FHszApp: HSZ;
    FConvs: TList;
    FCliConvs: TList;
    FConvCtrls: TList;
    FDdeInstId: Longint;
    FLinkClipFmt: Word;
    procedure Disconnect(DdeSrvrConv: TComponent);
    function GetSrvrConv(const Topic: string ): TComponent;
    function AllowConnect(hszApp: HSZ; hszTopic: HSZ): Boolean;
    function AllowWildConnect(hszApp: HSZ; hszTopic: HSZ): HDdeData;
    function Connect(Conv: HConv; hszTopic: HSZ; SameInst: Boolean): Boolean;
    procedure PostDataChange(const Topic: string; Item: string);
    procedure SetAppName(const Name: string);
    procedure ResetAppName;
    function  GetServerConv(const Topic: string): TDdeServerConv;
    procedure InsertServerConv(SConv: TDdeServerConv);
    procedure RemoveServerConv(SConv: TDdeServerConv);
//    procedure DoError;
    function  GetForm(const Topic: string): TForm;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetExeName: string;     // obsolete
    property DdeInstId: LongInt read FDdeInstId write FDdeInstId;
    property AppName: string read FAppName write SetAppName;
    property LinkClipFmt: Word read FLinkClipFmt;
  end;

  function GetPasteLinkInfo(var Service: string; var Topic: string;
    var Item: string): Boolean;
var
  ddeMgr: TDdeMgr;

implementation

uses SysUtils, Dialogs, Consts, Clipbrd;

type
  EDdeError = class(Exception);
  TDdeSrvrConv = class;

{ TDdeSrvrItem }

  TDdeSrvrItem = class(TComponent)
  private
    FConv: TDdeSrvrConv;
    FItem: string;
    FHszItem: HSZ;
    FSrvr: TDdeServerItem;
  protected
    procedure SetItem(const Value: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function RequestData(Fmt: Word): HDdeData;
    procedure PostDataChange;
    property Conv: TDdeSrvrConv read FConv write FConv;
    property Item: string read FItem write SetItem;
    property Srvr: TDdeServerItem read FSrvr write FSrvr;
    property HszItem: HSZ read FHszItem;
  end;

{ TDdeSrvrConv }

  TDdeSrvrConv = class(TComponent)
  private
    FTopic: string;
    FHszTopic: HSZ;
    FForm: TForm;
    FSConv: TDdeServerConv;
    FConv: HConv;
//    FCnvInfo: TConvInfo;
//    FDdeFmt: Integer;
    FItems: TList;
  protected
    function GetControl(WinCtrl: TWinControl; DdeConv: TDdeServerConv; const ItemName: string): TDdeServerItem;
    function GetSrvrItem(hszItem: HSZ): TDdeSrvrItem;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function RequestData(Conv: HConv; hszTopic: HSZ; hszItem: HSZ;
      Fmt: Word): HDdeData;
    function AdvStart(Conv: HConv; hszTopic: HSZ; hszItem: HSZ;
      Fmt: Word): Boolean;
    procedure AdvStop(Conv: HConv; hszTopic: HSZ; hszItem: HSZ);
    function PokeData(Conv: HConv; hszTopic: HSZ; hszItem: HSZ; Data: HDdeData;
      Fmt: Integer): LongInt;
    function ExecuteMacro(Conv: HConv; hszTopic: HSZ; Data: HDdeData): Integer;
    function GetItem(const ItemName: string): TDdeSrvrItem;
    property Conv: HConv read FConv;
    property Form: TForm read FForm;
    property SConv: TDdeServerConv read FSConv;
    property Topic: string read FTopic write FTopic;
    property HszTopic: HSZ read FHszTopic;
  end;

{ TDdeCliItem }

  TDdeCliItem = class(TPersistent)
  protected
    FItem: string;
    FHszItem: HSZ;
    FCliConv: TDdeClientConv;
    FCtrl: TDdeClientItem;
    function StartAdvise: Boolean;
    function StopAdvise: Boolean;
    procedure StoreData(DdeDat: HDDEData);
    procedure DataChange;
    function AccessData(DdeDat: HDDEData; pDataLen: PDWORD): Pointer;
    procedure ReleaseData(DdeDat: HDDEData);
  public
    constructor Create(ADS: TDdeClientConv);
    destructor Destroy; override;
    function RefreshData: Boolean;
    function SetItem(const S: string): Boolean;
    procedure SrvrDisconnect;
    property HszItem: HSZ read FHszItem;
    property Control: TDdeClientItem read FCtrl write FCtrl;
  published
    property Item: string read FItem;
  end;

procedure DDECheck(Success: Boolean);
var
  err: Integer;
  ErrStr: string;
begin
  if Success then Exit;
  err := DdeGetLastError(DDEMgr.DdeInstId);
  case err of
    DMLERR_LOW_MEMORY, DMLERR_MEMORY_ERROR:
      ErrStr := Format(SDdeMemErr, [err]);
    DMLERR_NO_CONV_ESTABLISHED:
      ErrStr := Format(SDdeConvErr, [err]);
  else
    ErrStr := Format(SDdeErr, [err]);
  end;
  raise EDdeError.Create(ErrStr);
end;

function DdeMgrCallBack(CallType, Fmt : UINT; Conv: HConv; hsz1, hsz2: HSZ;
  Data: HDDEData; Data1, Data2: DWORD): HDDEData; stdcall;
var
  ci: TConvInfo;
  ddeCli: TComponent;
  ddeSrv: TDdeSrvrConv;
  ddeObj: TComponent;
  xID: DWORD;
begin
  Result := 0;
  case CallType of
    XTYP_CONNECT:
      Result := HDdeData(ddeMgr.AllowConnect(hsz2, hsz1));
    XTYP_WILDCONNECT:
      Result := ddeMgr.AllowWildConnect(hsz2, hsz1);
    XTYP_CONNECT_CONFIRM:
      ddeMgr.Connect(Conv, hsz1, Boolean(Data2));
  end;
  if Conv <> 0 then
  begin
    ci.cb := sizeof(TConvInfo);
    if CallType = XTYP_XACT_COMPLETE then
      xID := Data1
    else
      xID := QID_SYNC;
    if DdeQueryConvInfo(Conv, xID, @ci) = 0 then Exit;
    case CallType of
      XTYP_ADVREQ:
        begin
          ddeSrv := TDdeSrvrConv(ci.hUser);
          Result := ddeSrv.RequestData(Conv, hsz1, hsz2, Fmt);
        end;
      XTYP_REQUEST:
        begin
          ddeSrv := TDdeSrvrConv(ci.hUser);
          Result := ddeSrv.RequestData(Conv, hsz1, hsz2, Fmt);
        end;
      XTYP_ADVSTOP:
        begin
          ddeSrv := TDdeSrvrConv(ci.hUser);
          ddeSrv.AdvStop(Conv, hsz1, hsz2);
        end;
      XTYP_ADVSTART:
        begin
          ddeSrv := TDdeSrvrConv(ci.hUser);
          Result := HDdeData(ddeSrv.AdvStart(Conv, hsz1, hsz2, Fmt));
        end;
      XTYP_POKE:
        begin
          ddeSrv := TDdeSrvrConv(ci.hUser);
          Result := HDdeData(ddeSrv.PokeData(Conv, hsz1, hsz2, Data, Fmt));
        end;
      XTYP_EXECUTE:
        begin
          ddeSrv := TDdeSrvrConv(ci.hUser);
          Result := HDdeData(ddeSrv.ExecuteMacro(Conv, hsz1, Data));
        end;
      XTYP_XACT_COMPLETE:
        begin
          ddeCli := TComponent(ci.hUser);
          if ddeCli <> nil then TDdeClientConv(ddeCli).XactComplete
        end;
      XTYP_ADVDATA:
        begin
          ddeCli := TComponent(ci.hUser);
          TDdeClientConv(ddeCli).DataChange(Data, hsz2);
        end;
      XTYP_DISCONNECT:
        begin
          ddeObj := TComponent(ci.hUser);
          if ddeObj <> nil then
          begin
            if ddeObj is TDdeClientConv then
              TDdeClientConv(ddeObj).SrvrDisconnect
            else
              ddeMgr.Disconnect(ddeObj);
          end;
        end;
    end;
  end;
end;

function GetPasteLinkInfo(var Service, Topic, Item: string): Boolean;
var
  hData: THandle;
  pData: Pointer;
  P: PChar;
begin
  Result := False;
  Clipboard.Open;
  hData := Clipboard.GetAsHandle(ddeMgr.LinkClipFmt);
  if hData <> 0 then
  begin
    pData := GlobalLock(hData);
    try
      P := PChar(pData);
      Service := PChar(pData);
      P := P + Length(Service) + 1;
      Topic := P;
      P := P + Length(Topic) + 1;
      Item := P;
    finally
      GlobalUnlock(hData);
    end;
    Result := True;
  end;
  Clipboard.Close;
end;


{ TDdeMgr }

constructor TDdeMgr.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FLinkClipFmt := RegisterClipboardFormat('Link');
  FDdeInstId := 0;
{$IFDEF MSWINDOWS}  
  DDECheck(DdeInitialize(FDdeInstId, DdeMgrCallBack, APPCLASS_STANDARD, 0) = 0);
{$ENDIF}   
  FConvs := TList.Create;
  FCliConvs := TList.Create;
  FConvCtrls := TList.Create;
  AppName := ParamStr(0);
end;

destructor TDdeMgr.Destroy;
var
  I: Integer;