//可用两个进程间通信来实现
//Form->ServerForm
//ListBox->Debug_List
//Button->Conn_Btn,Send_Btn,Empty_Btn分别为连接,发送文本,清空
unit SevForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, DdeMan;
type
TServerForm = class(TForm)
Conn_btn: TButton;
Debug_List: TListBox;
Label1: TLabel;
Send_Btn: TButton;
Empty_btn: TButton;
procedure FormCreate(Sender: TObject);
procedure Conn_btnClick(Sender: TObject);//要求连接
procedure WndProc(var AMessage : TMessage);
override;
procedure Send_BtnClick(Sender: TObject);//发送文本
procedure Receive_Text(var AMessage: TMessage);
message WM_CopyData;//接收数据
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
procedure Empty_btnClick(Sender: TObject);
//清空列表
private
{ Private declarations }
public
Remote_Handle : Integer;
wm_Init,wm_Answer,wm_Stop : Word;
{ Public declarations }
end;
var
ServerForm: TServerForm;
const
Init_Str = '初始化';
Answer_Str = '回答';
Stop_Str = '结束会话';
implementation
{$R *.DFM}
procedure TServerForm.FormCreate(Sender: TObject);
begin
ServerForm.Caption := 'Handle: '+IntToStr(Self.Handle );
Application.Title := ServerForm.Caption ;
Remote_Handle := 0;
wm_init := RegisterWindowMessage(Init_Str);
wm_Answer := RegisterWindowMessage(Answer_Str);
wm_Stop := RegisterWindowMessage(Stop_Str);
end;
procedure TServerForm.Conn_btnClick(Sender: TObject);
begin
if Remote_Handle = 0 then
SendMessage(65535,wm_Init,Self.Handle,0)
else
SendMessage(Remote_Handle,wm_Stop,Self.Handle,0);
end;
procedure TServerForm.WndProc(var AMessage : TMessage);
begin
if AMessage.Msg = wm_Init then
begin
if AMessage.WParam = Self.Handle
then
Exit;
Debug_list.Items.Add ('窗体: ' + IntToStr(AMessage.WParam) + ' 要求连接');
Remote_Handle := AMessage.WParam ;
SendMessage(Remote_Handle,wm_Answer,Self.Handle,0);
Conn_Btn.Caption := '停止连接';
Send_Btn.Enabled := True;
end;
if AMessage.Msg = wm_Answer then
begin
if AMessage.LParam = 3 then
begin
Debug_List.Items.Add ('文本已成功发送');
Exit;
end;
Debug_List.Items.Add ('窗体: ' + IntToStr(AMessage.WParam) + ' 同意连接');
if Remote_Handle = 0 then
Remote_Handle := AMessage.WParam ;
Conn_Btn.Caption := '停止连接';
Send_Btn.Enabled := True;
end;
if AMessage.Msg = wm_Stop then
begin
if AMessage.LParam = 0 then
begin
Debug_List.Items.Add ('窗体: ' + IntToStr(AMessage.WParam)
+ ' 要求停止连接');
SendMessage(Remote_Handle,wm_Stop,Self.Handle,1);
end else
if (AMessage.LParam = 1) or (AMessage.LParam = 2) then
Debug_List.Items.Add ('窗体: ' + IntToStr(AMessage.WParam)
+ ' 已断开连接');
Remote_Handle := 0;
Conn_Btn.Caption := '开始连接';
Send_Btn.Enabled := False;
end;
inherited WndProc(AMessage);
end;
procedure TServerForm.Send_BtnClick(Sender: TObject);
var
Send_Text : String;
Send_Struct : Tcopydatastruct;
begin
Send_Text := InputBox('文字传送','传送文字:','');
if Send_Text = '' then
exit;
Send_Struct.dwData := 0;
Send_Struct.cbData := SizeOf(Send_Text);
Send_Struct.lpData := Pchar(Send_Text);
if Remote_Handle = 0 then
Conn_BtnClick(nil) ;
SendMessage(Remote_Handle,Wm_Copydata,Self.Handle,Lparam(@Send_Struct));
end;
procedure TServerForm.Receive_Text(var AMessage: TMessage);
var
Txt : Pchar;
PText : ^CopyDataStruct;
begin
PText := Pointer(AMessage.LParam);
Txt := PText.lpData ;
Debug_List.Items.Add ('以下为窗体 '+ IntToStr(Remote_Handle) + ' 传来的文本:');
Debug_List.Items.Add (Txt);
SendMessage(Remote_Handle,wm_Answer,Self.Handle,3);
end;
procedure TServerForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
SendMessage(Remote_Handle,wm_Stop,Handle,2);
end;
procedure TServerForm.Empty_btnClick(Sender: TObject);
begin
Debug_List.Items.Clear;
end;
end.