Walkie-talkie 2 or How to send a stream to another application
Sending string, stream, component to another Delphi application

    
       
         
   

Lets continue our discussion about inter-process communication in Delphi. In the previous article we discussed  how to send an simple message to another Delphi application. Now the task will be more complex: how to copy string, files, streams, components, etc... between two Delphi applications.

To encapsulate the complexities of messages handling I wrote a small unit with all procedures and functions we will need further.

unit Shared;

Interface

uses
   Windows, SysUtils, Classes;

const
   ShareStr = 'SHARE_MESSAGE';

var
  ShareMsg : UINT;

function FindWindowProcessID(ClassName : PChar; WindowName : PChar) : DWORD;

function AllocateSharedData(AData : Pointer; DataSize : DWORD;
                            DestinationProcessId : DWORD) : THANDLE;

function FreeSharedData(AData : THandle; SourceProcessId : DWORD) : boolean;

function LockSharedData(AData : THandle; SourceProcessId : THandle) : pointer;

function UnlockSharedData(AData : pointer) : boolean;

procedure RegisterShareMessage;

procedure SendStream(AStream : TStream; ProcessID : DWORD; AWindow : HWND; AUserInfo : DWORD = 0);

procedure ReceiveStream(AStream : TStream; AData : THandle);

procedure SendString(S : string; ProcessID : DWORD; AWindow : HWND; AUserInfo : DWORD = 0);

function ReceiveString(AData : THandle) : string;

procedure SendFile(AFileName : string; ProcessID : DWORD; AWindow : HWND; AUserInfo : DWORD = 0);

procedure ReceiveFile(AFileName : string; AData : THandle);

function  GetDataSize(AData : Pointer) : DWORD;

function FindDelphiApplicationWindow(ACaption : string) : THandle;

function FindDelphiApplicationPID(ACaption : string) : DWORD;

procedure GetWindowHandleAndPID(ClassName : PChar; WindowName : PChar; var PID : DWORD; var Window : THandle);

procedure SendComponent(AComponent : TComponent; ProcessID : DWORD; AWindow : HWND; AUserInfo : DWORD = 0);

function ReceiveComponent(AComponent : TComponent; AData : THandle) : TComponent;

implementation

type
  PMapHeader = ^TMapHeader;
  TMapHeader = record
    Size : DWORD;
  end;


function MapHandle(AData : THANDLE; Source : DWORD; Dest : DWORD;
                   DesiredAccess: DWORD; Flags: DWORD) : THANDLE;
var
 hSource : THandle;
 hDest: THandle;
 hNew: THandle;
begin
  hNew := 0;

  if (Source = GetCurrentProcessId) then
    hSource := GetCurrentProcess
      else
        hSource := OpenProcess(PROCESS_DUP_HANDLE, FALSE, Source);

  if (hSource <> 0) then
   begin
      if (Dest = GetCurrentProcessId) then
        hDest := GetCurrentProcess
         else
           hDest := OpenProcess(PROCESS_DUP_HANDLE, FALSE, Dest);

      if (hDest <> 0) then
        begin
          if not DuplicateHandle(hSource, AData,
                           hDest, @hNew,
                           DesiredAccess,
                           FALSE, Flags OR DUPLICATE_SAME_ACCESS) then
           hNew := 0;
         end;
   end
     else
       hDest := 0;

   if (hSource and  Source <> GetCurrentProcessId) then
     CloseHandle(hSource);

   if (hDest and Dest <> GetCurrentProcessId) then
        CloseHandle(hDest);

   Result :=  hNew;
end;


function AllocateSharedData(AData : Pointer; DataSize : DWORD;
                            DestinationProcessId : DWORD) : THANDLE;
var
 hData  : THANDLE;
 Header : PMapHeader;
 hUsableData : THandle;
begin
  Result := 0;
  hData := CreateFileMapping( THandle($FFFFFFFF), nil, PAGE_READWRITE,0,
                               DataSize + SizeOf(TMapHeader), nil);
  if (hData = INVALID_HANDLE_VALUE ) then
     Exit;

  Header := MapViewOfFile(hData, FILE_MAP_READ or FILE_MAP_WRITE, 0, 0, 0);
  if (Header = nil ) then
   begin
     CloseHandle(hData);
     Exit;
   end;

  Header.Size := DataSize;

  if (AData <> nil) then
    move(AData^, Pointer(Integer(Header)+ SizeOf(TMapHeader) )^, DataSize);

  UnmapViewOfFile(Header);

  hUsableData := MapHandle(hData, GetCurrentProcessId,
                            DestinationProcessId,
                            FILE_MAP_ALL_ACCESS,
                            DUPLICATE_SAME_ACCESS);

    CloseHandle(hData);

    Result := hUsableData;
