Question

Delphi中保存图像列表

Answer 1

　　最近在做项目时遇到将图像列表(TImageList)中一系列的图像保存到指定的文件或二进制流中 以便在需要时进行动态恢复的情况 于是在Delphi的帮助中查找TImageList类相关的属性 方法 遗憾的是Delphi在TImageList中并未提供SaveToFile和SaveToStream方法 所以针对TImageList目前的限制 必须采取其它的办法来扩展TImageList的功能 以满足实际项目的需要 　　一 解决方法 　　方法一 　　使用API函数ImageList_Write和ImageList_Read 二者都需要指定一个类型为IStream的参数 前者的作用是将指定句柄的图像列表保存到类型为IStream的二进制流中 后者是从类型为IStream的二进制流中读出原先保存的图像列表 并且返回指向这个图像列表的句柄 　　IStream是一个OLE对象 它在Delphi中的声明为TStreamAdapter =　class(TInterfacedObject IStream) 意为TStreamAdapter是从TInterfacedObject继承下来的操纵 IStream接口的对象 通过TStreamAdapter对象可以实现Delphi内部TStream对象对ISTream接口对象的操纵 　　方法二 　　从TImageList继承一个子类TImageListEx 实现自定义的SaveToFileEx和SaveToStreamEx方法 在默认情况下TImageList中保存的图像是由普通图像及其掩码图像组合而成 所以必须调用其基类TCustomImageList的Protected部分提供的GetImages(Index: Integer; Image Mask: TBitmap)方法 以获得图像列表中指定索引号的位图及其掩码位图 之后分别保存到自定义的文件或二进制流中 此外还需提供LoadFromFileEx和LoadFromStreamEx方法从自定义的文件或二进制流中恢复图像集合

　　二 实现步骤 　　自定义的TImageListEx控件在Public部分一并实现了对上述两种方法的封装 TImageListEx类源代码如下 unit ImageListEx;

interface

uses Windows SysUtils Classes Graphics Controls Commctrl ImgList Consts;

type TImageListEx = class(TImageList) public procedure LoadFromFile(const FileName: string);//实现API方式保存 procedure LoadFromStream(Stream: TStream); procedure SaveToFile(const FileName: string); procedure SaveToStream(Stream: TStream); procedure LoadFromFileEx(const FileName: string);//实现自定义方式保存 procedure LoadFromStreamEx(Stream: TStream); procedure SaveToFileEx(const FileName: string); procedure SaveToStreamEx(Stream: TStream); end;

procedure Register;

implementation

procedure Register; begin RegisterComponents( ImageListEx [TImageListEx]); end;

{ TImageListEx }

procedure TImageListEx LoadFromFile(const FileName: string); var Stream: TStream; begin Stream := TFileStream Create(FileName fmOpenRead); try LoadFromStream(Stream); finally Stream Free; end; end;

procedure TImageListEx LoadFromFileEx(const FileName: string); var Stream: TStream; begin Stream := TFileStream Create(FileName fmOpenRead); try LoadFromStreamEx(Stream); finally Stream Free; end; end;

procedure TImageListEx LoadFromStream(Stream: TStream); var SA: TStreamAdapter; begin SA := TStreamAdapter Create(Stream); try Handle := ImageList_Read(SA);//将当前图像列表的句柄指向从二进制流中得到的句柄 if Handle = then raise EReadError CreateRes(@SImageReadFail); finally SA Free; end; end;

procedure TImageListEx LoadFromStreamEx(Stream: TStream); var Width Height: Integer; Bitmap Mask: TBitmap; BinStream: TMemoryStream;

procedure LoadImageFromStream(Image: TBitmap); var Count: DWORD; begin Image Assign(nil); Stream ReadBuffer(Count SizeOf(Count));//首先读出位图的大小 BinStream Clear; BinStream CopyFrom(Stream Count);//接着读出位图 BinStream Position := ;//流指针复位 Image LoadFromStream(BinStream); end;

begin Stream ReadBuffer(Height SizeOf(Height)); Stream ReadBuffer(Width SizeOf(Width)); Self Height := Height; Self Width := Width;//恢复图像列表原来的高度 宽度 Bitmap := TBitmap Create; Mask := TBitmap Create; BinStream := TMemoryStream Create; try while Stream Position <> Stream Size do begin LoadImageFromStream(Bitmap);//从二进制流中读出位图 LoadImageFromStream(Mask);//从二进制流中读出掩码位图 Add(Bitmap Mask);//将位图及其掩码位图合并添加到图像列表中 end; finally Bitmap Free; Mask Free; BinStream Free; end; end;

procedure TImageListEx SaveToFile(const FileName: string); var Stream: TStream; begin Stream := TFileStream Create(FileName fmCreate); try SaveToStream(Stream); finally Stream Free; end; end;

procedure TImageListEx SaveToFileEx(const FileName: string); var Stream: TStream; begin Stream := TFileStream Create(FileName fmCreate); try SaveToStreamEx(Stream); finally Stream Free; end; end;

procedure TImageListEx SaveToStream(Stream: TStream); var SA: TStreamAdapter; begin SA := TStreamAdapter Create(Stream); try if not ImageList_Write(Handle SA) then//将当前图像列表保存到二进制流中 raise EWriteError CreateRes(@SImageWriteFail); finally SA Free; end; end;

procedure TImageListEx SaveToStreamEx(Stream: TStream); var I: Integer; Width Height: Integer; Bitmap Mask: TBitmap; BinStream: TMemoryStream;

procedure SetImage(Image: TBitmap; IsMask: Boolean); begin Image Assign(nil);//清除上一次保存的图像 避免出现图像重叠 with Image do begin if IsMask then Monochrome := True;//掩码位图必须使用单色 Height := Self Height; Width := Self Width; end; end;

procedure SaveImageToStream(Image: TBitmap); var Count: DWORD; begin BinStream Clear; Image SaveToStream(BinStream); Count := BinStream Size; Stream WriteBuffer(Count SizeOf(Count));//首先保存位图的大小 Stream CopyFrom(BinStream );//接着保存位图 end;

lishixinzhi/Article/program/Delphi/201311/8481