source: trunk/Packages/bgrabitmap/bgraiconcursor.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 23.2 KB
Line 
1unit BGRAIconCursor;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, BGRAMultiFileType, BGRABitmapTypes;
9
10type
11 { TBGRAIconCursorEntry }
12
13 TBGRAIconCursorEntry = class(TMultiFileEntry)
14 protected
15 FWidth,FHeight,FBitDepth: integer;
16 FExtension: string;
17 FContent: TStream;
18 FHotSpot: TPoint;
19 function GetName: utf8string; override;
20 procedure SetName({%H-}AValue: utf8string); override;
21 function GetExtension: utf8string; override;
22 function GetFileSize: int64; override;
23 public
24 constructor Create(AContainer: TMultiFileContainer; AExtension: string; AInfo: TQuickImageInfo; AContent: TStream);
25 class function TryCreate(AContainer: TMultiFileContainer; AContent: TStream): TBGRAIconCursorEntry;
26 destructor Destroy; override;
27 function CopyTo(ADestination: TStream): int64; override;
28 function GetBitmap: TBGRACustomBitmap;
29 property Width: integer read FWidth;
30 property Height: integer read FHeight;
31 property BitDepth: integer read FBitDepth;
32 property HotSpot: TPoint read FHotSpot write FHotSpot;
33 end;
34
35 { TBGRAIconCursor }
36
37 TBGRAIconCursor = class(TMultiFileContainer)
38 private
39 function GetBitDepthAt(AIndex: integer): integer;
40 function GetHeightAt(AIndex: integer): integer;
41 function GetHotSpotAtAt(AIndex: integer): TPoint;
42 function GetWidthAt(AIndex: integer): integer;
43 procedure SetFileType(AValue: TBGRAImageFormat);
44 procedure SetHotSpotAt(AIndex: integer; AValue: TPoint);
45 protected
46 FFileType : TBGRAImageFormat;
47 FLoading : boolean;
48 function CreateEntry(AName: utf8string; AExtension: utf8string;
49 AContent: TStream): TMultiFileEntry; override;
50 function ExpectedMagic: Word;
51 procedure Init; override;
52 public
53 constructor Create(AFileType: TBGRAImageFormat); overload;
54 function Add(ABitmap: TBGRACustomBitmap; ABitDepth: integer; AOverwrite: boolean = false): integer; overload;
55 function Add(AContent: TStream; AOverwrite: boolean = false; AOwnStream: boolean = true): integer; overload;
56 procedure LoadFromStream(AStream: TStream); override;
57 procedure SaveToStream(ADestination: TStream); override;
58 function GetBitmap(AIndex: integer): TBGRACustomBitmap;
59 function GetBestFitBitmap(AWidth,AHeight: integer): TBGRACustomBitmap;
60 function IndexOf(AWidth,AHeight,ABitDepth: integer): integer; overload;
61 property FileType: TBGRAImageFormat read FFileType write SetFileType;
62 property Width[AIndex: integer]: integer read GetWidthAt;
63 property Height[AIndex: integer]: integer read GetHeightAt;
64 property BitDepth[AIndex: integer]: integer read GetBitDepthAt;
65 property HotSpot[AIndex: integer]: TPoint read GetHotSpotAtAt write SetHotSpotAt;
66 end;
67
68function BGRADitherIconCursor(ABitmap: TBGRACustomBitmap; ABitDepth: integer; ADithering: TDitheringAlgorithm): TBGRACustomBitmap;
69
70implementation
71
72uses BGRAWinResource, BGRAUTF8, BGRAReadPng, BGRAReadBMP, FPWriteBMP, BGRAPalette, BGRAWritePNG,
73 BGRAColorQuantization;
74
75function BGRADitherIconCursor(ABitmap: TBGRACustomBitmap; ABitDepth: integer;
76 ADithering: TDitheringAlgorithm): TBGRACustomBitmap;
77var
78 frameMask, temp: TBGRACustomBitmap;
79 quantizer: TBGRAColorQuantizer;
80 maskQuantizer: TBGRAColorQuantizer;
81
82 x,y: integer;
83 psrc,pdest: PBGRAPixel;
84begin
85 if ABitDepth <= 0 then
86 raise exception.Create('Invalid bit depth');
87
88 if ABitDepth <= 24 then
89 begin
90 if ABitDepth = 1 then
91 begin
92 quantizer := TBGRAColorQuantizer.Create([BGRABlack,BGRAWhite,BGRAPixelTransparent],false,3);
93 result := quantizer.GetDitheredBitmap(ADithering, ABitmap);
94 quantizer.Free;
95 end
96 else
97 begin
98 frameMask := ABitmap.GetMaskFromAlpha;
99 maskQuantizer := TBGRAColorQuantizer.Create([BGRABlack,BGRAWhite],false,2);
100 temp := maskQuantizer.GetDitheredBitmap(ADithering, frameMask);
101 frameMask.Free;
102 frameMask := temp;
103 maskQuantizer.Free;
104
105 result := ABitmap.Duplicate;
106 result.ReplaceTransparent(BGRABlack);
107 result.AlphaFill(255);
108
109 if ABitDepth <= 8 then
110 begin
111 quantizer := TBGRAColorQuantizer.Create(result,acFullChannelInPalette, 1 shl ABitDepth);
112 temp := quantizer.GetDitheredBitmap(daFloydSteinberg, result);
113 result.free;
114 result := temp;
115 quantizer.Free;
116 end;
117
118 result.ApplyMask(frameMask);
119 frameMask.Free;
120 end;
121 end else
122 result := ABitmap.Duplicate;
123
124 if Assigned(ABitmap.XorMask) then
125 begin
126 result.NeedXorMask;
127 for y := 0 to ABitmap.XorMask.Height-1 do
128 begin
129 psrc := ABitmap.XorMask.ScanLine[y];
130 pdest := result.XorMask.ScanLine[y];
131 for x := 0 to ABitmap.XorMask.Width-1 do
132 begin
133 if ((psrc^.red shl 1)+(psrc^.green shl 2)+psrc^.blue >= 128*(1+2+4)) then
134 pdest^ := BGRA(255,255,255,0);
135 inc(psrc);
136 inc(pdest);
137 end;
138 end;
139 end;
140end;
141
142{ TBGRAIconCursorEntry }
143
144constructor TBGRAIconCursorEntry.Create(AContainer: TMultiFileContainer; AExtension: string; AInfo: TQuickImageInfo;
145 AContent: TStream);
146begin
147 inherited Create(AContainer);
148 FExtension:= AExtension;
149 FWidth := AInfo.Width;
150 FHeight:= AInfo.Height;
151
152 // 16 bit per channel is not relevant for icon depth
153 if AInfo.ColorDepth >= 24 then
154 begin
155 if AInfo.AlphaDepth >= 8 then
156 FBitDepth := 32
157 else
158 FBitDepth := 24;
159 end else
160 FBitDepth := AInfo.ColorDepth;
161
162 FContent := AContent;
163end;
164
165class function TBGRAIconCursorEntry.TryCreate(
166 AContainer: TMultiFileContainer; AContent: TStream): TBGRAIconCursorEntry;
167var
168 format: TBGRAImageFormat;
169 imageInfo: TQuickImageInfo;
170 tempStream: TMemoryStream;
171 reader: TBGRAImageReader;
172 bmp: TBGRACustomBitmap;
173 maskLine: packed array of byte;
174 maskStride: integer;
175 psrc: PBGRAPixel;
176 maskBit: byte;
177 maskPos,x,y: integer;
178 headerSize, dataSize: integer;
179begin
180 AContent.Position:= 0;
181 format := DetectFileFormat(AContent);
182 case format of
183 ifBmp:
184 begin
185 reader := TBGRAReaderBMP.Create;
186 bmp := BGRABitmapFactory.Create;
187 try
188 AContent.Position := 0;
189 imageInfo := reader.GetQuickInfo(AContent);
190 if (imageInfo.width <= 0) or (imageInfo.height <= 0) or
191 (imageInfo.width > 256) or (imageInfo.height > 256) then
192 raise exception.Create('Invalid image size');
193 AContent.Position := 0;
194 //load bitmap to build mask
195 bmp.LoadFromStream(AContent);
196 maskStride := ((bmp.Width+31) div 32)*4;
197
198 tempStream := TMemoryStream.Create;
199 //BMP header is not stored in icon/cursor
200 AContent.Position:= sizeof(TBitMapFileHeader);
201 tempStream.CopyFrom(AContent, AContent.Size - sizeof(TBitMapFileHeader));
202 AContent.Free;
203
204 //fix height
205 tempStream.Position := 0;
206 headerSize := LEtoN(tempStream.ReadDWord);
207 if headerSize = sizeof(TOS2BitmapHeader) then // OS/2 1.x
208 begin
209 tempStream.Position := 6;
210 tempStream.WriteWord(NtoLE(word(bmp.Height*2))); //include mask size
211 end else
212 begin
213 tempStream.Position := 8;
214 tempStream.WriteDWord(NtoLE(dword(bmp.Height*2))); //include mask size
215 if headerSize >= 20+4 then
216 begin
217 tempStream.Position:= 20;
218 dataSize := LEtoN(tempStream.ReadDWord);
219 if dataSize <> 0 then
220 begin //if data size is supplied, include mask size
221 dataSize += maskStride*bmp.Height;
222 tempStream.Position:= 20;
223 tempStream.WriteDWord(NtoLE(dataSize));
224 end;
225 end;
226 end;
227
228 //build mask
229 tempStream.Position := tempStream.Size;
230 setlength(maskLine, maskStride);
231 for y := bmp.Height-1 downto 0 do
232 begin
233 maskBit := $80;
234 maskPos := 0;
235 psrc := bmp.ScanLine[y];
236 fillchar(maskLine[0], length(maskLine), 0);
237 for x := 0 to bmp.Width-1 do
238 begin
239 if psrc^.alpha = 0 then
240 maskLine[maskPos] := maskLine[maskPos] or maskBit;
241 maskBit := maskBit shr 1;
242 if maskBit = 0 then
243 begin
244 maskBit := $80;
245 maskPos += 1;
246 end;
247 inc(psrc);
248 end;
249 tempStream.WriteBuffer(maskLine[0], length(maskLine));
250 end;
251
252 result := TBGRAIconCursorEntry.Create(AContainer, 'dib', imageInfo, tempStream);
253 finally
254 bmp.Free;
255 reader.Free;
256 end;
257 end;
258 ifPng:
259 begin
260 reader := TBGRAReaderPNG.Create;
261 imageInfo := reader.GetQuickInfo(AContent);
262 reader.Free;
263 result := TBGRAIconCursorEntry.Create(AContainer, 'png', imageInfo, AContent);
264
265 end;
266 ifUnknown, ifLazPaint {a headerless bmp can be confused for a headerless lzp}:
267 begin
268 //assume headerless BMP
269 AContent.Position := 0;
270 reader := TBGRAReaderBMP.Create;
271 imageInfo := reader.GetQuickInfo(AContent);
272 imageInfo.Height:= imageInfo.Height div 2; //mask size is included
273 reader.Free;
274 if (imageInfo.width <= 0) or (imageInfo.height <= 0) or
275 (imageInfo.width > 256) or (imageInfo.height > 256) then
276 raise exception.Create('Invalid image size');
277 result := TBGRAIconCursorEntry.Create(AContainer, 'dib', imageInfo, AContent);
278 end;
279 else
280 raise exception.Create(SuggestImageExtension(format) + ' format is not handled');
281 end;
282end;
283
284destructor TBGRAIconCursorEntry.Destroy;
285begin
286 FContent.Free;
287 inherited Destroy;
288end;
289
290function TBGRAIconCursorEntry.CopyTo(ADestination: TStream): int64;
291begin
292 if FContent.Size = 0 then
293 begin
294 result := 0;
295 exit;
296 end;
297
298 FContent.Position := 0;
299 result := ADestination.CopyFrom(FContent, FContent.Size);
300end;
301
302function TBGRAIconCursorEntry.GetBitmap: TBGRACustomBitmap;
303var reader: TBGRAImageReader;
304begin
305 if Extension = 'dib' then
306 begin
307 reader := TBGRAReaderBMP.Create;
308 TBGRAReaderBMP(reader).Subformat := bsfHeaderlessWithMask;
309 end else
310 reader := TBGRAReaderPNG.create;
311
312 result := BGRABitmapFactory.Create;
313 FContent.Position := 0;
314 try
315 result.LoadFromStream(FContent, reader);
316 except on ex: Exception do
317 begin
318 result.Free;
319 reader.Free;
320 raise ex;
321 end;
322 end;
323 reader.Free;
324
325 result.HotSpot := HotSpot;
326end;
327
328function TBGRAIconCursorEntry.GetName: utf8string;
329begin
330 result := IntToStr(FWidth)+'x'+IntToStr(FHeight)+'x'+IntToStr(FBitDepth);
331end;
332
333procedure TBGRAIconCursorEntry.SetName(AValue: utf8string);
334begin
335 raise exception.Create('Name cannot be changed');
336end;
337
338function TBGRAIconCursorEntry.GetExtension: utf8string;
339begin
340 result := FExtension;
341end;
342
343function TBGRAIconCursorEntry.GetFileSize: int64;
344begin
345 result := FContent.Size;
346end;
347
348{ TBGRAIconCursor }
349
350function TBGRAIconCursor.GetBitDepthAt(AIndex: integer): integer;
351begin
352 if (AIndex < 0) or (AIndex >= Count) then raise ERangeError.Create('Index out of bounds');
353 result := TBGRAIconCursorEntry(Entry[AIndex]).BitDepth;
354end;
355
356function TBGRAIconCursor.GetHeightAt(AIndex: integer): integer;
357begin
358 if (AIndex < 0) or (AIndex >= Count) then raise ERangeError.Create('Index out of bounds');
359 result := TBGRAIconCursorEntry(Entry[AIndex]).Height;
360end;
361
362function TBGRAIconCursor.GetHotSpotAtAt(AIndex: integer): TPoint;
363begin
364 if (AIndex < 0) or (AIndex >= Count) then raise ERangeError.Create('Index out of bounds');
365 result := TBGRAIconCursorEntry(Entry[AIndex]).HotSpot;
366end;
367
368function TBGRAIconCursor.GetWidthAt(AIndex: integer): integer;
369begin
370 if (AIndex < 0) or (AIndex >= Count) then raise ERangeError.Create('Index out of bounds');
371 result := TBGRAIconCursorEntry(Entry[AIndex]).Width;
372end;
373
374procedure TBGRAIconCursor.SetFileType(AValue: TBGRAImageFormat);
375begin
376 if FFileType=AValue then Exit;
377 if not (AValue in [ifIco,ifCur,ifUnknown]) then
378 raise exception.Create('Allowed formats: ICO, CUR or unknown');
379 FFileType:=AValue;
380end;
381
382procedure TBGRAIconCursor.SetHotSpotAt(AIndex: integer; AValue: TPoint);
383begin
384 if (AIndex < 0) or (AIndex >= Count) then raise ERangeError.Create('Index out of bounds');
385 TBGRAIconCursorEntry(Entry[AIndex]).HotSpot := AValue;
386end;
387
388function TBGRAIconCursor.CreateEntry(AName: utf8string;
389 AExtension: utf8string; AContent: TStream): TMultiFileEntry;
390begin
391 AExtension := UTF8LowerCase(AExtension);
392 if (AExtension <> 'png') and (AExtension <> 'dib') then
393 raise exception.Create('The only supported extensions are PNG and DIB');
394
395 result := TBGRAIconCursorEntry.TryCreate(self, AContent);
396 if result.Extension <> AExtension then
397 begin
398 result.Free;
399 raise exception.Create(AExtension + ' file extension expected but ' + result.Extension + ' found');
400 end;
401
402 if result.Name <> AName then
403 begin
404 result.Free;
405 raise exception.Create('"' + AName + '" dimension expected but "' + result.Name + '" found');
406 end;
407end;
408
409function TBGRAIconCursor.ExpectedMagic: Word;
410begin
411 case FFileType of
412 ifIco: result := ICON_OR_CURSOR_FILE_ICON_TYPE;
413 ifCur: result := ICON_OR_CURSOR_FILE_CURSOR_TYPE;
414 else
415 raise exception.Create('Invalid icon/cursor type');
416 end;
417end;
418
419procedure TBGRAIconCursor.Init;
420begin
421 inherited Init;
422 FFileType:= ifUnknown;
423end;
424
425constructor TBGRAIconCursor.Create(AFileType: TBGRAImageFormat);
426begin
427 if not (AFileType in [ifIco,ifCur,ifUnknown]) then
428 raise exception.Create('Allowed formats: ICO, CUR or unknown');
429
430 Init;
431 FFileType := AFileType;
432end;
433
434function TBGRAIconCursor.Add(ABitmap: TBGRACustomBitmap; ABitDepth: integer;
435 AOverwrite: boolean): integer;
436var stream, temp: TStream;
437 writer: TFPWriterBMP;
438 bmpXOR: TBGRACustomBitmap;
439 y: Integer;
440 psrcMask, pdest: PBGRAPixel;
441 bitAndMask: array of byte;
442 bitAndMaskPos: integer;
443 bitAndMaskBit: byte;
444 bitAndMaskRowSize, x: integer;
445 palette: TBGRAPalette;
446 writerPng: TBGRAWriterPNG;
447
448begin
449 stream := TMemoryStream.Create;
450 try
451 //PNG format is advised from 256 on but does not handle XOR
452 if ((ABitmap.Width >= 256) or (ABitmap.Height >= 256)) and (ABitDepth >= 8) and
453 ((ABitmap.XorMask = nil) or ABitmap.XorMask.IsZero) then
454 begin
455 writerPng := TBGRAWriterPNG.Create;
456 try
457 writerPng.WordSized := false;
458 if ABitDepth = 8 then
459 begin
460 writerPng.Indexed := true;
461 writerpng.UseAlpha := ABitmap.HasTransparentPixels;
462 end else
463 begin
464 writerPng.Indexed := false;
465 writerpng.UseAlpha := (ABitDepth = 32);
466 end;
467 ABitmap.SaveToStream(stream, writerPng);
468 finally
469 writerPng.Free;
470 end;
471 result := Add(stream, AOverwrite, true);
472 stream := nil;
473 end else
474 if ((ABitmap.XorMask = nil) or ABitmap.XorMask.IsZero) and
475 (not ABitmap.HasTransparentPixels or (ABitDepth = 32)) then
476 begin
477 writer := TFPWriterBMP.Create;
478 writer.BitsPerPixel := ABitDepth;
479 try
480 if not ABitmap.UsePalette and (ABitDepth < 24) then
481 begin
482 palette := TBGRAPalette.Create(ABitmap);
483 try
484 palette.AssignTo(ABitmap);
485 finally
486 palette.Free;
487 end;
488 ABitmap.SaveToStream(stream, writer);
489 ABitmap.UsePalette:= false;
490 end
491 else
492 ABitmap.SaveToStream(stream, writer);
493 finally
494 writer.Free;
495 end;
496 result := Add(stream, AOverwrite, true);
497 stream := nil;
498 end else
499 begin
500 bmpXOR := BGRABitmapFactory.Create(ABitmap);
501 try
502 bitAndMaskRowSize := ((bmpXOR.Width+31) div 32)*4;
503 setlength(bitAndMask, bitAndMaskRowSize*bmpXOR.Height);
504 for y := bmpXOR.Height-1 downto 0 do
505 begin
506 if assigned(ABitmap.XorMask) then
507 psrcMask := ABitmap.XorMask.ScanLine[y]
508 else
509 psrcMask := nil;
510 pdest := bmpXOR.ScanLine[y];
511 bitAndMaskPos := (bmpXOR.Height-1-y)*bitAndMaskRowSize;
512 bitAndMaskBit:= $80;
513 for x := bmpXOR.Width-1 downto 0 do
514 begin
515 //xor mask is either 100% or 0%
516 if assigned(psrcMask) and ((psrcMask^.red <> 0) or (psrcMask^.green <> 0) or (psrcMask^.blue <> 0)) then
517 begin
518 pdest^ := psrcMask^;
519 pdest^.alpha := 255;
520 bitAndMask[bitAndMaskPos] := bitAndMask[bitAndMaskPos] or bitAndMaskBit;
521 end else
522 if pdest^.alpha = 0 then
523 begin
524 bitAndMask[bitAndMaskPos] := bitAndMask[bitAndMaskPos] or bitAndMaskBit;
525 if ABitDepth <= 24 then //if we cannot save alpha, replace with black.
526 begin //mask will task care of making it transparent
527 pdest^ := BGRABlack;
528 end;
529 end;
530
531 bitAndMaskBit := bitAndMaskBit shr 1;
532 if bitAndMaskBit = 0 then
533 begin
534 bitAndMaskBit := $80;
535 bitAndMaskPos += 1;
536 end;
537 if assigned(psrcMask) then inc(psrcMask);
538 inc(pdest);
539 end;
540 end;
541 bmpXOR.InvalidateBitmap;
542
543 if ABitDepth < 24 then
544 begin
545 palette := TBGRAPalette.Create(bmpXor);
546 palette.AssignTo(bmpXor);
547 palette.Free;
548 end;
549
550 temp := TMemoryStream.Create;
551 try
552 writer := TFPWriterBMP.Create;
553 writer.BitsPerPixel := ABitDepth;
554 try
555 bmpXOR.SaveToStream(temp, writer);
556 //write double height to include mask
557 temp.Position := 22;
558 temp.WriteDWord(NtoLE(DWord(bmpXOR.Height*2)));
559 //go after the file header
560 temp.Position := 14;
561 //copy bitmap without header
562 stream.CopyFrom(temp, temp.Size-temp.Position);
563 finally
564 writer.Free;
565 end;
566 finally
567 temp.Free;
568 end;
569 //write mask
570 stream.WriteBuffer(bitAndMask[0],length(bitAndMask));
571 result := Add(stream, AOverwrite, true);
572 stream := nil;
573 finally
574 bmpXOR.Free;
575 end;
576 end;
577
578 finally
579 stream.Free;
580 end;
581end;
582
583function TBGRAIconCursor.Add(AContent: TStream; AOverwrite: boolean;
584 AOwnStream: boolean): integer;
585var
586 index,i: Integer;
587 newEntry: TBGRAIconCursorEntry;
588 contentCopy: TMemoryStream;
589begin
590 if not AOwnStream then
591 begin
592 AContent.Position:= 0;
593 contentCopy := TMemoryStream.Create;
594 contentCopy.CopyFrom(AContent, AContent.Size);
595 newEntry := TBGRAIconCursorEntry.TryCreate(self, contentCopy);
596 end else
597 newEntry := TBGRAIconCursorEntry.TryCreate(self, AContent);
598
599 index := IndexOf(newEntry.Name, newEntry.Extension);
600 if index <> -1 then
601 begin
602 if AOverwrite then
603 Delete(index)
604 else
605 begin
606 newEntry.Free;
607 raise Exception.Create('Duplicate entry');
608 end;
609 end else if not FLoading then
610 begin
611 for i := 0 to Count-1 do
612 if ((Width[i] < newEntry.Width) and (Height[i] < newEntry.Height)) or
613 ((Width[i] = newEntry.Width) and (Height[i] = newEntry.Height) and (BitDepth[i] < newEntry.BitDepth)) then
614 begin
615 index := i;
616 break;
617 end;
618 end;
619 result := AddEntry(newEntry, index);
620end;
621
622procedure TBGRAIconCursor.LoadFromStream(AStream: TStream);
623var header: TGroupIconHeader;
624 dir: packed array of TIconFileDirEntry;
625 startPos: int64;
626 entryContent: TMemoryStream;
627 entryIndex, i: integer;
628begin
629 FLoading:= true;
630 try
631 startPos := AStream.Position;
632 AStream.ReadBuffer({%H-}header, sizeof(header));
633 header.SwapIfNecessary;
634 if header.Reserved <> 0 then
635 raise exception.Create('Invalid file format');
636 if FileType = ifUnknown then
637 begin
638 case header.ResourceType of
639 ICON_OR_CURSOR_FILE_ICON_TYPE: FFileType := ifIco;
640 ICON_OR_CURSOR_FILE_CURSOR_TYPE: FFileType := ifCur;
641 end;
642 end;
643 if header.ResourceType <> ExpectedMagic then
644 raise exception.Create('Invalid resource type');
645 Clear;
646 setlength(dir, header.ImageCount);
647 AStream.ReadBuffer(dir[0], sizeof(TIconFileDirEntry)*length(dir));
648 for i := 0 to high(dir) do
649 begin
650 AStream.Position:= LEtoN(dir[i].ImageOffset) + startPos;
651 entryContent := TMemoryStream.Create;
652 entryContent.CopyFrom(AStream, LEtoN(dir[i].ImageSize));
653 entryIndex := Add(entryContent, false, true);
654 if ((dir[i].Width = 0) and (Width[entryIndex] < 256)) or
655 ((dir[i].Width > 0) and (Width[entryIndex] <> dir[i].Width)) or
656 ((dir[i].Height = 0) and (Height[entryIndex] < 256)) or
657 ((dir[i].Height > 0) and (Height[entryIndex] <> dir[i].Height)) then
658 raise Exception.Create('Inconsistent image size');
659 if FFileType = ifCur then
660 TBGRAIconCursorEntry(Entry[entryIndex]).HotSpot := Point(LEtoN(dir[i].HotSpotX),LEtoN(dir[i].HotSpotY));
661 end;
662 finally
663 FLoading:= false;
664 end;
665end;
666
667procedure TBGRAIconCursor.SaveToStream(ADestination: TStream);
668var header: TGroupIconHeader;
669 i: integer;
670 accSize: DWord;
671 dir: packed array of TIconFileDirEntry;
672 contentSize: DWord;
673begin
674 if Count = 0 then
675 raise exception.Create('File cannot be empty');
676 if FileType = ifUnknown then
677 raise exception.Create('You need to specify the file type');
678 header.ImageCount:= Count;
679 header.Reserved := 0;
680 header.ResourceType:= ExpectedMagic;
681 header.SwapIfNecessary;
682 accSize := sizeof(header) + sizeof(TIconFileDirEntry)*Count;
683 setlength(dir, Count);
684 for i := 0 to Count-1 do
685 begin
686 if Width[i] >= 256
687 then dir[i].Width := 0
688 else dir[i].Width := Width[i];
689
690 if Height[i] >= 256
691 then dir[i].Height := 0
692 else dir[i].Height := Height[i];
693
694 if BitDepth[i] < 8 then
695 dir[i].Colors := 1 shl BitDepth[i]
696 else
697 dir[i].Colors := 0;
698 dir[i].Reserved := 0;
699 case FFileType of
700 ifCur: begin dir[i].HotSpotX:= NtoLE(Word(HotSpot[i].X)); dir[i].HotSpotY := NtoLE(Word(HotSpot[i].Y)); end;
701 ifIco: begin dir[i].BitsPerPixel:= NtoLE(Word(BitDepth[i])); dir[i].Planes := NtoLE(Word(1)); end;
702 else dir[i].Variable:= 0;
703 end;
704 dir[i].ImageOffset := LEtoN(accSize);
705 contentSize:= Entry[i].FileSize;
706 dir[i].ImageSize := NtoLE(contentSize);
707 inc(accSize,contentSize);
708 end;
709
710 ADestination.WriteBuffer(header, sizeof(header));
711 ADestination.WriteBuffer(dir[0], sizeof(TIconFileDirEntry)*length(dir));
712 for i := 0 to Count-1 do
713 if Entry[i].CopyTo(ADestination) <> Entry[i].FileSize then
714 raise exception.Create('Unable to write data in stream');
715end;
716
717function TBGRAIconCursor.GetBitmap(AIndex: integer): TBGRACustomBitmap;
718begin
719 if (AIndex < 0) or (AIndex >= Count) then raise ERangeError.Create('Index out of bounds');
720 result := TBGRAIconCursorEntry(Entry[AIndex]).GetBitmap;
721end;
722
723function TBGRAIconCursor.GetBestFitBitmap(AWidth, AHeight: integer): TBGRACustomBitmap;
724var bestIndex: integer;
725 bestSizeDiff: integer;
726 bestBPP: integer;
727 sizeDiff, i: integer;
728begin
729 bestBPP := 0;
730 bestSizeDiff := high(integer);
731 bestIndex := -1;
732 for i := 0 to Count-1 do
733 begin
734 sizeDiff := abs(AWidth-Width[i])+abs(AHeight-Height[i]);
735 if (sizeDiff < bestSizeDiff) or
736 ((sizeDiff = bestSizeDiff) and (BitDepth[i] > bestBPP)) then
737 begin
738 bestIndex := i;
739 bestSizeDiff:= sizeDiff;
740 bestBPP:= BitDepth[i];
741 end;
742 end;
743 if bestIndex = -1 then
744 raise Exception.Create('No bitmap found')
745 else
746 result := GetBitmap(bestIndex);
747end;
748
749function TBGRAIconCursor.IndexOf(AWidth, AHeight, ABitDepth: integer): integer;
750var
751 i: Integer;
752begin
753 for i := 0 to Count-1 do
754 if (Width[i] = AWidth) and (Height[i] = AHeight) and (BitDepth[i] = ABitDepth) then
755 begin
756 result := i;
757 exit;
758 end;
759 result := -1;
760end;
761
762end.
763
Note: See TracBrowser for help on using the repository browser.