ddeman.pas

这是不可多得的源代码

begin
  if FConvs <> nil then
  begin
    for I := 0 to FConvs.Count - 1 do
      TDdeSrvrConv(FConvs[I]).Free;
    FConvs.Free;
    FConvs := nil;
  end;
  if FCliConvs <> nil then
  begin
    for I := 0 to FCliConvs.Count - 1 do
      TDdeSrvrConv(FCliConvs[I]).Free;
    FCliConvs.Free;
    FCliConvs := nil;
  end;
  if FConvCtrls <> nil then
  begin
    FConvCtrls.Free;
    FConvCtrls := nil;
  end;
  ResetAppName;
{$IFDEF MSWINDOWS}   
  DdeUnInitialize(FDdeInstId);
{$ENDIF}   
  DdeMgr := nil;
  inherited Destroy;
end;

function TDdeMgr.AllowConnect(hszApp: HSZ; hszTopic: HSZ): Boolean;
var
  Topic: string;
  Buffer: array[0..4095] of Char;
  Form: TForm;
  SConv: TDdeServerConv;
begin
  Result := False;
  if (hszApp = 0) or (DdeCmpStringHandles(hszApp, FHszApp) = 0)  then
  begin
    SetString(Topic, Buffer, DdeQueryString(FDdeInstId, hszTopic, Buffer,
      SizeOf(Buffer), CP_WINANSI));
    SConv := GetServerConv(Topic);
    if SConv <> nil then
      Result := True
    else begin
      Form := GetForm(Topic);
      if Form <> nil then Result := True;
    end;
  end;
end;

function TDdeMgr.AllowWildConnect(hszApp: HSZ; hszTopic: HSZ): HDdeData;
var
  conns: packed array[0..1] of THSZPair;
begin
  Result := 0;
  if hszTopic = 0 then Exit;
  if AllowConnect(hszApp, hszTopic) = True then
  begin
    conns[0].hszSvc := FHszApp;
    conns[0].hszTopic := hszTopic;
    conns[1].hszSvc := 0;
    conns[1].hszTopic := 0;
    Result := DdeCreateDataHandle(ddeMgr.DdeInstId, @conns,
      2 * sizeof(THSZPair), 0, 0, CF_TEXT, 0);
  end;
end;

function TDdeMgr.Connect(Conv: HConv; hszTopic: HSZ; SameInst: Boolean): Boolean;
var
  Topic: string;
  Buffer: array[0..4095] of Char;
  DdeConv: TDdeSrvrConv;
begin
  DdeConv := TDdeSrvrConv.Create(Self);
  SetString(Topic, Buffer, DdeQueryString(FDdeInstId, hszTopic, Buffer,
    SizeOf(Buffer), CP_WINANSI));
  DdeConv.Topic := Topic;
  DdeConv.FSConv := GetServerConv(Topic);
  if DdeConv.FSConv = nil then
    DdeConv.FForm := GetForm(Topic);
  DdeConv.FConv := Conv;
  DdeSetUserHandle(Conv, QID_SYNC, DWORD(DdeConv));
  FConvs.Add(DdeConv);
  if DdeConv.FSConv <> nil then DdeConv.FSConv.Connect;
  Result := True;
end;

procedure TDdeMgr.Disconnect(DdeSrvrConv: TComponent);
var
  DdeConv: TDdeSrvrConv;
begin
  DdeConv := TDdeSrvrConv(DdeSrvrConv);
  if DdeConv.FSConv <> nil then DdeConv.FSConv.Disconnect;
  if DdeConv.FConv <> 0 then DdeSetUserHandle(DdeConv.FConv, QID_SYNC, 0);
  DdeConv.FConv := 0;
  if FConvs <> nil then
  begin
    FConvs.Remove(DdeConv);
    DdeConv.Free;
  end;
end;

function TDdeMgr.GetExeName: string;
begin
  Result := ParamStr(0);
end;

procedure TDdeMgr.SetAppName(const Name: string);
var
  Dot: Integer;
begin
  ResetAppName;
  FAppName := ExtractFileName(Name);
  Dot := Pos('.', FAppName);
  if Dot <> 0 then
    Delete(FAppName, Dot, Length(FAppName));
  FHszApp := DdeCreateStringHandle(FDdeInstId, PChar(FAppName), CP_WINANSI);
  DdeNameService(FDdeInstId, FHszApp, 0, DNS_REGISTER);
end;

procedure TDdeMgr.ResetAppName;
begin
  if FHszApp <> 0 then
  begin
    DdeNameService(FDdeInstId, FHszApp, 0, DNS_UNREGISTER);
    DdeFreeStringHandle(FDdeInstId, FHszApp);
  end;
  FHszApp := 0;