end;


function LockSharedData(AData : THandle;
                        SourceProcessId : THandle) : Pointer;
var
 Header : PMapHeader;
 hUsableData : THandle;
begin
   Result := nil;
   hUsableData := MapHandle(AData, SourceProcessId,GetCurrentProcessId,FILE_MAP_ALL_ACCESS,0);
   Header := MapViewOfFile(hUsableData, FILE_MAP_READ OR FILE_MAP_WRITE, 0, 0, 0);
   CloseHandle(hUsableData);

   if (Header = nil) then
    Exit;

    Result := Pointer(integer(Header)+ SizeOf(TMapHeader));
end;


function UnlockSharedData(AData : pointer) : boolean;
var
  Header : PMapHeader;
begin
  Header  := PMapHeader(AData);
  Result :=  UnmapViewOfFile(Pointer(integer(Header)- SizeOf(TMapHeader)));
end;


function FreeSharedData(AData : THandle; SourceProcessId : DWORD) : boolean;
var
  hUsableData : THandle;
begin
  hUsableData := MapHandle(AData, SourceProcessId,
                            GetCurrentProcessId,
                            FILE_MAP_ALL_ACCESS,DUPLICATE_CLOSE_SOURCE);

  Result :=  CloseHandle(hUsableData);
end;


procedure RegisterShareMessage;
begin
  ShareMsg := RegisterWindowMessage(ShareStr);
end;


function FindWindowProcessID(ClassName : PChar; WindowName : PChar) : DWORD;
var
 W : THandle;
begin
  Result := 0;
  W := FindWindow(ClassName, WindowName);
  if W > 0 then
   GetWindowThreadProcessID(W, @Result);
end;


procedure SendStream(AStream : TStream; ProcessID : DWORD; AWindow : HWND; AUserInfo : DWORD = 0);
var
 H : THandle;
 P : Pointer;
begin
  if not Assigned(AStream) then
   Exit;

  H := AllocateSharedData(nil, AStream.Size, ProcessID);
  if H > 0 then
   begin
     P := LockSharedData(H, ProcessID);
     AStream.Position := 0;
     AStream.Read(P^, AStream.Size);
     UnlockSharedData(P);
     SendMessage(AWindow, ShareMSG, AUserInfo, integer(H));
   end;
  FreeSharedData(H, ProcessID);
end;


procedure SendComponent(AComponent : TComponent; ProcessID : DWORD; AWindow : HWND; AUserInfo : DWORD = 0);
var
  MS : TMemoryStream;
begin
  MS := TMemoryStream.Create;
  try
    MS.WriteComponent(AComponent);
    MS.Position := 0;
    SendStream(MS, ProcessID, AWindow, AUserInfo);
  finally
    MS.Free;
  end;
end;

procedure ReceiveStream(AStream : TStream; AData : THandle);
var
  P : Pointer;
  ADataSize : DWORD;
begin
  P := LockSharedData(AData, GetCurrentProcessID);
  ADataSize := GetDataSize(P);
  AStream.Write(P^, ADataSize);
  UnlockSharedData(P);
end;


procedure SendString(S : string; ProcessID : DWORD; AWindow : HWND; AUserInfo : DWORD = 0);
var
 H : THandle;
 P : Pointer;
begin
  H := AllocateSharedData(nil, Length(S), ProcessID);
  if H > 0 then
   begin
     P := LockSharedData(H, ProcessID);
     Move(S[1], P^, Length(S));
     UnlockSharedData(P);
     SendMessage(AWindow, ShareMSG, AUserInfo, integer(H));
   end;
  FreeSharedData(H, ProcessID);
end;

function ReceiveString(AData : THandle) : string;
var
  P : pointer;
  ADataSize : DWORD;
begin
  P := LockSharedData(AData, GetCurrentProcessID);
  ADataSize := GetDataSize(P);
  SetLength(Result, ADataSize);
  Move(P^, Result[1], ADataSize);
  UnlockSharedData(P);
end;


procedure SendFile(AFileName : string; ProcessID : DWORD; AWindow : HWND; AUserInfo : DWORD = 0);
var
 FS : TFileStream;
begin
  FS := TFileStream.Create(AFileName, fmOpenRead);
  try
    SendStream(FS, ProcessID, AWindow, AUserInfo);
  finally
    FS.Free;
  end;
end;

procedure ReceiveFile(AFileName : string; AData : THandle);
var
  FS : TFileStream;
begin
  FS := TFileStream.Create(AFileName, fmCreate);
  try
    ReceiveStream(FS, AData);
  finally
    FS.Free;
  end;
