胡小文

---- 有一张光盘提供了5000多个256色的各种各样的图标的压缩文件，解压后按动物、人物、计算机、网络等门类分类放置在一个个图标库（icon library）文件（后缀为ICL），使用起来相当不方便。我利用Delphi3.0开发了一个这样的程序，它可以浏览这些图标库所有图标并且把自己所需要的图标以Icon的文件格式保存起来，支持直接从文件夹图标库文件到程序的拖放，自动建立ICL文件的关联，以后你只要双击ICL文件就可以打开。具体实现过程如下。
---- 一、 文件夹图标库文件到程序拖放的实现
---- 要使得一个程序可以支持从文件夹的直接拖放，在程序初始化时运行Windows Api函数：dragacceptFiles(handle,true); 其中handle是接受文件拖放的窗口句柄，true表示为接受，false表示拒绝接受。一旦你设置为接受后，程序运行时如果有文件拖放到该窗口，系统将把消息WM_DROPFiles发送到你的程序。程序中必须对该消息做出处理，可用的Windows Api函数是DragQueryFile和DragFinish，其中DragQueryFile是获取拖放过来的文件名，DragFinish是告诉系统该拖放操作完成。这两个函数和WM_DropFiles消息的详细资料请查阅Windows Api手册。
---- 二、ICL文件关联建立的实现
---- windows文件关联的建立实际是对注册表进行一些操作。在HKEY_CLASSES_ROOT中建立一系列的键和设置相关的键值。具体步骤如下：
---- 1、 在HKEY_CLASSES_ROOT中建立"．ICL"键，并且默认的键值设置为"ICL_Auto_File"；
---- 2、 在HKEY_CLASSES_ROOT中建立"ICL_Auto_File"键，并且默认的键值设置为"图标库关联文件程序"；
---- 3、 在HKEY_CLASSES_ROOT中"ICL_Auto_File"键下设立三级子键：shell-->open--->command；
---- 4、 为command这级子键默认的键值设置为："< 程序名称 >" 1%。其中程序名包含程序的绝对路径。
----三、图标库图标的获得
---- 在windows API中有许多获取图标的函数，但能从图标库ICL文件中获取图标的函数是ExtractIconEx，它的格式和参数如下：
Uint ExtractIconExA(lpszFile: PAnsiChar;
nIconIndex: Integer;
var phiconLarge, phiconSmall: HICON;
nIcons: UINT);
lpszFile:图标库的文件名；
Niconindex: 要读取的图标在图标库中的次序（从0开始编号）；
PhiconLarge、Phiconsmall:如果读取成功时图标的句柄值；
Nicons:要读取的图标个数，通常设置为1
该函数返回的值如果是0的话表示读取失败。
要枚举一个图标库中的所有图标只要利用以上函数从读取序号0图标、
序号1图标....直到函数返回值为0
---- 四、图标库图标的显示
---- 图标库的图标显示的方法有很多，在Delphi中提供了列表框，用户通过自己绘制列表项来列表实现项非文字显示。方法是：
---- 1、 把列表框的风格(Style)设置为用户自己绘制lbOwnerDrawVariable模式；
---- 2、 重载OnDrawItem和OnMeasureItem事件，OnMeasureItem事件计算列表项显示所需要的方框尺寸高度，OnDrawItem绘制列表项。两个事件都有Index参数，它是对应列表框的列表项次序（从0开始编号）。本人是把图标库图标序号做为列表框的列表项，也就是列表框中的列表项是一组序号。然后通过序号来进行图标的显示处理工作。
---- 五、图标库图标的保存
---- 把图标库中喜欢的图标保存下来，只要利用Ticon类的方法SaveToFile。本人在程序中设置了Tpopupmenu控件popupmenu1和TsaveDialog控件Savedialog1，把Listbox1的popupmenu属性设置为Popupmenu1，这样当在Listbox1控件右击时弹出Popupmenu1菜单，选择SaveAs菜单项后就可以保存到用户指定的一个文件中。
---- 六、程序清单及说明
unit iconlibreadsource;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
StdCtrls, Menus;
type
TForm1 = class(TForm)
ListBox1: TListBox;
SaveDialog1: TSaveDialog;
PopupMenu1: TPopupMenu;
Save1: TMenuItem;
N1: TMenuItem;
eXit1: TMenuItem;
procedure ListBox1DrawItem(Control:
TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure ListBox1MeasureItem(Control:
TWinControl; Index: Integer;
var Height: Integer);
procedure FormCreate(Sender: TObject);
procedure eXit1Click(Sender: TObject);
procedure Save1Click(Sender: TObject);
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
private
iconlibname :string; //当前图标库文件名
Icon :TIcon;
Procedure handlemsg (var Msg: TMsg;
var Handled: Boolean);
end;
var
Form1: TForm1;
implementation
uses shellapi,registry;
{$R *.DFM}
var
smallicon,largeicon :Hicon;
iconindex :Uint;
//处理WM_DropFile消息
Procedure TForm1.handlemsg (var Msg: TMsg;
var Handled: Boolean);
var
Fname :pchar;
begin
if msg.message=wm_DropFiles then
begin
getmem(Fname,250);
dragqueryFile(msg.wParam,0,fname,250);
//取拖放到程序的文件名
dragFinish(msg.wParam);
//重新形成列表框的列表项
listbox1.Items.Clear;
iconlibname:=string(Fname);
iconindex:=0;
while Extracticonex(pchar(iconlibname),
iconindex,smallicon,largeicon,1)>0 do
begin
listbox1.items.add(intTostr(iconindex));
inc(iconindex);
end;
if listbox1.Items.count>0
then listbox1.PopupMenu:=popupmenu1
else listbox1.popupmenu:=nil;
freemem(Fname,250);
handled:=true;
end;
end;
//以下是重载OnDrawItem和OnMeasureItem
事件实现图标在列表框中的显示
procedure TForm1.ListBox1DrawItem(Control:
TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
Extracticonex(pchar(iconlibname),index,
smallicon,largeicon,1);
Icon.handle:=Smallicon;
with listbox1.canvas do
begin
FillRect(Rect);
draw(rect.left+1,Rect.top+1,Icon);
end;
end;
procedure TForm1.ListBox1MeasureItem(Control:
TWinControl; Index: Integer;
var Height: Integer);
begin
Extracticonex(pchar(iconlibname),index,smallicon,largeicon,1);
Icon.handle:=Smallicon;
with listbox1.canvas do height:=icon.height+2;
end;
//以下是程序初始化并且自动建立ICL的文件关联
procedure TForm1.FormCreate(Sender: TObject);
var
regICL :TRegistry;
begin
regICL:=TRegistry.Create;
regICL.RootKey:=HkEY_CLASSES_ROOT;
if not(regICL.keyexists(''\.ICL'')) then //如果没有建立关联
begin
regICL.openkey(''\.ICL'',true); regICL.writestring('''',''icl_auto_file'');
regICL.openkey(''\icl_auto_file'',true);
regICL.writestring('''',''图标库的关联程序'');
regICL.openkey(''\icl_auto_file\shell\open\command'',true);
regICL.WriteString('''',''"''+application.exename+''" %1'');
end;
regICL.free;
if paramcount< 1 then halt(1);
icon:=Ticon.create;
//利用getcommandline取得命令行参数
iconlibname:=getcommandline;
//注意在windows的命令行中主程序是全路径并且用双引号括起
delete(iconlibname,1,length(application.exename)+2);
iconlibname:=trim(iconlibname);
//形成列表框项
iconindex:=0;
while Extracticonex(pchar(iconlibname),
iconindex,smallicon,largeicon,1)>0 do
begin
listbox1.items.add(intTostr(iconindex));
inc(iconindex);
end;
if listbox1.Items.count>0 then
listbox1.PopupMenu:=popupmenu1;
dragacceptFiles(handle,true); //允许程序接受拖放文件
application.onmessage:=handlemsg; //指定处理WM_DropFiles的函数
end;
//保存指定图标
procedure TForm1.Save1Click(Sender: TObject);
begin
if savedialog1.Execute then
begin
savedialog1.filename:=changeFileext(savedialog1.filename,''.ico'');
if listbox1.ItemIndex=-1 then listbox1.itemindex:=0;
Extracticonex(pchar(iconlibname),
listbox1.itemindex,smallicon,largeicon,1);
icon.handle:=smallicon;
icon.SaveToFile(savedialog1.Filename);
end;
end;
procedure TForm1.eXit1Click(Sender: TObject);
begin
close;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
icon.free;
end;
end.
---- 这样一个图标库浏览程序就建立好了，你可以把图标库直接拖放到程序中，也可以双击这些图标库文件都可以看到丰富多彩的图标！