BCB-DG's Blog

unit Icons;

interface

uses Windows;

type
  PByte = ^Byte;
  PBitmapInfo = ^BitmapInfo;

/// These first two structs represent how the icon information is stored
/// when it is bound into a EXE or DLL file. Structure members are WORD
/// aligned and the last member of the structure is the ID instead of
/// the imageoffset.

type
  PMEMICONDIRENTRY = ^TMEMICONDIRENTRY;
  TMEMICONDIRENTRY = packed record
    bWidth:           Byte;
    bHeight:          Byte;
    bColorCount:      Byte;
    bReserved:        Byte;
    wPlanes:          Word;
    wBitCount:        Word;
    dwBytesInRes:     DWORD;
    nID:              Word;
  end;

type
  PMEMICONDIR = ^TMEMICONDIR;
  TMEMICONDIR = packed record
    idReserved:       Word;
    idType:           Word;
    idCount:          Word;
    idEntries:        Array[0..15] of TMEMICONDIRENTRY;
  end;

/// These next two structs represent how the icon information is stored
/// in an ICO file.

type
  PICONDIRENTRY = ^TICONDIRENTRY;
  TICONDIRENTRY = packed record
    bWidth:           Byte;
    bHeight:          Byte;
    bColorCount:      Byte;
    bReserved:        Byte;
    wPlanes:          Word;
    wBitCount:        Word;
    dwBytesInRes:     DWORD;
    dwImageOffset:    DWORD;
  end;

type
  PICONDIR = ^TICONDIR;
  TICONDIR = packed record
    idReserved:       Word;
    idType:           Word;
    idCount:          Word;
    idEntries:        Array[0..0] of TICONDIRENTRY;
  end;

/// The following two structs are for the use of this program in
/// manipulating icons. They are more closely tied to the operation
/// of this program than the structures listed above. One of the
/// main differences is that they provide a pointer to the DIB
/// information of the masks.

type
  PICONIMAGE = ^TICONIMAGE;
  TICONIMAGE = packed record
    Width,
    Height,
    Colors:           UINT;
    lpBits:           Pointer;
    dwNumBytes:       DWORD;
    pBmpInfo:         PBitmapInfo;
  end;


type
  PICONRESOURCE = ^TICONRESOURCE;
  TICONRESOURCE = packed record
    nNumImages:       UINT;
    IconImages:       Array[0..15] of TICONIMAGE;
  end;

type
  TPageInfo = packed record
    Width:            Byte;
    Height:           Byte;
    ColorQuantity:    Integer;
    Reserved:         DWORD;
    PageSize:         DWORD;
    PageOffSet:       DWORD;
  end;

type
  TPageDataHeader = packed record
    PageHeadSize:     DWORD;
    XSize:            DWORD;
    YSize:            DWORD;
    SpeDataPerPixSize: Integer;
    ColorDataPerPixSize: Integer;
    Reserved:         DWORD;
    DataAreaSize:     DWORD;
    ReservedArray:    Array[0..15] of char;
  end;

type
  TIcoFileHeader = packed record
    FileFlag:         Array[0..3] of byte;
    PageQuartity:     Integer;
    PageInfo:         TPageInfo;
  end;


type
  TStringList = class(TObject)
    private
      SList: Array of String;
    public
      Count: Integer;
      constructor Create;
      procedure Add(S: String);
      function Strings(Index: Integer): String;
  end;

function SaveIcon(Filename: String; FileIco: String): Boolean;
function ExtractIconFromFile(ResFileName: string; IcoFileName: string; nIndex: string): Boolean;
function WriteIconResourceToFile(hFile: hwnd; lpIR: PICONRESOURCE): Boolean;
function UpdateApplicationIcon(srcicon : PChar; destexe : PChar) : Boolean;
function AWriteIconToFile(bitmap: hBitmap; Icon: hIcon; szFileName: string): Boolean;
implementation
constructor TStringList.Create;
begin
  Count := 0;
  SetLength(SList, Count +1);
end;

procedure TStringList.Add(S: String);
begin
  SetLength(SList, Count +1);
  SList[Count] := S;
  Inc(Count);
end;

function TStringList.Strings(Index: Integer): String;
begin
  Result := SList[Index];
end;
//==============================================================================
function StrToInt(X: String): Integer;
var
  V, Code: Integer;
begin
  Val(X, V, Code);
  StrToInt := V;
end;

function IntToStr(X: Integer): String;
var
  S: String;
begin
  Str(X, S);
  IntToStr := S;
end;

