sharedmemory.pas

使用共享内存块的方式在进程间共享内存的源代码

unit SharedMemory;

interface

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

type
  TSharedMemory = class( TComponent )
  private
    hFileMapping: THandle;
    FHandle: string;
    lp: pointer;
    FSize: integer;
    procedure SetContents(const Value: string);
    procedure SetHandle(const Value: string);
    function GetContents: string;
    procedure SetSize(const Value: integer);
  protected
  public
    constructor Create( AOwner: TComponent ); override;
    destructor Destroy; override;
    property Contents: string read GetContents write SetContents;
  published
    property Handle: string read FHandle write SetHandle;
    property Size: integer read FSize write SetSize default 255;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents( 'Silicon Commander', [TSharedMemory] );
end;

constructor TSharedMemory.Create(AOwner: TComponent);
begin
  inherited Create( AOwner );
  FSize := 255;
end;

destructor TSharedMemory.Destroy;
begin
  inherited Destroy;
  if lp <> nil then
    UnmapViewOfFile( lp );
  if hFileMapping <> 0 then
    CloseHandle( hFileMapping );
end;

function TSharedMemory.GetContents: string;
begin
  if lp = nil then
    Result := ''
  else
    Result := StrPas( lp );
end;

procedure TSharedMemory.SetContents(const Value: string);
begin
  if ( csDesigning in ComponentState ) then
    Exit;
(* If a mapping does not exist, do nothing *)
  if lp = nil then
    Exit;
  StrPCopy( lp, Value );
end;

procedure TSharedMemory.SetHandle(const Value: string);
begin
  if FHandle = Value then
    Exit;
  FHandle := Value;
  if ( csDesigning in ComponentState ) then
    Exit;
(* Close down any file mapping that may be currently open *)
  if lp <> nil then
    UnmapViewOfFile( lp );
  if hFileMapping <> 0 then
    CloseHandle( hFileMapping );
(* See if a file mapping already exists with this name *)
  hFileMapping := OpenFileMapping( FILE_MAP_ALL_ACCESS, FALSE, PChar( FHandle ) );
(* If not, create a new one *)
  if hFileMapping = 0 then
    hFileMapping := CreateFileMapping( $ffffffff, nil, PAGE_READWRITE or SEC_COMMIT, 0, FSize, PChar( FHandle ) );
  if hFileMapping = 0 then
    raise Exception.Create( 'CreateFileMapping failed with error code ' + IntToStr( GetLastError) );
(* Map the view of the file *)
  lp := MapViewOfFile( hFileMapping, FILE_MAP_ALL_ACCESS, 0, 0, FSize );
  if lp = nil then
    raise Exception.Create( 'MapViewOfFile failed with error code ' + IntToStr( GetLastError ) );
end;

procedure TSharedMemory.SetSize(const Value: integer);
begin
  FSize := Value;
end;

end.