1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:

unit IconClass;
(*
*
*   this is a
*   XEONLAB DEVELOPMENT FILE
*
*   Language:   Pascal/Delphi
*   Title:      "Unit IconClass"
*   Developer:  Konstantin S. M. Möllers
*   Contact:    http://xeonlab.com
*   Published:  20-01-2010
*
*   Copyright © 2010 xeonlab.
*
*   This file was published under GNU General Public License (GPL).
*
*)
interface

uses
  Classes, PNGImage;

type
  { TIco }
  TIconHeader = record
    BitsPerPix: Word;
    Width, Height: Byte;
    Position: Int64;
  end;
  TIconHeaders = array of TIconHeader;
  TIcoBody = Array of TPNGImage;
  TIco = class
  private
    { Fields }
    FImageCount: Word;
    FImages: TIcoBody;
    FIconHeaders: TIconHeaders;
    { Functions }
    procedure DestroyImages;
    procedure WriteHeader( Str: TStream );
    procedure WriteImageHeader( Id: Integer; Str: TStream );
    procedure WriteImage( Id: Integer; Str: TStream; var Size, Offset: Integer );
    procedure ReadHeaderAndImage( Id: Integer; Str: TStream );
    procedure ReadImage( Id: Integer; Str: TStream; Start: Integer );
    function GetHeader( Index: Integer ): TIconHeader;
    function GetImage( Index: Integer ): TPNGImage;
    procedure SaveImages(Stream: TStream);
  public
    { Constructors / Destructors }
    constructor Create; virtual;
    destructor Destroy; override;
    { Add-Procedures }
    function AddImage( aImage: TPNGImage ): Integer;
    function AddImageRes( const aResName, aResType: String ): Integer;
    { Savers / Loaders }
    procedure SaveToStream( Stream: TStream );
    procedure LoadFromStream( Stream: TStream );
    procedure SaveToFile( const FileN: String );
    procedure LoadFromFile( const FileN: String );
    { Properties }
    property ImgCount: Word read FImageCount;
    property Header[ Index: Integer ]: TIconHeader read GetHeader;
    property Images[ Index: Integer ]: TPNGImage read GetImage;
  end;

implementation

