ddeman.pas

这是不可多得的源代码

end;

function TDdeCliItem.StartAdvise: Boolean;
var
  ddeRslt: LongInt;
  hdata: HDDEData;
begin
  Result := False;
  if FCliConv.Conv = 0 then Exit;
  if Length(Item) = 0 then Exit;
  if FHszItem = 0 then
    FHszItem := DdeCreateStringHandle(ddeMgr.DdeInstId, PChar(Item), CP_WINANSI);
  hdata := DdeClientTransaction(nil, DWORD(-1), FCliConv.Conv, FHszItem,
    FCliConv.DdeFmt, XTYP_ADVSTART or XTYPF_NODATA, 1000, @ddeRslt);
  if hdata = 0 then
  begin
    DdeGetLastError(ddeMgr.DdeInstId);
    DdeFreeStringHandle(ddeMgr.DdeInstId, FHszItem);
    FHszItem := 0;
    FCtrl.Lines.Clear;
  end else
    Result := True;
end;

function TDdeCliItem.StopAdvise: Boolean;
var
  ddeRslt: LongInt;
begin
  if FCliConv.Conv <> 0 then
    if FHszItem <> 0 then
      DdeClientTransaction(nil, DWORD(-1), FCliConv.Conv, FHszItem,
        FCliConv.DdeFmt, XTYP_ADVSTOP, 1000, @ddeRslt);
  SrvrDisconnect;
  Result := True;
end;

procedure TDdeCliItem.SrvrDisconnect;
begin
  if FHszItem <> 0 then
  begin
    DdeFreeStringHandle(ddeMgr.DdeInstId, FHszItem);
    FHszItem := 0;
  end;
end;

procedure TDdeCliItem.DataChange;
begin
  FCtrl.OnAdvise;
end;

constructor TDdeServerItem.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFmt := CF_TEXT;
  FLines := TStringList.Create;
end;

destructor TDdeServerItem.Destroy;
begin
  FLines.Free;
  inherited Destroy;
end;

procedure TDdeServerItem.SetServerConv(SConv: TDdeServerConv);
begin
  FServerConv := SConv;
  if SConv <> nil then SConv.FreeNotification(Self);
end;

function TDdeServerItem.GetText: string;
begin
  if FLines.Count > 0 then
    Result := FLines.Strings[0]
  else Result := '';
end;

procedure TDdeServerItem.SetText(const Item: string);
begin
  FFmt := CF_TEXT;
  FLines.Clear;
  FLines.Add(Item);
  ValueChanged;
end;

procedure TDdeServerItem.SetLines(Value: TStrings);
begin
  if AnsiCompareStr(Value.Text, FLines.Text) <> 0 then
  begin
    FFmt := CF_TEXT;
    FLines.Assign(Value);
    ValueChanged;
  end;
end;

procedure TDdeServerItem.ValueChanged;
begin
  if Assigned(FOnChange) then FOnChange(Self);
  if FServerConv <> nil then
    ddeMgr.PostDataChange(FServerConv.Name, Name)
  else if (Owner <> nil) and (Owner is TForm) then
    ddeMgr.PostDataChange(TForm(Owner).Caption, Name);
end;

function TDdeServerItem.PokeData(Data: HDdeData): LongInt;
var
  Len: Integer;
  pData: Pointer;
begin
  Result := dde_FNotProcessed;
  pData := DdeAccessData(Data, @Len);
  if pData <> nil then
  begin
    Lines.Text := PChar(pData);
    DdeUnaccessData(Data);
    ValueChanged;
    if Assigned(FOnPokeData) then FOnPokeData(Self);
    Result := dde_FAck;
  end;
end;

procedure TDdeServerItem.CopyToClipboard;
var
  Data: THandle;
  LinkData: string;
  DataPtr: Pointer;
begin
  if FServerConv <> nil then
    LinkData := ddeMgr.AppName + #0 + FServerConv.Name + #0 + Name
  else if (Owner =nil) then Exit
  else if Owner is TForm then
    LinkData := ddeMgr.AppName + #0 + TForm(Owner).Caption + #0 + Name;
  try
    Clipboard.AsText := Text;
    Data := GlobalAlloc(GMEM_MOVEABLE, Length(LinkData) + 1);
    try
      DataPtr := GlobalLock(Data);
      try
        Move(PChar(LinkData)^, DataPtr^, Length(LinkData) + 1);
        Clipboard.SetAsHandle(DdeMgr.LinkClipFmt, Data);
      finally
        GlobalUnlock(Data);
      end;
    except
      GlobalFree(Data);
      raise;
    end;
  finally
    Clipboard.Close;
  end;
end;

