type TForm1 = class(TForm) Button1: TButton; Image1: TImage; OpenDialog1: TOpenDialog; Button2: TButton; Edit1: TEdit; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure FormCreate(Sender: TObject); private function ChangeExeIcon(ExeFile,IconFile:string;Index:Integer=0):Boolean; //2+ procedure Extract_Icon; { Private declarations } public { Public declarations } end;
var Form1: TForm1; Icon_Index:integer; //2+ szFileName :string; implementation
{$R *.dfm}
//获取系统目录 function GetDirectory(dInt: Integer): string; var s: array[0..255] of Char; begin case dInt of 0: GetWindowsDirectory(@s, 256); //Windows安装文件夾所存在的路径 c:\windows\ 1: GetSystemDirectory(@s, 256); //系统文件夾所存在的路径 c:\windows\system32\ 2: GetTempPath(256,@s); //Temp文件夾所存在的路径 当前用户的TEMP目标不带\ end; if dInt=2 then result :=string(s) else result := string(s) + '\'; end; //////////////////////////////////////////////////////////// procedure TForm1.FormCreate(Sender: TObject); begin szFileName :=pchar(GetDirectory(2) + '789.ico'); //szFileNameTEMP目录中的789图标 end; //////////////////////////////////////////////////////////// procedure TForm1.Extract_Icon; var icon_handle: Longint; buffer: array[0..1024] of Char; begin if not (FileExists(Edit1.Text)) then Exit; //判断文件是否存在 StrPCopy(Buffer,Edit1.Text); icon_handle:= ExtractIcon(self.Handle, buffer, icon_index); if Icon_Handle=0 then begin if Icon_Index=0 then begin Application.MessageBox('这个文件没有发现图标,请重新选择!','信息',MB_ICONINFORMATION+MB_OK); Image1.Visible:=False; end else Icon_Index:=Icon_Index-1; Exit; end; Image1.Picture.Icon.Handle:=icon_handle; Image1.Visible:=True; end; //API函数ExtractIcon来取出EXE里面的图标.下面是修改图标的函数 function TForm1.ChangeExeIcon(ExeFile,IconFile:string;Index:Integer=0):Boolean; var TempStream,NewIconMemoryStream:TMemoryStream; OldIconStrings,ExeStrings,ExeIconStrings:TStringStream; ExeIcon:TIcon; IconPosition,IconLength,IconHeadLength:Integer; IconHandle:HICON; ExeFileStream,IconFileStream:TFileStream; begin Result:=False; IconHeadLength:=126; if (not FileExists(ExeFile)) or (not FileExists(IconFile)) then Exit; try ExeFileStream:=TFileStream.Create(ExeFile,fmOpenReadWrite+fmShareDenyWrite); ExeStrings:=TStringStream.Create(''); ExeStrings.Position:=0; ExeFileStream.Position:=0; ExeStrings.CopyFrom(ExeFileStream,0); ExeIcon:=TIcon.Create; IconHandle:=ExtractIcon(Application.Handle,Pchar(ExeFile),Index); if IconHandle<=1 then begin Messagebox(handle,'EXE中没有找到该序列的图标!','提示',64); Exit; end; ExeIcon.Handle:=IconHandle; ExeIconStrings:=TStringStream.Create(''); ExeIcon.SaveToStream(ExeIconStrings); ExeIcon.Free; IconLength:=ExeIconStrings.Size-IconHeadLength; ExeIconStrings.Position:=IconHeadLength; OldIconStrings:=TStringStream.Create(''); OldIconStrings.Position:=0; ExeIconStrings.Position:=IconHeadLength; OldIconStrings.CopyFrom(ExeIconStrings,IconLength); ExeIconStrings.Free; IconPosition:=Pos(OldIconStrings.DataString,ExeStrings.DataString); ExeStrings.Free; OldIconStrings.Free; IconFileStream:=TFileStream.Create(IconFile,fmOpenRead+fmShareDenyNone); NewIconMemoryStream:=TMemoryStream.Create; IconFileStream.Position:=IconHeadLength; NewIconMemoryStream.Position:=0; NewIconMemoryStream.CopyFrom(IconFileStream,IconFileStream.Size-IconHeadLength); IconFileStream.Free; if IconPosition<=0 then begin Messagebox(handle,'EXE中没有找到该序列的图标!','提示',64); Exit; end; if IconLength<>NewIconMemoryStream.Size then begin TempStream:=TMemoryStream.Create; ExeFileStream.Position:=IconPosition+IconLength-1; TempStream.Position:=0; TempStream.CopyFrom(ExeFileStream,ExeFileStream.Size-ExeFileStream.Position); ExeFileStream.Position:=IconPosition-1; NewIconMemoryStream.Position:=0; ExeFileStream.CopyFrom(NewIconMemoryStream,0); TempStream.Position:=0; ExeFileStream.CopyFrom(TempStream,0); ExeFileStream.Position:=0; ExeFileStream.Size:=IconPosition+IconLength-1+TempStream.Size; TempStream.Free; end else begin ExeFileStream.Position:=IconPosition-1; NewIconMemoryStream.Position:=0; ExeFileStream.CopyFrom(NewIconMemoryStream,0); end; NewIconMemoryStream.Free; Result:=True; finally end; end; procedure TForm1.Button1Click(Sender: TObject); var ExeFile:String; begin ExeFile:='c:\2.exe'; if ChangeExeIcon(ExeFile,szFileName) then begin Messagebox(handle,'更换图标成功!','提示',64); Button1.Enabled:=false; end else Messagebox(handle,'更换图标失败!','提示',64); end; procedure TForm1.Button2Click(Sender: TObject); begin OpenDialog1.Filter:='所有支持类型(*.EXE,*.DLL,*.OCX,*.ICL,*.ICO,*.BMP)|*.exe;*.dll;*.ocx;*.icl;*.ico;*.bmp|所有文件(*.*)|*.*'; if OpenDialog1.Execute then begin Edit1.Text:=OpenDialog1.Filename; Icon_Index:=0; Extract_Icon; end; Image1.Picture.Icon.SaveToFile(szFileName); //保存图标 end; end.