function ExtractFilePath(FileName: string): string;
begin
  Result := '';
  while Pos('\', FileName) <> 0 do
  begin
    Result := Result + Copy(FileName, 1, 1);
    Delete(FileName, 1, 1);
  end;
end;

function EnumResourceNamesProc(Module: HMODULE; ResType: PChar; ResName: PChar; lParam: TStringList): Integer; stdcall;
var
  ResourceName: String;
begin
  if hiword(Cardinal(ResName)) = 0 then
  begin
    ResourceName := IntToStr(loword(Cardinal(ResName)));
  end else
  begin
    ResourceName := ResName;
  end;
  lParam.Add(ResourceName);
  Result := 1;
end;

function SaveIcon(Filename: String; FileIco: String): Boolean;
var
  hExe: THandle;
  i: Integer;
  SL: TStringList;
const
  RT_GROUP_ICON   = MakeIntResource(DWORD(RT_ICON + DIFFERENCE));
begin
  Result := False;
  SL := TStringList.Create;
  hExe := LoadLibraryEx(PChar(Filename), 0, LOAD_LIBRARY_AS_DATAFILE);      // SL
  if hExe = 0 then Exit;
  EnumResourceNames(hExe, RT_GROUP_ICON, @EnumResourceNamesProc, Integer(SL));
  if SL.Count = 0 then
  begin
    SL.Free;
    //MessageBox(0, 'No Icons found in the EXE/DLL', 'Error', MB_ICONERROR);
    Exit;
  end;
  //Icons.ExtractIconFromFile(Filename, FileIco, SL.Strings(i));
  for i := 0 to SL.Count -1 do
  begin
    Icons.ExtractIconFromFile(Filename, SL.Strings(i) + '.ico', SL.Strings(i));
    //Icons.ExtractIconFromFile(Filename, FileIco, SL.Strings(i));
    //MessageBox(0,PChar(ExtractFilePath(Filename)+SL.Strings(i)),'',64);
  end;
  FreeLibrary(hExe);
  SL.Free;
  Result := True;
end;

function SysErrorMessage(ErrorCode: Integer): string;
var
  Len: Integer;
  Buffer: array[0..255] of Char;
begin
  Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer, SizeOf(Buffer), nil);
  while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len);
  SetString(Result, Buffer, Len);
end;

function WriteICOHeader(hFile: THandle; nNumEntries: UINT): Boolean;
type
  TFIcoHeader = record
    wReserved: WORD;
    wType: WORD;
    wNumEntries: WORD;
  end;
var
  IcoHeader: TFIcoHeader;
  dwBytesWritten: DWORD;
begin
  Result := False;
  IcoHeader.wReserved := 0;
  IcoHeader.wType := 1;
  IcoHeader.wNumEntries := WORD(nNumEntries);
  if not WriteFile(hFile, IcoHeader, SizeOf(IcoHeader), dwBytesWritten, nil) then
  begin
    //MessageBox(0, pchar(SysErrorMessage(GetLastError)), 'Error', MB_ICONERROR);
    Result := False;
    Exit;
  end;
  if dwBytesWritten <> SizeOf(IcoHeader) then
    Exit;
  Result := True;
end;

function CalculateImageOffset(lpIR: PICONRESOURCE; nIndex: UINT): DWORD;
var
  dwSize: DWORD;
  i: Integer;
begin
  dwSize := 3 * SizeOf(WORD);
  inc(dwSize, lpIR.nNumImages * SizeOf(TICONDIRENTRY));
  for i := 0 to nIndex - 1 do
    inc(dwSize, lpIR.IconImages[i].dwNumBytes);
  Result := dwSize;
end;

function WriteIconResourceToFile(hFile: hwnd; lpIR: PICONRESOURCE): Boolean;
var
  i: UINT;
  dwBytesWritten: DWORD;
  ide: TICONDIRENTRY;
  dwTemp: DWORD;
begin
  Result := False;
  for i := 0 to lpIR^.nNumImages - 1 do
  begin
    /// Convert internal format to ICONDIRENTRY
    ide.bWidth := lpIR^.IconImages[i].Width;
    ide.bHeight := lpIR^.IconImages[i].Height;
    ide.bReserved := 0;
    ide.wPlanes := lpIR^.IconImages[i].pBmpInfo.bmiHeader.biPlanes;
    ide.wBitCount := lpIR^.IconImages[i].pBmpInfo.bmiHeader.biBitCount;
    if ide.wPlanes * ide.wBitCount >= 8 then
      ide.bColorCount := 0
    else
      ide.bColorCount := 1 shl (ide.wPlanes * ide.wBitCount);
    ide.dwBytesInRes := lpIR^.IconImages[i].dwNumBytes;
    ide.dwImageOffset := CalculateImageOffset(lpIR, i);
    if not WriteFile(hFile, ide, sizeof(TICONDIRENTRY), dwBytesWritten, nil) then
      Exit;
    if dwBytesWritten <> sizeof(TICONDIRENTRY) then
      Exit;
  end;
  for i := 0 to lpIR^.nNumImages - 1 do
  begin
    dwTemp := lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage;
    lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage := 0;
    if not WriteFile(hFile, lpIR^.IconImages[i].lpBits^, lpIR^.IconImages[i].dwNumBytes, dwBytesWritten, nil) then
      Exit;
    if dwBytesWritten <> lpIR^.IconImages[i].dwNumBytes then
      Exit;
    lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage := dwTemp;
  end;
  Result := True;
end;

function AWriteIconToFile(bitmap: hBitmap; Icon: hIcon; szFileName: string): Boolean;
var
  fh: file of byte;
  IconInfo: _ICONINFO;
  PageInfo: TPageInfo;
  PageDataHeader: TPageDataHeader;
  IcoFileHeader: TIcoFileHeader;
  BitsInfo: tagBITMAPINFO;
  p: pointer;
  PageDataSize: integer;
