ges, 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(iconi