procedure TDdeServerItem.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TDdeServerItem.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = FServerConv) and (Operation = opRemove) then
    FServerConv := nil;
end;

constructor TDdeServerConv.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ddeMgr.InsertServerConv (Self);
end;

destructor TDdeServerConv.Destroy;
begin
  ddeMgr.RemoveServerConv(Self);
  inherited Destroy;
end;

function TDdeServerConv.ExecuteMacro(Data: HDdeData): LongInt;
var
  Len: Integer;
  pData: Pointer;
  MacroLines: TStringList;
begin
  Result := dde_FNotProcessed;
  pData := DdeAccessData(Data, @Len);
  if pData <> nil then
  begin
    if Assigned(FOnExecuteMacro) then
    begin
      MacroLines := TStringList.Create;
      MacroLines.Text := PChar(pData);
      FOnExecuteMacro(Self, MacroLines);
      MacroLines.Destroy;
    end;
    Result := dde_FAck;
  end;
end;

procedure TDdeServerConv.Connect;
begin
  if Assigned(FOnOpen) then FOnOpen(Self);
end;

procedure TDdeServerConv.Disconnect;
begin
  if Assigned(FOnClose) then FOnClose(Self);
end;

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

destructor TDdeSrvrConv.Destroy;
var
  I: Integer;
begin
  if FItems <> nil then
  begin
    for I := 0 to FItems.Count - 1 do
      TDdeSrvrItem(FItems[I]).Free;
    FItems.Free;
    FItems := nil;
  end;
  if FConv <> 0 then DdeDisconnect(FConv);
  if FHszTopic <> 0 then
  begin
    DdeFreeStringHandle(ddeMgr.DdeInstId, FHszTopic);
    FHszTopic := 0;
  end;
  inherited Destroy;
end;

function TDdeSrvrConv.AdvStart(Conv: HConv; hszTopic: HSZ; hszItem: HSZ;
  Fmt: Word): Boolean;
var
  Srvr: TDdeServerItem;
  Buffer: array[0..4095] of Char;
  SrvrItem: TDdeSrvrItem;
begin
  Result := False;
  if Fmt <> CF_TEXT then Exit;
  DdeQueryString(ddeMgr.DdeInstId, hszItem, Buffer, SizeOf(Buffer), CP_WINANSI);
  Srvr := GetControl(FForm, FSConv, Buffer);
  if Srvr = nil then Exit;
  SrvrItem := TDdeSrvrItem.Create(Self);
  SrvrItem.Srvr := Srvr;
  SrvrItem.Item := Buffer;
  FItems.Add(SrvrItem);
  SrvrItem.FreeNotification(Self);
  if FHszTopic = 0 then
    FHszTopic := DdeCreateStringHandle(ddeMgr.DdeInstId, PChar(Topic), CP_WINANSI);
  Result := True;
end;

procedure TDdeSrvrConv.AdvStop(Conv: HConv; hszTopic: HSZ; hszItem :HSZ);
var
  SrvrItem: TDdeSrvrItem;
begin
  SrvrItem := GetSrvrItem(hszItem);
  if SrvrItem <> nil then
  begin
    FItems.Remove(SrvrItem);
    SrvrItem.Free;
  end;
end;

function TDdeSrvrConv.PokeData(Conv: HConv; hszTopic: HSZ; hszItem: HSZ;
  Data: HDdeData; Fmt: Integer): LongInt;
var
  Srvr: TDdeServerItem;
  Buffer: array[0..4095] of Char;
begin
  Result := dde_FNotProcessed;
  if Fmt <> CF_TEXT then Exit;
  DdeQueryString(ddeMgr.DdeInstId, hszItem, Buffer, SizeOf(Buffer), CP_WINANSI);
  Srvr := GetControl(FForm, FSConv, Buffer);
  if Srvr <> nil then Result := Srvr.PokeData(Data);
end;

function TDdeSrvrConv.ExecuteMacro(Conv: HConv; hszTopic: HSZ;
  Data: HDdeData): Integer;
begin
  Result := dde_FNotProcessed;
  if (FSConv <> nil)  then
    Result := FSConv.ExecuteMacro(Data);
end;

function TDdeSrvrConv.RequestData(Conv: HConv; hszTopic: HSZ; hszItem :HSZ;
  Fmt: Word): HDdeData;
var
  Data: string;
  Buffer: array[0..4095] of Char;
  SrvrIt: TDdeSrvrItem;
  Srvr: TDdeServerItem;
