-
Notifications
You must be signed in to change notification settings - Fork 6
/
KOLClasses.pas
4346 lines (4086 loc) · 136 KB
/
KOLClasses.pas
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
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
unit KOLClasses;
interface
uses
Winapi.Windows, Classes, Graphics, SysUtils, CommonUtilities, Dialogs, Math, Types;
{$DEFINE PAS_VERSION}
{$DEFINE ICON_DIFF_WH}
{$DEFINE LOADEX}
type
TKOLBitmap = class
{* Bitmap incapsulation object. }
protected
fHeight: Integer;
fWidth: Integer;
fHandle: HBitmap;
fCanvas: TCanvas;
fScanLineSize: Integer;
fBkColor: TColor;
fApplyBkColor2Canvas: procedure( Sender: TKOLBitmap );
fDetachCanvas: procedure( Sender: TKOLBitmap );
fCanvasAttached : Integer;
fHandleType: TBitmapHandleType;
fDIBHeader: PBitmapInfo;
fDIBBits: Pointer;
fDIBSize: Integer;
fNewPixelFormat: TPixelFormat;
fFillWithBkColor: procedure( BmpObj: TKOLBitmap; DC: HDC; oldW, oldH: Integer );
//stdcall;
fTransMaskBmp: TKOlBitmap;
fTransColor: TColor;
fGetDIBPixels: function( Bmp: TKOLBitmap; X, Y: Integer ): TColor;
fSetDIBPixels: procedure( Bmp: TKOLBitmap; X, Y: Integer; Value: TColor );
fScanLine0: PByte;
fScanLineDelta: Integer;
fPixelMask: DWORD;
fPixelsPerByteMask: Integer;
fBytesPerPixel: Integer;
fDIBAutoFree: Boolean;
procedure SetHeight(const Value: Integer);
procedure SetWidth(const Value: Integer);
function GetEmpty: Boolean;
function GetHandle: HBitmap;
function GetHandleAllocated: Boolean;
procedure SetHandle(const Value: HBitmap);
procedure SetPixelFormat(Value: TPixelFormat);
procedure FormatChanged;
function GetCanvas: TCanvas;
procedure CanvasChanged( Sender: TObject );
function GetScanLine(Y: Integer): Pointer;
function GetScanLineSize: Integer;
procedure ClearData;
procedure ClearTransImage;
procedure SetBkColor(const Value: TColor);
function GetDIBPalEntries(Idx: Integer): TColor;
function GetDIBPalEntryCount: Integer;
procedure SetDIBPalEntries(Idx: Integer; const Value: TColor);
procedure SetHandleType(const Value: TBitmapHandleType);
function GetPixelFormat: TPixelFormat;
function GetPixels(X, Y: Integer): TColor;
procedure SetPixels(X, Y: Integer; const Value: TColor);
function GetDIBPixels(X, Y: Integer): TColor;
procedure SetDIBPixels(X, Y: Integer; const Value: TColor);
function GetBoundsRect: TRect;
public
constructor Create(AWidth, AHeight: Integer);
constructor CreateDIB(AWidth, AHeight: Integer; APixelFormat: TPixelFormat);
destructor Destroy; override;
public
property Width: Integer read fWidth write SetWidth;
{* Width of bitmap. To make code smaller, avoid changing Width or Height
after bitmap is created (using NewBitmap) or after it is loaded from
file, stream of resource. }
property Height: Integer read fHeight write SetHeight;
{* Height of bitmap. To make code smaller, avoid changing Width or Height
after bitmap is created (using NewBitmap) or after it is loaded from
file, stream of resource. }
property BoundsRect: TRect read GetBoundsRect;
{* Returns rectangle (0,0,Width,Height). }
property Empty: Boolean read GetEmpty;
{* Returns True if Width or Height is 0. }
procedure Clear;
{* Makes bitmap empty, setting its Width and Height to 0. }
procedure LoadFromFile( const Filename: string );
{* Loads bitmap from file (LoadFromStream used). }
function LoadFromFileEx( const Filename: string ): Boolean;
{* Loads bitmap from a file. If necessary, bitmap is RLE-decoded. Code given
by Vyacheslav A. Gavrik. }
procedure SaveToFile( const Filename: string );
{* Stores bitmap to file (SaveToStream used). }
procedure CoreSaveToFile( const Filename: string );
{* Stores bitmap to file (CoreSaveToStream used). }
procedure RLESaveToFile( const Filename: string );
{* Stores bitmap to file (CoreSaveToStream used). }
procedure LoadFromStream( Strm: TStream );
{* Loads bitmap from stream. Follow loading, bitmap has DIB format (without
handle allocated). It is possible to draw DIB bitmap without creating
handle for it, which can economy GDI resources. }
function LoadFromStreamEx( Strm: TStream ): Boolean;
{* Loads bitmap from a stream. Difference is that RLE decoding supported.
Code given by Vyacheslav A. Gavrik. }
procedure SaveToStream( Strm: TStream );
{* Saves bitmap to stream. If bitmap is not DIB, it is converted to DIB
before saving. }
procedure CoreSaveToStream( Strm: TStream );
{* Saves bitmap to stream using CORE format with RGBTRIPLE palette and
with BITMAPCOREHEADER as a header.
If bitmap is not DIB, it is converted to DIB before saving. }
procedure RLESaveToStream( Strm: TStream );
{* Saves bitmap to stream using CORE format with RGBTRIPLE palette and
with BITMAPCOREHEADER as a header.
If bitmap is not DIB, it is converted to DIB before saving. }
procedure LoadFromResourceID( Inst: DWORD; ResID: Integer );
{* Loads bitmap from resource using integer ID of resource. To load by name,
use LoadFromResurceName. To load resource of application itself, pass
hInstance as first parameter. This method also can be used to load system
predefined bitmaps, if 0 is passed as Inst parameter:
|<pre>
OBM_BTNCORNERS OBM_REDUCE
OBM_BTSIZE OBM_REDUCED
OBM_CHECK OBM_RESTORE
OBM_CHECKBOXES OBM_RESTORED
OBM_CLOSE OBM_RGARROW
OBM_COMBO OBM_RGARROWD
OBM_DNARROW OBM_RGARROWI
OBM_DNARROWD OBM_SIZE
OBM_DNARROWI OBM_UPARROW
OBM_LFARROW OBM_UPARROWD
OBM_LFARROWD OBM_UPARROWI
OBM_LFARROWI OBM_ZOOM
OBM_MNARROW OBM_ZOOMD
|</pre> }
procedure LoadFromResourceName( Inst: DWORD; ResName: PChar );
{* Loads bitmap from resurce (using passed name of bitmap resource. }
function Assign( SrcBmp: TKOLBitmap ): Boolean;
{* Assigns bitmap from another. Returns False if not success.
Note: remember, that Canvas is not assigned - only bitmap image
is copied. And for DIB, handle is not allocating due this process. }
property Handle: HBitmap read GetHandle write SetHandle;
{* Handle of bitmap. Created whenever property accessed. To check if handle
is allocated (without allocating it), use HandleAllocated property. }
property HandleAllocated: Boolean read GetHandleAllocated;
{* Returns True, if Handle already allocated. }
function ReleaseHandle: HBitmap;
{* Returns Handle and releases it, so bitmap no more know about handle.
This method does not destroy bitmap image, but converts it into DIB.
Returned Handle actually is a handle of copy of original bitmap. If
You need not in keping it up, use Dormant method instead. }
procedure Dormant;
{* Releases handle from bitmap and destroys it. But image is not destroyed
and its data are preserved in DIB format. Please note, that in KOL, DIB
bitmaps can be drawn onto given device context without allocating of
handle. So, it is very useful to call Dormant preparing it using
Canvas drawing operations - to economy GDI resources. }
property HandleType: TBitmapHandleType read fHandleType write SetHandleType;
{* bmDIB, if DIB part of image data is filled and stored internally in
TBitmap object. DIB image therefore can have Handle allocated, which
require resources. Use HandleAllocated funtion to determine if handle
is allocated and Dormant method to remove it, if You want to economy
GDI resources. (Actually Handle needed for DIB bitmap only in case
when Canvas is used to draw on bitmap surface). Please note also, that
before saving bitmap to file or stream, it is converted to DIB. }
property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
{* Current pixel format. If format of bitmap is unknown, or bitmap is DDB,
value is pfDevice. Setting PixelFormat to any other format converts
bitmap to DIB, back to pfDevice converts bitmap to DDB again. Avoid
such conversations for large bitmaps or for numerous bitmaps in your
application to keep good performance. }
function BitsPerPixel: Integer;
{* Returns bits per pixel if possible. }
procedure Draw( DC: HDC; X, Y: Integer );
{* Draws bitmap to given device context. If bitmap is DIB, it is always
drawing using SetDIBitsToDevice API call, which does not require bitmap
handle (so, it is very sensible to call Dormant method to free correspondent
GDI resources). }
procedure StretchDraw( DC: HDC; const Rect: TRect );
{* Draws bitmap onto DC, stretching it to fit given rectangle Rect. }
procedure DrawTransparent( DC: HDC; X, Y: Integer; TranspColor: TColor );
{* Draws bitmap onto DC transparently, using TranspColor as transparent.
See function DesktopPixelFormat also. }
procedure StretchDrawTransparent( DC: HDC; const Rect: TRect; TranspColor: TColor );
{* Draws bitmap onto given rectangle of destination DC (with stretching it
to fit Rect) - transparently, using TranspColor as transparent.
See function DesktopPixelFormat also. }
procedure DrawMasked( DC: HDC; X, Y: Integer; Mask: HBitmap );
{* Draws bitmap to destination DC transparently by mask. It is possible
to pass as a mask handle of another TBitmap, previously converted to
monochrome mask using Convert2Mask method. }
procedure StretchDrawMasked( DC: HDC; const Rect: TRect; Mask: HBitmap );
{* Like DrawMasked, but with stretching image onto given rectangle. }
procedure Convert2Mask( TranspColor: TColor );
{* Converts bitmap to monochrome (mask) bitmap with TranspColor replaced
to clBlack and all other ones to clWhite. Such mask bitmap can be used
to draw original bitmap transparently, with given TranspColor as
transparent. (To preserve original bitmap, create new instance of
TBitmap and assign original bitmap to it). See also DrawTransparent and
StretchDrawTransparent methods. }
procedure Invert;
{* Obvious. }
property Canvas: TCanvas read GetCanvas;
{* Canvas can be used to draw onto bitmap. Whenever it is accessed, handle
is allocated for bitmap, if it is not yet (to make it possible
to select bitmap to display compatible device context). }
procedure RemoveCanvas;
{* Call this method to destroy Canvas and free GDI resources. }
property BkColor: TColor read fBkColor write SetBkColor;
{* Used to fill background for Bitmap, when its width or height is increased.
Although this value always synchronized with Canvas.Brush.Color, use it
instead if You do not use Canvas for drawing on bitmap surface. }
property Pixels[ X, Y: Integer ]: TColor read GetPixels write SetPixels;
{* Allows to obtain or change certain pixels of a bitmap. This method is
both for DIB and DDB bitmaps, and leads to allocate handle anyway. For
DIB bitmaps, it is possible to use property DIBPixels[ ] instead,
which is much faster and does not require in Handle. }
property ScanLineSize: Integer read GetScanLineSize;
{* Returns size of scan line in bytes. Use it to measure size of a single
ScanLine. To calculate increment value from first byte of ScanLine to
first byte of next ScanLine, use difference
! Integer(ScanLine[1]-ScanLine[0])
(this is because bitmap can be oriented from bottom to top, so
step can be negative). }
property ScanLine[ Y: Integer ]: Pointer read GetScanLine;
{* Use ScanLine to access DIB bitmap pixels in memory to direct access it
fast. Take in attention, that for different pixel formats, different
bit counts are used to represent bitmap pixels. Also do not forget, that
for formats pf4bit and pf8bit, pixels actually are indices to palette
entries, and for formats pf16bit, pf24bit and pf32bit are actually
RGB values (for pf16bit B:5-G:6-R:5, for pf15bit B:5-G:5-R:5 (high order
bit not used), for pf24bit B:8-G:8-R:8, and for pf32bit high order byte
of TRGBQuad structure is not used). }
property DIBPixels[ X, Y: Integer ]: TColor read GetDIBPixels write SetDIBPixels;
{* Allows direct access to pixels of DIB bitmap, faster then Pixels[ ]
property. Access to read is slower for pf15bit, pf16bit formats (because
some conversation needed to translate packed RGB color to TColor). And
for write, operation performed most slower for pf4bit, pf8bit (searching
nearest color required) and fastest for pf24bit, pf32bit and pf1bit. }
property DIBPalEntryCount: Integer read GetDIBPalEntryCount;
{* Returns palette entries count for DIB image. Always returns 2 for pf1bit,
16 for pf4bit, 256 for pf8bit and 0 for other pixel formats. }
property DIBPalEntries[ Idx: Integer ]: TColor read GetDIBPalEntries write
SetDIBPalEntries;
{* Provides direct access to DIB palette. }
function DIBPalNearestEntry( Color: TColor ): Integer;
{* Returns index of entry in DIB palette with color nearest (or matching)
to given one. }
property DIBBits: Pointer read fDIBBits;
{* This property is mainly for internal use. }
property DIBSize: Integer read fDIBSize;
{* Size of DIBBits array. }
property DIBHeader: PBitmapInfo read fDIBHeader;
{* This property is mainly for internal use. }
procedure DIBDrawRect( DC: HDC; X, Y: Integer; const R: TRect );
{* This procedure copies given rectangle to the target device context,
but only for DIB bitmap (using SetDIBBitsToDevice API call). }
procedure RotateRight;
{* Rotates bitmap right (90 degree). Bitmap must be DIB. If You definitevely
know format of a bitmap, use instead one of methods RotateRightMono,
RotateRight4bit, RotateRight8bit, RotateRight16bit or RotateRightTrueColor
- this will economy code. But if for most of formats such methods are
called, this can be more economy just to call always universal method
RotateRight. }
procedure RotateLeft;
{* Rotates bitmap left (90 degree). Bitmap must be DIB. If You definitevely
know format of a bitmap, use instead one of methods RotateLeftMono,
RotateLeft4bit, RotateLeft8bit, RotateLeft16bit or RotateLeftTrueColor
- this will economy code. But if for most of formats such methods are
called, this can be more economy just to call always universal method
RotateLeft. }
procedure RotateRightMono;
{* Rotates bitmat right, but only if bitmap is monochrome (pf1bit). }
procedure RotateLeftMono;
{* Rotates bitmap left, but only if bitmap is monochrome (pf1bit). }
procedure RotateRight4bit;
{* Rotates bitmap right, but only if PixelFormat is pf4bit. }
procedure RotateLeft4bit;
{* Rotates bitmap left, but only if PixelFormat is pf4bit. }
procedure RotateRight8bit;
{* Rotates bitmap right, but only if PixelFormat is pf8bit. }
procedure RotateLeft8bit;
{* Rotates bitmap left, but only if PixelFormat is pf8bit. }
procedure RotateRight16bit;
{* Rotates bitmap right, but only if PixelFormat is pf16bit. }
procedure RotateLeft16bit;
{* Rotates bitmap left, but only if PixelFormat is pf16bit. }
procedure RotateRightTrueColor;
{* Rotates bitmap right, but only if PixelFormat is pf24bit or pf32bit. }
procedure RotateLeftTrueColor;
{* Rotates bitmap left, but only if PixelFormat is pf24bit or pf32bit. }
procedure FlipVertical;
{* Flips bitmap vertically }
procedure FlipHorizontal;
{* Flips bitmap horizontally }
procedure CopyRect( const DstRect : TRect; SrcBmp : TKOLBitmap; const SrcRect : TRect );
{* It is possible to use Canvas.CopyRect for such purpose, but if You
do not want use TCanvas, it is possible to copy rectangle from one
bitmap to another using this function. }
function CopyToClipboard: Boolean;
{* Copies bitmap to clipboard. }
function PasteFromClipboard: Boolean;
{* Takes CF_DIB format bitmap from clipboard and assigns it to the
TBitmap object. }
end;
function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat;
function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer;
{* May be will be useful. }
var
DefaultPixelFormat: TPixelFormat = pf32bit; //pf16bit;
type
TKOLIcon = class
{* Object type to incapsulate icon or cursor image. }
protected
{$IFDEF ICON_DIFF_WH}
FWidth: Integer;
FHeight: Integer;
{$ELSE}
FSize : Integer;
{$ENDIF}
FHandle: HIcon;
FShareIcon: Boolean;
procedure SetSize(const Value: Integer);
{$IFDEF ICON_DIFF_WH}
function GeTKOLIconSize: Integer;
{$ENDIF}
procedure SetHandle(const Value: HIcon);
function GetHotSpot: TPoint;
function GetEmpty: Boolean;
public
constructor Create;
destructor Destroy; override;
public
{$IFDEF ICONLOAD_PRESERVEBMPS}
ImgBmp, MskBmp : PBitmap;
Only_Bmp: Boolean;
{$ENDIF ICONLOAD_PRESERVEBMPS}
property Size : Integer read
{$IFDEF ICON_DIFF_WH}
GeTKOLIconSize
{$ELSE}
FSize
{$ENDIF}
write SetSize;
{* Icon dimension (width and/or height, which are equal to each other always). }
{$IFDEF ICON_DIFF_WH}
property Width: Integer read FWidth;
property Height: Integer read FHeight;
{$ENDIF}
property Handle : HIcon read FHandle write SetHandle;
{* Windows icon object handle. }
procedure SetHandleEx( NewHandle: HIcon );
{* Set Handle without changing Size (Width/Height). }
procedure Clear;
{* Clears icon, freeing image and allocated GDI resource (Handle). }
property Empty: Boolean read GetEmpty;
{* Returns True if icon is Empty. }
property ShareIcon : Boolean read FShareIcon write FShareIcon;
{* True, if icon object is shared and can not be deleted when TKOLIcon object
is destroyed (set this flag is to True, if an icon is obtained from another
TKOLIcon object, for example). }
property HotSpot : TPoint read GetHotSpot;
{* Hot spot point - for cursors. }
procedure Draw( DC : HDC; X, Y : Integer );
{* Draws icon onto given device context. Icon always is drawn transparently
using its transparency mask (stored internally in icon object). }
procedure StretchDraw( DC : HDC; Dest : TRect );
{* Draws icon onto given device context with stretching it to fit destination
rectangle. See also Draw. }
procedure LoadFromStream( Strm : TStream );
{* Loads icon from stream. If stream contains several icons (of
different dimentions), icon with the most appropriate size is loading. }
procedure LoadFromFile( const FileName : string );
{* Load icon from file. If file contains several icons (of
different dimensions), icon with the most appropriate size is loading. }
procedure LoadFromResourceID( Inst: Integer; ResID: Integer; DesiredSize: Integer );
{* Loads icon from resource. To load system default icon, pass 0 as Inst and
one of followin values as ResID:
|<pre>
IDI_APPLICATION Default application icon.
IDI_ASTERISK Asterisk (used in informative messages).
IDI_EXCLAMATION Exclamation point (used in warning messages).
IDI_HAND Hand-shaped icon (used in serious warning messages).
IDI_QUESTION Question mark (used in prompting messages).
IDI_WINLOGO Windows logo.
|</pre> It is also possible to load icon from resources of another module,
if pass instance handle of loaded module as Inst parameter. }
procedure LoadFromResourceName( Inst: Integer; ResName: PChar; DesiredSize: Integer );
{* Loads icon from resource. To load own application resource, pass
hInstance as Inst parameter. It is possible to load resource from
another module, if pass its instance handle as Inst. }
procedure LoadFromExecutable( const FileName: string; IconIdx: Integer );
{* Loads icon from executable (exe or dll file). Always default sized icon
is loaded. It is possible also to get know how much icons are contained
in executable using gloabl function GetFileIconCount. To obtain icon of
another size, try to load given executable and use LoadFromResourceID
method. }
procedure SaveToStream( Strm : TStream );
{* Saves single icon to stream. To save icons with several different
dimensions, use global procedure SaveIcons2Stream. }
procedure SaveToFile( const FileName : string );
{* Saves single icon to file. To save icons with several different
dimensions, use global procedure SaveIcons2File. }
function Convert2Bitmap( TranColor: TColor ): HBitmap;
{* Converts icon to bitmap, returning Windows GDI bitmap resource as
a result. It is possible later to assign returned bitmap handle to
Handle property of TBitmap object to use features of TBitmap.
Pass TranColor to replace transparent area of icon with given color. }
end;
implementation
type
TWindowsVersion = ( wv31, wv95, wv98, wvME, wvNT, wvY2K, wvXP, wvServer2003,
wvVista, wvSeven );
function WriteVal(Stm: TStream; Value, Count: DWORD): DWORD; inline;
begin
Result := Stm.Write( Value, Count );
end;
var SaveWinVer: Byte = $FF;
function WinVer : TWindowsVersion;
var MajorVersion, MinorVersion: Byte;
dwVersion: Integer;
begin
if SaveWinVer <> $FF then Result := TWindowsVersion( SaveWinVer )
else
begin
dwVersion := GetVersion;
MajorVersion := LoByte( dwVersion );
MinorVersion := HiByte( LoWord( dwVersion ) );
if dwVersion >= 0 then
begin
Result := wvNT;
if (MajorVersion >= 6) then begin
if (MinorVersion >= 1) then
Result := wvSeven
else
Result := wvVista;
end else begin
if MajorVersion >= 5 then
if MinorVersion >= 1 then
begin
Result := wvXP;
if MinorVersion >= 2 then
Result := wvServer2003;
end
else Result := wvY2K;
end;
end
else
begin
Result := wv95;
if (MajorVersion > 4) or
(MajorVersion = 4) and (MinorVersion >= 10) then
begin
Result := wv98;
if (MajorVersion = 4) and (MinorVersion >= $5A) then
Result := wvME;
end
else
if MajorVersion <= 3 then
Result := wv31;
end;
SaveWinVer := Ord( Result );
end;
end;
function ColorToRGBQuad( Color: TColor ): TRGBQuad;
var C: Integer;
begin
C := ColorToRGB( Color );
C := ((C shr 16) and $FF)
or ((C shl 16) and $FF0000)
or (C and $FF00);
Result := TRGBQuad( C );
end;
function ColorToColor15( Color: TColor ): WORD;
begin
Color := ColorToRGB( Color );
Result := (Color shr 19) and $1F or
(Color shr 6) and $3E0 or
(Color shl 7) and $7C00;
end;
function ColorToColor16( Color: TColor ): WORD;
begin
Color := ColorToRGB( Color );
Result := (Color shr 19) and $1F or
(Color shr 5) and $7E0 or
(Color shl 8) and $F800;
end;
////////////////////////////////////////////////////////////////////////
// t B I T M A P
///////////////////////////////////////////////////////////////////////
{ -- bitmap -- }
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo;
begin
{$IFDEF KOL_ASSERTIONS}
Assert( W > 0, 'Width must be >0' );
Assert( H > 0, 'Height must be >0' );
{$ENDIF KOL_ASSERTIONS}
Result := AllocMem( 256*Sizeof(TRGBQuad)+Sizeof(TBitmapInfoHeader) );
{$IFDEF KOL_ASSERTIONS}
Assert( Result <> nil, 'No memory' );
{$ENDIF KOL_ASSERTIONS}
Result.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );
Result.bmiHeader.biWidth := W;
Result.bmiHeader.biHeight := H; // may be, -H ?
Result.bmiHeader.biPlanes := 1;
Result.bmiHeader.biBitCount := BitsPerPixel;
end;
{$ENDIF PAS_VERSION}
const
BitsPerPixel_By_PixelFormat: array[ TPixelFormat ] of Byte =
( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat;
var I: TPixelFormat;
begin
for I := High(I) downto Low(I) do
if BitsPerPixel = BitsPerPixel_By_PixelFormat[ I ] then
begin
Result := I; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
end;
Result := pfDevice;
end;
{$ENDIF PAS_VERSION}
procedure DummyDetachCanvas( Sender: TKOLBitmap );
begin
end;
const InitColors: array[ 0..17 ] of DWORD = ( $F800, $7E0, $1F, 0, $800000, $8000,
$808000, $80, $800080, $8080, $808080, $C0C0C0, $FF0000, $FF00, $FFFF00, $FF,
$FF00FF, $FFFF );
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
procedure PreparePF16bit( DIBHeader: PBitmapInfo );
begin
DIBHeader.bmiHeader.biCompression := BI_BITFIELDS;
Move( InitColors[ 0 ], DIBHeader.bmiColors[ 0 ], 19*Sizeof(TRGBQUAD) );
end;
{$ENDIF PAS_VERSION}
{ TKOLBitmap }
procedure TKOLBitmap.ClearData;
begin
fDetachCanvas( Self );
if fHandle <> 0 then
begin
DeleteObject( fHandle );
fHandle := 0;
fDIBBits := nil;
end;
if fDIBBits <> nil then
begin
if not fDIBAutoFree then
GlobalFree( THandle( fDIBBits ) );
fDIBBits := nil;
end;
if fDIBHeader <> nil then
begin
FreeMem( fDIBHeader );
fDIBHeader := nil;
end;
fScanLineSize := 0;
fGetDIBPixels := nil;
fSetDIBPixels := nil;
ClearTransImage;
end;
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
procedure TKOLBitmap.Clear;
begin
RemoveCanvas;
ClearData;
fWidth := 0;
fHeight := 0;
fDIBAutoFree := FALSE;
end;
{$ENDIF PAS_VERSION}
constructor TKOLBitmap.Create(AWidth, AHeight: Integer);
var
DC: HDC;
begin
inherited Create;
fHandleType := bmDDB;
fDetachCanvas := DummyDetachCanvas;
fWidth := AWidth;
fHeight := AHeight;
if (AWidth <> 0) and (AHeight <> 0) then
begin
DC := GetDC( 0 );
fHandle := CreateCompatibleBitmap( DC, AWidth, AHeight );
ReleaseDC( 0, DC );
end;
end;
constructor TKOLBitmap.CreateDIB(AWidth, AHeight: Integer; APixelFormat: TPixelFormat);
const
BitsPerPixel: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
var
BitsPixel: Integer;
begin
fDetachCanvas := DummyDetachCanvas;
fWidth := AWidth;
fHeight := AHeight;
if (AWidth <> 0) and (AHeight <> 0) then
begin
BitsPixel := BitsPerPixel[ PixelFormat ];
if BitsPixel = 0 then
begin
fNewPixelFormat := DefaultPixelFormat;
BitsPixel := BitsPerPixel[DefaultPixelFormat];
end
else
fNewPixelFormat := PixelFormat;
fDIBHeader := PrepareBitmapHeader( AWidth, AHeight, BitsPixel );
if PixelFormat = pf16bit then
begin
PreparePF16bit( fDIBHeader );
end;
fDIBSize := ScanLineSize * AHeight;
fDIBBits :=
Pointer( GlobalAlloc( GMEM_FIXED or GMEM_ZEROINIT, fDIBSize + 16 ) );
end;
end;
function TKOLBitmap.GetBoundsRect: TRect;
begin
Result := MakeRect( 0, 0, Width, Height );
end;
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
destructor TKOLBitmap.Destroy;
begin
Clear;
inherited;
end;
{$ENDIF PAS_VERSION}
function TKOLBitmap.BitsPerPixel: Integer;
var B: tagBitmap;
begin
CASE PixelFormat OF
pf1bit: Result := 1;
pf4bit: Result := 4;
pf8bit: Result := 8;
pf15bit: Result := 15;
pf16bit: Result := 16;
pf24bit: Result := 24;
pf32bit: Result := 32;
else begin
Result := 0;
if fHandle <> 0 then
if GetObject( fHandle, Sizeof( B ), @B ) > 0 then
Result := B.bmBitsPixel * B.bmPlanes;
end;
END;
end;
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
procedure TKOLBitmap.Draw(DC: HDC; X, Y: Integer);
var
DCfrom, DC0: HDC;
oldBmp: HBitmap;
oldHeight: Integer;
B: tagBitmap;
label
TRYAgain;
begin
TRYAgain:
if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
if fHandle <> 0 then
begin
fDetachCanvas( Self );
oldHeight := fHeight;
if GetObject( fHandle, sizeof( B ), @B ) <> 0 then
oldHeight := B.bmHeight;
{$IFDEF KOL_ASSERTIONS}
ASSERT( oldHeight > 0, 'oldHeight must be > 0' );
{$ENDIF KOL_ASSERTIONS}
DC0 := GetDC( 0 );
DCfrom := CreateCompatibleDC( DC0 );
ReleaseDC( 0, DC0 );
oldBmp := SelectObject( DCfrom, fHandle );
{$IFDEF KOL_ASSERTIONS}
ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
{$ENDIF KOL_ASSERTIONS}
BitBlt( DC, X, Y, fWidth, oldHeight, DCfrom, 0, 0, SRCCOPY );
{$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
SelectObject( DCfrom, oldBmp );
DeleteDC( DCfrom );
end
else
if fDIBBits <> nil then
begin
oldHeight := Abs(fDIBHeader.bmiHeader.biHeight);
{$IFDEF KOL_ASSERTIONS}
ASSERT( oldHeight > 0, 'oldHeight must be > 0' );
ASSERT( fWidth > 0, 'Width must be > 0' );
{$ENDIF KOL_ASSERTIONS}
if StretchDIBits( DC, X, Y, fWidth, oldHeight, 0, 0, fWidth, oldHeight,
fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY ) = 0 then
begin
if GetHandle <> 0 then
goto TRYAgain;
end;
end;
end;
{$ENDIF PAS_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
procedure TKOLBitmap.StretchDraw(DC: HDC; const Rect: TRect);
var DCfrom: HDC;
oldBmp: HBitmap;
label DrawHandle;
begin
if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
DrawHandle:
if fHandle <> 0 then
begin
fDetachCanvas( Self );
DCfrom := CreateCompatibleDC( 0 );
oldBmp := SelectObject( DCfrom, fHandle );
{$IFDEF KOL_ASSERTIONS}
ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
{$ENDIF KOL_ASSERTIONS}
StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
Rect.Bottom - Rect.Top, DCfrom, 0, 0, fWidth, fHeight,
SRCCOPY );
SelectObject( DCfrom, oldBmp );
DeleteDC( DCfrom );
end
else
if fDIBBits <> nil then
begin
if StretchDIBits( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
Rect.Bottom - Rect.Top, 0, 0, fWidth, fHeight,
fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY )<=0 then
begin
if GetHandle <> 0 then
goto DrawHandle;
end;
end;
end;
{$ENDIF PAS_VERSION}
procedure TKOLBitmap.DrawMasked(DC: HDC; X, Y: Integer; Mask: HBitmap);
begin
StretchDrawMasked( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ), Mask );
end;
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
procedure TKOLBitmap.DrawTransparent(DC: HDC; X, Y: Integer; TranspColor: TColor);
begin
if TranspColor = clNone then
Draw( DC, X, Y )
else
StretchDrawTransparent( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ),
TranspColor );
end;
{$ENDIF PAS_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
procedure TKOLBitmap.StretchDrawTransparent(DC: HDC; const Rect: TRect; TranspColor: TColor);
begin
if TranspColor = clNone then
StretchDraw( DC, Rect )
else
begin
if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
TranspColor := ColorToRGB( TranspColor );
if (fTransMaskBmp = nil) or (fTransColor <> TranspColor) then
begin
if fTransMaskBmp = nil then
fTransMaskBmp := TKOLBitmap.Create( 0, 0 {fWidth, fHeight} );
fTransColor := TranspColor;
// Create here mask bitmap:
fTransMaskBmp.Assign( Self );
fTransMaskBmp.Convert2Mask( TranspColor );
end;
StretchDrawMasked( DC, Rect, fTransMaskBmp.Handle );
end;
end;
{$ENDIF PAS_VERSION}
{$IFDEF DEBUG_DRAWTRANSPARENT}
procedure DebugDrawTransparent( DC: HDC; X, Y, W, H: Integer; PF: TPixelFormat;
const Note: AnsiString );
const PixelFormatAsStr: array[ TPixelFormat ] of String = ( 'pfDevice', 'pf1bit',
'pf4bit', 'pf8bit', 'pf15bit', 'pf16bit', 'pf24bit', 'pf32bit', 'pfCustom' );
var Bmp: TKOLBitmap;
begin
Bmp := NewDibBitmap( W, H, pf32bit );
BitBlt( Bmp.Canvas.Handle, 0, 0, W, H, DC, X, Y, SrcCopy );
Bmp.SaveToFile( GetStartDir + PixelFormatAsStr[ PF ] + Note );
Bmp.Free;
end;
{$ENDIF DEBUG_DRAWTRANSPARENT}
const
ROP_DstCopy = $00AA0029;
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
procedure TKOLBitmap.StretchDrawMasked(DC: HDC; const Rect: TRect; Mask: HBitmap);
var
DCfrom, MemDC, MaskDC: HDC;
MemBmp: HBITMAP;
//Save4From,
Save4Mem, Save4Mask: THandle;
crText, crBack: TColorRef;
{$IFDEF FIX_TRANSPBMPPALETTE}
FixBmp: TKOLBitmap;
{$ENDIF FIX_TRANSPBMPPALETTE}
begin
{$IFDEF FIX_TRANSPBMPPALETTE}
if PixelFormat in [ pf4bit, pf8bit ] then
begin
FixBmp := NewBitmap( 0, 0 );
FixBmp.Assign( @ Self );
FixBmp.PixelFormat := pf32bit;
FixBmp.StretchDrawMasked( DC, Rect, Mask );
FixBmp.Free; Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
end;
{$ENDIF FIX_TRANSPBMPPALETTE}
if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
DCFrom := Canvas.Handle;
MaskDC := CreateCompatibleDC( 0 );
Save4Mask := SelectObject( MaskDC, Mask );
{$IFDEF KOL_ASSERTIONS}
ASSERT( Save4Mask <> 0, 'Can not select mask bitmap to DC' );
{$ENDIF KOL_ASSERTIONS}
MemDC := CreateCompatibleDC( 0 );
MemBmp := CreateCompatibleBitmap( DCfrom, fWidth, fHeight );
Save4Mem := SelectObject( MemDC, MemBmp ); if Save4Mem <> 0 then;
{$IFDEF KOL_ASSERTIONS}
ASSERT( Save4Mem <> 0, 'Can not select memory bitmap to DC' );
{$ENDIF KOL_ASSERTIONS}
StretchBlt( MemDC, 0, 0, fWidth, fHeight, MaskDC, 0, 0, fWidth, fHeight, SrcCopy);
{$IFDEF DEBUG_DRAWTRANSPARENT}
DebugDrawTransparent( MemDC, 0, 0, fWidth, fWidth, PixelFormat, '1SrcCopy.bmp' );
{$ENDIF}
StretchBlt( MemDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, fWidth, fHeight, SrcErase);
{$IFDEF DEBUG_DRAWTRANSPARENT}
DebugDrawTransparent( MemDC, 0, 0, fWidth, fWidth, PixelFormat, '2SrcErase.bmp' );
{$ENDIF}
crText := SetTextColor(DC, $0);
crBack := Winapi.Windows.SetBkColor(DC, $FFFFFF);
StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
MaskDC, 0, 0, fWidth, fHeight, SrcAnd);
{$IFDEF DEBUG_DRAWTRANSPARENT}
DebugDrawTransparent( DC, Rect.Left, Rect.Top, fWidth, fHeight, PixelFormat, '3SrcAnd.bmp' );
{$ENDIF}
StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
MemDC, 0, 0, fWidth, fHeight, SrcInvert);
{$IFDEF DEBUG_DRAWTRANSPARENT}
DebugDrawTransparent( DC, Rect.Left, Rect.Top, fWidth, fHeight, PixelFormat, '4SrcInvert.bmp' );
{$ENDIF}
Winapi.Windows.SetBkColor( DC, crBack);
SetTextColor( DC, crText);
DeleteObject(MemBmp);
DeleteDC(MemDC);
SelectObject( MaskDC, Save4Mask );
DeleteDC( MaskDC );
end;
{$ENDIF PAS_VERSION}
procedure ApplyBitmapBkColor2Canvas( Sender: TKOLBitmap );
begin
if Sender.fCanvas = nil then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
Sender.fCanvas.Brush.Color := Sender.BkColor;
end;
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
procedure DetachBitmapFromCanvas( Sender: TKOLBitmap );
begin
if Sender.fCanvasAttached = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
SelectObject( Sender.fCanvas.Handle, Sender.fCanvasAttached );
Sender.fCanvasAttached := 0;
end;
{$ENDIF PAS_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
function TKOLBitmap.GetCanvas: TCanvas;
var DC: HDC;
begin
Result := nil;
if Empty then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
if GetHandle = 0 then Exit; {>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
if fCanvas = nil then
begin
fApplyBkColor2Canvas := ApplyBitmapBkColor2Canvas;
fCanvas := TCanvas.Create; //NewCanvas( 0 );
DC := CreateCompatibleDC( 0 );
fCanvas.Handle := DC;
fCanvasAttached := 0;
fCanvas.Handle := DC;
fCanvas.OnChange := CanvasChanged;
if fBkColor <> 0 then
fCanvas.Brush.Color := fBkColor;
end;
Result := fCanvas;
if fCanvas.Handle = 0 then
begin
DC := CreateCompatibleDC( 0 );
fCanvas.Handle := DC;
fCanvasAttached := 0;
end;
if fCanvasAttached = 0 then
begin
fCanvasAttached := SelectObject( fCanvas.Handle, fHandle );
{$IFDEF KOL_ASSERTIONS}
ASSERT( fCanvasAttached <> 0, 'Can not select bitmap to DC of Canvas' );
{$ENDIF KOL_ASSERTIONS}
end;
fDetachCanvas := DetachBitmapFromCanvas;
end;
{$ENDIF PAS_VERSION}
{$IFDEF ASM_VERSION}{$ELSE PAS_VERSION} //Pascal
function TKOLBitmap.GetEmpty: Boolean;
begin
Result := (fWidth = 0) or (fHeight = 0);
{$IFDEF KOL_ASSERTIONS}
ASSERT( (fWidth >= 0) and (fHeight >= 0), 'Bitmap dimensions can be negative' );
{$ENDIF KOL_ASSERTIONS}
end;
{$ENDIF PAS_VERSION}
{$IFDEF ASM_noVERSION}
function TKOLBitmap.GetHandle: HBitmap;
asm
PUSH EBX
MOV EBX, EAX
CALL GetEmpty
JZ @@exit
MOV EAX, EBX
CALL [EAX].fDetachCanvas
MOV ECX, [EBX].fHandle
INC ECX
LOOP @@exit
MOV ECX, [EBX].fDIBBits
JECXZ @@exit
PUSH ECX
PUSH 0
CALL GetDC
PUSH EAX
PUSH 0
PUSH 0
LEA EDX, [EBX].fDIBBits
PUSH EDX
PUSH DIB_RGB_COLORS
PUSH [EBX].fDIBHeader
PUSH EAX
CALL CreateDIBSection
MOV [EBX].fHandle, EAX
PUSH 0
CALL ReleaseDC
POP EAX
PUSH EAX
MOV EDX, [EBX].fDIBBits
MOV ECX, [EBX].fDIBSize
CALL System.Move
POP EAX
CMP [EBX].fDIBAutoFree, 0