使用SharedMemory技术 unit SharedMemory;interfaceuses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;type TSharedMemory = class(TComponent) private { Private declarations } FShareName: String; FSize: integer; FHandle, FMutex: THandle; FReadOnly: boolean; FTimeout: integer; protected procedure SetName(const aValue: TComponentName );override; { Protected declarations } public constructor Create(AOwner: TComponent);override; destructor Destroy;override; function MemoryExist: boolean; function MapMemory: pointer; { Public declarations } function UnMapMemory(aMapPtr: pointer):boolean; function CreateMemory: boolean; function CloseMemory: boolean; function OpenMemory: boolean; function RequestOwnership: boolean; function ReleaseOwnership: boolean; property Handle: THandle read FHandle; property Mutex: THandle read FMutex; published { Published declarations } property ReadOnly: boolean read FReadOnly write FReadOnly default false; property ShareName: String read FShareName write FShareName; property Size: integer read FSize write FSize; property Timeout: integer read FTimeout write FTimeout default -1; end; const MUTEX_NAME = '_SMMutex';procedure Register;implementationprocedure TSharedMemory.SetName(const aValue: TComponentName ); var lChange: boolean; begin lChange := (csDesigning in ComponentState) and ((Name = FShareName) or (Length(FShareName) = 0)); inherited; if lChange then begin FShareName := Name; end; end; //--------------------------------------------------------------------------- function TSharedMemory.MapMemory:pointer; var lMapping: DWord; begin if FHandle = 0 then begin Result := nil; exit; end; if(FReadOnly)then begin lMapping := FILE_MAP_READ; end else begin lMapping := File_Map_All_Access; end; Result := MapViewOfFile(FHandle, lMapping, 0, 0, FSize); if(Result = nil)then begin ReleaseMutex(FMutex); end; end; //--------------------------------------------------------------------------- function TSharedMemory.UnMapMemory(aMapPtr: pointer): boolean; begin if FHandle <> 0 then begin UnmapViewOfFile(aMapPtr); result := true; end else begin result := false; end; end; //--------------------------------------------------------------------------- function TSharedMemory.CreateMemory: boolean; var lMutexName: string; begin Result := true; if FHandle <> 0 then CreateMemory := false; FHandle := CreateFileMapping(THANDLE($FFFFFFFF), nil, PAGE_READWRITE, 0, FSize, pchar(FShareName)); if (FHandle = 0) or ((FHandle <> 0) and (GetLastError = ERROR_ALREADY_EXISTS)) then begin CloseMemory; Result := false; end; lMutexName := FShareName + MUTEX_NAME; FMutex := CreateMutex(nil, false, pchar(lMutexName)); if(FMutex = 0) then begin CloseMemory; Result := false; end; end; //--------------------------------------------------------------------------- function TSharedMemory.CloseMemory: boolean; begin if(FHandle <> 0) then begin CloseHandle(FHandle); FHandle := 0; end; if(FMutex <> 0) then begin CloseHandle(FMutex); FMutex := 0; end; Result := true; end; //--------------------------------------------------------------------------- function TSharedMemory.OpenMemory: boolean; var lMutexName: string; begin Result := false; if(FHandle = 0) then begin FHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, true, pchar(FShareName)); if(FHandle <> 0) then begin lMutexName := FShareName + MUTEX_NAME; FMutex := OpenMutex(MUTEX_ALL_ACCESS, true, pchar(lMutexName)); if(FMutex <> 0 ) then begin Result := true; end else begin CloseMemory; end; end; end; end; //--------------------------------------------------------------------------- function TSharedMemory.RequestOwnership: boolean; var lTimeout: DWord; begin Result := false; if(FHandle <> 0) then begin if(FTimeout < 0) then begin lTimeout := INFINITE; end else begin lTimeout := FTimeout; end; Result := WaitForSingleObject(FMutex, lTimeout) = WAIT_OBJECT_0; end; end; //--------------------------------------------------------------------------- function TSharedMemory.ReleaseOwnership: boolean; begin Result := false; if(FHandle <> 0) then begin Result := ReleaseMutex(FMutex); end; end; //--------------------------------------------------------------------------- constructor TSharedMemory.Create(AOwner: TComponent); begin inherited; FShareName := ''; FTimeout := -1; FSize := 0; FReadOnly := false; FHandle := 0; FMutex := 0; end; //--------------------------------------------------------------------------- destructor TSharedMemory.Destroy; begin CloseMemory; inherited; end; //--------------------------------------------------------------------------- procedure Register; begin RegisterComponents('Custom', [TSharedMemory]); end; //--------------------------------------------------------------------------- function TSharedMemory.MemoryExist: boolean; var PVHandle:THandle; begin Result := false; PVHandle := CreateFileMapping(THANDLE($FFFFFFFF), nil, PAGE_READWRITE, 0, FSize, pchar(FShareName)); if (PVHandle <> 0) and (GetLastError = ERROR_ALREADY_EXISTS) then Result:=true else CloseHandle(PVHandle); end;end. 与其他程序共享内存文件
unit SharedMemory;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;type TSharedMemory = class(TComponent)
private
{ Private declarations }
FShareName: String;
FSize: integer;
FHandle, FMutex: THandle;
FReadOnly: boolean;
FTimeout: integer; protected
procedure SetName(const aValue: TComponentName );override;
{ Protected declarations }
public
constructor Create(AOwner: TComponent);override;
destructor Destroy;override;
function MemoryExist: boolean;
function MapMemory: pointer; { Public declarations }
function UnMapMemory(aMapPtr: pointer):boolean;
function CreateMemory: boolean;
function CloseMemory: boolean;
function OpenMemory: boolean;
function RequestOwnership: boolean;
function ReleaseOwnership: boolean;
property Handle: THandle read FHandle;
property Mutex: THandle read FMutex; published
{ Published declarations }
property ReadOnly: boolean read FReadOnly write FReadOnly default false;
property ShareName: String read FShareName write FShareName;
property Size: integer read FSize write FSize;
property Timeout: integer read FTimeout write FTimeout default -1; end; const
MUTEX_NAME = '_SMMutex';procedure Register;implementationprocedure TSharedMemory.SetName(const aValue: TComponentName );
var
lChange: boolean;
begin
lChange := (csDesigning in ComponentState) and
((Name = FShareName) or (Length(FShareName) = 0));
inherited;
if lChange then
begin
FShareName := Name;
end;
end;
//---------------------------------------------------------------------------
function TSharedMemory.MapMemory:pointer;
var
lMapping: DWord;
begin
if FHandle = 0 then
begin
Result := nil;
exit;
end; if(FReadOnly)then
begin
lMapping := FILE_MAP_READ;
end
else
begin
lMapping := File_Map_All_Access;
end;
Result := MapViewOfFile(FHandle, lMapping, 0, 0, FSize);
if(Result = nil)then
begin
ReleaseMutex(FMutex);
end;
end;
//---------------------------------------------------------------------------
function TSharedMemory.UnMapMemory(aMapPtr: pointer): boolean;
begin
if FHandle <> 0 then
begin
UnmapViewOfFile(aMapPtr);
result := true;
end
else
begin
result := false;
end;
end;
//---------------------------------------------------------------------------
function TSharedMemory.CreateMemory: boolean;
var
lMutexName: string;
begin
Result := true;
if FHandle <> 0 then CreateMemory := false;
FHandle := CreateFileMapping(THANDLE($FFFFFFFF), nil, PAGE_READWRITE, 0,
FSize, pchar(FShareName));
if (FHandle = 0) or ((FHandle <> 0) and (GetLastError = ERROR_ALREADY_EXISTS)) then
begin
CloseMemory;
Result := false;
end;
lMutexName := FShareName + MUTEX_NAME;
FMutex := CreateMutex(nil, false, pchar(lMutexName));
if(FMutex = 0) then
begin
CloseMemory;
Result := false;
end;
end;
//---------------------------------------------------------------------------
function TSharedMemory.CloseMemory: boolean;
begin
if(FHandle <> 0) then
begin
CloseHandle(FHandle);
FHandle := 0;
end;
if(FMutex <> 0) then
begin
CloseHandle(FMutex);
FMutex := 0;
end;
Result := true;
end;
//---------------------------------------------------------------------------
function TSharedMemory.OpenMemory: boolean;
var
lMutexName: string;
begin
Result := false;
if(FHandle = 0) then
begin
FHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, true, pchar(FShareName));
if(FHandle <> 0) then
begin
lMutexName := FShareName + MUTEX_NAME;
FMutex := OpenMutex(MUTEX_ALL_ACCESS, true, pchar(lMutexName));
if(FMutex <> 0 ) then
begin
Result := true;
end
else
begin
CloseMemory;
end;
end;
end;
end;
//---------------------------------------------------------------------------
function TSharedMemory.RequestOwnership: boolean;
var
lTimeout: DWord;
begin
Result := false;
if(FHandle <> 0) then
begin
if(FTimeout < 0) then
begin
lTimeout := INFINITE;
end
else
begin
lTimeout := FTimeout;
end;
Result := WaitForSingleObject(FMutex, lTimeout) = WAIT_OBJECT_0;
end;
end;
//---------------------------------------------------------------------------
function TSharedMemory.ReleaseOwnership: boolean;
begin
Result := false;
if(FHandle <> 0) then
begin
Result := ReleaseMutex(FMutex);
end;
end;
//---------------------------------------------------------------------------
constructor TSharedMemory.Create(AOwner: TComponent);
begin
inherited;
FShareName := '';
FTimeout := -1;
FSize := 0;
FReadOnly := false;
FHandle := 0;
FMutex := 0;
end;
//---------------------------------------------------------------------------
destructor TSharedMemory.Destroy;
begin
CloseMemory;
inherited;
end;
//---------------------------------------------------------------------------
procedure Register;
begin
RegisterComponents('Custom', [TSharedMemory]);
end;
//---------------------------------------------------------------------------
function TSharedMemory.MemoryExist: boolean;
var PVHandle:THandle;
begin
Result := false;
PVHandle := CreateFileMapping(THANDLE($FFFFFFFF), nil, PAGE_READWRITE, 0,
FSize, pchar(FShareName));
if (PVHandle <> 0) and (GetLastError = ERROR_ALREADY_EXISTS)
then Result:=true
else CloseHandle(PVHandle);
end;end.
与其他程序共享内存文件