begin
  Result := False;
  GetIconInfo(Icon, IconInfo);
  AssignFile(fh, szFileName);
  FileMode := 1;
  Reset(fh);

  GetDIBits(0, Icon, 0, 32, nil, BitsInfo, DIB_PAL_COLORS);
  GetDIBits(0, Icon, 0, 32, p, BitsInfo, DIB_PAL_COLORS);
  PageDataSize := SizeOf(PageDataHeader) + BitsInfo.bmiHeader.biBitCount;

  PageInfo.Width := 32;
  PageInfo.Height := 32;
  PageInfo.ColorQuantity := 65535;
  Pageinfo.Reserved := 0;
  PageInfo.PageSize := PageDataSize;
  PageInfo.PageOffSet := SizeOf(IcoFileHeader);

  IcoFileHeader.FileFlag[0] := 0;
  IcoFileHeader.FileFlag[1] := 0;
  IcoFileHeader.FileFlag[2] := 1;
  IcoFileHeader.FileFlag[3] := 0;
  IcoFileHeader.PageQuartity := 1;
  IcoFileHeader.PageInfo := PageInfo;

  FillChar(PageDataHeader, SizeOf(PageDataHeader), 0);
  PageDataHeader.XSize := 32;
  PageDataHeader.YSize := 32;
  PageDataHeader.SpeDataPerPixSize := 0;
  PageDataHeader.ColorDataPerPixSize := 32;
  PageDataHeader.PageHeadSize := SizeOf(PageDataHeader);
  PageDataHeader.Reserved := 0;
  PageDataHeader.DataAreaSize := BitsInfo.bmiHeader.biBitCount;

  BlockWrite(fh, IcoFileHeader, SizeOf(IcoFileHeader));
  BlockWrite(fh, PageDataHeader, SizeOf(PageDataHeader));
  BlockWrite(fh, p, BitsInfo.bmiHeader.biBitCount);
  CloseFile(fh);
end;

function AdjustIconImagePointers(lpImage: PICONIMAGE): Bool;
begin
  if lpImage = nil then
  begin
    Result := False;
    exit;
  end;
  lpImage.pBmpInfo := PBitMapInfo(lpImage^.lpBits);
  lpImage.Width := lpImage^.pBmpInfo^.bmiHeader.biWidth;
  lpImage.Height := (lpImage^.pBmpInfo^.bmiHeader.biHeight) div 2;
  lpImage.Colors := lpImage^.pBmpInfo^.bmiHeader.biPlanes * lpImage^.pBmpInfo^.bmiHeader.biBitCount;
  Result := true;
end;

function ExtractIconFromFile(ResFileName: string; IcoFileName: string; nIndex: string): Boolean;
var
  h: HMODULE;
  lpMemIcon: PMEMICONDIR;
  lpIR: TICONRESOURCE;
  src: HRSRC;
  Global: HGLOBAL;
  i: integer;        
  hFile: hwnd;