{ TIco }

  { Creates the Class. }
  constructor TIco.Create;
  begin
    // Reset FImages
    SetLength( FImages, 0 );
    // Reset Headers
    SetLength( FIconHeaders, 0 );
    FImageCount := 0;
  end;

  { Detroys the Class. }
  destructor TIco.Destroy;
  begin
    // Detroys all images which are owned by SELF
    DestroyImages;
    inherited Destroy;
  end;

  { Destroys all owned PNGs. }
  procedure TIco.DestroyImages;
  var
    I: Integer;
  begin
    if Length( FImages ) > 0 then
      begin
        for I := 0 to FImageCount - 1 do
          FImages[ I ].Free;
        SetLength( FImages, 0 );
        // Destroy Headers
        SetLength( FIconHeaders, 0 );
      end;
  end;

  { Adds a PNG to SELF. }
  function TIco.AddImage(aImage: TPngImage): Integer;
  var
    L: Integer;
  begin
    // Get new ID, stretch FImages
    L := ImgCount;
    // Set Lengths of Image- and IconHeader-Lists
    SetLength( FImages, L+1 );
    Setlength( FIconHeaders, L+1 );
    Inc( FImageCount );
    // Create new Image
    FImages[L] := TPNGImage.Create;
    FImages[L].Assign( aImage );
    // Set Header
    with FIconHeaders[L] do
      begin
        BitsPerPix := 32;
        Width := 0;
        if FImages[L].Width < 256 then
          Width := FImages[L].Width;
        Height := 0;
        if FImages[L].Height < 256 then
          Height := FImages[L].Height;
      end;
    // Return new ID
    Result := L;
  end;

  { Gets a PNG from FImages. }
  function TIco.GetImage(Index: Integer): TPNGImage;
  begin
    Result := nil;

    // Control parameters
    if Index < 0 then Exit;
    if Index >= FImageCount then Exit;

    // Create new PNGImage
    Result := TPngImage.Create;
    try
      Result.Assign( FImages[ Index ] );
    except
      // Delete if fails
      Result.Free;
    end;
  end;

  { Writes a Header for a PNG on a Stream. }
  procedure TIco.WriteImageHeader( Id: Integer; Str: TStream );
  var
    // Height / Width of PNG
    Buffer: Word;
  begin
    with FIconHeaders[ Id ] do
      begin
        // Write Size on Stream
        Str.Write( Width, 1 );
        Str.Write( Height, 1 );

        // Zeros
        Buffer := 0;
        Str.Write( Buffer, 2 );
        Buffer := 1;
        Str.Write( Buffer, 2 );
        {Str.Write( BitsPerPix, 2 );}
        Buffer := 32;
        Str.Write( Buffer, 2 );

        // Save position
        Position := Str.Position;

        // Writes a free space for information about the image
        Str.Write( Buffer, 8 );
      end;

  end;

  { Writes the image content on a Stream. }
  procedure TIco.WriteImage(Id: Integer; Str: TStream; var Size: Integer; var Offset: Integer);
  begin
    // Return current position
    Offset := Str.Position;
    // Saves the PNG
    FImages[ Id ].SaveToStream( Str );
    // Return used PNG-Size
    Size := Str.Position - Offset;
  end;

  { Writes the header of an ICO-File. }
  procedure TIco.WriteHeader(Str: TStream);
  var
    Buffer: Word;
  begin
    // Reserved
    Buffer := 0;
    Str.Write( Buffer, 2 );
    // ImageType (1 = Icon)
    Buffer := 1;
    Str.Write( Buffer, 2 );
    // Number of Images
    Str.Write( FImageCount, 2 );
  end;

  { Writes Icon on Stream. }
  procedure TIco.SaveToStream(Stream: TStream);
  var
    I: Integer;
  begin
    // Check if Stream exists
    if not assigned( Stream ) then
      Exit;

    // Write the header
    WriteHeader( Stream );

    // Write Image-headers
    for I := 0 to FImageCount - 1 do
      WriteImageHeader( I, Stream );

    // Save PNG-Images on the Stream
    SaveImages( Stream );
  end;

  { Saves the Icon in a File. }
  procedure TIco.SaveToFile(const FileN: string);
  var
    Fs: TFileStream;
  begin
    // Create a FileStream
    Fs := TFileStream.Create( FileN, fmCreate );
    try
      // Save
      SaveToStream( Fs );
    finally
      Fs.Free;
    end;
  end;

  { Returns the HeaderTag for an icon. }
  function TIco.GetHeader(Index: Integer): TIconHeader;
  begin
    // Control parameters
    if Index < 0 then Exit;
    if Index >= FImageCount then Exit;
    // Get Header
    Result := FIconHeaders[ Index ];
  end;

  { Loads an Icon from a Stream. }
  procedure TIco.LoadFromStream(Stream: TStream);
  var
    I: Integer;
  begin
    // Read Image count
    Stream.Position := 4;
    Stream.Read( FImageCount, 2 );
    // Set lengths
    DestroyImages;
    SetLength( FImages, FImageCount );
    SetLength( FIconheaders, FImageCount );
    // Read information
    for I := 0 to FImageCount - 1 do
      ReadHeaderAndImage( I, Stream );
  end;

  { Loads an Icon from a File. }
  procedure TIco.LoadFromFile(const FileN: string);
  var
    Fs: TFileStream;
  begin
    // Create a FileStream
    Fs := TFileStream.Create( FileN, $0000 );
    try
      // Load
      LoadFromStream( Fs );
    finally
      Fs.Free;
    end;
  end;

  { Saves the PNGs on a Stream. }
  procedure TIco.SaveImages(Stream: TStream);
  var
    CurPos: Int64;
    Size,
    I,
    Offset: Integer;
  begin
    for I := 0 to FImageCount - 1 do
      begin
        // Write the Image
        WriteImage(I, Stream, Size, Offset);
        // Save Position
        CurPos := Stream.Position;
        // Update ImageHeader
        Stream.Position := FIconHeaders[I].Position;
        Stream.Write(Size, 4);
        Stream.Write(Offset, 4);
        // Load old Position
        Stream.Position := CurPos;
      end;
  end;

  { Reads Header and Image from Stream. }
  procedure TIco.ReadHeaderAndImage(Id: Integer; Str: TStream);
  var
    Start: Integer;
  begin
    with FIconHeaders[Id] do
      begin
        // Read Header information
        Str.Read( Width, 1 );
        Str.Read( Height, 1 );
        Str.Position := Str.Position + 4;
        Str.Read( BitsPerPix, 2 );
        Str.Position := Str.Position + 4;
        Str.Read( Start, 4 );
        // Load the image
        ReadImage( Id, Str, Start );
      end;
  end;

  { Read the PNG Image from a Stream. }
  procedure TIco.ReadImage(Id: Integer; Str: TStream; Start: Integer);
  var
    CurPos: Int64;
  begin
    // Save Position
    CurPos := Str.Position;
    Str.Position := Start;
    // Create the PNG
    FImages[ Id ] := TPNGImage.Create;
    FImages[ Id ].LoadFromStream( Str );
    // Load old Position
    Str.Position := CurPos;
  end;

  { Adds an image from the Resource. }
  function TIco.AddImageRes(const aResName: string; const aResType: string): Integer;
  var
    RC: TResourceStream;
    PNG: TPNGImage;
  begin
    // Create a Resource Stream
    RC := TResourceStream.Create( HInstance, aResName, PChar( aResType ) );
    try
      // Create a PNG
      PNG := TPngImage.Create;
      try
        // Load from Stream
        PNG.LoadFromStream( RC );
        Result := AddImage( PNG );
      finally
        PNG.Free;
      end;
    finally
      RC.Free;
    end;
  end;

{ End Of TIco }

end.