DBR Delphi-Ecke

// Getestet mit D4 unter XP

// Variante 1:

// Hiermit kann man Integer-Werte an eine andere Anwendung senden:

unit senden; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  StdCtrls; 
 
const WM_MyMsg = WM_USER + $7FFF; 
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Button2: TButton; 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    { Public-Deklarationen } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  h: THandle; 
  i: integer; 
begin 
  i := 1234; 
  h := findwindow(nil, 'Empfangstest'); 
  if h <> 0 then 
    sendmessage(h, WM_MyMsg, 0, i) 
  else showmessage('Empfänger nicht gefunden'); 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  h: THandle; 
  i: integer; 
begin 
  i := 9999; 
  h := findwindow(nil, 'Empfangstest'); 
  if h <> 0 then 
    sendmessage(h, WM_MyMsg, 1, i) 
  else showmessage('Empfänger nicht gefunden'); 
end; 
 
end.

// Und so wird beispielsweise empfangen:

unit empfangen; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  StdCtrls; 
 
const WM_MyMsg = WM_USER + $7FFF; 
 
type 
  TForm1 = class(TForm) 
    Label1: TLabel; 
    Label2: TLabel; 
    procedure FormCreate(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    procedure Empfang(var Msg: TMessage); message WM_MyMsg; 
    procedure anzeige; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
const 
  zahl: array[0..1] of integer = (0, 0); 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  caption := 'Empfangstest'; 
  anzeige; 
end; 
 
procedure TForm1.anzeige; 
begin 
  Label1.caption := inttostr(zahl[0]); 
  Label2.caption := inttostr(zahl[1]); 
end; 
 
procedure TForm1.Empfang(var Msg: TMessage); 
begin 
  zahl[Msg.WParam] := Msg.LParam; 
  anzeige; 
end; 
 
end.

// ************************************************************

// Variante 2:

// Hiermit kann man Text an eine andere Anwendung senden:

unit senden; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  StdCtrls; 
 
const WM_TXTHANDLE = WM_USER + $7FFE; 
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    procedure Button1Click(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    { Public-Deklarationen } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
var 
  BlindMemo: TMemo; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  BlindMemo := TMemo.create(self); 
  BlindMemo.parent := self; 
  BlindMemo.Visible := false; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  BlindMemo.free; 
end; 
 
procedure SendText(h: THandle; s: string); 
begin 
  with BlindMemo do begin 
    Text := adjustlinebreaks(s); 
    sendmessage(h, WM_TXTHANDLE, length(text), handle); 
  end; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
var h: THandle; 
begin 
  h := findwindow(nil, 'Empfangstest'); 
  if h = 0 then showmessage('Empfänger nicht gefunden') else 
    SendText(h, 'Das ist ein Test' + #13 + 'zum Senden von Strings'); 
end; 
 
end.

// Und so kann man den Text empfangen:

unit empfangen; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  StdCtrls; 
 
const WM_TXTHANDLE = WM_USER + $7FFE; 
 
type 
  TForm1 = class(TForm) 
    Memo1: TMemo; 
    procedure FormCreate(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    procedure Empfang(var Msg: TMessage); message WM_TXTHANDLE; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  caption := 'Empfangstest'; 
end; 
 
function GetText(lang: word; h: THandle): string; 
begin 
  setlength(result, lang); 
  SendMessage(h, WM_GETTEXT, lang + 1, integer(PChar(result))); 
end; 
 
procedure TForm1.Empfang(var Msg: TMessage); 
begin 
  Memo1.Text := GetText(Msg.WParam, Msg.LParam); 
end; 
 
end.

// ************************************************************

// Variante 3:

// Records, Bilder oder Töne an eine andere Anwendung senden:

unit sendu; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  StdCtrls; 
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Button2: TButton; 
    Button3: TButton; 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    procedure SendRecord(h: THandle); 
    procedure SendStream(str: TMemoryStream; was: integer; h: THandle); 
    function FindReceiver: THandle; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
type 
  TRecord = packed record 
    d: double; 
    i: integer; 
    s: shortstring; 
  end; 
 
var 
  MyRecord: TRecord; 
  struct: TCopyDataStruct; 
  h: THandle; 
 
procedure TForm1.SendRecord(h: THandle); 
begin 
  struct.dwData := 0; 
  struct.cbData := SizeOf(MyRecord); 
  struct.lpData := @MyRecord; 
  SendMessage(h, WM_COPYDATA, handle, Integer(@struct)); 
end; 
 
procedure TForm1.SendStream(str: TMemoryStream; was: integer; h: THandle); 
begin 
  if was = 0 then 
    raise exception.create('"0" ist für Records reserviert'); 
  Struct.dwData := was; 
  Struct.cbData := str.Size; 
  Struct.lpData := str.Memory; 
  SendMessage(h, WM_COPYDATA, handle, Integer(@struct)); 
end; 
 
function TForm1.FindReceiver: THandle; 
begin 
  result := findwindow(nil, 'Empfangstest'); 
  if result = 0 then showmessage('Empfänger nicht gefunden'); 
end; 
 
// Record senden 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  h := FindReceiver; 
  if h <> 0 then begin 
    MyRecord.d := 100.77; 
    MyRecord.i := 123456; 
    MyRecord.s := 'Record senden'; 
    SendRecord(h); 
  end; 
end; 
 
// Bitmap senden 
 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  b: TBitmap; 
  ms: TMemoryStream; 
  art: integer; 
begin 
  h := FindReceiver; 
  if h <> 0 then begin 
    art := 1; 
    b := TBitmap.create; 
    ms := TMemoryStream.create; 
    b.loadfromfile('c:\test.bmp'); 
    b.savetostream(ms); 
    sendStream(ms, art, h); 
    b.free; 
    ms.free; 
  end; 
end; 
 
// Wave senden 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  ms: TMemoryStream; 
  art: integer; 
begin 
  h := FindReceiver; 
  if h <> 0 then begin 
    art := 2; 
    ms := TMemoryStream.create; 
    ms.loadfromfile('d:\music.wav'); 
    sendStream(ms, art, h); 
    ms.free; 
  end; 
end; 
 
end.

// Und so kann man Records, Bilder und Töne empfangen:

unit empfu; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  StdCtrls, ExtCtrls; 
 
type 
  TForm1 = class(TForm) 
    Label1: TLabel; 
    Label2: TLabel; 
    Label3: TLabel; 
    Image1: TImage; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    procedure WMCopyData(var Msg: TWMCopyData); message WM_COPYDATA; 
    procedure ReceiveRecord(Struct: PCopyDataStruct); 
    procedure ReceiveBitmap(Struct: PCopyDataStruct); 
    procedure ReceiveWave(Struct: PCopyDataStruct); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
uses mmsystem; 
 
type 
  TRecord = packed record 
    d: double; 
    i: integer; 
    s: shortstring; 
  end; 
 
var 
  buf: array of byte; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  caption := 'Empfangstest'; 
end; 
 
procedure TForm1.WMCopyData(var Msg: TWMCopyData); 
begin 
  case Msg.CopyDataStruct.dwData of 
    0: ReceiveRecord(Msg.CopyDataStruct); 
    1: ReceiveBitmap(Msg.CopyDataStruct); 
    2: ReceiveWave(Msg.CopyDataStruct); 
  end; 
end; 
 
procedure TForm1.ReceiveRecord(Struct: PCopyDataStruct); 
var 
  MyRecord: TRecord; 
begin 
  MyRecord.d := TRecord(Struct.lpData^).d; 
  MyRecord.i := TRecord(Struct.lpData^).i; 
  MyRecord.s := TRecord(Struct.lpData^).s; 
  Label1.caption := FloatToStr(MyRecord.d); 
  Label2.caption := IntToStr(MyRecord.i); 
  Label3.caption := MyRecord.s; 
end; 
 
procedure TForm1.ReceiveBitmap(Struct: PCopyDataStruct); 
var 
  ms: TMemoryStream; 
begin 
  ms := TMemoryStream.Create; 
  ms.Write(Struct.lpData^, Struct.cbData); 
  ms.seek(0, soFromBeginning); 
  Image1.Picture.Bitmap.LoadFromStream(ms); 
  Image1.autosize := true; 
  ms.Free; 
end; 
 
procedure TForm1.ReceiveWave(Struct: PCopyDataStruct); 
var 
  ms: TMemoryStream; 
begin 
  ms := TMemoryStream.Create; 
  ms.Write(Struct.lpData^, Struct.cbData); 
  setlength(buf, ms.size); 
  copymemory(buf, ms.memory, ms.size); 
  ms.free; 
  playsound(@buf[0], 0, SND_MEMORY or SND_ASYNC); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  buf := nil; 
end; 
 
end.