Delphi内存映射文件例子 .

unit  FileMap; 
 
interface 
 
uses 
   Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms,StdCtrls,Dialogs; 
 
type 
   TFileMap=class(TComponent) 
   private 
       FMapHandle:THandle;                  //内存映射文件句柄 
       FMutexHandle:THandle;              //互斥句柄 
       FMapName:string;                        //内存映射对象 
       FSynchMessage:string;              //同步消息 
       FMapStrings:TStringList;        //存储映射文件信息 
       FSize:DWord;                                //映射文件大小 
       FMessageID:DWord;                      //注册的消息号 
       FMapPointer:PChar;                    //映射文件的数据区指针 
       FLocked:Boolean;                        //锁定 
       FIsMapOpen:Boolean;                  //文件是否打开 
       FExistsAlready:Boolean;          //是否已经建立过映射文件 
       FReading:Boolean;                      //是否正在读取内存文件数据 
       FAutoSynch:Boolean;                  //是否同步 
       FOnChange:TNotifyEvent;          //当内存数据区内容改变时 
       FFormHandle:Hwnd;                      //存储本窗口的窗口句柄 
       FPNewWndHandler:Pointer; 
       FPOldWndHandler:Pointer; 
       procedure  SetMapName(Value:string); 
       procedure  SetMapStrings(Value:TStringList); 
       procedure  SetSize(Value:DWord); 
       procedure  SetAutoSynch(Value:Boolean); 
       procedure  EnterCriticalSection; 
       procedure  LeaveCriticalSection; 
       procedure  MapStringsChange(Sender:TObject); 
       procedure  NewWndProc(var  FMessage:TMessage); 
   public 
       constructor  Create(AOwner:TComponent);override; 
       destructor  Destroy;override; 
       procedure  OpenMap; 
       procedure  CloseMap; 
       procedure  ReadMap; 
       procedure  WriteMap; 
       property  ExistsAlready:Boolean  read  FExistsAlready; 
       property  IsMapOpen:Boolean  read  FIsMapOpen; 
   published 
       property  MaxSize:DWord  read  FSize  write  SetSize; 
       property  AutoSynchronize:Boolean  read  FAutoSynch  write  SetAutoSynch; 
       property  MapName:string  read  FMapName  write  SetMapName; 
       property  MapStrings:TStringList  read  FMapStrings  write  SetMapStrings; 
       property  OnChange:TNotifyEvent  read  FOnChange  write  FOnChange; 
   end; 
implementation 
constructor  TFileMap.Create(AOwner:TComponent); 
begin 
   inherited  Create(AOwner); 
   FAutoSynch:=True; 
   FSize:=4096; 
   FReading:=False; 
   FMapStrings:=TStringList.Create; 
   FMapStrings.OnChange:=MapStringsChange; 
   FMapName:='Unique  &  Common  name'; 
   FSynchMessage:=FMapName+'Synch-Now'; 
   if  AOwner  is  TForm  then 
   begin 
       FFormHandle:=(AOwner  as  TForm).Handle; 
       FPOldWndHandler:=Ptr(GetWindowLong(FFormHandle,GWL_wNDPROC)); 
       FPNewWndHandler:=MakeObjectInstance(NewWndProc); 
       if  FPNewWndHandler=nil  then 
           raise  Exception.Create('超出资源'); 
       SetWindowLong(FFormHandle,GWL_WNDPROC,Longint(FPNewWndHandler)); 
   end 
   else  raise  Exception.Create('组件的所有者应该是TForm'); 
end; 
destructor  TFileMap.Destroy; 
begin 
   CloseMap; 
   SetWindowLong(FFormHandle,GWL_WNDPROC,Longint(FPOldWndHandler)); 
   if  FPNewWndHandler<>nil  then 
       FreeObjectInstance(FPNewWndHandler); 
   FMapStrings.Free; 
   FMapStrings:=nil; 
   inherited  destroy; 
end; 
procedure  TFileMap.OpenMap; 
var 
   TempMessage:array[0..255]  of  Char; 
begin 
   if  (FMapHandle=0)  and  (FMapPointer=nil)  then 
   begin 
       FExistsAlready:=False; 
       FMapHandle:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,FSize,PChar(FMapName)); 
       if  (FMapHandle=INVALID_HANDLE_VALUE)  or  (FMapHandle=0)  then 
           raise  Exception.Create('创建文件映射对象失败!') 
       else 
       begin 
           if  (FMapHandle<>0)  and  (GetLastError=ERROR_ALREADY_EXISTS)  then 
               FExistsAlready:=True;  //如果已经建立的话，就设它为TRUE； 
           FMapPointer:=MapViewOfFile(FMapHandle,FILE_MAP_ALL_ACCESS,0,0,0); 
           if  FMapPointer=nil  then 
               raise  Exception.Create('映射文件的视图到进程的地址空间失败') 
           else 
           begin 
               StrPCopy(TempMessage,FSynchMessage); 
               FMessageID:=RegisterWindowMessage(TempMessage); 
               if  FMessageID=0  then 
                   raise  Exception.Create('注册消息失败') 
           end 
       end; 
       FMutexHandle:=Windows.CreateMutex(nil,False,PChar(FMapName+'.Mtx')); 
       if  FMutexHandle=0  then 
           raise  Exception.Create('创建互斥对象失败'); 
       FIsMapOpen:=True; 
       if  FExistsAlready  then  //判断内存文件映射是否已打开 
           ReadMap 
       else 
           WriteMap; 
   end; 
