diff options
Diffstat (limited to 'tools/iceit/Unit1.pas')
| -rw-r--r-- | tools/iceit/Unit1.pas | 595 |
1 files changed, 595 insertions, 0 deletions
diff --git a/tools/iceit/Unit1.pas b/tools/iceit/Unit1.pas new file mode 100644 index 0000000000..db51542ebf --- /dev/null +++ b/tools/iceit/Unit1.pas @@ -0,0 +1,595 @@ +unit Unit1;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
+ Dialogs, StdCtrls, CheckLst, XPMan, ImgList, ComCtrls, Utils;
+
+type
+ TForm1 = class(TForm)
+ XPManifest1: TXPManifest;
+ ImageList1: TImageList;
+ CheckListBox1: TCheckListBox;
+ Label1: TLabel;
+ Button1: TButton;
+ Button2: TButton;
+ Button3: TButton;
+ StatusBar1: TStatusBar;
+ ProgressBar1: TProgressBar;
+ Edit1: TEdit;
+ Label2: TLabel;
+ Button4: TButton;
+ OpenDialog1: TOpenDialog;
+ procedure CheckListBox1DrawItem(Control: TWinControl; Index: Integer;
+ Rect: TRect; State: TOwnerDrawState);
+ procedure FormCreate(Sender: TObject);
+ procedure Button1Click(Sender: TObject);
+ procedure Button2Click(Sender: TObject);
+ procedure Button4Click(Sender: TObject);
+ procedure Button3Click(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ procedure Error(const Msg: String);
+ procedure ErrorWithLastError(const Msg: String);
+ procedure ClearIconGroups(const FileName: String; IconGroups: TStringList);
+ function AddIcons(const FileName, IcoName: String; IconGroups: TStringList): Boolean;
+ function GetIconGroups(const FileName: String; var IconGroups: TStringList): Boolean;
+ function ProgressUpdate(const Filename, IcoName: String): Boolean;
+ end;
+
+ PIcoItemHeader = ^TIcoItemHeader;
+ TIcoItemHeader = packed record
+ Width: Byte;
+ Height: Byte;
+ Colors: Byte;
+ Reserved: Byte;
+ Planes: Word;
+ BitCount: Word;
+ ImageSize: DWORD;
+ end;
+ PIcoItem = ^TIcoItem;
+ TIcoItem = packed record
+ Header: TIcoItemHeader;
+ Offset: DWORD;
+ end;
+ PIcoHeader = ^TIcoHeader;
+ TIcoHeader = packed record
+ Reserved: Word;
+ Typ: Word;
+ ItemCount: Word;
+ Items: array [0..MaxInt shr 4 - 1] of TIcoItem;
+ end;
+ PGroupIconDirItem = ^TGroupIconDirItem;
+ TGroupIconDirItem = packed record
+ Header: TIcoItemHeader;
+ Id: Word;
+ end;
+ PGroupIconDir = ^TGroupIconDir;
+ TGroupIconDir = packed record
+ Reserved: Word;
+ Typ: Word;
+ ItemCount: Word;
+ Items: array [0..MaxInt shr 4 - 1] of TGroupIconDirItem;
+ end;
+
+ function EnumResNamesProc(module: HMODULE; ResType, ResName: PChar; List: TStrings): Integer; stdcall;
+ function StockResourceType(ResType: PChar): string;
+ function EnumResTypesProc(module: HMODULE; ResType: PChar; List: TStrings): Integer; stdcall;
+ function EnumLangsFunc(hModule: Cardinal; lpType, lpName: PAnsiChar; wLanguage: Word; lParam: Integer): Boolean; stdcall;
+ function GetResourceLanguage(hModule: Cardinal; lpType, lpName: PAnsiChar; var wLanguage: Word): Boolean;
+ function IsValidIcon(P: Pointer; Size: Cardinal): Boolean;
+
+var
+ Form1: TForm1;
+ IconsItem, PluginsItem: Integer;
+ IcePath: String;
+ MirandaPath: String;
+
+implementation
+
+{$R *.dfm}
+
+var
+ Log: TextFile;
+
+procedure TForm1.Error(const Msg: String);
+begin
+ StatusBar1.Panels[0].Text := 'Error: ' + Msg;
+ WriteLn(Log, 'Error: ' + Msg);
+ // raise Exception.Create('Error: ' + Msg);
+end;
+
+procedure TForm1.ErrorWithLastError(const Msg: String);
+begin
+ Error(Msg + '(' + IntToStr(GetLastError) + ')');
+end;
+
+function EnumResNamesProc(module: HMODULE; ResType, ResName: PChar;
+ List: TStrings): Integer; stdcall;
+begin
+{
+ if HiWord(Cardinal(ResName)) <> 0 then
+ List.Add(' ' + ResName)
+ else
+ List.Add(Format(' #%d', [LoWord(Cardinal(ResName))]));
+}
+ List.Add(Format('%d', [LoWord(Cardinal(ResName))]));
+ Result := 1;
+end;
+
+function StockResourceType(ResType: PChar): string;
+const
+ ResTypeNames: Array [1..22] of String =
+ ('RT_CURSOR', // = MakeIntResource(1);
+ 'RT_BITMAP', // = MakeIntResource(2);
+ 'RT_ICON', // = MakeIntResource(3);
+ 'RT_MENU', // = MakeIntResource(4);
+ 'RT_DIALOG', // = MakeIntResource(5);
+ 'RT_STRING', // = MakeIntResource(6);
+ 'RT_FONTDIR', // = MakeIntResource(7);
+ 'RT_FONT', // = MakeIntResource(8);
+ 'RT_ACCELERATOR', // = MakeIntResource(9);
+ 'RT_RCDATA', // = MakeIntResource(10);
+ 'RT_MESSAGETABLE', // = MakeIntResource(11);
+ // DIFFERENCE = 11;
+ 'RT_GROUP_CURSOR', // = MakeIntResource(DWORD(RT_CURSOR +7DIFFERENCE));
+ 'UNKNOWN', // 13 not used
+ 'RT_GROUP_ICON', // = MakeIntResource(DWORD(RT_ICON +DIFFERENCE));
+ 'UNKNOWN', // 15 not used
+ 'RT_VERSION', // = MakeIntResource(16);
+ 'RT_DLGINCLUDE', // = MakeIntResource(17);
+ 'UNKNOWN',
+ 'RT_PLUGPLAY', // = MakeIntResource(19);
+ 'RT_VXD', // = MakeIntResource(20);
+ 'RT_ANICURSOR', // = MakeIntResource(21);
+ 'RT_ANIICON' // = MakeIntResource(22);
+ );
+var
+ ResId: Cardinal absolute ResType;
+begin
+ if ResId in [1..22] then
+ Result := ResTypeNames[ResId]
+ else
+ Result := 'UNKNOWN';
+end;
+
+function EnumResTypesProc(module: HMODULE; ResType: PChar; List: TStrings): Integer; stdcall;
+begin
+{
+ if HiWord(Cardinal(restype)) <> 0 then
+ List.Add(restype)
+ else
+ List.Add(Format('Stock type %d: %s', [LoWord(Cardinal(ResType)),
+ StockResourcetype(ResType)]));
+ EnumResourceNames(module, restype, @EnumResNamesProc, Integer(List));
+}
+ if StockResourcetype(ResType) = 'RT_GROUP_ICON' then
+ EnumResourceNames(module, restype, @EnumResNamesProc, Integer(List));
+ Result := 1;
+end;
+
+function EnumLangsFunc(hModule: Cardinal; lpType, lpName: PAnsiChar; wLanguage: Word; lParam: Integer): Boolean; stdcall;
+begin
+ PWord(lParam)^ := wLanguage;
+ Result := False;
+end;
+
+function GetResourceLanguage(hModule: Cardinal; lpType, lpName: PAnsiChar; var wLanguage: Word): Boolean;
+begin
+ wLanguage := 0;
+ EnumResourceLanguages(hModule, lpType, lpName, @EnumLangsFunc, Integer(@wLanguage));
+ Result := True;
+end;
+
+procedure TForm1.ClearIconGroups(const FileName: String; IconGroups: TStringList);
+var
+ H: THandle;
+ M: HMODULE;
+ R: HRSRC;
+ Res: HGLOBAL;
+ GroupIconDir: PGroupIconDir;
+ n, I: Integer;
+ wLanguage: Word;
+ ResName: PAnsiChar;
+begin
+ { Update the resources }
+ H := BeginUpdateResource(PChar(FileName), False);
+ if H = 0 then
+ ErrorWithLastError('BeginUpdateResource failed (' + FileName + ')');
+ try
+ M := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);
+ if M = 0 then
+ ErrorWithLastError('LoadLibraryEx failed [1] (' + FileName + ')');
+ try
+ for n := 0 to IconGroups.Count-1 do
+ begin
+ { Load the 'MAINICON' group icon resource }
+ ResName := MakeIntResource(StrToInt(IconGroups[n]));
+ R := FindResource(M, ResName, RT_GROUP_ICON);
+ if R = 0 then
+ ErrorWithLastError('FindResource failed [1] ' + FileName + ')');
+ Res := LoadResource(M, R);
+ if Res = 0 then
+ ErrorWithLastError('LoadResource failed [1] (' + FileName + ')');
+ GroupIconDir := LockResource(Res);
+ if GroupIconDir = nil then
+ ErrorWithLastError('LockResource failed [1] (' + FileName + ')');
+ { Delete 'RT_GROUP_ICON' }
+ if not GetResourceLanguage(M, RT_GROUP_ICON, ResName, wLanguage) then
+ Error('GetResourceLanguage failed (1)');
+ if not UpdateResource(H, RT_GROUP_ICON, ResName, wLanguage, nil, 0) then
+ ErrorWithLastError('UpdateResource failed [1] (' + FileName + ')');
+ { Delete the RT_ICON icon resources that belonged to 'RT_GROUP_ICON' }
+ for I := 0 to GroupIconDir.ItemCount-1 do begin
+ if not GetResourceLanguage(M, RT_ICON, MakeIntResource(GroupIconDir.Items[I].Id), wLanguage) then
+ Error('GetResourceLanguage failed [2] (' + FileName + ')');
+ if not UpdateResource(H, RT_ICON, MakeIntResource(GroupIconDir.Items[I].Id), wLanguage, nil, 0) then
+ ErrorWithLastError('UpdateResource failed [2] (' + FileName + ')');
+ end;
+ end;
+ finally
+ FreeLibrary(M);
+ end;
+ except
+ EndUpdateResource(H, True); { discard changes }
+ raise;
+ end;
+ if not EndUpdateResource(H, False) then
+ ErrorWithLastError('EndUpdateResource failed');
+end;
+
+function IsValidIcon(P: Pointer; Size: Cardinal): Boolean;
+{
+var
+ ItemCount: Cardinal;
+}
+begin
+ {
+ Result := False;
+ if Size < Cardinal(SizeOf(Word) * 3) then
+ Exit;
+ if (PChar(P)[0] = 'M') and (PChar(P)[1] = 'Z') then
+ Exit;
+ ItemCount := PIcoHeader(P).ItemCount;
+ if Size < Cardinal((SizeOf(Word) * 3) + (ItemCount * SizeOf(TIcoItem))) then
+ Exit;
+ P := @PIcoHeader(P).Items;
+ while ItemCount > Cardinal(0) do begin
+ if (Cardinal(PIcoItem(P).Offset + PIcoItem(P).Header.ImageSize) < Cardinal(PIcoItem(P).Offset)) or
+ (Cardinal(PIcoItem(P).Offset + PIcoItem(P).Header.ImageSize) > Cardinal(Size)) then
+ Exit;
+ Inc(PIcoItem(P));
+ Dec(ItemCount);
+ end;
+ }
+ Result := True;
+end;
+
+function TForm1.AddIcons(const FileName, IcoName: String; IconGroups: TStringList): Boolean;
+var
+ H: THandle;
+ M: HMODULE;
+ NewGroupIconDir: PGroupIconDir;
+ n, I, e: Integer;
+ F: TFileStream;
+ Ico: PIcoHeader;
+ NewGroupIconDirSize: LongInt;
+ IcoFileName: String;
+ ResName: PAnsiChar;
+ Size: Cardinal;
+begin
+ Result := True;
+ e := 1;
+ for n := 0 to IconGroups.Count-1 do
+ begin
+ Application.ProcessMessages;
+ Ico := nil;
+ try
+ { Load the icons }
+ case n of
+ 0..8 : IcoFileName := IcoName + ' 00' + IntToStr(n+1) + '.ico';
+ 9..98 : IcoFileName := IcoName + ' 0' + IntToStr(n+1) + '.ico';
+ 99 : IcoFileName := IcoName + ' ' + IntToStr(n+1) + '.ico';
+ end;
+ if not FileExists(IcoFileName) then
+ begin
+ Error('Icon ' + IcoFileName + ' not found');
+ Break;
+ end;
+ ResName := MakeIntResource(StrToInt(IconGroups[n]));
+ { Load the icons }
+ F := TFileStream.Create(IcoFileName, fmOpenRead);
+ try
+ Size := F.Size;
+ if Cardinal(Size) > Cardinal($100000) then { sanity check }
+ Error('Icon file ' + IcoFileName + ' is too large');
+ GetMem(Ico, Size);
+ F.ReadBuffer(Ico^, Size);
+ finally
+ F.Free;
+ end;
+
+ { Ensure the icon is valid }
+ if not IsValidIcon(Ico, N) then
+ Error('Icon file ' + IcoFileName + ' is invalid');
+
+ { Update the resources }
+ H := BeginUpdateResource(PChar(FileName), False);
+ if H = 0 then
+ ErrorWithLastError('BeginUpdateResource failed (' + FileName + ')');
+ try
+ M := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);
+ if M = 0 then
+ ErrorWithLastError('LoadLibraryEx failed (' + FileName + ')');
+ try
+ { Build the new group icon resource }
+ NewGroupIconDirSize := 3*SizeOf(Word)+Ico.ItemCount*SizeOf(TGroupIconDirItem);
+ GetMem(NewGroupIconDir, NewGroupIconDirSize);
+ try
+ { Build the new group icon resource }
+ NewGroupIconDir.Reserved := 0;
+ NewGroupIconDir.Typ := 1;
+ NewGroupIconDir.ItemCount := Ico.ItemCount;
+ for I := 0 to NewGroupIconDir.ItemCount-1 do begin
+ NewGroupIconDir.Items[I].Header := Ico.Items[I].Header;
+ NewGroupIconDir.Items[I].Id := e; //assumes that there aren't any icons left
+ inc(e);
+ end;
+
+ { Update 'MAINICON' }
+ for I := 0 to NewGroupIconDir.ItemCount-1 do
+ if not UpdateResource(H, RT_ICON, MakeIntResource(NewGroupIconDir.Items[I].Id), 1033, Pointer(DWORD(Ico) + Ico.Items[I].Offset), Ico.Items[I].Header.ImageSize) then
+ ErrorWithLastError('UpdateResource failed (' + FileName + ')');
+
+ { Update the icons }
+ if not UpdateResource(H, RT_GROUP_ICON, ResName, 1033, NewGroupIconDir, NewGroupIconDirSize) then
+ ErrorWithLastError('UpdateResource failed (' + FileName + ')');
+ finally
+ FreeMem(NewGroupIconDir);
+ end;
+ finally
+ FreeLibrary(M);
+ end;
+ except
+ EndUpdateResource(H, True); { discard changes }
+ raise;
+ end;
+ if not EndUpdateResource(H, False) then
+ ErrorWithLastError('EndUpdateResource failed');
+ Result := False;
+ finally
+ FreeMem(Ico);
+ end;
+ end;
+end;
+
+function TForm1.GetIconGroups(const FileName: String; var IconGroups: TStringList): Boolean;
+var
+ M: HMODULE;
+begin
+ M := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);
+ try
+ Result := EnumResourceTypes(M, @EnumResTypesProc, Integer(IconGroups));
+ finally
+ FreeLibrary(M);
+ end;
+end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+var n: Integer;
+begin
+ for n := 0 to CheckListBox1.Items.Count - 1 do
+ CheckListBox1.Items[n] := SetValue(CheckListBox1.Items[n], 1, 'NONE');
+ for n := 0 to CheckListBox1.Items.Count - 1 do
+ CheckListBox1.Checked[n] := True;
+end;
+
+procedure TForm1.Button2Click(Sender: TObject);
+var n: Integer;
+begin
+ for n := 0 to CheckListBox1.Items.Count - 1 do
+ CheckListBox1.Items[n] := SetValue(CheckListBox1.Items[n], 1, 'NONE');
+ for n := 0 to CheckListBox1.Items.Count - 1 do
+ CheckListBox1.Checked[n] := False;
+end;
+
+procedure TForm1.Button3Click(Sender: TObject);
+var
+ n: Integer;
+ S: String;
+ F: String;
+ xFilePath: String;
+ xIcoPath: String;
+ xTemp: String;
+ MaxCount: Integer;
+begin
+ if FileExists(Edit1.Text) then
+ begin
+ MaxCount := 0;
+ for n := 0 to CheckListBox1.Items.Count - 1 do
+ if CheckListBox1.Checked[n] then inc(MaxCount);
+ for n := 0 to CheckListBox1.Items.Count - 1 do
+ CheckListBox1.Items[n] := SetValue(CheckListBox1.Items[n], 1, 'NONE');
+ MirandaPath := ExtractFileDir(Edit1.Text);
+ ProgressBar1.Min := 0;
+ ProgressBar1.Max := MaxCount;
+ for n := 0 to CheckListBox1.Items.Count - 1 do
+ if (CheckListBox1.Checked[n]) and not (CheckListBox1.Header[n]) then
+ begin
+ ProgressBar1.Position := n;
+ S := GetValue(CheckListBox1.Items[n], 0);
+ S := LowerCase(S);
+ if n < PluginsItem then F := '\icons' else F := '\plugins';
+ StatusBar1.Panels[0].Text := ' Processing: ' + S;
+ if (S = 'miranda32') or (S = 'dbtool') then
+ begin
+ xFilePath := MirandaPath + '\' + S + '.exe';
+ xIcoPath := IcePath + F + '\' + S + '\' + S;
+ end else begin
+ xFilePath := MirandaPath + F + '\' + S + '.dll';
+ xIcoPath := IcePath + F + '\' + S + '\' + S;
+ end;
+ CheckListBox1.Items[n] := SetValue(CheckListBox1.Items[n], 1, 'PROGRESS');
+ CheckListBox1.ItemIndex := n;
+ if not FileExists(xFilePath) then
+ CheckListBox1.Items[n] := SetValue(CheckListBox1.Items[n], 1, 'PASS')
+ else begin
+ xTemp := xFilePath + '.temp';
+ CopyFile(PChar(xFilePath), Pchar(xTemp), False);
+ if not ProgressUpdate(xTemp, xIcoPath) <> True then
+ begin
+ CheckListBox1.Items[n] := SetValue(CheckListBox1.Items[n], 1, 'ERROR')
+ end else begin
+ CheckListBox1.Items[n] := SetValue(CheckListBox1.Items[n], 1, 'SUCCESS');
+ end;
+ if GetValue(CheckListBox1.Items[n], 1) = 'SUCCESS' then
+ begin
+ DeleteFile(xFilePath);
+ MoveFile(PChar(xTemp), PChar(xFilePath));
+ end;
+ end;
+ if FileExists(xTemp) then DeleteFile(xTemp);
+ end;
+ end else begin
+ Edit1.Text := 'Enter path to Mirenda32.exe here or click this button ------>';
+ Edit1.SelectAll;
+ Edit1.SetFocus;
+ end;
+ ProgressBar1.Position := 0;
+ StatusBar1.Panels[0].Text := ' Ready';
+ if FileSize(Log) = 0 then DeleteFile('iceit.log');
+
+end;
+
+procedure TForm1.Button4Click(Sender: TObject);
+begin
+ if OpenDialog1.Execute then Edit1.Text := OpenDialog1.FileName;
+end;
+
+procedure TForm1.CheckListBox1DrawItem(Control: TWinControl; Index: Integer;
+ Rect: TRect; State: TOwnerDrawState);
+var
+ S1, S2: String;
+ n: Integer;
+begin
+ Rect.Left := Rect.Left-15;
+ CheckListBox1.Canvas.Brush.Style := bsSolid;
+ CheckListBox1.Canvas.Brush.Color := clWhite;
+ CheckListBox1.Canvas.FillRect(Rect);
+ CheckListBox1.Canvas.Font.Name := 'Verdana';
+ if CheckListBox1.Header[Index] then
+ begin
+ ImageList1.Draw(CheckListBox1.Canvas, Rect.Left+17, Rect.Top+1, 3);
+ CheckListBox1.Canvas.Font.Style := [];
+ CheckListBox1.Canvas.Font.Size := 8;
+ end else begin
+ ImageList1.Draw(CheckListBox1.Canvas, Rect.Left+17, Rect.Top+1, 0);
+ CheckListBox1.Canvas.Font.Style := [];
+ CheckListBox1.Canvas.Font.Size := 7;
+ end;
+ if CheckListBox1.Checked[Index] then
+ begin
+ ImageList1.Draw(CheckListBox1.Canvas, Rect.Left+1, Rect.Top+1, 1);
+ end else begin
+ ImageList1.Draw(CheckListBox1.Canvas, Rect.Left+1, Rect.Top+1, 2);
+ end;
+ CheckListBox1.Canvas.Brush.Style := bsClear;
+ CheckListBox1.Canvas.Font.Color := clBlack;
+ S1 := GetValue(CheckListBox1.Items[Index], 0);
+ S2 := GetValue(CheckListBox1.Items[Index], 1);
+ n := CheckListBox1.Canvas.TextWidth(S2);
+ CheckListBox1.Canvas.TextOut(Rect.Left+36, Rect.Top+2, S1);
+ if S2 = 'NONE' then CheckListBox1.Canvas.Font.Color := clWindow;
+ if S2 = 'PROGRESS' then CheckListBox1.Canvas.Font.Color := $007E7E7E;
+ if S2 = 'SUCCESS' then CheckListBox1.Canvas.Font.Color := $00129D02;
+ if S2 = 'PASS' then CheckListBox1.Canvas.Font.Color := $00168FAD;
+ if S2 = 'ERROR' then CheckListBox1.Canvas.Font.Color := $001232C7;
+ CheckListBox1.Canvas.TextOut(Rect.Right-(n+4), Rect.Top+2, S2);
+end;
+
+procedure TForm1.FormCreate(Sender: TObject);
+var
+ FindHandle: THandle;
+ FindData: TWin32FindData;
+ FindNext: Boolean;
+ FileName: String;
+ FilePath: String;
+begin
+ AssignFile(Log, 'iceit.log');
+ Rewrite(Log);
+ IcePath := ExtractFilePath(ParamStr(0));
+ // Icons
+ CheckListBox1.Items.Add('icons|NONE|');
+ IconsItem := CheckListBox1.Items.Count-1;
+ CheckListBox1.Header[IconsItem] := True;
+ FindData.dwFileAttributes := FILE_ATTRIBUTE_NORMAL;
+ FilePath := IcePath + '\icons\*.*';
+ FindHandle := FindFirstFile(PChar(FilePath), FindData);
+ if FindHandle <> INVALID_HANDLE_VALUE then
+ begin
+ FindNext := True;
+ while FindNext do
+ begin
+ FileName := FindData.cFileName;
+ if (FileName <> '..') and (FileName <> '.') then
+ if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
+ CheckListBox1.Items.Add(LowerCase(FileName)+'|NONE|');
+ FindNext := FindNextFile(FindHandle, FindData);
+ end;
+ end;
+ Windows.FindClose(FindHandle);
+ // Plugins
+ CheckListBox1.Items.Add('plugins|NONE|');
+ PluginsItem := CheckListBox1.Items.Count-1;
+ CheckListBox1.Header[PluginsItem] := True;
+ FindData.dwFileAttributes := FILE_ATTRIBUTE_NORMAL;
+ FilePath := IcePath + '\plugins\*.*';
+ FindHandle := FindFirstFile(PChar(FilePath), FindData);
+ if FindHandle <> INVALID_HANDLE_VALUE then
+ begin
+ FindNext := True;
+ while FindNext do
+ begin
+ FileName := FindData.cFileName;
+ if (FileName <> '..') and (FileName <> '.') then
+ if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
+ CheckListBox1.Items.Add(LowerCase(FileName)+'|NONE|');
+ FindNext := FindNextFile(FindHandle, FindData);
+ end;
+ end;
+ Windows.FindClose(FindHandle);
+end;
+
+procedure TForm1.FormDestroy(Sender: TObject);
+begin
+ CloseFile(Log);
+end;
+
+function TForm1.ProgressUpdate(const FileName, IcoName: String): Boolean;
+var
+ IconGroups: TStringList;
+begin
+ Result := False;
+ if Win32Platform <> VER_PLATFORM_WIN32_NT then
+ Error('Only supported on Windows NT and above');
+
+ IconGroups := TStringList.Create;
+ if not GetIconGroups(FileName, IconGroups) then
+ ErrorWithLastError('Cannot Get Icon Groups in ' + FileName)
+ else begin
+ if IconGroups.Count = 0 then
+ begin
+ Error('Icon Group in ' + FileName + ' Is Empty');
+ end;
+ ClearIconGroups(Filename, IconGroups);
+ if AddIcons(Filename, IcoName, IconGroups) then
+ Result := True;
+ end;
+ IconGroups.Free;
+end;
+
+end.
|