共通のパスワード入力がある複数のexeを起動するとき，既に起動しているexe
がある場合にパスワード入力を省略したい，等の目的に使える共有文字列
を提供するコンポーネントの例です．文字列の最大サイズは固定になっています
が，設計時に可変にするのは簡単ですのでやってみてください．

unit InterProcText;

interface

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

type
{ TCommonMemoryStream }
  TCommonMemoryStream = class(TStream)
  protected
    FMemory: Pointer;
    FHandle: Integer;
    FSize, FPosition: Longint;
    FAlreadyExists: boolean;
  public
    constructor Create(const Name: string; Size: Longint);
    destructor Destroy; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    procedure Clear;
    property Handle: Integer read FHandle;
    property Memory: Pointer read FMemory;
    property AlreadyExists: boolean read FAlreadyExists;
  end;

{ TInterProcText }
const
  COMMONMEMORYSIZE = 4096;

type
  TInterProcText = class(TComponent)
  protected
    FTextName: string;
    FCMStream: TCommonMemoryStream;
    procedure SetString(AText: string);
    function  GetString: string;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Text: string  // 共有メモリに書き込み，読み出しする文字列
             read GetString write SetString;
  published
    property TextName: string read FTextName write FTextName;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TInterProcText]);
end;

{ TCommonMemoryStream }
constructor TCommonMemoryStream.Create(const Name: string; Size: Longint);

begin
  // ファイル無しのメモリマップドファイルを作成
  FHandle := CreateFileMapping( $FFFFFFFF, nil, PAGE_READWRITE,
                               0, Size, PChar(Name));

  if FHandle < 0 then
    raise EFCreateError.Create('共有メモリ['+Name+']を開けません')
  else begin
    if GetLastError = ERROR_ALREADY_EXISTS then begin
      FAlreadyExists := True;
    end else begin
      FAlreadyExists := False;
    end;
    FMemory := MapViewOfFile(FHandle,
                  FILE_MAP_READ or FILE_MAP_WRITE, 0, 0, 0);
    FSize := Size;
    FPosition := 0;
    if not FAlreadyExists then Clear;
  end;
end;

destructor TCommonMemoryStream.Destroy;
begin
  if Handle >= 0 then begin
    UnmapViewOfFile(FMemory);
    CloseHandle(Handle);
  end;
end;

function TCommonMemoryStream.Read(var Buffer; Count: Longint): Longint;
begin
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Result := FSize - FPosition;
    if Result > 0 then
    begin
      if Result > Count then Result := Count;
      Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
      Inc(FPosition, Result);
      Exit;
    end;
  end;
  Result := 0;
end;

function TCommonMemoryStream.Write(const Buffer; Count: Longint): Longint;
var
  Pos: Longint;
begin
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Pos := FPosition + Count;
    if Pos > 0 then
    begin
      if Pos > FSize then
      begin
        raise EAccessViolation.Create( '共有メモリを逸脱した書き込み');
      end;
      System.Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count);
      FPosition := Pos;
      Result := Count;
      Exit;
    end;
  end;
  Result := 0;
end;

function TCommonMemoryStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
  case Origin of
    0: FPosition := Offset;
    1: Inc(FPosition, Offset);
    2: FPosition := FSize + Offset;
  end;
  Result := FPosition;
end;

procedure TCommonMemoryStream.Clear;
var
  i: integer;
  Pt: Pointer;
begin
  Pt := FMemory;
  for i := 0 to FSize-1 do begin
    Byte(Pt^) := 0;
    inc(integer(Pt));
  end;
end;

{ TInterProcText }
constructor TInterProcText.Create;
begin
  inherited Create(AOwner);
  FTextName := 'TextName1';
end;

destructor TInterProcText.Destroy;
begin
  FCMStream.Free;
  inherited Destroy;
end;

function  TInterProcText.GetString: string;
var
  St: TStringList;
begin
  if FTextName = '' then begin
    raise Exception.Create('TextNameが設定されていません');
  end;
  if FCMStream = nil then begin
    FCMStream := TCommonMemoryStream.Create(FTextName, COMMONMEMORYSIZE);
  end;
  St := TStringList.Create;
  try
    FCMStream.Seek(0, soFromBeginning);
    St.LoadFromStream( FCMStream );
    Result := St.Text;
  finally
    St.Free;
  end;
end;

procedure TInterProcText.SetString(AText: string);
begin
  if FTextName = '' then begin
    raise Exception.Create('TextNameが設定されていません');
  end;
  if FCMStream = nil then begin
    FCMStream := TCommonMemoryStream.Create(FTextName, COMMONMEMORYSIZE);
  end;
  FCMStream.Clear;
  FCMStream.Seek(0, soFromBeginning);
  FCMStream.WriteBuffer(Pointer(AText)^, Length(AText));
end;

end.

使い方の例：ボタンをクリックすると共有文字列に書き込んだり読み出したり
　します．書き込まずに読み出すと空白文字列が返ります．

procedure TForm1.Button1Click(Sender: TObject);
begin
  Label1.Caption := InterProcText1.Text;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  InterProcText1.Text := Edit1.Text;
end;

                                                  ＴＮ(CQJ01721)

Original document by ＴＮ            氏 ID:(CQJ01721)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。