end; 
procedure  TFileMap.CloseMap; 
begin 
   if  FIsMapOpen  then 
   begin 
       if  FMutexHandle<>0  then 
       begin 
           CloseHandle(FMutexHandle); 
           FMutexHandle:=0; 
       end; 
       if  FMapPointer<>nil  then 
       begin 
           UnMapViewOfFile(FMapPointer); 
           FMapPointer:=nil; 
       end; 
       if  FMapHandle<>0  then 
       begin 
           CloseHandle(FMapHandle); 
           FMapHandle:=0; 
       end; 
       FIsMapOpen:=False; 
   end; 
end; 
procedure  TFileMap.ReadMap; 
begin 
   FReading:=True; 
   if(FMapPointer<>nil)  then  FMapStrings.SetText(FMapPointer); 
end; 
procedure  TFileMap.WriteMap; 
var 
   StringsPointer:PChar; 
   HandleCounter:integer; 
   SendToHandle:HWnd; 
begin 
   if  FMapPointer<>nil  then 
   begin 
       StringsPointer:=FMapStrings.GetText; 
       EnterCriticalSection; 
       if  StrLen(StringsPointer)+1<=FSize 
           then  System.Move(StringsPointer^,FMapPointer^,StrLen(StringsPointer)+1) 
       else 
           raise  Exception.Create('写字符串失败，字符串太大！'); 
       LeaveCriticalSection; 
       SendMessage(HWND_BROADCAST,FMessageID,FFormHandle,0); 
       StrDispose(StringsPointer); 
   end; 
end; 
procedure  TFileMap.MapStringsChange(Sender:TObject); 
begin 
   if  FReading  and  Assigned(FOnChange)  then 
       FOnChange(Self) 
   else  if  (not  FReading)  and  FIsMapOpen  and  FAutoSynch  then 
       WriteMap; 
end; 
procedure  TFileMap.SetMapName(Value:string); 
begin 
   if  (FMapName<>Value)  and  (FMapHandle=0)  and  (Length(Value)<246)  then 
   begin 
       FMapName:=Value; 
       FSynchMessage:=FMapName+'Synch-Now'; 
   end; 
end; 
procedure  TFileMap.SetMapStrings(Value:TStringList); 
begin 
   if  Value.Text<>FMapStrings.Text  then 
   begin 
       if  Length(Value.Text)<=FSize  then 
           FMapStrings.Assign(Value) 
       else 
           raise  Exception.Create('写入值太大'); 
   end; 
end; 
procedure  TFileMap.SetSize(Value:DWord); 
var 
   StringsPointer:PChar; 
begin 
   if  (FSize<>Value)  and  (FMapHandle=0)  then 
   begin 
       StringsPointer:=FMapStrings.GetText; 
       if  (Value<StrLen(StringsPointer)+1)  then 
           FSize:=StrLen(StringsPointer)+1 
       else  FSize:=Value; 
       if  FSize<32  then  FSize:=32; 
       StrDispose(StringsPointer); 
   end; 
end; 
procedure  TFileMap.SetAutoSynch(Value:Boolean); 
begin 
   if  FAutoSynch<>Value  then 
   begin 
       FAutoSynch:=Value; 
       if  FAutoSynch  and  FIsMapOpen  then  WriteMap; 
   end; 
end; 
procedure  TFileMap.EnterCriticalSection; 
begin 
   if    (FMutexHandle<>0)  and  not  FLocked  then 
   begin 
       FLocked:=(WaitForSingleObject(FMutexHandle,INFINITE)=WAIT_OBJECT_0); 
   end; 
end; 
procedure  TFileMap.LeaveCriticalSection; 
begin 
   if  (FMutexHandle<>0)  and  FLocked  then 
   begin 
       ReleaseMutex(FMutexHandle); 
       FLocked:=False; 
   end; 
end; 
//消息捕获过程 
procedure  TFileMap.NewWndProc(var  FMessage:TMessage); 
begin 
   with  FMessage  do 
   begin 
       if  FIsMapOpen 
         if  (Msg=FMessageID)  and  (WParam<>FFormHandle)  then 
               ReadMap; 
       Result:=CallWindowProc(FPOldWndHandler,FFormHandle,Msg,wParam,lParam); 
   end; 
end;end.