Category : Pascal Source Code
Archive   : TPWUTILS.ZIP
Filename : ICONFILE.PAS

 
Output of file : ICONFILE.PAS contained in archive : TPWUTILS.ZIP
{************************************************}
{ }
{ Turbo Pascal for Windows }
{ Icon file loader unit }
{ Copyright (c) 1991 by Borland International }
{ }
{ by Dave Scofield and Danny Thorpe }
{************************************************}


Unit ICONFile;

interface

Uses WinTypes;

{ Basic Icon Loader }

function LoadIconFile( FileName:PChar ): HIcon;

{ LoadIconFile reads an ICO icon file, loads the *FIRST* bitmap set in the file,
and creates an icon out of that bitmap set. Note that ICO files can contain
multiple bitmap sets targeted to different screen resolutions and color
capabilities. This function only reads the first such bitmap set and does
not attempt to match the icon file bitmaps to the display device capabilities.

Returns: A valid Icon handle if successful.
Zero if the file is not in ICO file format, or an error occured. }



{ Extended Icon Loader }

procedure LoadIconFileBitmaps( FileName: PChar;
var ColorBitmap, MonoBitmap: HBitmap;
var BitInfo: TBitmap);

{ Input: Filename of an ICO format file.

Output: An XOR color bitmap handle,
an AND monochrome bitmap handle,
and a TBitmap info record

If the file is not an ICO format or an error occurs, zeros are returned
for all handles and the function result.

This procedure works like LoadIconFile, but returns the color and monochrome
bitmaps of the icon image. Normally, all you have is an icon handle, and you
can't access the bitmaps inside that icon. This function gives you those
bitmaps from the ICO file.

The BitInfo record contains the pixel width, height, color planes, and other
information about the color bitmap. The mono bitmap has the same pixel width
and height.}



implementation

uses WinProcs;

function LoadIconFile(FileName: PChar): HIcon;
var ColorBitmap, MonoBitmap: HBitmap;
BitInfo : TBitmap;
DeviceBitsSize: word;
lpXORBits, lpANDBits: pointer;
begin
LoadIconFile := 0;
LoadIconFileBitmaps(Filename, ColorBitmap, MonoBitmap, Bitinfo);

if (ColorBitmap <> 0) and (MonoBitmap <> 0) then
begin
with BitInfo do
DeviceBitsSize := bmWidthBytes * bmHeight * bmPlanes;

{ extract those device dependent pixel bits into our own buffer }
GetMem(lpXORBits, DeviceBitsSize);
GetBitmapBits(ColorBitmap, DeviceBitsSize, lpXORBits);

GetMem(lpANDBits, DeviceBitsSize); { 1) Yes, this is more than a mono bitmap needs. 2) We're lazy. }
GetBitmapBits(MonoBitmap, DeviceBitsSize, lpANDBits);

{ give those device dependent pixel buffers to CreateIcon }
with BitInfo do
LoadIconFile := CreateIcon(hInstance, bmWidth, bmHeight, bmPlanes, bmBitsPixel,
lpANDBits, lpXORBits);
FreeMem(lpXORBits, DeviceBitsSize);
FreeMem(lpANDBits, DeviceBitsSize);

DeleteObject(ColorBitmap);
DeleteObject(MonoBitmap);
end;
end;


procedure LoadIconFileBitmaps(FileName:PChar;
var ColorBitmap, MonoBitmap: HBitmap;
var BitInfo: TBitMap);
type
IconHeaderRec = record
icoReserved : word;
icoResourceType : word;
icoResourceCount : word;
end;
ResourceDirRec = record
Width : byte;
Height : byte;
ColorCount : byte;
Reserved1 : byte;
Reserved2 : longint; { 2 reserved WORDs }
icoDIBSize : longint;
icoDIBOffset : longint;
end;
var
IconFile : File;
I : Integer;
IconHeader : IconHeaderRec;
ResourceDir : ResourceDirRec;
BitmapInfoHeader : TBitmapInfoHeader;
BitmapInfo : PBitmapInfo;
ColorTableSize : longint;
nColors : longint;
MonoBits : PChar;
ColorBits: pointer;
MonoSize : longint;
ColorSize : longint;
DeviceBitsSize: longint;
DC : HDC;
OldFileMode: byte;
begin

{ Set everything to zero in case we hit an error }
ColorBitmap := 0;
MonoBitmap := 0;

OldFileMode := FileMode;
FileMode := 0; { read only mode, for network compatibility }
Assign(IconFile, FileName);
{$I-}
Reset(IconFile,1);
{$I+}
if IOResult <> 0 then Exit;

{ read the icon header }
BlockRead(IconFile, IconHeader, SizeOf(IconHeaderRec));

{ test for valid file type }
with IconHeader do
begin
if (icoReserved<>0) or (icoResourceType<>1) then Exit; { bad file }
end;

{ Read the resource directory. Note that this code supports only 1 }
{ directory in the file, although the specs say there could be }
{ IconHeader.icoResourceCount directories. }

BlockRead(IconFile, ResourceDir, SizeOf(ResourceDirRec));

{ move to the DIB record }
Seek(IconFile, ResourceDir.icoDIBOffset);

{ read the DIB header - first the BitmapInfoHeader }
BlockRead(IconFile, BitmapInfoHeader, SizeOf(TBitmapInfoHeader));

{ calc the size of the color table }
if BitmapInfoHeader.biBitCount <= 8 then { 24 bit images have no color table }
nColors := 1 SHL BitmapInfoHeader.biBitCount
else
nColors := 0;
ColorTableSize := nColors * SizeOf(TRGBQuad);

{ read the entire structure into the BitmapInfo variable }

GetMem(BitmapInfo, SizeOf(TBitmapInfoHeader) + ColorTableSize);
BitmapInfo^.bmiHeader := BitmapInfoheader;
BlockRead(IconFile, BitmapInfo^.bmiColors, ColorTableSize);

with BitmapInfo^.bmiHeader do
begin
MonoSize :=(biWidth * (biHeight div 2)) div 8;
ColorSize :=BitmapInfoHeader.biSizeImage-MonoSize;
end;

{ read the color bitmap }

GetMem(ColorBits, ColorSize);
BlockRead(IconFile, ColorBits^, ColorSize);

{ read the monochrome bitmap }
GetMem(MonoBits, MonoSize);
for i := 31 downto 0 do
BlockRead(IconFile, MonoBits[I*4], 4);
Close(IconFile);

{ create a device dependant bitmap }
with BitmapInfo^.bmiHeader do
begin
biHeight := biHeight div 2; { biHeight is always 2x too big in the ICO file. }

{ Take the device INdependent bits and produce a device DEpendent bitmap for
the screen device context. }
DC := CreateDC('Display', nil, nil, nil);
ColorBitmap := CreateDIBitmap(DC, BitmapInfo^.bmiHeader, CBM_INIT, ColorBits,
BitmapInfo^, dib_RGB_Colors);
DeleteDC(DC);

{ Find out how big the device dependent bitmap we just created is. }
GetObject(ColorBitmap, sizeof(BitInfo), @BitInfo);

{ There's nothing device dependent about a monochrome bitmap. }
MonoBitmap := CreateBitmap(biWidth, biHeight, 1, 1, Monobits);
end;

FreeMem(ColorBits, ColorSize);
Freemem(MonoBits, MonoSize);
FreeMem(BitmapInfo, SizeOf(TBitmapInfoHeader) + ColorTableSize);

FileMode := OldFileMode;
end;

end.


  3 Responses to “Category : Pascal Source Code
Archive   : TPWUTILS.ZIP
Filename : ICONFILE.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/