end;


function  GetDataSize(AData : Pointer) : DWORD;
begin
  Result := PMapHeader(integer(AData)- SizeOf(TMapHeader))^.Size;
end;


function FindDelphiApplicationWindow(ACaption : string) : THandle;
begin
  Result := FindWindow('TApplication', PChar(ACaption));
end;


function FindDelphiApplicationPID(ACaption : string) : DWORD;
begin
  Result := FindWindowProcessID('TApplication', PChar(ACaption));
end;


procedure GetWindowHandleAndPID(ClassName : PChar; WindowName : PChar; var PID : DWORD; var Window : THandle);
begin
  Window := FindWindow(ClassName, WindowName);
  if Window > 0 then
   GetWindowThreadProcessID(Window, @PID);
end;

function ReceiveComponent(AComponent : TComponent; AData : THandle) : TComponent;
var
 MS : TMemoryStream;
begin
  MS := TMemoryStream.Create;
  try
   ReceiveStream(MS, AData);
   MS.Position := 0;
   Result := MS.ReadComponent(AComponent);
   finally
     MS.Free;
   end;
end;

initialization
  RegisterShareMessage;

end.

Next, we have to create an client application:

unit uclientmain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Shared;

type
  TfrmClientMain = class(TForm)
    btnComponent: TButton;
    OpenDialog1: TOpenDialog;
    Memo1: TMemo;
    btnStream: TButton;
    btnString: TButton;
    procedure btnComponentClick(Sender: TObject);
    procedure btnStreamClick(Sender: TObject);
    procedure btnStringClick(Sender: TObject);
  private
    { Private declarations }
    ServerPid : DWORD;
    ServerWnd : THandle;
  public
    { Public declarations }
    function FindServerInformation : boolean;
  end;

var
  frmClientMain: TfrmClientMain;

implementation

{$R *.DFM}

procedure TfrmClientMain.btnComponentClick(Sender: TObject);
begin
  if not FindServerInformation then
   Exit;
  SendComponent(Memo1, ServerPid, ServerWnd, 1);
  BtnStream.Enabled := true;
end;

function TfrmClientMain.FindServerInformation: boolean;
begin
  GetWindowHandleAndPID('TApplication', 'Shareserver', ServerPID, ServerWND);
  if ServerWnd = 0 then
   begin
     ShowMessage('Server not found');
     Result := false;
   end
    else
      Result := true;
end;

procedure TfrmClientMain.btnStreamClick(Sender: TObject);
begin
   if not OpenDialog1.Execute then
    Exit;
   if not FindServerInformation then
    Exit;
   SendFile(OpenDialog1.FileName, ServerPID, ServerWND, 2);
   btnString.Enabled := true;
end;

procedure TfrmClientMain.btnStringClick(Sender: TObject);
begin
   if not FindServerInformation then
    Exit;
   SendString('Hello', ServerPid, ServerWnd, 3);
end;

end.

 And a server application:

unit usharemain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Shared, StdCtrls;

type
  TfrmServer = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    Memo : TMemo;
  public
    { Public declarations }
    function MsgHook(var Message : TMessage) : boolean;
  end;

var
  frmServer: TfrmServer;

implementation

{$R *.DFM}

{ TForm1 }

function TfrmServer.MsgHook(var Message: TMessage) : boolean;
var
 MS : TMemoryStream;
 S  : string;
begin
  if Message.Msg = ShareMSG then
   begin
     case Message.WParam of
     1: begin
         Memo := TMemo.Create(Self);
         Memo.Parent := Self;
         Memo := TMemo(ReceiveComponent(Memo, Message.LParam));
        end;
     2: begin
          MS := TMemoryStream.Create;
          ReceiveStream(MS, Message.LParam);
          Ms.Position := 0;
          Memo.Lines.LoadFromStream(MS);
          MS.Free;
        end;
      3: begin
           S := ReceiveString(Message.LParam);
           ShowMessage(S);
         end;
       end;
     Result := true;
   end
    else
      Result := false;
end;

procedure TfrmServer.FormCreate(Sender: TObject);
begin
  Application.HookMainWindow(MsgHook);
  RegisterClass(TMemo);
end;


procedure TfrmServer.FormDestroy(Sender: TObject);
begin
  Application.UnhookMainWindow(MsgHook);
end;

end.







          

 Download demo project 
shared.zip
          
          
          		
        

      

      

    

    		
     
     
  

  

     
     
    
    

      

      

        

          
          

          
          
          
          http://users.chello.be/ws36637

          
          

          
          serge_perevoznyk@hotmail.com