end;

function TDdeMgr.GetServerConv(const Topic: string): TDdeServerConv;
var
  I: Integer;
  SConv: TDdeServerConv;
begin
  Result := nil;
  for I := 0 to FConvCtrls.Count - 1 do
  begin
    SConv := TDdeServerConv(FConvCtrls[I]);
    if AnsiCompareText(SConv.Name, Topic) = 0 then
    begin
      Result := SConv;
      Exit;
    end;
  end;
end;

function TDdeMgr.GetForm(const Topic: string): TForm;
var
  I: Integer;
  Form: TForm;
begin
  Result := nil;
  for I := 0 to Screen.FormCount - 1 do
  begin
    Form := TForm(Screen.Forms[I]);
    if AnsiCompareText(Form.Caption, Topic) = 0 then
    begin
      Result := Form;
      Exit;
    end;
  end;
end;

function TDdeMgr.GetSrvrConv(const Topic: string ): TComponent;
var
  I: Integer;
  Conv: TDdeSrvrConv;
begin
  Result := nil;
  for I := 0 to FConvs.Count - 1 do
  begin
    Conv := FConvs[I];
    if AnsiCompareText(Conv.Topic, Topic) = 0 then
    begin
      Result := Conv;
      Exit;
    end;
  end;
end;

procedure TDdeMgr.PostDataChange(const Topic: string; Item: string);
var
  Conv: TDdeSrvrConv;
  Itm: TDdeSrvrItem;
begin
  Conv := TDdeSrvrConv(GetSrvrConv (Topic));
  If Conv <> nil then
  begin
    Itm := Conv.GetItem(Item);
    if Itm <> nil then Itm.PostDataChange;
  end;
end;

procedure TDdeMgr.InsertServerConv(SConv: TDdeServerConv);
begin
  FConvCtrls.Insert(FConvCtrls.Count, SConv);
end;

procedure TDdeMgr.RemoveServerConv(SConv: TDdeServerConv);
begin
  FConvCtrls.Remove(SConv);
end;

{procedure TDdeMgr.DoError;
begin
  DDECheck(False);
end;}

constructor TDdeClientConv.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FItems := TList.Create;
end;

destructor TDdeClientConv.Destroy;
begin
  CloseLink;
  inherited Destroy;
  FItems.Free;
  FItems := nil;
end;

procedure TDdeClientConv.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('LinkInfo', ReadLinkInfo, WriteLinkInfo,
    not ((DdeService = '') and (DdeTopic = '')));
end;

procedure TDdeClientConv.Loaded;
var
  Service, Topic: string;
begin
  inherited Loaded;
  Service := DdeService;
  Topic := DdeTopic;
  if (Length(Service) <> 0) and (ConnectMode <> ddeManual) then
    ChangeLink(Service, Topic, '');
end;

procedure TDdeClientConv.ReadLinkInfo (Reader: TReader);
var
  Value: string;
  Text: string;
  Temp: Integer;
begin
  Reader.ReadListBegin;
  while not Reader.EndOfList do
  begin
    Value := Reader.ReadString;
    Temp := Pos(' ', Value);
    Text := Copy(Value, Temp + 1, Length (Value) - Temp);
    case Value[1] of
      'S': SetService(Text);
      'T': SetTopic(Text);
    end;
  end;
  Reader.ReadListEnd;
end;

procedure TDdeClientConv.WriteLinkInfo (Writer: TWriter);
var
  Value: string;
begin
  Writer.WriteListBegin;
  Value := DdeService;
  Writer.WriteString(Format('Service %s', [Value]));
  Value := DdeTopic;
  Writer.WriteString(Format('Topic %s', [Value]));
  Writer.WriteListEnd;
end;

procedure TDdeClientConv.OnAttach(aCtrl: TDdeClientItem);
var
  ItemLnk: TDdeCliItem;
begin
  ItemLnk := TDdeCliItem.Create(Self);
  FItems.Insert(FItems.Count, ItemLnk);
  ItemLnk.Control := aCtrl;
  ItemLnk.SetItem('');
end;

procedure TDdeClientConv.OnDetach(aCtrl: TDdeClientItem);
var
  ItemLnk: TDdeCliItem;
begin
  ItemLnk := TDdeCliItem(GetCliItemByCtrl(aCtrl));
  if ItemLnk <> nil then
  begin
    ItemLnk.SetItem('');
    FItems.Remove(ItemLnk);
    ItemLnk.Free;
  end;
end;