begin
  Result := 0;
  SrvrIt := GetSrvrItem(hszItem);
  if SrvrIt <> nil then
    Result := SrvrIt.RequestData(Fmt)
  else
  begin
    DdeQueryString(ddeMgr.DdeInstId, hszItem, Buffer, SizeOf(Buffer), CP_WINANSI);
    Srvr := GetControl(FForm, FSConv, Buffer);
    if Srvr <> nil then
    begin
      if Fmt = CF_TEXT then
      begin
        Data := Srvr.Lines.Text;
        Result := DdeCreateDataHandle(ddeMgr.DdeInstId, PChar(Data),
          Length(Data) + 1, 0, hszItem, Fmt, 0 );
      end;
    end;
  end;
end;

function TDdeSrvrConv.GetControl(WinCtrl: TWinControl; DdeConv: TDdeServerConv; const ItemName: string): TDdeServerItem;
var
  I: Integer;
  Ctrl: TComponent;
  MainCtrl: TWinControl;
  Srvr: TDdeServerItem;
begin
  Result := nil;
  MainCtrl := WinCtrl;
  if MainCtrl = nil then
  begin
    if (DdeConv <> nil) and (DdeConv.Owner <> nil) and
      (DdeConv.Owner is TForm) then
      MainCtrl := TWinControl(DdeConv.Owner);
  end;
  if MainCtrl = nil then Exit;
  for I := 0 to MainCtrl.ComponentCount - 1 do
  begin
    Ctrl := MainCtrl.Components[I];
    if Ctrl is TDdeServerItem then
    begin
      if (Ctrl.Name = ItemName) and
        (TDdeServerItem(Ctrl).ServerConv = DdeConv) then
      begin
        Result := TDdeServerItem(Ctrl);
        Exit;
      end;
    end;
    if Ctrl is TWinControl then
    begin
      Srvr := GetControl(TWinControl(Ctrl), DdeConv, ItemName);
      if Srvr <> nil then
      begin
        Result := Srvr;
        Exit;
      end;
    end;
  end;
end;

function TDdeSrvrConv.GetItem(const ItemName: string): TDdeSrvrItem;
var
  I: Integer;
  Item: TDdeSrvrItem;
begin
  Result := nil;
  for I := 0 to FItems.Count - 1 do
  begin
    Item := FItems[I];
    If Item.Item = ItemName then
    begin
      Result := Item;
      Exit;
    end;
  end;
end;

function TDdeSrvrConv.GetSrvrItem(hszItem: HSZ): TDdeSrvrItem;
var
  I: Integer;
  Item: TDdeSrvrItem;
begin
  Result := nil;
  for I := 0 to FItems.Count - 1 do
  begin
    Item := FItems[I];
    If DdeCmpStringHandles(Item.HszItem, hszItem) = 0 then
    begin
      Result := Item;
      Exit;
    end;
  end;
end;

constructor TDdeSrvrItem.Create(AOwner: TComponent);
begin
  FConv := TDdeSrvrConv(AOwner);
  inherited Create(AOwner);
end;

destructor TDdeSrvrItem.Destroy;
begin
  if FHszItem <> 0 then
  begin
    DdeFreeStringHandle(ddeMgr.DdeInstId, FHszItem);
    FHszItem := 0;
  end;
  inherited Destroy;
end;

function TDdeSrvrItem.RequestData(Fmt: Word): HDdeData;
var
  Data: string;
  Buffer: array[0..4095] of Char;
begin
  Result := 0;
  SetString(FItem, Buffer, DdeQueryString(ddeMgr.DdeInstId, FHszItem, Buffer,
    SizeOf(Buffer), CP_WINANSI));
  if Fmt = CF_TEXT then
  begin
    Data := FSrvr.Lines.Text;
    Result := DdeCreateDataHandle(ddeMgr.DdeInstId, PChar(Data), Length(Data) + 1,
      0, FHszItem, Fmt, 0 );
  end;
end;

procedure TDdeSrvrItem.PostDataChange;
begin
  DdePostAdvise(ddeMgr.DdeInstId, FConv.HszTopic, FHszItem);
end;

procedure TDdeSrvrItem.SetItem(const Value: string);
begin
  FItem := Value;
  if FHszItem <> 0 then
  begin
    DdeFreeStringHandle(ddeMgr.DdeInstId, FHszItem);
    FHszItem := 0;
  end;
  if Length(FItem) > 0 then
    FHszItem := DdeCreateStringHandle(ddeMgr.DdeInstId, PChar(FItem), CP_WINANSI);
end;

initialization
  ddeMgr := TDdeMgr.Create(Application);
  GroupDescendentsWith(TDdeClientConv, TControl);
  GroupDescendentsWith(TDdeClientItem, TControl);
  GroupDescendentsWith(TDdeServerConv, TControl);
  GroupDescendentsWith(TDdeServerItem, TControl);
finalization
  FreeAndNil(ddeMgr);
end.