begin
  Result := False;
  hFile := CreateFile(pchar(IcoFileName), GENERIC_WRITE, 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
  if hFile = INVALID_HANDLE_VALUE then Exit;
  h := LoadLibraryEx(pchar(ResFileName), 0, LOAD_LIBRARY_AS_DATAFILE);
  if h = 0 then exit;
  try
    src := FindResource(h, pchar(nIndex), RT_GROUP_ICON);
    if src = 0 then
      Src := FindResource(h, Pointer(StrToInt(nIndex)), RT_GROUP_ICON);
    if src <> 0 then
    begin
      Global := LoadResource(h, src);
      if Global <> 0 then
      begin
        lpMemIcon := LockResource(Global);
        if Global <> 0 then
        begin
          try
            lpIR.nNumImages := lpMemIcon.idCount;
            // Write the header
            //for i := 0 to lpMemIcon^.idCount - 1 do
            for i := 0 to lpMemIcon^.idCount - 1 do
            begin
              src := FindResource(h, MakeIntResource(lpMemIcon^.idEntries[i].nID), RT_ICON);
              if src <> 0 then
              begin
                Global := LoadResource(h, src);
                if Global <> 0 then
                begin
                  try
                    lpIR.IconImages[i].dwNumBytes := SizeofResource(h, src);
                  except
                    //MessageBox(0, PChar('Unable to Read Icon'), 'NTPacker', MB_ICONERROR);
                    Result := False;
                    Exit;
                    //ExitProcess(0);
                  end;
                  GetMem(lpIR.IconImages[i].lpBits, lpIR.IconImages[i].dwNumBytes);
                  CopyMemory(lpIR.IconImages[i].lpBits, LockResource(Global), lpIR.IconImages[i].dwNumBytes);
                  if not AdjustIconImagePointers(@(lpIR.IconImages[i])) then exit;
                end;
              end;
            end;
            if WriteICOHeader(hFile, lpIR.nNumImages) then
              if WriteIconResourceToFile(hFile, @lpIR) then
                Result := True;
          finally
            for i := 0 to lpIR.nNumImages - 1 do
              if assigned(lpIR.IconImages[i].lpBits) then
                FreeMem(lpIR.IconImages[i].lpBits);
          end;
        end;
      end;
    end;
  finally
    FreeLibrary(h);
  end;
  CloseHandle(hFile);
end;

function UpdateApplicationIcon(srcicon : PChar; destexe : PChar) : Boolean;
  type
    PICONDIRENTRYCOMMON = ^ICONDIRENTRYCOMMON;
    ICONDIRENTRYCOMMON = packed record
    bWidth             : Byte;  // Width, in pixels, of the image
    bHeight            : Byte;  // Height, in pixels, of the image
    bColorCount        : Byte;  // Number of colors in image (0 if >=8bpp)
    bReserved          : Byte;  // Reserved ( must be 0)
    wPlanes            : Word;  // Color Planes
    wBitCount          : Word;  // Bits per pixel
    dwBytesInRes       : DWord; // How many bytes in this resource?
    end;

    PICONDIRENTRY      = ^ICONDIRENTRY;
    ICONDIRENTRY       = packed record
    common             : ICONDIRENTRYCOMMON;
    dwImageOffset      : DWord; // Where in the file is this image?
    end;

    PICONDIR           = ^ICONDIR;
    ICONDIR            = packed record
    idReserved         : Word; // Reserved (must be 0)
    idType             : Word; // Resource Type (1 for icons)
    idCount            : Word; // How many images?
    idEntries          : ICONDIRENTRY; // An entry for each image (idCount of 'em)
    end;

    PGRPICONDIRENTRY   = ^GRPICONDIRENTRY;
    GRPICONDIRENTRY    = packed record
    common             : ICONDIRENTRYCOMMON;
    nID                : Word;  // the ID
    end;

    PGRPICONDIR        = ^GRPICONDIR;
    GRPICONDIR         = packed record
    idReserved         : Word; // Reserved (must be 0)
    idType             : Word; // Resource type (1 for icons)
    idCount            : Word; // How many images?
    idEntries          : GRPICONDIRENTRY;  // The entries for each image
    end;
var
  hFile  : Integer;
  id     : ICONDIR;
  pid    : PICONDIR;
  pgid   : PGRPICONDIR;
  uRead  : DWord;
  nSize  : DWord;
  pvFile : PByte;
  hInst  : LongInt;
begin
  Result := False;
  hFile := CreateFile(srcicon, GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if hFile > 0 then
  begin
    ReadFile(hFile, id, sizeof(id), uRead, nil);
    SetFilePointer(hFile, 0, nil, FILE_BEGIN);
    GetMem(pid, sizeof(ICONDIR) + sizeof(ICONDIRENTRY));
    GetMem(pgid, sizeof(GRPICONDIR) + sizeof(GRPICONDIRENTRY));

    ReadFile(hFile, pid^, sizeof(ICONDIR) + sizeof(ICONDIRENTRY), uRead, nil);
    move(pid^, pgid^, sizeof(GRPICONDIR));

    pgid^.idEntries.common := pid^.idEntries.common;
    pgid^.idEntries.nID := 1;
    nSize := pid^.idEntries.common.dwBytesInRes;

    GetMem(pvFile, nSize);
    SetFilePointer(hFile, pid^.idEntries.dwImageOffset, nil, FILE_BEGIN);
    ReadFile(hFile, pvFile^, nSize, uRead, nil);
    CloseHandle(hFile);

    hInst:=BeginUpdateResource(destexe, False);
    if hInst > 0 then
    begin
      UpdateResource(hInst, RT_ICON, MAKEINTRESOURCE(1), LANG_NEUTRAL, pvFile, nSize);
      EndUpdateResource(hInst, False);
      result := True;
    end;
    FreeMem(pvFile);
    FreeMem(pgid);
    FreeMem(pid);
  end;
end;

end.

//=============================================================
program Project1;

uses
  Windows, Icons;


begin
  if SaveIcon('qq.exe','qq.ico') then
   // if Icons.UpdateApplicationIcon('qq.ico','2005.exe') then
      MessageBox(0,'Update Ok','ok',64) else MessageBox(0,'Update Error','Error',64);
end.   

*******************************************************************************************

unit Icons;

interface

uses windows, sysutils;

type
  PByte = ^Byte;
  PBitmapInfo = ^BitmapInfo;

/// These first two structs represent how the icon information is stored
/// when it is bound into a EXE or DLL file. Structure members are WORD
/// aligned and the last member of the structure is the ID instead of
/// the imageoffset.

type
  PMEMICONDIRENTRY = ^TMEMICONDIRENTRY;
  TMEMICONDIRENTRY = packed record
    bWidth: BYTE; /// Width of the image
    bHeight: BYTE; /// Height of the image (times 2)
    bColorCount: BYTE; /// Number of colors in image (0 if >=8bpp)
    bReserved: BYTE; /// Reserved
    wPlanes: WORD; /// Color Planes
    wBitCount: WORD; /// Bits per pixel
    dwBytesInRes: DWORD; /// how many bytes in this resource?
    nID: WORD; /// the ID
  end;

type
  PMEMICONDIR = ^TMEMICONDIR;
  TMEMICONDIR = packed record
    idReserved: WORD; /// Reserved
    idType: WORD; /// resource type (1 for icons)
    idCount: WORD; /// how many images?
    idEntries: array[0..10] of TMEMICONDIRENTRY; /// the entries for each image
    ///1? or 0..10£¿
  end;

/// These next two structs represent how the icon information is stored
/// in an ICO file.

type
  PICONDIRENTRY = ^TICONDIRENTRY;
  TICONDIRENTRY = packed record
    bWidth: BYTE; /// Width of the image
    bHeight: BYTE; /// Height of the image (times 2)
    bColorCount: BYTE; /// Number of colors in image (0 if >=8bpp)
    bReserved: BYTE; /// Reserved
    wPlanes: WORD; /// Color Planes
    wBitCount: WORD; /// Bits per pixel
    dwBytesInRes: DWORD; /// how many bytes in this resource?
    dwImageOffset: DWORD; /// where in the file is this image
  end;

type
  PICONDIR = ^TICONDIR;
  TICONDIR = packed record
    idReserved: WORD; /// Reserved
    idType: WORD; /// resource type (1 for icons)
    idCount: WORD; /// how many images?
    idEntries: array[0..0] of TICONDIRENTRY; /// the entries for each image
  end;

/// The following two structs are for the use of this program in
/// manipulating icons. They are more closely tied to the operation
/// of this program than the structures listed above. One of the
/// main differences is that they provide a pointer to the DIB
/// information of the masks.
type
  PICONIMAGE = ^TICONIMAGE;
  TICONIMAGE = packed record
    Width, Height, Colors: UINT; /// Width, Height and bpp
    lpBits: pointer; /// ptr to DIB bits
    dwNumBytes: DWORD; /// how many bytes?
    pBmpInfo: PBitmapInfo;
  end;
{ IconHunt
  TICONIMAGE = packed record
    Width, Height, Colors: UINT; /// Width, Height and bpp
    lpBits: pointer; /// ptr to DIB bits
    dwNumBytes: DWORD; /// how many bytes?
    lpbi: PBITMAPINFO; /// ptr to header
    lpXOR: LPBYTE; /// ptr to XOR image bits
    lpAND: LPBYTE; /// ptr to AND image bits
  end;
}
type
  PICONRESOURCE = ^TICONRESOURCE;
  TICONRESOURCE = packed record
    nNumImages: UINT; /// How many images?
    IconImages: array[0..10] of TICONIMAGE; /// Image entries
  end;
{IconHunt
  TICONRESOURCE = packed record
    bHasChanged: BOOL; /// Has image changed?
    szOriginalICOFileName: array[0..MAX_PATH] of char; /// Original name
    szOriginalDLLFileName: array[0..MAX_PATH] of char; /// Original name
    nNumImages: UINT; /// How many images?
    IconImages: array[0..0] of ICONIMAGE; /// Image entries
  end;
}

type
  TPageInfo = packed record
    Width: byte;
    Height: byte;
    ColorQuantity: integer;
    Reserved: DWORD;
    PageSize: DWORD;
    PageOffSet: DWORD;
  end;

type
  TPageDataHeader = packed record
    PageHeadSize: DWORD;
    XSize: DWORD;
    YSize: DWORD;
    SpeDataPerPixSize: integer;
    ColorDataPerPixSize: integer;
    Reserved: DWORD;
    DataAreaSize: DWORD;
    ReservedArray: array[0..15] of char;
  end;

type
  TIcoFileHeader = packed record
    FileFlag: array[0..3] of byte;
    PageQuartity: integer;
    PageInfo: TPageInfo;
  end;

///function WriteIconToFile(Bitmap: hBitmap; Icon: hIcon; szFileName: string): Boolean; overload;
function ExtractIconFromFile(ResFileName: string; IcoFileName: string; nIndex: string): Boolean;
function WriteIconResourceToFile(hFile: hwnd; lpIR: PICONRESOURCE): Boolean;

implementation

function WriteICOHeader(hFile: HWND; nNumEntries: UINT): Boolean;
type
  TFIcoHeader = record
    wReserved: WORD;
    wType: WORD;
    wNumEntries: WORD;
  end;
var
  IcoHeader: TFIcoHeader;
///  Output: WORD;
  dwBytesWritten: DWORD;
begin
  Result := False;
  IcoHeader.wReserved := 0;
  IcoHeader.wType := 1;
  IcoHeader.wNumEntries := WORD(nNumEntries);
  if not WriteFile(hFile, IcoHeader, SizeOf(IcoHeader), dwBytesWritten, nil) then
  begin
    MessageBox(0, pchar(SysErrorMessage(GetLastError)), 'info', MB_OK);
    exit;
  end;
  if dwBytesWritten <> SizeOf(IcoHeader) then
    exit;
{
  Output := 0;
  /// Write 'reserved' WORD
  if not WriteFile(hFile, Output, SizeOf(WORD), dwBytesWritten, nil) then
    exit;
  /// Did we write a WORD?
  if dwBytesWritten <> SizeOf(WORD) then exit;
  /// Write 'type' WORD (1)
  Output := 1;
  if not WriteFile(hFile, Output, SizeOf(WORD), dwBytesWritten, nil) then
    exit;
  if dwBytesWritten <> SizeOf(WORD) then exit;
  /// Write Number of Entries
  Output := WORD(nNumEntries);
  if not WriteFile(hFile, Output, SizeOf(WORD), dwBytesWritten, nil) then
    exit;
  if dwBytesWritten <> SizeOf(WORD) then exit;
 }
  Result := True;
end;

function CalculateImageOffset(lpIR: PICONRESOURCE; nIndex: UINT): DWORD;
var
  dwSize: DWORD;
  i: integer;
begin
    /// Calculate the ICO header size
  dwSize := 3 * sizeof(WORD);
    /// Add the ICONDIRENTRY's
  inc(dwSize, lpIR.nNumImages * sizeof(TICONDIRENTRY));
    /// Add the sizes of the previous images
  for i := 0 to nIndex - 1 do
    inc(dwSize, lpIR.IconImages[i].dwNumBytes);
    /// we're there - return the number
  Result := dwSize;
end;

function WriteIconResourceToFile(hFile: hwnd; lpIR: PICONRESOURCE): Boolean;
var
  i: UINT;
  dwBytesWritten: DWORD;
  ide: TICONDIRENTRY;
  dwTemp: DWORD;
begin
    /// open the file
  Result := False;
    /// Write the ICONDIRENTRY's
  for i := 0 to lpIR^.nNumImages - 1 do
  begin
    /// Convert internal format to ICONDIRENTRY
    ide.bWidth := lpIR^.IconImages[i].Width;
    ide.bHeight := lpIR^.IconImages[i].Height;
    ide.bReserved := 0;
    ide.wPlanes := lpIR^.IconImages[i].pBmpInfo.bmiHeader.biPlanes;
    ide.wBitCount := lpIR^.IconImages[i].pBmpInfo.bmiHeader.biBitCount;
    if ide.wPlanes * ide.wBitCount >= 8 then
      ide.bColorCount := 0
    else
      ide.bColorCount := 1 shl (ide.wPlanes * ide.wBitCount);
    ide.dwBytesInRes := lpIR^.IconImages[i].dwNumBytes;
    ide.dwImageOffset := CalculateImageOffset(lpIR, i);
        /// Write the ICONDIRENTRY out to disk
    if not WriteFile(hFile, ide, sizeof(TICONDIRENTRY), dwBytesWritten, nil) then
      exit;
        /// Did we write a full ICONDIRENTRY ?
    if dwBytesWritten <> sizeof(TICONDIRENTRY) then
      exit;
  end;
    /// Write the image bits for each image
  for i := 0 to lpIR^.nNumImages - 1 do
  begin
    dwTemp := lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage;
        /// Set the sizeimage member to zero
    lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage := 0;
        /// Write the image bits to file
    if not WriteFile(hFile, lpIR^.IconImages[i].lpBits^, lpIR^.IconImages[i].dwNumBytes, dwBytesWritten, nil) then
      exit;
    if dwBytesWritten <> lpIR^.IconImages[i].dwNumBytes then
      exit;
        /// set it back
    lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage := dwTemp;
  end;
  Result := True;
end;

function AWriteIconToFile(bitmap: hBitmap; Icon: hIcon; szFileName: string): Boolean;
var
  fh: file of byte;
  IconInfo: _ICONINFO;
  PageInfo: TPageInfo;
  PageDataHeader: TPageDataHeader;
  IcoFileHeader: TIcoFileHeader;
  BitsInfo: tagBITMAPINFO;
  p: pointer;
  PageDataSize: integer;
begin
  Result := False;
  GetIconInfo(Icon, IconInfo);
  AssignFile(fh, szFileName);
  FileMode := 1;
  Reset(fh);

  GetDIBits(0, Icon, 0, 32, nil, BitsInfo, DIB_PAL_COLORS);
  GetDIBits(0, Icon, 0, 32, p, BitsInfo, DIB_PAL_COLORS);
  PageDataSize := SizeOf(PageDataHeader) + BitsInfo.bmiHeader.biBitCount;

  PageInfo.Width := 32;
  PageInfo.Height := 32;
  PageInfo.ColorQuantity := 65535;
  Pageinfo.Reserved := 0;
  PageInfo.PageSize := PageDataSize;
  PageInfo.PageOffSet := SizeOf(IcoFileHeader);

  IcoFileHeader.FileFlag[0] := 0;
  IcoFileHeader.FileFlag[1] := 0;
  IcoFileHeader.FileFlag[2] := 1;
  IcoFileHeader.FileFlag[3] := 0;
  IcoFileHeader.PageQuartity := 1;
  IcoFileHeader.PageInfo := PageInfo;

  FillChar(PageDataHeader, SizeOf(PageDataHeader), 0);
  PageDataHeader.XSize := 32;
  PageDataHeader.YSize := 32;
  PageDataHeader.SpeDataPerPixSize := 0;
  PageDataHeader.ColorDataPerPixSize := 32;
  PageDataHeader.PageHeadSize := SizeOf(PageDataHeader);
  PageDataHeader.Reserved := 0;
  PageDataHeader.DataAreaSize := BitsInfo.bmiHeader.biBitCount;

  BlockWrite(fh, IcoFileHeader, SizeOf(IcoFileHeader));
  BlockWrite(fh, PageDataHeader, SizeOf(PageDataHeader));
  BlockWrite(fh, p, BitsInfo.bmiHeader.biBitCount);
  CloseFile(fh);
end;

function AdjustIconImagePointers(lpImage: PICONIMAGE): Bool;
begin
  if lpImage = nil then
  begin
    Result := False;
    exit;
  end;
  lpImage.pBmpInfo := PBitMapInfo(lpImage^.lpBits);
  lpImage.Width := lpImage^.pBmpInfo^.bmiHeader.biWidth;
  lpImage.Height := (lpImage^.pBmpInfo^.bmiHeader.biHeight) div 2;
  lpImage.Colors := lpImage^.pBmpInfo^.bmiHeader.biPlanes * lpImage^.pBmpInfo^.bmiHeader.biBitCount;
  Result := true;
end;

function ExtractIconFromFile(ResFileName: string; IcoFileName: string; nIndex: string): Boolean;
var
  h: HMODULE;
  lpMemIcon: PMEMICONDIR;
  lpIR: TICONRESOURCE;
  src: HRSRC;
  Global: HGLOBAL;
  i: integer;
  hFile: hwnd;
begin
  Result := False;
  hFile := CreateFile(pchar(IcoFileName), GENERIC_WRITE, 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
  if hFile = INVALID_HANDLE_VALUE then exit; ///Error Create File
  h := LoadLibraryEx(pchar(ResFileName), 0, LOAD_LIBRARY_AS_DATAFILE);
  if h = 0 then exit;
  try
    src := FindResource(h, pchar(nIndex), RT_GROUP_ICON);
    if src = 0 then
      Src := FindResource(h, Pointer(StrToInt(nIndex)), RT_GROUP_ICON);
    if src <> 0 then
    begin
      Global := LoadResource(h, src);
      if Global <> 0 then
      begin
        lpMemIcon := LockResource(Global);
        if Global <> 0 then
        begin
///          lpIR := @IR;
          try
            lpIR.nNumImages := lpMemIcon.idCount;
              /// Write the header
            for i := 0 to lpMemIcon^.idCount - 1 do
            begin
              src := FindResource(h, MakeIntResource(lpMemIcon^.idEntries[i].nID), RT_ICON);
              if src <> 0 then
              begin
                Global := LoadResource(h, src);
                if Global <> 0 then
                begin
                  lpIR.IconImages[i].dwNumBytes := SizeofResource(h, src);
                  GetMem(lpIR.IconImages[i].lpBits, lpIR.IconImages[i].dwNumBytes);
                  CopyMemory(lpIR.IconImages[i].lpBits, LockResource(Global), lpIR.IconImages[i].dwNumBytes);
                  if not AdjustIconImagePointers(@(lpIR.IconImages[i])) then exit;
                end;
              end;
            end;
            if WriteICOHeader(hFile, lpIR.nNumImages) then ///No Error Write File
              if WriteIconResourceToFile(hFile, @lpIR) then
                Result := True;
          finally
            for i := 0 to lpIR.nNumImages - 1 do
              if assigned(lpIR.IconImages[i].lpBits) then
                FreeMem(lpIR.IconImages[i].lpBits);
          end;
        end;
      end;
    end;
  finally
    FreeLibrary(h);
  end;
  CloseHandle(hFile);
end;
end.  

*********************************************************************

#include <windows.h>

#pragma argsused
int WINAPI DllEntryPoint(HINSTANCE hinst,unsigned long reason, void* lpReserved)
{
return 1;
}

struct TCursorOrIcon
{
WORD Reserved;
WORD wType;
WORD Count;
};

struct TIconRec
{
BYTE Width;
BYTE Height;
WORD Colors;
WORD Reserved1;
WORD Reserved2;
long DIBSize;
long DIBOffset;
};

static void InitBmpInfoHeader(HBITMAP Bitmap,BITMAPINFOHEADER& BI, int nBit)
{
int Bytes;
DIBSECTION DS;

DS.dsBmih.biSize = 0;
Bytes = GetObject(Bitmap, sizeof(DS), &DS);
if (Bytes>=sizeof(DS.dsBm)+sizeof(DS.dsBmih) && DS.dsBmih.biSize>=sizeof(DS.dsBmih))
memcpy(&BI, &DS.dsBmih, sizeof(BITMAPINFOHEADER));
else {
memset(&BI, 0, sizeof(BI));
BI.biSize = sizeof(BI);
BI.biWidth = DS.dsBm.bmWidth;
BI.biHeight = DS.dsBm.bmHeight;
BI.biBitCount = DS.dsBm.bmPlanes
* DS.dsBm.bmBitsPixel;
}
if (nBit!=0) BI.biBitCount = nBit;
if (BI.biBitCount <= 8)
BI.biClrUsed = 1<<BI.biBitCount;
BI.biPlanes = 1;
if (BI.biClrImportant > BI.biClrUsed)
BI.biClrImportant = BI.biClrUsed;
if (BI.biSizeImage == 0)
BI.biSizeImage = ((BI.biWidth*BI.biBitCount+31) / 32) * 4 * BI.biHeight;
}

static void GetDIBSizes(HBITMAP Bitmap,DWORD& InfoSize, DWORD& ImageSize,int nBit)
{
BITMAPINFOHEADER BI;

InitBmpInfoHeader(Bitmap, BI, nBit);
InfoSize = sizeof(BITMAPINFOHEADER);
if (BI.biBitCount > 8) {
if (BI.biCompression&BI_BITFIELDS)
InfoSize += 12;
}
else
InfoSize += sizeof(RGBQUAD) * (BI.biClrUsed!=0 ? BI.biClrUsed :(1 << BI.biBitCount));
ImageSize = BI.biSizeImage;
}

static void GetDIB(HBITMAP Bitmap,BITMAPINFO* BmpInfo, void* Bits, int nBit)
{
HDC DC;
DC = CreateCompatibleDC(NULL);
InitBmpInfoHeader(Bitmap, BmpInfo->bmiHeader, nBit);
GetDIBits(DC, Bitmap, 0, BmpInfo->bmiHeader.biHeight, Bits,BmpInfo, DIB_RGB_COLORS);
DeleteDC(DC);
}

extern "C" __declspec(dllexport) BOOL _stdcall SaveIcon(HICON Icon, LPCSTR FileName, int nBit)
{
BOOL ret;
UINT nColor;
long Length;
void *MonoBits;
void *ColorBits;
DWORD dwWrite;
HANDLE hFile;
TIconRec List;
ICONINFO IconInfo;
TCursorOrIcon CI;
DWORD MonoInfoSize;
DWORD ColorInfoSize;
DWORD MonoBitsSize;
DWORD ColorBitsSize;
BITMAPINFO *MonoInfo;
BITMAPINFO *ColorInfo;

switch(nBit) {
case 0:
case 1:
case 4:
case 8:
case 16:
case 24:
case 32: break;
default: return FALSE;
}
if (Icon==NULL || !FileName)
return FALSE;

hFile = CreateFile(FileName,GENERIC_WRITE, FILE_SHARE_READ,0, CREATE_ALWAYS, 0, 0);
if (hFile==INVALID_HANDLE_VALUE)
return false;
memset(&CI, 0, sizeof(CI));
memset(&List, 0, sizeof(List));
GetIconInfo(Icon, &IconInfo);

GetDIBSizes(IconInfo.hbmMask, MonoInfoSize, MonoBitsSize, 1);
GetDIBSizes(IconInfo.hbmColor,ColorInfoSize, ColorBitsSize, nBit);
MonoInfo = (BITMAPINFO*)malloc(MonoInfoSize);
ColorInfo = (BITMAPINFO*)malloc(ColorInfoSize);
MonoBits = malloc(MonoBitsSize);
ColorBits = malloc(ColorBitsSize);
GetDIB(IconInfo.hbmMask, MonoInfo,MonoBits, 1);
GetDIB(IconInfo.hbmColor, ColorInfo,ColorBits, nBit);
CI.wType = 0x10001; CI.Count = 1;
ret &= WriteFile(hFile, &CI, sizeof(CI),&dwWrite, NULL);
List.Width = ColorInfo->bmiHeader.biWidth;
List.Height = ColorInfo->bmiHeader.biHeight;
List.Colors = ColorInfo->bmiHeader.biPlanes * ColorInfo->bmiHeader.biBitCount;
List.DIBSize = ColorInfoSize + ColorBitsSize + MonoBitsSize;
List.DIBOffset = sizeof(CI) + sizeof(List);
ret &= WriteFile(hFile, &List, sizeof(List), &dwWrite, NULL);
ColorInfo->bmiHeader.biHeight *= 2;
ret &= WriteFile(hFile, ColorInfo,ColorInfoSize, &dwWrite, NULL);
ret &= WriteFile(hFile, ColorBits,ColorBitsSize, &dwWrite, NULL);
ret &= WriteFile(hFile, MonoBits,MonoBitsSize, &dwWrite, NULL);
free(ColorInfo);
free(MonoInfo);
free(ColorBits);
free(MonoBits);
DeleteObject(IconInfo.hbmColor);
DeleteObject(IconInfo.hbmMask);

CloseHandle(hFile); return ret;
}

*********************************************************************

HCURSOR hcur = GetCursor();  
if(hcur==NULL) return;  
  ICONINFO     icon;  
  ::GetIconInfo(hcur,&icon);  
  HBITMAP   hbmp;  
  BITMAP   bm;  
  ::GetObject(icon.hbmMask,sizeof(BITMAP),&bm);  
   
  HDC hGlobal,hDCMask,hDCColor;  
  hGlobal  =   ::GetDC(NULL);  
  hDCMask  =   ::CreateCompatibleDC(hGlobal);  
  hDCColor =   ::CreateCompatibleDC(hGlobal);  
  hbmp     =   ::CreateCompatibleBitmap(hGlobal,bm.bmWidth,bm.bmWidth);  
  ::SelectObject(hDCColor,hbmp);  
   
  ::FloodFill(hDCColor,0,0,RGB(255,255,255));//back color  
  ::SelectObject(hDCMask,icon.hbmMask);  
  ::BitBlt(hDCColor,0,0,bm.bmWidth,bm.bmWidth,hDCMask,0,0,SRCAND);  
  if   (icon.hbmColor   ==   NULL)  
  ::BitBlt(hDCColor,0,0,bm.bmWidth,bm.bmWidth,hDCMask,0,bm.bmWidth,SRCINVERT);  
  else  
  {  
  ::SelectObject(hDCMask,icon.hbmColor);  
  ::BitBlt(hDCColor,0,0,bm.bmWidth,bm.bmWidth,hDCMask,0,0,SRCINVERT);  
  }  
   
  PICTDESC   picdesc;  
  picdesc.cbSizeofstruct   =   sizeof(PICTDESC);  
  picdesc.picType   =   PICTYPE_BITMAP   ;                          
  picdesc.bmp.hbitmap   =   hbmp;  
  IPicture*   pPicture=NULL;  
  OleCreatePictureIndirect(&picdesc,   IID_IPicture,   TRUE,(VOID**)&pPicture);  
  LPSTREAM   pStream;  
  CreateStreamOnHGlobal(NULL,TRUE,&pStream);  
  LONG   size;  
  HRESULT hr=pPicture->SaveAsFile(pStream,TRUE,&size);  
  char   pathbuf[1024];  
  strcpy(pathbuf,"c:\\myarrow.bmp");  
   
  FILE   *stream;  
  stream   =   fopen(   pathbuf,   "w"   );  
  LARGE_INTEGER   li;  
  li.HighPart   =0;  
  li.LowPart   =0;  
  ULARGE_INTEGER   ulnewpos;  
  pStream->Seek(   li,STREAM_SEEK_SET,&ulnewpos);  
  ULONG   uReadCount   =   1;  
  while(uReadCount>0)  
  {  
   
  pStream->Read(pathbuf,sizeof(pathbuf),&uReadCount);  
  if(uReadCount>0)  
  fwrite(   pathbuf,sizeof(char),uReadCount,stream);  
  }  
  pStream->Release();  
  fclose(   stream   );  
   
  ::DeleteObject(icon.hbmMask);  
  if   (icon.hbmColor   !=   NULL)  
  ::DeleteObject(icon.hbmColor);  
  ::DeleteObject(hbmp);  
  ::ReleaseDC(NULL,hDCMask);  
  ::ReleaseDC(NULL,hDCColor);  
  ::ReleaseDC(NULL,hGlobal);

*********************************************************************