function TDdeClientConv.OnSetItem(aCtrl: TDdeClientItem; const S: string): Boolean;
var
  ItemLnk: TDdeCliItem;
begin
  Result := True;
  ItemLnk := TDdeCliItem(GetCliItemByCtrl(aCtrl));

  if (ItemLnk = nil) and (Length(S) > 0) then
  begin
    OnAttach (aCtrl);
    ItemLnk := TDdeCliItem(GetCliItemByCtrl(aCtrl));
  end;

  if (ItemLnk <> nil) and (Length(S) = 0) then
  begin
    OnDetach (aCtrl);
  end
  else if ItemLnk <> nil then
  begin
    Result := ItemLnk.SetItem(S);
    if Not (Result) and Not (csLoading in ComponentState) then
      OnDetach (aCtrl);  {error occurred, do cleanup}
  end;
end;

function TDdeClientConv.GetCliItemByCtrl(ACtrl: TDdeClientItem): TPersistent;
var
  ItemLnk: TDdeCliItem;
  I: word;
begin
  Result := nil;
  I := 0;
  while I < FItems.Count do
  begin
    ItemLnk := FItems[I];
    if ItemLnk.Control = aCtrl then
    begin
      Result := ItemLnk;
      Exit;
    end;
    Inc(I);
  end;
end;

function TDdeClientConv.PasteLink: Boolean;
var
  Service, Topic, Item: string;
begin
  if GetPasteLinkInfo(Service, Topic, Item) = True then
    Result := ChangeLink(Service, Topic, Item) else
    Result := False;
end;

function TDdeClientConv.ChangeLink(const App, Topic, Item: string): Boolean;
begin
  CloseLink;
  SetService(App);
  SetTopic(Topic);
  Result := OpenLink;
  if Not Result then
  begin
    SetService('');
    SetTopic('');
  end;
end;

function TDdeClientConv.OpenLink: Boolean;
var
  CharVal: array[0..255] of Char;
  Res: Boolean;
begin
  Result := False;
  if FConv <> 0 then Exit;

  if (Length(DdeService) = 0) and (Length(DdeTopic) = 0) then
  begin
    ClearItems;
    Exit;
  end;

  if FHszApp = 0 then
  begin
    StrPCopy(CharVal, DdeService);
    FHszApp := DdeCreateStringHandle(ddeMgr.DdeInstId, CharVal, CP_WINANSI);
  end;
  if FHszTopic = 0 then
  begin
    StrPCopy(CharVal, DdeTopic);
    FHszTopic := DdeCreateStringHandle(ddeMgr.DdeInstId, CharVal, CP_WINANSI);
  end;
  Res := CreateDdeConv(FHszApp, FHszTopic);
  if Not Res then
  begin
    if Not((Length(DdeService) = 0) and
      (Length(ServiceApplication) = 0)) then
    begin
      if Length(ServiceApplication) <> 0 then
        StrPCopy(CharVal, ServiceApplication)
      else
        StrPCopy(CharVal, DdeService + ' ' + DdeTopic);
      if WinExec(CharVal, SW_SHOWMINNOACTIVE) >= 32 then
        Res := CreateDdeConv(FHszApp, FHszTopic);
    end;
  end;
  if Not Res then
  begin
    ClearItems;
    Exit;
  end;
  if FCnvInfo.wFmt <> 0 then FDdeFmt := FCnvInfo.wFmt
  else FDdeFmt := CF_TEXT;
  if StartAdvise = False then Exit;
  Open;
  DataChange(0, 0);
  Result := True;
end;

procedure TDdeClientConv.CloseLink;
var
  OldConv: HConv;
begin
  if FConv <> 0 then
  begin
    OldConv := FConv;
    SrvrDisconnect;
    FConv := 0;
    DdeSetUserHandle(OldConv, QID_SYNC, 0);
    DdeDisconnect(OldConv);
  end;

  if FHszApp <> 0 then
  begin
    DdeFreeStringHandle(ddeMgr.DdeInstId, FHszApp);
    FHszApp := 0;
  end;

  if FHszTopic <> 0 then
  begin
    DdeFreeStringHandle(ddeMgr.DdeInstId, FHszTopic);
    FHszTopic := 0;
  end;
  SetService('');
  SetTopic('');
end;

procedure TDdeClientConv.ClearItems;
var
  ItemLnk: TDdeCliItem;
  i: word;
begin
  if FItems.Count = 0 then Exit;

  for I := 0 to FItems.Count - 1 do
  begin
    ItemLnk := TDdeCliItem(FItems [0]);
    ItemLnk.Control.DdeItem := EmptyStr;