{ @abstract(This unit provides an advanced Windows icon management i.e. replacement for the Graphics.TIcon component) @author(Tomas Krysl (tomkrysl@tkweb.eu)) @created(9 Jan 2005) @lastmod(20 Jun 2010) Copyright © 2005 Tomas Krysl (tomkrysl@@tkweb.eu)

The purpose of the TKIcon component is to replace and expand the standard TIcon component provided by VCL. The TKIcon component is not based on Windows icon functions, but manages the icon structures by itself. License:
This code is distributed as a freeware. You are free to use it as part of your application for any purpose including freeware, commercial and shareware applications. The origin of this source code must not be misrepresented; you must not claim your authorship. You may modify this code solely for your own purpose. Please feel free to contact the author if you think your changes might be useful for other users. You may distribute only the original package. The author accepts no liability for any damage that may result from using this code. } unit KIcon; {$include kcontrols.inc} {$IFNDEF TKICON_REGISTER} {$WEAKPACKAGEUNIT ON} {$ENDIF} interface {$IFDEF USE_WINAPI} uses Windows, SysUtils, Classes, Graphics, KGraphics {$IFDEF USE_PNG_SUPPORT} {$IFDEF FPC} , fpImage, GraphType, IntfGraphics {$ELSE} , PngImage {$ENDIF} {$ENDIF}; resourcestring { @exclude } SVIcons = 'Icons'; { @exclude } SVCursors = 'Cursors'; { @exclude } SIconAllocationError = 'Error while allocating icon data'; { @exclude } SIconBitmapError = 'Invalid icon bitmap handles'; { @exclude } SIconFormatError = 'Invalid icon format'; { @exclude } SIconResourceError = 'Invalid icon resource'; { @exclude } SIconIndexError = 'Invalid icon resource index'; { @exclude } SIconInvalidModule = 'Invalid module or no icon resources'; { @exclude } SIconResizingError = 'Error while resizing icon'; { @exclude } SIconAssocResolveError = 'Error while resolving associated icon'; type {$IFDEF USE_PNG_SUPPORT} { @exclude } TKIconPngObject = TKPngImage; {$ELSE} { @exclude } TKIconPngObject = TMemoryStream; //used to store compressed PNG stream {$ENDIF} { @abstract(Icon file header) } TKIconHeader = packed record idReserved: Word; idType: Word; idCount: Word; end; { Pointer to the icon file header structure } PKIconHeader = ^TKIconHeader; { @abstract(Helper structure identifying attributes that are different for icons and cursors) } TKIconCursorDirInfo = packed record case Integer of 0: ( wPlanes: Word; wBitCount: Word; ); 1: ( wX: Word; wY: Word; ); end; { @abstract(Icon/cursor directory entry. This structure decribes each icon/cursor image. These structures describing all images immediately follow the @link(TKIconHeader) structure in the icon file. After these the bitmap data for all images are stored (TBitmapInfoHeader, palette data, bitmap bits - XOR, AND).) } TKIconCursorDirEntry = packed record Width: Byte; Height: Byte; ColorCount: Byte; Reserved: Byte; Info: TKIconCursorDirInfo; dwBytesInRes: Longint; dwImageOffset: Longint; end; { Pointer to the icon/cursor directory entry } PKIconCursorDirEntry = ^TKIconCursorDirEntry; { Helper structure to typecast cursor hot spot coordinates } TKCursorHotSpot = packed record xHotSpot: Word; yHotSpot: Word; end; { Pointer to the cursor hot spot structure } PKCursorHotSpot = ^TKCursorHotSpot; { Helper structure for cursor specific data in resource file } TKCursorDir = packed record Width: Word; Height: Word; end; { Helper structure for icon specific data in resource file } TKIconResdir = packed record Width: Byte; Height: Byte; ColorCount: Byte; Reserved: Byte; end; { Helper structure merging icon and cursor specific data } TKIconCursorInfo = packed record case Integer of 0: (Icon: TKIconResdir); 1: (Cursor: TKCursorDir); end; { @abstract(Icon/cursor directory entry as found in resource files) } TKIconCursorDirEntryInRes = packed record Info: TKIconCursorInfo; wPlanes: Word; wBitCount: Word; dwBytesInRes: Longint; wEntryName: Word; end; { Pointer to the icon/cursor resource file directory entry } PKIconCursorDirEntryInRes = ^TKIconCursorDirEntryInRes; { Helper structure to access resource data } TKIconCursorInRes = packed record IH: TKIconHeader; Entries: array [0..MaxInt div SizeOf(TKIconCursorDirEntryInRes) - 2] of TKIconCursorDirEntryInRes; end; { Pointer to the helper structure } PKIconCursorInRes = ^TKIconCursorInRes; { Controls how the image should be aligned when they are beeing resized } TKIconAlignStyle = ( { image remains aligned to the top-left corner } asNone, { image will be centered within the new boundary rectangle } asCenter ); { Specifies the width and height of an icon or cursor image } TKIconDimension = record Width, Height: Integer; end; { @abstract(Specifies the GDI handles for one icon/cursor image) } TKIconHandles = record hXOR, hAND: HBITMAP; end; { @abstract(Represents the internal data structure describing each icon/cursor image) } TKIconData = record Width: Integer; Height: Integer; Bpp: Integer; BytesInRes: Integer; Offset: Integer; HotSpot: TPoint; iXOR: PBitmapInfo; iXORSize: Integer; pXOR: Pointer; pXORSize: Integer; hXOR: HBITMAP; pAND: Pointer; pANDSize: Integer; hAND: HBITMAP; IsPNG: Boolean; PNG: TKIconPngObject; end; { Pointer to the internal image description structure } PKIconData = ^TKIconData; { Specifies how the icon image(s) should be rendered. This feature can be used along with the MaskFromColor method to implement a ‘color picker’ for a new mask construction. } TKIconDrawStyle = ( { paint normally } idsNormal, { paint without applying the mask - color bitmap only } idsNoMask, { paint only the mask - monochrome bitmap only } idsMaskOnly, { paint only the alpha channel as grayscale image - only for 32 bit icon bitmaps else paint as with idsNoMask style } idsAlphaChannel ); { KIcon main class. } TKIcon = class(TGraphic) private FAlignStyle: TKIconAlignStyle; FBpp: Integer; FCreating: Boolean; FCurrentIndex: Integer; FCursor: Boolean; FDisplayAll: Boolean; FDisplayHorz: Boolean; FIconCount: Integer; FIconData: array of TKIconData; FIconDrawStyle: TKIconDrawStyle; FInHandleBpp: Integer; FInHandleFullAlpha: Boolean; FMaxHeight: Integer; FMaxWidth: Integer; FOptimalIcon: Boolean; FOverSizeWeight: Single; FRequestedSize: TKIconDimension; FSpacing: Integer; FStretchEnabled: Boolean; function GetDimensions(Index: Integer): TKIconDimension; function GetHandles(Index: Integer): TKIconHandles; function GetHeights(Index: Integer): Integer; function GetHotSpot(Index: Integer): TPoint; function GetIconData(Index: Integer): TKIconData; function GetWidths(Index: Integer): Integer; procedure SetCurrentIndex(Value: Integer); procedure SetDimensions(Index: Integer; Value: TKIconDimension); procedure SetDisplayAll(Value: Boolean); procedure SetDisplayHorz(Value: Boolean); procedure SetHandles(Index: Integer; Value: TKIconHandles); procedure SetHeights(Index: Integer; Value: Integer); procedure SetHotSpot(Index: Integer; Value: TPoint); procedure SetInHandleBpp(Value: Integer); procedure SetIconDrawStyle(Value: TKIconDrawStyle); procedure SetOptimalIcon(Value: Boolean); procedure SetOverSizeWeight(Value: Single); procedure SetRequestedSize(Value: TKIconDimension); procedure SetSpacing(Value: Integer); procedure SetStretchEnabled(Value: Boolean); procedure SetWidths(Index: Integer; Value: Integer); protected { Overriden method - see Delphi help. Calls @link(Update) method. } procedure Changed(Sender: TObject); override; { Overriden method - see Delphi help. } procedure Draw(ACanvas: TCanvas; const Rect: TRect); override; { Overriden method - see Delphi help. } function GetEmpty: Boolean; override; { Overriden method - see Delphi help. } function GetHeight: Integer; override; { Overriden method - see Delphi help. } function GetTransparent: Boolean; override; { Overriden method - see Delphi help. } function GetWidth: Integer; override; { Copies the bitmaps stored in Handles to the icon image identified by Index. If OrigBpp is True, the color resolution for the color bitmap remains unchanged, otherwise the value of InHandleBpp will be used. } procedure LoadHandles(Index: Integer; const Handles: TKIconHandles; OrigBpp: Boolean); { Overriden method - see Delphi help. } procedure SetHeight(Value: Integer); override; { Overriden method - see Delphi help. } procedure SetTransparent(Value: Boolean); override; { Overriden method - see Delphi help. } procedure SetWidth(Value: Integer); override; { Updates @link(MaxWidth), @link(MaxHeight) and @link(CurrentIndex) properties accordingly. } procedure Update; dynamic; { Resizes an icon image identified by Index to new dimensions stored in Value. The AlignStyle property controls the image alignment within the new rectangle. } procedure UpdateDim(Index: Integer; Value: TKIconDimension); public { Overriden method - see Delphi help. } constructor Create; override; { Overriden method - see Delphi help. } destructor Destroy; override; { Adds a new image to the end of the internal image list. You should always specify valid color and mask bitmap handles else an exception will occur. } procedure Add(const Handles: TKIconHandles); { Overriden method - see Delphi help. } procedure Assign(Source: TPersistent); override; { Clears all images so that the instance contains no icon/cursor. } procedure Clear; {$IFDEF FPC}override{$ELSE}dynamic{$ENDIF}; { Copies the icon image into an alpha bitmap identified by Bitmap. Icon image is copied to the alpha bitmap. It icon has alpha channel it is copied as well. Bitmap size will always be matched to the icon image. } procedure CopyToAlphaBitmap(Index: Integer; Bitmap: TKAlphaBitmap); { Copies the icon image into a bitmap identified by Bitmap. Both color and mask image is copied to preserve true transparency. You can use this to pass to Glyph properties (e.g. TSpeedButton). Bitmap properties will always be matched to the icon image. For 32bpp icon images, alpha channel is copied as well. } procedure CopyToBitmap(Index: Integer; Bitmap: TBitmap); {$IFDEF USE_PNG_SUPPORT} { Copies the icon image into a png image identified by Png. It is saved always in truecolor format with alpha channel (32bpp). Png size will always be matched to the icon image. } procedure CopyToPng(Index: Integer; Png: TKPngImage); {$ENDIF} { Creates an icon handle for use with Win32 API icon functions. The image identified by Index will be used for this handle. If DisplayAll is False and Index is out of range, CurrentIndex will be used instead. } function CreateHandle(Index: Integer): HICON; { Deletes an image identified by Index from the internal image list. } procedure Delete(Index: Integer); { Inserts an image at the position identified by Index into the internal image list. The existing images will be preserved and shifted accordingly. } procedure Insert(Index: Integer; const Handles: TKIconHandles); {$IFNDEF FPC} { Overriden method - see Delphi help. Does nothing for icons/cursors. } procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); override; { Loads the icon from the module associated with the file identified by FileName (DefaultIcon registry key). If no association can be found for the file, an exception will be raised and the function will try to load FileName as if it was a module itself. } {$ENDIF} procedure LoadFromAssocFile(const FileName: string); { Loads the icon from the module associated with the file extension identified by Extension (DefaultIcon registry key). The Extension parameter should contain the leading period ('.'). If no association can be found for that extension, an exception will be triggered. } procedure LoadFromAssocExtension(const Extension: string); { Loads the icon from Win32 API icon handle. Please keep in mind that icon bitmaps can't be loaded as DIBs because they are already converted to DDBs when accessible through HICON. So it is impossible to load the icon in it's native format (e.g. as stored in an *.ico file) from HICON. This function has been introduced only to complete the loading schemes of this class and you should rather use another LoadFrom... methods. The behavior of this function can be controlled via the InHandleBpp and InHandleFullAlpha properties. It is not recommended to use this function in new projects. } procedure LoadFromHandle(Handle: HICON); { Loads the icon from resources of a module identified by ModuleName. A valid icon resource must be specified by ID, otherwise an exception occurs. This function uses the LoadLibrary API function, so it is recommended to use the LoadFromResourceX functions to load multiple icons from the same module. ID is of type Word so it can’t exceed 65535. } procedure LoadFromModule(const ModuleName: string; ID: Word); overload; { Does the same thing, but with resource ID specified as string. Let's suppose ID = 123. Here you can pass it as a string '#123'. } procedure LoadFromModule(const ModuleName, ResName: string); overload; { This function does the same as @link(LoadFromModule), but the icon resource is specified by index here. The index stands for the n-th icon stored in the module resources. So, LoadFromModule('dummy.exe', 'MAINICON') would produce the same results as LoadFromModuleByIndex('dummy.exe', 0), provided 'MAINICON' is the first icon resource in 'dummy.exe'. } procedure LoadFromModuleByIndex(const ModuleName: string; Index: Integer); { Loads the icon from resources of a module instance identified by Instance. Further behavior corresponds to @link(LoadFromModule) with resource ID specified as integer. } procedure LoadFromResource(Instance: HINST; ID: Word); overload; { Loads the icon from resources of a module instance identified by Instance. Further behavior corresponds to @link(LoadFromModule) with resource ID specified as string. } procedure LoadFromResource(Instance: HINST; const ResName: string); overload; { Loads the icon from resources of a module instance identified by Instance. Further behavior corresponds to @link(LoadFromModuleByIndex). } procedure LoadFromResourceByIndex(Instance: HINST; Index: Integer); { Loads the icon from the stream. Parses the *.ico file structure. An overriden method. } procedure LoadFromStream(Stream: TStream); override; { Makes it possible to create a new mask bitmap for the image identified by Index. The new monochrome mask bitmap will be created from the color bitmap. Pixels of the color bitmap that match Color will be masked by the new mask, other pixels will be unmasked. If the Color parameter contains alpha channel, you should set HasAlpha to True to perform comparison with the alpha channel. Otherwise, only the red, green and blue channels will be compared. } procedure MaskFromColor(Index: Integer; Color: TColor; HasAlpha: Boolean = False); {$IFNDEF FPC} { Overriden method - see Delphi help. Does nothing for icons/cursors. } procedure SaveToClipboardFormat(var Format: Word; var Data: THandle; var APalette: HPALETTE); override; {$ENDIF} { Saves the icon to the stream. Assembles the *.ico file structure. An overriden method. } procedure SaveToStream(Stream: TStream); override; { Controls the icon image resizing which is performed by the UpdateDim method. } property AlignStyle: TKIconAlignStyle read FAlignStyle write FAlignStyle; { Specifies the index of the currently displayed icon image. If no image is loaded (no icon), the value of CurrentIndex is -1. } property CurrentIndex: Integer read FCurrentIndex write SetCurrentIndex; { Indicates whether the instance of this class represents a cursor (True) or an icon (False). } property Cursor: Boolean read FCursor write FCursor; { Specifies whether all icon images (True) or a single subimage should be drawn (False). When True, all available icon images will be rendered. } property DisplayAll: Boolean read FDisplayAll write SetDisplayAll; { Specifies how the images should be drawn when @link(DisplayAll) is True. If True, the images will be drawn horizontally aligned. If False, the images will be drawn vertically aligned. } property DisplayHorz: Boolean read FDisplayHorz write SetDisplayHorz; { Makes it possible to read/modify the size of an icon image. } property Dimensions[Index: Integer]: TKIconDimension read GetDimensions write SetDimensions; { Makes it possible to read/modify icon image bitmaps (color and mask bitmap). Bitmaps that you pass will be copied and remain unchanged. When reading original bitmap handles are returned and thus must not be modified or released. } property Handles[Index: Integer]: TKIconHandles read GetHandles write SetHandles; { Makes it possible to read/modify the height of an icon image. } property Heights[Index: Integer]: Integer read GetHeights write SetHeights; { For a cursor, this property contains the hot spots for all cursor images. } property HotSpot[Index: Integer]: TPoint read GetHotSpot write SetHotSpot; { Returns the number of images found in this instance. } property IconCount: Integer read FIconCount; { Makes it possible to read the internal data structure of each icon image. A copy of the structure is returned but the pointers or handles are original (no copies are created) and thus must not be modified or released. } property IconData[Index: Integer]: TKIconData read GetIconData; { Affects the icon image rendering. } property IconDrawStyle: TKIconDrawStyle read FIconDrawStyle write SetIconDrawStyle; { Specifies the color resolution a DIB should have after converted from a DDB that has been passed to the LoadHandles method. } property InHandleBpp: Integer read FInHandleBpp write SetInHandleBpp; { Determines whether a DIB with 32 bits per pixel should have full visibility (alpha channel of each pixel set to 0xFF) after converted from a DDB that has been passed to the LoadHandles method. The alpha channel values will be only set to 0xFF when the current alpha channel of every pixel is zero. } property InHandleFullAlpha: Boolean read FInHandleFullAlpha write FInHandleFullAlpha; { Returns the height of the image that has the maximum height of all icon images. When @link(DisplayAll) is True and @link(DisplayHorz) is False, returns the total height of all images and spaces between them (specified by @link(Spacing)). } property MaxHeight: Integer read FMaxHeight; { Returns the width of the image that has the maximum width of all icon images. When both @link(DisplayAll) and @link(DisplayHorz) is True, returns the total width of all images and spaces between them (specified by @link(Spacing)). } property MaxWidth: Integer read FMaxWidth; { This property applies only when DisplayAll is False. It determines whether the icon image corresponding to the RequestedSize property and the current display mode color resolution (True) or the subimage specified by CurrentIndex (False) should be displayed. } property OptimalIcon: Boolean read FOptimalIcon write SetOptimalIcon; { Controls the decision threshold for the optimal image when OptimalIcon is True. The bigger the value is, the less is the probability a subimage greater than RequestedSize will be selected. This value is big enough by default so that almost always a smaller image will be selected if none with the exact size is found. } property OverSizeWeight: Single read FOverSizeWeight write SetOverSizeWeight; { Specifies the preferred image size when OptimalIcon is True. When OverSizeWeight is small, a greater subimage may be often selected. } property RequestedSize: TKIconDimension read FRequestedSize write SetRequestedSize; { Specifies the spacing between icon images when @link(DisplayAll) is True. } property Spacing: Integer read FSpacing write SetSpacing; { Specifies whether icon images can be stretched when drawn. This property was introduced perhaps only for backward compatibility with Graphics.TIcon. } property StretchEnabled: Boolean read FStretchEnabled write SetStretchEnabled; { Makes it possible to read/modify the width of an icon image. } property Widths[Index: Integer]: Integer read GetWidths write SetWidths; end; { This class is necessary because of the TPicture streaming. } TIcon = class(TKIcon); { Creates a bitmap from an icon object stored in application resources. } function CreateBitmapFromResIcon(const ResName: string; ResType: PChar = RT_ICON): TBitmap; { Creates an alpha bitmap from an icon object stored in application resources. } function CreateAlphaBitmapFromResIcon(const ResName: string; ResType: PChar): TKAlphaBitmap; { Returns the str1ucture containing hXOR and hAND bitmaps. } function MakeHandles(hXOR, hAND: HBITMAP): TKIconHandles; { Returns the total number of resources of a type specified by ResType in a module identified by Instance. } function GetModuleResourceCount(Instance: HINST; ResType: PChar): Integer; { Returns the total number of HW-independent icon resources in a module identified by Instance. } function GetModuleIconCount(Instance: HINST): Integer; overload; { Returns the total number of HW-independent icon resources in a module identified by ModuleName. } function GetModuleIconCount(const ModuleName: string): Integer; overload; { Integrates KIcon into TPicture. } procedure RegisterKIcon; { Removes KIcon from TPicture. } procedure UnregisterKIcon; {$ENDIF} implementation {$IFDEF USE_WINAPI} uses Math, Registry, KFunctions; type TKMaskBitmapInfo = packed record Header: TBitmapInfoHeader; Black, White: TRGBQuad; end; procedure FreeSubimage(PID: PKIconData); begin FreeMem(PID.iXOR); if PID.hXOR <> 0 then DeleteObject(PID.hXOR); if PID.hAND <> 0 then DeleteObject(PID.hAND); PID.PNG.Free; FillChar(PID^, SizeOf(TKIconData), 0); end; function CalcByteWidth(Width, Bpp: Integer): Integer; begin Result := DivUp(Width * Bpp, SizeOf(LongWord) shl 3) * SizeOf(LongWord); end; function CalcBitmapSize(Width, Height, Bpp: Integer): Integer; begin Result := CalcByteWidth(Width, Bpp) * Height; end; procedure CalcByteWidths(Width, Bpp: Integer; out XORWidth, ANDWidth: Integer); begin XORWidth := CalcByteWidth(Width, Bpp); ANDWidth := CalcByteWidth(Width, 1); end; procedure CalcBitmapSizes(Width, Height, Bpp: Integer; out XORSize, ANDSize: Integer); begin XORSize := CalcBitmapSize(Width, Height, Bpp); ANDSize := CalcBitmapSize(Width, Height, 1); end; function GetPaletteSize(Bpp: Integer): Integer; begin if Bpp <= 8 then Result := 1 shl Bpp else Result := 0; end; procedure QueryBitmapBits(DC: HDC; hBmp: HBITMAP; var Bits: Pointer; var Size: Integer); var BInfo: Windows.TBitmap; BI: TBitmapInfo; begin GetObject(hBmp, SizeOf(Windows.TBitmap), @BInfo); Size := CalcBitmapSize(BInfo.bmWidth, BInfo.bmHeight, BInfo.bmBitsPixel); GetMem(Bits, Size); FillChar(BI, SizeOf(TBitmapInfo), 0); with BI.bmiHeader do begin biSize := SizeOf(TBitmapInfoHeader); biWidth := BInfo.bmWidth; biHeight := BInfo.bmHeight; biPlanes := 1; biBitCount := BInfo.bmBitsPixel; biCompression := BI_RGB; end; GetDIBits(DC, hBmp, 0, BInfo.bmHeight, Bits, BI, DIB_RGB_COLORS); end; procedure CreateColorInfo(Width, Height, Bpp: Integer; var BI: PBitmapInfo; var InfoSize: Integer); begin InfoSize := SizeOf(TBitmapInfoHeader) + GetPaletteSize(Bpp) * SizeOf(TRGBQuad); GetMem(BI, InfoSize); FillChar(BI^, InfoSize, 0); with BI.bmiHeader do begin biSize := SizeOf(TBitmapInfoHeader); biWidth := Width; biHeight := Height; biPlanes := 1; biBitCount := Bpp; end; end; procedure CreateMaskInfo(Width, Height: Integer; var BIMask: TKMaskBitmapInfo); begin FillChar(BIMask, SizeOf(TKMaskBitmapInfo), 0); with BIMask.Header do begin biSize := SizeOf(TBitmapInfoHeader); biWidth := Width; biHeight := Height; biPlanes := 1; biBitCount := 1; end; Cardinal(BIMask.Black) := clBlack; Cardinal(BIMask.White) := clWhite; end; function CreateMonochromeBitmap(Width, Height: Integer): HBITMAP; begin Result := GDICheck(CreateBitmap(Width, Height, 1, 1, nil)); end; procedure MaskOrBitBlt(ACanvas: TCanvas; X, Y, Width, Height: Integer; DC_XOR, DC_AND: HDC; BM_XOR, BM_AND: HBITMAP; XORBits: PKColorRecs; XORSize: Integer; ANDBits: PBytes; ANDSize: Integer; Bpp: Integer; Style: TKIconDrawStyle); var I, J, K, LAnd: Integer; Alpha, ByteMask: Byte; FreeBits: Boolean; Q: PBytes; Ps, Pd: PKColorRecs; BMSrc, BMDest: TKAlphaBitmap; R: TRect; begin if Style <> idsMaskOnly then begin BMSrc := TKAlphaBitmap.Create; try BMDest := TKAlphaBitmap.Create; try R := Rect(X, Y, X + Width, Y + Height); BMSrc.SetSize(Width, Height); if Bpp = 32 then begin // perform alphablend if XORBits = nil then begin QueryBitmapBits(DC_XOR, BM_XOR, Pointer(XORBits), XORSize); FreeBits := True; end else FreeBits := False; try if Style = idsAlphaChannel then begin for I := 0 to Height - 1 do begin Ps := BMSrc.ScanLine[I]; K := I * Width; for J := 0 to Width - 1 do begin Alpha := 255 - XORBits[K + J].A; Ps[J].R := Alpha; Ps[J].G := Alpha; Ps[J].B := Alpha; end; end; end else begin BMSrc.DrawFrom(ACanvas, R); for I := 0 to Height - 1 do begin Ps := @XORBits[I * Width]; Pd := BMSrc.ScanLine[I]; BlendLine(Ps, Pd, Width); end end finally if FreeBits then FreeMem(XORBits); end; end else BitBlt(BMSrc.Canvas.Handle, 0, 0, Width, Height, DC_XOR, 0, 0, SRCCOPY); if Style = idsNormal then begin BMDest.SetSize(Width, Height); BMDest.DrawFrom(ACanvas, R); if ANDBits = nil then begin QueryBitmapBits(DC_XOR, BM_AND, Pointer(ANDBits), ANDSize); FreeBits := True; end else FreeBits := False; if ANDBits <> nil then begin try LAnd := CalcByteWidth(Width, 1); Q := ANDBits; for I := 0 to Height - 1 do begin Ps := BMSrc.ScanLine[I]; Pd := BMDest.ScanLine[I]; ByteMask := $80; for J := 0 to Width - 1 do begin if Q[J shr 3] and ByteMask <> 0 then Ps[J] := Pd[J]; asm ror ByteMask, 1 end; end; Inc(Cardinal(Q), LAnd); end; finally if FreeBits then FreeMem(ANDBits); end; end; end; BMSrc.DrawTo(ACanvas, R); finally BMDest.Free; end; finally BMSrc.Free; end; end else begin if DC_AND = 0 then begin DC_AND := CreateCompatibleDC(ACanvas.Handle); try SelectObject(DC_AND, BM_AND); BitBlt(ACanvas.Handle, X, Y, Width, Height, DC_AND, 0, 0, SrcCopy); finally DeleteDC(DC_AND); end; end else BitBlt(ACanvas.Handle, X, Y, Width, Height, DC_AND, 0, 0, SrcCopy); end; end; procedure FillAlphaIfNone(Pixels: PKColorRecs; Size: Integer; Alpha: Byte); var I: Integer; begin Size := Size shr 2; for I := 0 to Size - 1 do if Pixels[I].A <> 0 then Exit; // bitmap has a nonempty alpha channel, don't fill for I := 0 to Size - 1 do Pixels[I].A := Alpha; end; function CreateBitmapFromResIcon(const ResName: string; ResType: PChar): TBitmap; var Icon: TKIcon; Stream: TResourceStream; begin Result := TBitmap.Create; Icon := TKIcon.Create; try Stream := TResourceStream.Create(HInstance, ResName, ResType); try Icon.LoadFromStream(Stream); Icon.CopyToBitmap(Icon.CurrentIndex, Result); finally Stream.Free; end; finally Icon.Free; end; end; function CreateAlphaBitmapFromResIcon(const ResName: string; ResType: PChar): TKAlphaBitmap; var Icon: TKIcon; Stream: TResourceStream; begin Result := TKAlphaBitmap.Create; Icon := TKIcon.Create; try Stream := TResourceStream.Create(HInstance, ResName, ResType); try Icon.LoadFromStream(Stream); Icon.CopyToAlphaBitmap(Icon.CurrentIndex, Result); finally Stream.Free; end; finally Icon.Free; end; end; procedure InternalCopyToAlphaBitmap(ABitmap: TKAlphaBitmap; BM_XOR: HBITMAP; AndBits: PBytes; Bpp: Integer); var I, J, LAnd: Integer; ByteMask: Byte; Q: PBytes; Ps: PKColorRecs; DC: HDC; begin if (ABitmap <> nil) and (AndBits <> nil) and (BM_XOR <> 0) then begin DC := CreateCompatibleDC(0); try SelectObject(DC, BM_XOR); BitBlt(ABitmap.Canvas.Handle, 0, 0, ABitmap.Width, ABitmap.Height, DC, 0, 0, SRCCOPY); LAnd := CalcByteWidth(ABitmap.Width, 1); Q := ANDBits; for I := 0 to ABitmap.Height - 1 do begin Ps := ABitmap.ScanLine[I]; ByteMask := $80; for J := 0 to ABitmap.Width - 1 do begin if Q[J shr 3] and ByteMask <> 0 then Ps[J].A := 0 else if Bpp < 32 then Ps[J].A := 255; asm ror ByteMask, 1 end; end; Inc(Cardinal(Q), LAnd); end; finally DeleteDC(DC); end; end; end; function MakeHandles(hXOR, hAND: HBITMAP): TKIconHandles; begin Result.hXOR := hXOR; Result.hAND := hAND; end; function GetModuleResourceCount(Instance: HINST; ResType: PChar): Integer; function EnumIcons(hModule: HINST; lpType, lpName: PChar; dwParam: DWORD): BOOL; stdcall; begin Inc(PInteger(dwParam)^); Result := True; end; begin Result := 0; EnumResourceNames(Instance, ResType, @EnumIcons, DWORD(@Result)); end; function GetModuleIconCount(Instance: HINST): Integer; begin Result := GetModuleResourceCount(Instance, RT_GROUP_ICON); end; function GetModuleIconCount(const ModuleName: string): Integer; var Module: HINST; begin Result := 0; Module := LoadLibraryEx(PChar(ModuleName), 0, LOAD_LIBRARY_AS_DATAFILE); if Module <> 0 then begin try Result := GetModuleIconCount(Module); finally FreeLibrary(Module); end; end; end; { TKIcon } constructor TKIcon.Create; begin inherited Create; FCreating := True; try Transparent := True; // we are not in Graphics.pas... finally FCreating := False; end; FAlignStyle := asCenter; FCursor := False; FDisplayAll := False; FIconDrawStyle := idsNormal; FInHandleBpp := 0; FInHandleFullAlpha := True; FIconData := nil; FOptimalIcon := True; FOverSizeWeight := 1000.0; // virtually always selects a lower resolution image FRequestedSize.Width := 32; FRequestedSize.Height := 32; FSpacing := 2; FStretchEnabled := True; Clear; end; destructor TKIcon.Destroy; begin Clear; inherited Destroy; end; procedure TKIcon.Add(const Handles: TKIconHandles); begin Inc(FIconCount); SetLength(FIconData, FIconCount); FillChar(FIconData[FIconCount - 1], SizeOf(TKIconData), 0); LoadHandles(FIconCount - 1, Handles, True); end; procedure TKIcon.Assign(Source: TPersistent); var MS: TMemoryStream; begin if (Source = nil) or (Source is TKIcon) then begin Clear; if Source <> nil then begin FAlignStyle := TKIcon(Source).AlignStyle; FCursor := TKIcon(Source).Cursor; FDisplayAll := TKIcon(Source).DisplayAll; FIconDrawStyle := TKIcon(Source).IconDrawStyle; FInHandleBpp := TKIcon(Source).InHandleBpp; FInHandleFullAlpha := TKIcon(Source).InHandleFullAlpha; FOptimalIcon := TKIcon(Source).OptimalIcon; FOverSizeWeight := TKIcon(Source).OverSizeWeight; FRequestedSize := TKIcon(Source).RequestedSize; FSpacing := TKIcon(Source).Spacing; FStretchEnabled := TKIcon(Source).StretchEnabled; if not TKIcon(Source).Empty then begin MS := TMemoryStream.Create; try TKIcon(Source).SaveToStream(MS); MS.Position := 0; LoadFromStream(MS); FCurrentIndex := TKIcon(Source).CurrentIndex; finally MS.Free; end; end else Changed(Self); end else Changed(Self); Exit; end; inherited Assign(Source); end; procedure TKIcon.Changed(Sender: TObject); begin Update; inherited; end; procedure TKIcon.Clear; var I: Integer; begin if FIconData <> nil then begin for I := 0 to FIconCount - 1 do FreeSubimage(@FIconData[I]); FIconData := nil; end; FIconCount := 0; Update; end; procedure TKIcon.CopyToAlphaBitmap(Index: Integer; Bitmap: TKAlphaBitmap); var ID: TKIconData; {$IFDEF USE_PNG_SUPPORT} I, J: Integer; C: TKColorRec; {$IFDEF FPC} IM: TLazIntfImage; FC: TFPColor; {$ENDIF} {$ENDIF} begin if (Index >= 0) and (Index < FIconCount) and (Bitmap <> nil) then begin ID := FIconData[Index]; Bitmap.SetSize(ID.Width, ID.Height); Bitmap.DirectCopy := True; try if ID.IsPng then begin {$IFDEF USE_PNG_SUPPORT} {$IFDEF FPC} IM := ID.PNG.CreateIntfImage; try for I := 0 to ID.Width - 1 do for J := 0 to ID.Height - 1 do begin FC := IM.Colors[I, J]; C.A := FC.alpha; C.B := FC.blue; C.R := FC.red; C.G := FC.green; Bitmap.Pixel[I, J] := C; end; finally IM.Free; end; {$ELSE} for I := 0 to ID.Width - 1 do for J := 0 to ID.Height - 1 do begin C.Value := ID.PNG.Pixels[I, J]; C.A := ID.PNG.AlphaScanline[J][I]; Bitmap.Pixel[I, J] := C; end; {$ENDIF} {$ENDIF} end else InternalCopyToAlphaBitmap(Bitmap, ID.hXOR, ID.pAND, ID.Bpp); finally Bitmap.DirectCopy := False; end; end; end; procedure TKIcon.CopyToBitmap(Index: Integer; Bitmap: TBitmap); var DC: HDC; ID: TKIconData; Mask: TBitmap; begin if (Index >= 0) and (Index < FIconCount) and (Bitmap <> nil) then begin ID := FIconData[Index]; {$IFDEF FPC} Bitmap.PixelFormat := PixelFormatFromBpp(ID.Bpp); {$ELSE} Bitmap.PixelFormat := pf32bit; {$ENDIF} Bitmap.Width := ID.Width; // SetSize not supported prior Delphi 2006 Bitmap.Height := ID.Height; if ID.IsPng then {$IFDEF USE_PNG_SUPPORT} Bitmap.Canvas.Draw(0, 0, ID.PNG) {$ENDIF} else begin Mask := TBitmap.Create; try Mask.MonoChrome := True; Mask.Width := ID.Width; Mask.Height := ID.Height; DC := CreateCompatibleDC(0); try SelectObject(DC, ID.hXOR); BitBlt(Bitmap.Canvas.Handle, 0, 0, ID.Width, ID.Height, DC, 0, 0, SRCCOPY); SelectObject(DC, ID.hAND); BitBlt(Mask.Canvas.Handle, 0, 0, ID.Width, ID.Height, DC, 0, 0, SRCCOPY); Bitmap.MaskHandle := Mask.ReleaseHandle; finally DeleteDC(DC); end; finally Mask.Free; end; end; end; end; {$IFDEF USE_PNG_SUPPORT} procedure TKIcon.CopyToPng(Index: Integer; Png: TKPngImage); var ID: TKIconData; {$IFNDEF FPC} I, J: Integer; C: TKColorRec; Bitmap: TKAlphaBitmap; {$ENDIF} begin if (Index >= 0) and (Index < FIconCount) and (Png <> nil) then begin ID := FIconData[Index]; if ID.IsPNG then Png.Assign(ID.PNG) else begin {$IFDEF FPC} Png.LoadFromBitmapHandles(ID.hXOR, ID.hAND); {$ELSE} Bitmap := TKAlphaBitmap.Create; try Bitmap.SetSize(ID.Width, ID.Height); Bitmap.DirectCopy := True; InternalCopyToAlphaBitmap(Bitmap, ID.hXOR, ID.pAND, ID.Bpp); Png.CreateBlank(COLOR_RGBALPHA, 8, ID.Width, ID.Height); for I := 0 to ID.Width - 1 do for J := 0 to ID.Height - 1 do begin C := Bitmap.Pixel[I, J]; Png.Pixels[I, J] := C.Value; Png.AlphaScanline[J][I] := C.A; end; finally Bitmap.Free; end; {$ENDIF} end; end; end; {$ENDIF} function TKIcon.CreateHandle(Index: Integer): HICON; var ABpp, ANDSize, XORSize: Integer; PID: PKIconData; PBI: PBitmapInfo; DC: HDC; hBmp: HBITMAP; ANDBits, XORBits: Pointer; begin Result := 0; if FIconData <> nil then begin DC := GetDC(0); try ABpp := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL); if ABpp <> FBpp then Update; if FDisplayAll then begin if (Index < 0) or (Index >= FIconCount) then Index := 0; end else if (Index < 0) or (Index >= FIconCount) then Index := FCurrentIndex; PID := @FIconData[Index]; CalcBitmapSizes(PID.Width, PID.Height, FBpp, XORSize, ANDSize); GetMem(XORBits, XORSize); try GetMem(ANDBits, XORSize); try PBI := PID.iXOR; hBmp := GDICheck(CreateDIBitmap(DC, PBI.bmiHeader, CBM_INIT, PID.pXOR, PBI^, DIB_RGB_COLORS)); try GetBitmapBits(hBmp, XORSize, XORBits); // obsolete, but the only that works fine... GetBitmapBits(PID.hAND, ANDSize, ANDbits); Result := CreateIcon(HInstance, PID.Width, PID.Height, 1, FBpp, ANDBits, XORBits); finally if hBmp <> 0 then DeleteObject(hBmp); end; finally FreeMem(ANDBits); end; finally FreeMem(XORBits); end; finally ReleaseDC(0, DC); end; end end; procedure TKIcon.Delete(Index: Integer); var I: Integer; begin if (Index >= 0) and (Index < FIconCount) then begin FreeSubimage(@FIconData[Index]); for I := Index + 1 to FIconCount - 1 do FIconData[I - 1] := FIconData[I]; Dec(FIconCount); SetLength(FIconData, FIconCount); Changed(Self); end; end; procedure TKIcon.Draw(ACanvas: TCanvas; const Rect: TRect); procedure Display(const P, WH: TPoint; Index: Integer); var ID: TKIconData; Stretch: Boolean; DC, DC_XOR, DC_AND: HDC; BM_XOR, BM_AND: HBITMAP; Obj, Obj_XOR, Obj_AND: HGDIObj; begin if (Index >= 0) and (Index < FIconCount) then begin ID := FIconData[Index]; if ID.IsPNG then begin {$IFDEF USE_PNG_SUPPORT} ACanvas.StretchDraw(Classes.Rect(P.X, P.Y, P.X + WH.X, P.Y + WH.Y), ID.PNG); {$ENDIF} end else begin Stretch := FStretchEnabled and ((WH.X <> ID.Width) or (WH.Y <> ID.Height)); DC := GDICheck(CreateCompatibleDC(0)); try Obj := SelectObject(DC, ID.hXOR); if Stretch then begin DC_XOR := GDICheck(CreateCompatibleDC(DC)); try BM_XOR := GDICheck(CreateCompatibleBitmap(DC, WH.X, WH.Y)); try DC_AND := GDICheck(CreateCompatibleDC(DC)); try BM_AND := GDICheck(CreateMonochromeBitmap(WH.X, WH.Y)); try Obj_XOR := SelectObject(DC_XOR, BM_XOR); Obj_AND := SelectObject(DC_AND, BM_AND); //SetStretchBltMode(DC_XOR, HALFTONE); //does not distribute alpha channel etc. StretchBlt(DC_XOR, 0, 0, WH.X, WH.Y, DC, 0, 0, ID.Width, ID.Height, SRCCOPY); SelectObject(DC, ID.hAND); StretchBlt(DC_AND, 0, 0, WH.X, WH.Y, DC, 0, 0, ID.Width, ID.Height, SRCCOPY); MaskOrBitBlt(ACanvas, P.X, P.Y, WH.X, WH.Y, DC_XOR, DC_AND, BM_XOR, BM_AND, nil, 0, nil, 0, ID.Bpp, FIconDrawStyle); SelectObject(DC_XOR, Obj_XOR); SelectObject(DC_AND, Obj_AND); finally DeleteObject(BM_AND); end; finally DeleteDC(DC_AND); end; finally DeleteObject(BM_XOR); end; finally DeleteDC(DC_XOR); end; end else MaskOrBitBlt(ACanvas, P.X, P.Y, ID.Width, ID.Height, DC, 0, ID.hXOR, ID.hAND, ID.pXOR, ID.pXORSize, ID.pAND, ID.pANDSize, ID.Bpp, FIconDrawStyle); SelectObject(DC, Obj); finally DeleteDC(DC); end; end; end; end; var ABpp, AWidth, AHeight, I: Integer; P, WH, WH_S: TPoint; begin with ACanvas do if FIconData <> nil then begin P := Rect.TopLeft; WH := Point(Rect.Right - Rect.Left, Rect.Bottom - Rect.Top); if not FStretchEnabled then begin Inc(P.X, (WH.X - Width) div 2); Inc(P.Y, (WH.Y - Height) div 2); end; if FDisplayAll then begin AWidth := Width; AHeight := Height; WH_S := WH; for I := 0 to FIconCount - 1 do begin WH_S.X := FIconData[I].Width * WH.X div AWidth; WH_S.Y := FIconData[I].Height * WH.Y div AHeight; Display(P, WH_S, I); if FDisplayHorz then Inc(P.X, (FIconData[I].Width + FSpacing) * WH.X div AWidth) else Inc(P.Y, (FIconData[I].Height + FSpacing) * WH.Y div AHeight) end; end else begin ABpp := GetDeviceCaps(Handle, PLANES) * GetDeviceCaps(Handle, BITSPIXEL); if ABpp <> FBpp then Update; Display(P, WH, FCurrentIndex); end; end; end; function TKIcon.GetDimensions(Index: Integer): TKIconDimension; begin Result.Width := 0; Result.Height := 0; if (Index >= 0) and (Index < FIconCount) then begin Result.Width := FIconData[Index].Width; Result.Height := FIconData[Index].Height; end; end; function TKIcon.GetEmpty: Boolean; begin Result := FIconData = nil; end; function TKIcon.GetHandles(Index: Integer): TKIconHandles; begin if (Index >= 0) and (Index < FIconCount) then begin Result.hXOR := FIconData[Index].hXOR; Result.hAND := FIconData[Index].hAND; end else begin Result.hXOR := 0; Result.hAND := 0; end; end; function TKIcon.GetHeight: Integer; begin if FDisplayAll and (FIconCount > 0) then Result := FMaxHeight else Result := Heights[FCurrentIndex]; end; function TKIcon.GetTransparent: Boolean; begin Result := True; end; function TKIcon.GetHeights(Index: Integer): Integer; begin Result := 0; if (Index >= 0) and (Index < FIconCount) then Result := FIconData[Index].Height; end; function TKIcon.GetHotSpot(Index: Integer): TPoint; begin Result.X := 0; Result.Y := 0; if (Index >= 0) and (Index < FIconCount) then Result := FIconData[Index].HotSpot; end; function TKIcon.GetIconData(Index: Integer): TKIconData; begin FillChar(Result, SizeOf(TKIconData), #0); if (Index >= 0) and (Index < FIconCount) then Result := FIconData[Index]; end; function TKIcon.GetWidth: Integer; begin if FDisplayAll and (FIconCount > 0) then Result := FMaxWidth else Result := Widths[FCurrentIndex]; end; function TKIcon.GetWidths(Index: Integer): Integer; begin Result := 0; if (Index >= 0) and (Index < FIconCount) then Result := FIconData[Index].Width; end; procedure TKIcon.Insert(Index: Integer; const Handles: TKIconHandles); var I: Integer; begin if Index >= 0 then if Index < FIconCount then begin Inc(FIconCount); SetLength(FIconData, FIconCount); for I := FIconCount - 2 downto Index do FIconData[I + 1] := FIconData[I]; FillChar(FIconData[Index], SizeOf(TKIconData), 0); LoadHandles(Index, Handles, True); end else Add(Handles); end; {$IFNDEF FPC} procedure TKIcon.LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); begin // does nothing end; {$ENDIF} procedure TKIcon.LoadFromHandle(Handle: HICON); var Handles: TKIconHandles; Info: TIconInfo; begin if (Handle <> 0) and GetIconInfo(Handle, Info) then try Clear; SetLength(FIconData, 1); FillChar(FIconData[0], SizeOf(TKIconData), 0); FIconCount := 1; Handles.hXOR := Info.hbmColor; Handles.hAND := Info.hbmMask; LoadHandles(0, Handles, False); finally DeleteObject(Info.hbmColor); DeleteObject(Info.hbmMask); end; end; procedure TKIcon.LoadFromAssocFile(const FileName: string); begin try LoadFromAssocExtension(ExtractFileExt(FileName)); except LoadFromModuleByIndex(FileName, 0); end; end; procedure TKIcon.LoadFromAssocExtension(const Extension: string); const IconKey = 'DefaultIcon'; var Code, DashPos, I: Integer; Module, S, T: string; Reg: TRegistry; begin if Extension = '' then Error(SIconAssocResolveError); Reg := TRegistry.Create(KEY_READ); try Reg.RootKey := HKEY_CLASSES_ROOT; if not Reg.KeyExists(Extension) then Error(SIconAssocResolveError); Reg.OpenKeyReadOnly(Extension); try S := Reg.ReadString(''); finally Reg.CloseKey; end; if S = '' then Error(SIconAssocResolveError); S := Format('%s\%s', [S, IconKey]); if not Reg.KeyExists(S) then Error(SIconAssocResolveError); Reg.OpenKeyReadOnly(S); try S := Reg.ReadString(''); if S = '' then Error(SIconAssocResolveError); finally Reg.CloseKey; end; finally Reg.Free; end; DashPos := Pos(',', S); if DashPos > 1 then Module := Copy(S, 1, DashPos - 1) else Module := S; while CharInSetEx(Module[1], [#9, #32, '''', '"']) do System.Delete(Module, 1, 1); while CharInSetEx(Module[Length(Module)], [#9, #32, '''', '"']) do System.Delete(Module, Length(Module), 1); if Module[1] = '%' then begin System.Delete(Module, 1, 1); I := Pos('%', Module); if I >= 1 then begin T := GetEnvironmentVariable(Copy(Module, 1, I - 1)); if T <> '' then begin System.Delete(Module, 1, I); Module := T + Module; end; end; end; if not FileExists(Module) then Error(SIconAssocResolveError); T := LowerCase(ExtractFileExt(Module)); if T = '.ico' then LoadFromFile(Module) else begin if DashPos > 0 then begin T := Copy(S, DashPos + 1, Length(S)); while CharInSetEx(T[1], [#9, #32]) do System.Delete(T, 1, 1); Val(T, I, Code); end else begin I := 0; Code := 0; end; if (Code = 0) and (I >= 0) then LoadFromModuleByIndex(Module, I) else begin if Code = 0 then T[1] := '#'; LoadFromModule(Module, T); end; end; end; procedure TKIcon.LoadFromModule(const ModuleName: string; ID: Word); begin LoadFromModule(ModuleName, Format('#%d', [ID])); end; procedure TKIcon.LoadFromModule(const ModuleName, ResName: string); var Module: HINST; begin Module := LoadLibraryEx(PChar(ModuleName), 0, LOAD_LIBRARY_AS_DATAFILE); if Module = 0 then Error(SIconInvalidModule); try LoadFromResource(Module, ResName); finally FreeLibrary(Module); end; end; procedure TKIcon.LoadFromModuleByIndex(const ModuleName: string; Index: Integer); var Module: HINST; begin Module := LoadLibraryEx(PChar(ModuleName), 0, LOAD_LIBRARY_AS_DATAFILE); if Module = 0 then Error(SIconInvalidModule); try LoadFromResourceByIndex(Module, Index); finally FreeLibrary(Module); end; end; procedure TKIcon.LoadFromResource(Instance: HINST; ID: Word); begin LoadFromResource(Instance, Format('#%d', [ID])); end; procedure TKIcon.LoadFromResource(Instance: HINST; const ResName: string); const ResGroup: array[Boolean] of PChar = (RT_GROUP_ICON, RT_GROUP_CURSOR); ResItem: array[Boolean] of PChar = (RT_ICON, RT_CURSOR); var I, L, IconName, ANDSize, PalSize, XORInfoSize, XORSize: Integer; Masked: Boolean; PIC: PKIconCursorInRes; PBIn: PBitmapInfo; PID: PKIcondata; BIMask: TKMaskBitmapInfo; hGroup, hItem: HRSRC; hMemGroup, hMem: HGLOBAL; DC: HDC; HSign: TKImageHeaderString; {$IFDEF USE_PNG_SUPPORT} Stream: TMemoryStream; {$ENDIF} function GetResSize(Instance: HINST; Entry : PKIconCursorDirEntryInRes) : integer; var Rsrc: HRSRC; C: Cardinal; begin Result := Entry.dwBytesInRes; Rsrc := FindResource(Instance, Pointer(Entry.wEntryName), RT_ICON); if Rsrc <> 0 then begin C := SizeofResource(Instance,Rsrc); if C <> 0 then // maybe if C > Result ?? Result := C; end; end; begin hGroup := FindResource(Instance, PChar(ResName), ResGroup[FCursor]); if hGroup = 0 then Error(SIconResourceError); hMemGroup := LoadResource(Instance, hGroup); if hMemGroup = 0 then Error(SIconResourceError); PIC := LockResource(hMemGroup); if (PIC.IH.idType = 1) and FCursor or (PIC.IH.idType = 2) and not FCursor then Error(SIconResourceError); DC := GetDC(0); try Clear; FIconCount := PIC.IH.idCount; SetLength(FIconData, FIconCount); FillChar(FIconData[0], SizeOf(TKIconData) * FIconCount, 0); for I := 0 to PIC.IH.idCount - 1 do begin IconName := PIC.Entries[I].wEntryName; hItem := FindResource(Instance, PChar(IconName), ResItem[FCursor]); if hItem = 0 then Error(SIconResourceError); hMem := LoadResource(Instance, hItem); if hMem = 0 then Error(SIconResourceError); PBIn := LockResource(hMem); try PID := @FIconData[I]; try if FCursor then begin PID.Width := PIC.Entries[I].Info.Cursor.Width; PID.Height := PIC.Entries[I].Info.Cursor.Height; PID.HotSpot.X := PKCursorHotSpot(PBIn).xHotSpot; PID.HotSpot.Y := PKCursorHotSpot(PBIn).yHotSpot; Inc(Integer(PBIn), SizeOf(TKCursorHotSpot)); end else begin PID.Width := PIC.Entries[I].Info.Icon.Width; PID.Height := PIC.Entries[I].Info.Icon.Height; end; if PID.Width = 0 then PID.Width := 256; if PID.Height = 0 then PID.Height := 256; // PID.BytesInRes := PIC.Entries[I].dwBytesInRes; // gigo PID.BytesInRes := GetResSize(Instance,@PIC.Entries[I]); PID.Bpp := PIC.Entries[I].wBitCount; L := Min(8, PID.BytesInRes); Byte(HSign[0]) := L; Move(PBIn^, HSign[1], L); if (HSign = PNGHeader) or (HSign = MNGHeader) then begin PID.IsPNG := True; PID.PNG := TKIconPngObject.Create; {$IFDEF USE_PNG_SUPPORT} Stream := TMemoryStream.Create; try Stream.Write(PBIn^, PID.BytesInRes); Stream.Seek(0, soFromBeginning); PID.PNG.LoadFromStream(Stream); finally Stream.Free; end; {$ELSE} PID.PNG.Write(PBIn^, PID.BytesInRes); {$ENDIF} end else begin //PID.Bpp := PIC.Entries[I].wBitCount; // this is wrong in some icons PID.Bpp := PBIn.bmiHeader.biBitCount; PID.Width := PBIn.bmiHeader.biWidth; // gigo PID.Height := PBIn.bmiHeader.biHeight shr 1; // gigo CalcBitmapSizes(PID.Width, PID.Height, PID.Bpp, XORSize, ANDSize); PalSize := GetPaletteSize(PID.Bpp); XORInfoSize := SizeOf(TBitmapInfoHeader) + PalSize * SizeOf(TRGBQuad); Masked := PID.BytesInRes = XORInfoSize + XORSize + ANDSize; if not Masked then Error(SIconFormatError); GetMem(PID.iXOR, XORInfoSize); PID.iXORSize := XORInfoSize; Move(PBIn^, PID.iXOR^, XORInfoSize); PID.iXOR.bmiHeader.biHeight := PID.iXOR.bmiHeader.biHeight div 2; PID.hXOR := GDICheck(CreateDIBSection(DC, PID.iXOR^, DIB_RGB_COLORS, PID.pXOR, 0, 0)); if PID.pXOR <> nil then begin Move(Pointer(Cardinal(PBIn) + Cardinal(XORInfoSize))^, PID.pXOR^, XORSize); PID.pXORSize := XORSize; end else Error(SIconAllocationError); CreateMaskInfo(PID.Width, PID.Height, BIMask); PID.hAND := GDICheck(CreateDIBSection(DC, PBitmapInfo(@BIMask)^, DIB_RGB_COLORS, PID.pAND, 0, 0)); if PID.pAND <> nil then begin Move(Pointer(Cardinal(PBIn) + Cardinal(XORInfoSize + XORSize))^, PID.pAND^, ANDSize); PID.pANDSize := ANDSize; end else Error(SIconAllocationError); end; except FreeSubimage(PID); raise; end; finally UnlockResource(hMem); // this is not necessary, but... FreeResource(hMem); end; end; finally ReleaseDC(0, DC); UnlockResource(hMemGroup); // this is not necessary, but... FreeResource(hMemGroup); end; Changed(Self); end; type PCallBack = ^TCallBack; TCallBack = record I, Index: Integer; S: string; end; function EnumIcons(hModule: HINST; lpType: DWORD; lpName: PChar; dwParam: DWORD): BOOL; stdcall; var CB: PCallBack; begin CB := PCallBack(dwParam); if CB.I = CB.Index then begin if HiWord(Cardinal(lpName)) = 0 then CB.S := Format('#%d', [Cardinal(lpName)]) else CB.S := lpName; Result := False; end else Result := True; Inc(CB.I); end; procedure TKIcon.LoadFromResourceByIndex(Instance: HINST; Index: Integer); var CB: TCallBack; begin CB.I := 0; CB.Index := Index; CB.S := ''; EnumResourceNames(Instance, RT_GROUP_ICON, @EnumIcons, DWORD(@CB)); if CB.S <> '' then LoadFromResource(Instance, CB.S) else if CB.I = 0 then Error(SIconInvalidModule) else Error(SIconIndexError); end; procedure TKIcon.LoadFromStream(Stream: TStream); var I, ANDSize, PalSize, XORInfoSize, XORSize: Integer; Masked: Boolean; PID: PKIconData; IH: TKIconHeader; II: TKIconCursorDirEntry; BI: TBitmapInfoHeader; BIMask: TKMaskBitmapInfo; DC: HDC; HSign: TKImageHeaderString; {$IFDEF USE_PNG_SUPPORT} MS: TMemoryStream; {$ENDIF} begin if Stream <> nil then begin DC := GetDC(0); try Clear; Stream.Read(IH, SizeOf(TKIconHeader)); FCursor := IH.idType = 2; FIconCount := IH.idCount; SetLength(FIconData, FIconCount); FillChar(FIconData[0], SizeOf(TKIconData) * FIconCount, 0); for I := 0 to FIconCount - 1 do begin PID := @FIconData[I]; Stream.Read(II, SizeOf(TKIconCursorDirEntry)); // for PNG read icon size here, otherwise this is overwritten when XOR bitmap is read PID.Width := II.Width; if PID.Width = 0 then PID.Width := 256; PID.Height := II.Height; if PID.Height = 0 then PID.Height := 256; if FCursor then begin PID.HotSpot.X := II.Info.wX; PID.HotSpot.Y := II.Info.wY; end; PID.BytesInRes := II.dwBytesInRes; PID.Offset := II.dwImageOffset; PID.Bpp := II.Info.wBitCount; // for PNG icons bpp is stored here end; for I := 0 to FIconCount - 1 do begin PID := @FIconData[I]; try Byte(HSign[0]) := Stream.Read(HSign[1], 8); Stream.Seek(-8, soFromCurrent); if (HSign = PNGHeader) or (HSign = MNGHeader) then begin PID.IsPNG := True; PID.PNG := TKIconPngObject.Create; {$IFDEF USE_PNG_SUPPORT} MS := TMemoryStream.Create; try MS.CopyFrom(Stream, PID.BytesInRes); // secure icon integrity MS.Seek(0, soFromBeginning); PID.PNG.LoadFromStream(MS); finally MS.Free; end; {$ELSE} PID.PNG.CopyFrom(Stream, PID.BytesInRes); {$ENDIF} end else begin Stream.Read(BI, SizeOf(TBitmapInfoHeader)); PID.Bpp := BI.biBitCount; PID.Width := BI.biWidth; PID.Height := BI.biHeight shr 1; PalSize := GetPaletteSize(PID.Bpp); CalcBitmapSizes(PID.Width, PID.Height, PID.Bpp, XORSize, ANDSize); XORInfoSize := SizeOf(TBitmapInfoHeader) + PalSize * SizeOf(TRGBQuad); Masked := PID.BytesInRes = XORInfoSize + XORSize + ANDSize; if not Masked then Error(SIconFormatError); BI.biHeight := BI.biHeight div 2; GetMem(PID.iXOR, XORInfoSize); PID.iXORSize := XORInfoSize; PID.iXOR.bmiHeader := BI; PID.iXOR.bmiHeader.biSizeImage := 0; Stream.Read(PID.iXOR.bmiColors, PalSize * SizeOf(TRGBQuad)); PID.hXOR := GDICheck(CreateDIBSection(DC, PID.iXOR^, DIB_RGB_COLORS, PID.pXOR, 0, 0)); if PID.pXOR <> nil then begin Stream.Read(PID.pXOR^, XORSize); PID.pXORSize := XORSize; end else Error(SIconAllocationError); CreateMaskInfo(PID.Width, PID.Height, BIMask); PID.hAND := GDICheck(CreateDIBSection(DC, PBitmapInfo(@BIMask)^, DIB_RGB_COLORS, PID.pAND, 0, 0)); if PID.pAND <> nil then begin Stream.Read(PID.pAND^, ANDSize); PID.pANDSize := ANDSize; end else Error(SIconAllocationError); end; except FreeSubimage(PID); raise; end; end; finally ReleaseDC(0, DC); end; Changed(Self); end; end; procedure TKIcon.LoadHandles(Index: Integer; const Handles: TKIconHandles; OrigBpp: Boolean); var ANDSize, PalSize, XORSize, XORInfoSize: Integer; PID: PKIconData; BInfo: Windows.TBitmap; BIMask: TKMaskBitmapInfo; P: Pointer; DC: HDC; hBmp: HBITMAP; begin if (Index >= 0) and (Index < FIconCount) then begin PID := @FIconData[Index]; if (Handles.hAND = 0) or (Handles.hXOR = PID.hXOR) or (Handles.hAND = PID.hXOR) or (Handles.hXOR = PID.hAND) or (Handles.hAND = PID.hAND) then Error(SIconBitmapError); FreeSubimage(PID); DC := GetDC(0); try try if Handles.hXOR <> 0 then begin GetObject(Handles.hXOR, SizeOf(Windows.TBitmap), @BInfo); PID.Height := BInfo.bmHeight; if OrigBpp or (FInHandleBpp = 0) then PID.Bpp := BInfo.bmPlanes * BInfo.bmBitsPixel else PID.Bpp := FInHandleBpp; end else begin // must be a monochrome icon - not fully tested GetObject(Handles.hAND, SizeOf(Windows.TBitmap), @BInfo); PID.Height := BInfo.bmHeight div 2; PID.Bpp := 1; end; PID.Width := BInfo.bmWidth; CalcBitmapSizes(PID.Width, PID.Height, PID.Bpp, XORSize, ANDSize); PalSize := GetPaletteSize(PID.Bpp); XORInfoSize := SizeOf(TBitmapInfoHeader) + PalSize * SizeOf(TRGBQuad); GetMem(PID.iXOR, XORInfoSize); PID.iXORSize := XORInfoSize; FillChar(PID.iXOR^, XORInfoSize, 0); PID.BytesInRes := XORInfoSize; PID.iXOR.bmiHeader.biSize := SizeOf(TBitmapInfoHeader); PID.iXOR.bmiHeader.biWidth := PID.Width; PID.iXOR.bmiHeader.biHeight := PID.Height; PID.iXOR.bmiHeader.biPlanes := 1; PID.iXOR.bmiHeader.biBitCount := PID.Bpp; PID.iXOR.bmiHeader.biCompression := BI_RGB; if Handles.hXOR <> 0 then hBmp := Handles.hXOR else hBmp := Handles.hAND; GetDIBits(DC, hBmp, 0, PID.Height, nil, PID.iXOR^, DIB_RGB_COLORS); PID.hXOR := GDICheck(CreateDIBSection(DC, PID.iXOR^, DIB_RGB_COLORS, PID.pXOR, 0, 0)); if PID.pXOR <> nil then begin GetDIBits(DC, hBmp, 0, PID.Height, PID.pXOR, PID.iXOR^, DIB_RGB_COLORS); PID.pXORSize := XORSize; if (PID.Bpp = 32) and FInHandleFullAlpha then FillAlphaIfNone(PKColorRecs(PID.pXOR), XORSize, $FF); Inc(PID.BytesInRes, XORSize); end else Error(SIconAllocationError); CreateMaskInfo(PID.Width, PID.Height, BIMask); PID.hAND := GDICheck(CreateDIBSection(DC, PBitmapInfo(@BIMask)^, DIB_RGB_COLORS, PID.pAND, 0, 0)); if PID.pAND <> nil then begin if Handles.hXOR <> 0 then begin GetDIBits(DC, Handles.hAND, 0, PID.Height, PID.pAND, PBitmapInfo(@BIMask)^, DIB_RGB_COLORS); end else begin GetMem(P, ANDSize * 2); try BIMask.Header.biHeight := 2 * PID.Height; GetDIBits(DC, Handles.hAND, 0, PID.Height * 2, P, PBitmapInfo(@BIMask)^, DIB_RGB_COLORS); Move(P^, PID.pAND^, ANDSize); finally FreeMem(P); end; end; PID.pANDSize := ANDSize; Inc(PID.BytesInRes, ANDSize); end else Error(SIconAllocationError); except FreeSubimage(PID); raise; end; finally ReleaseDC(0, DC); end; Changed(Self); end; end; procedure TKIcon.MaskFromColor(Index: Integer; Color: TColor; HasAlpha: Boolean = False); var PID: PKIconData; DC: HDC; OldObj: HGDIObj; BM: TKAlphaBitmap; ByteMask: Byte; I, J, L, LAnd: Integer; ColorMask: Cardinal; P: PKColorRecs; Q: PBytes; begin if (Index >= 0) and (Index < FIconCount) then begin Color := SwitchRGBToBGR(Color); PID := @FIconData[Index]; DC := 0; BM := TKAlphaBitmap.Create; try BM.SetSize(PID.Width, PID.Height); DC := GDICheck(CreateCompatibleDC(0)); OldObj := SelectObject(DC, PID.hXOR); BitBlt(BM.Canvas.Handle, 0, 0, PID.Width, PID.Height, DC, 0, 0, SRCCOPY); FillChar(PID.pAND^, PID.pANDSize, $FF); LAnd := CalcByteWidth(PID.Width, 1); Q := PID.pAND; Inc(Cardinal(Q), PID.pANDSize - LAnd); if HasAlpha then ColorMask := $FFFFFFFF else ColorMask := $00FFFFFF; for I := 0 to PID.Height - 1 do begin ByteMask := $7F; P := BM.ScanLine[I]; for J := 0 to PID.Width - 1 do begin L := J shr 3; if P[J].Value and ColorMask <> Cardinal(Color) then Q[L] := Q[L] and ByteMask; asm ror ByteMask, 1 end; end; Dec(Cardinal(Q), LAnd); end; SelectObject(DC, OldObj); finally if DC <> 0 then DeleteDC(DC); BM.Free; end; Changed(Self); end; end; procedure TKIcon.SaveToStream(Stream: TStream); var I, Offset, RSize: Integer; IH: TKIconHeader; PID: PKIconData; II: TKIconCursorDirEntry; {$IFDEF USE_PNG_SUPPORT} J, Delta: Integer; MS: TMemoryStream; {$ENDIF} begin if (Stream <> nil) and (FIconData <> nil) then begin Offset := SizeOf(TKIconHeader) + FIconCount * SizeOf(TKIconCursorDirEntry); IH.idReserved := 0; if FCursor then IH.idType := 2 else IH.idType := 1; IH.idCount := 0; for I := 0 to FIconCount - 1 do if (FIconData[I].iXOR <> nil) or FIconData[I].IsPNG then Inc(IH.idCount); Stream.Write(IH, SizeOf(TKIconHeader)); for I := 0 to FIconCount - 1 do begin FillChar(II, SizeOf(TKIconCursorDirEntry), 0); // gigo PID := @FIconData[I]; if PID.IsPNG then begin II.Width := PID.Width; II.Height := PID.Height; II.ColorCount := GetPaletteSize(PID.Bpp); II.Info.wPlanes := 1; II.Info.wBitCount := PID.Bpp; II.dwBytesInRes := PID.BytesInRes; II.dwImageOffset := Offset; Stream.Write(II, SizeOf(TKIconCursorDirEntry)); Inc(Offset, PID.BytesInRes); end else if PID.iXOR <> nil then begin II.Width := PID.Width; II.Height := PID.Height; II.ColorCount := GetPaletteSize(PID.Bpp); if FCursor then begin II.Info.wX := PID.HotSpot.X; II.Info.wY := PID.HotSpot.Y; end else begin II.Info.wPlanes := 1; II.Info.wBitCount := PID.Bpp; end; RSize := PID.iXORSize + PID.pXORSize + PID.pANDSize; II.dwBytesInRes := RSize; II.dwImageOffset := Offset; Stream.Write(II, SizeOf(TKIconCursorDirEntry)); Inc(Offset, RSize); end; end; for I := 0 to FIconCount - 1 do begin PID := @FIconData[I]; if PID.IsPNG then begin {$IFDEF USE_PNG_SUPPORT} MS := TMemoryStream.Create; try PID.PNG.SaveToStream(MS); MS.Seek(0, soFromBeginning); //// gigo if Ms.Size <> PID.BytesInRes then begin Delta := PID.BytesInRes - MS.Size; PID.BytesInRes := MS.Size; Stream.Seek(SizeOf(TKIconHeader) + I * SizeOf(TKIconCursorDirEntry), soFromBeginning); Stream.Read(II, SizeOf(TKIconCursorDirEntry)); II.dwBytesInRes := PID.BytesInRes; Stream.Seek(-1 * SizeOf(TKIconCursorDirEntry), soFromCurrent); Stream.Write(II, SizeOf(TKIconCursorDirEntry)); for J := I + 1 to FIconCount - 1 do begin Stream.Read(II, SizeOf(TKIconCursorDirEntry)); II.dwImageOffset := II.dwImageOffset - Delta; Stream.Seek(-1 * SizeOf(TKIconCursorDirEntry), soFromCurrent); Stream.Write(II, SizeOf(TKIconCursorDirEntry)); end; Stream.Seek(0,soFromEnd); end; //// end gigo Stream.CopyFrom(MS, PID.BytesInRes); // secure icon integrity finally MS.Free; end; {$ELSE} PID.PNG.Seek(0, soFromBeginning); Stream.CopyFrom(PID.PNG, PID.BytesInRes); {$ENDIF} end else if PID.iXOR <> nil then begin PID.iXOR.bmiHeader.biHeight := PID.iXOR.bmiHeader.biHeight * 2; Stream.Write(PID.iXOR^, PID.iXORSize); PID.iXOR.bmiHeader.biHeight := PID.iXOR.bmiHeader.biHeight div 2; Stream.Write(PID.pXOR^, PID.pXORSize); Stream.Write(PID.pAND^, PID.pANDSize); end; end; end; end; {$IFNDEF FPC} procedure TKIcon.SaveToClipboardFormat(var Format: Word; var Data: THandle; var APalette: HPALETTE); begin // does nothing end; {$ENDIF} procedure TKIcon.SetCurrentIndex(Value: Integer); begin if (Value >= 0) and (Value < FIconCount) and (Value <> FCurrentIndex) then begin FCurrentIndex := Value; Changed(Self); end; end; procedure TKIcon.SetDisplayAll(Value: Boolean); begin if Value <> FDisplayAll then begin FDisplayAll := Value; Changed(Self); end; end; procedure TKIcon.SetDisplayHorz(Value: Boolean); begin if Value <> FDisplayHorz then begin FDisplayHorz := Value; Changed(Self); end; end; procedure TKIcon.SetDimensions(Index: Integer; Value: TKIconDimension); begin if (Index >= 0) and (Index < FIconCount) and (Value.Width > 0) and (Value.Height > 0) and (Value.Width <> Widths[Index]) and (Value.Width <> Heights[Index]) then begin UpdateDim(Index, Value); Changed(Self); end; end; procedure TKIcon.SetHandles(Index: Integer; Value: TKIconHandles); begin LoadHandles(Index, Value, True); end; procedure TKIcon.SetHeight(Value: Integer); begin if not FDisplayAll then Heights[FCurrentIndex] := Value; end; procedure TKIcon.SetHeights(Index: Integer; Value: Integer); var D: TKIconDimension; begin D.Width := Widths[Index]; D.Height := Value; Dimensions[Index] := D; end; procedure TKIcon.SetHotSpot(Index: Integer; Value: TPoint); var PID: PKIconData; begin if (Index >= 0) and (Index < FIconCount) then begin PID := @FIconData[Index]; if (PID.HotSpot.X <> Value.X) or (PID.HotSpot.Y <> Value.Y) then begin PID.HotSpot := Value; Changed(Self); end; end; end; procedure TKIcon.SetIconDrawStyle(Value: TKIconDrawStyle); begin if Value <> FIconDrawStyle then begin FIconDrawStyle := Value; Changed(Self); end; end; procedure TKIcon.SetInHandleBpp(Value: Integer); begin if Value in [0, 1, 4, 8, 32] then FInHandleBpp := Value; end; procedure TKIcon.SetOptimalIcon(Value: Boolean); begin if Value <> FOptimalIcon then begin FOptimalIcon := Value; Changed(Self); end; end; procedure TKIcon.SetOverSizeWeight(Value: Single); begin if Value <> FOverSizeWeight then begin FOverSizeWeight := Value; Changed(Self); end; end; procedure TKIcon.SetRequestedSize(Value: TKIconDimension); begin if (Value.Width > 0) and (Value.Height > 0) then begin FRequestedSize := Value; Changed(Self); end; end; procedure TKIcon.SetSpacing(Value: Integer); begin if Value <> FSpacing then begin FSpacing := Value; Changed(Self); end; end; procedure TKIcon.SetStretchEnabled(Value: Boolean); begin if Value <> FStretchEnabled then begin FStretchEnabled := Value; Changed(Self); end; end; procedure TKIcon.SetTransparent(Value: Boolean); begin if FCreating then inherited else // Ignore assignments to this property. // Icons are always transparent. end; procedure TKIcon.SetWidth(Value: Integer); begin if not FDisplayAll then Widths[FCurrentIndex] := Value; end; procedure TKIcon.SetWidths(Index: Integer; Value: Integer); var D: TKIconDimension; begin D.Width := Value; D.Height := Heights[Index]; Dimensions[Index] := D; end; procedure TKIcon.Update; var dW, dH, BestBpp, I, MaxWeight, Weight: Integer; DC: HDC; PID: PKIconData; begin FBpp := 0; FMaxWidth := 0; FMaxHeight := 0; if FIconData <> nil then begin DC := GetDC(0); try FBpp := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL); MaxWeight := MaxInt; for I := 0 to FIconCount - 1 do begin PID := @FIconData[I]; if FDisplayAll and FDisplayHorz then begin Inc(FMaxWidth, PID.Width); if I <> 0 then Inc(FMaxWidth, FSpacing); end else if PID.Width > FMaxWidth then FMaxWidth := PID.Width; if FDisplayAll and not FDisplayHorz then begin Inc(FMaxHeight, PID.Height); if I <> 0 then Inc(FMaxHeight, FSpacing); end else if PID.Height > FMaxHeight then FMaxHeight := PID.Height; end; if FOptimalIcon and (FIconCount >= 2) then begin FCurrentIndex := 0; BestBpp := FIconData[0].Bpp; for I := 0 to FIconCount - 1 do begin PID := @FIconData[I]; if (PID.Bpp <= FBpp) and (PID.Bpp >= BestBpp) then begin BestBpp := PID.Bpp; dW := FRequestedSize.Width - PID.Width; dH := FRequestedSize.Height - PID.Height; if dW < 0 then DW := Round(-DW * FOverSizeWeight); if dH < 0 then dH := Round(-DH * FOverSizeWeight); Weight := dW + dH; if Weight <= MaxWeight then begin MaxWeight := Weight; FCurrentIndex := I; end; end; end; end else if (FCurrentIndex < 0) or (FCurrentIndex >= FIconCount) then FCurrentIndex := 0; finally ReleaseDC(0, DC); end; end else FCurrentIndex := -1; end; procedure TKIcon.UpdateDim(Index: Integer; Value: TKIconDimension); procedure BitMove(const Src, Dest; BitSize, BitOffset: Integer); asm // eax: Src // ecx: BitSize // edx: Dest // stack: BitOffset // push registers that must be preserved push esi push edi push ebx // set registers for register adressing mov esi, eax mov edi, edx // test for scroll direction mov edx, BitOffset cmp edx, 0 js @left // perform move mov ebx, edx shr ebx, 3 add edi, ebx and edx, $07 jnz @bitwise_right // bytewise move mov edx, ecx shr ecx, 3 rep movsb and dl, $07 jz @exit mov cl, dl mov al, [esi] rol eax, cl mov al, [edi] ror eax, cl mov [edi], al jmp @exit @bitwise_right: // bitwise move mov ebx, ecx mov cl, dl xor ch, ch mov dl, $7F ror dl, cl mov dh, dl not dh @R00: mov ah, [esi] ror ah, cl and ah, dh mov al, [edi] and al, dl or al, ah mov [edi], al dec ebx jz @exit inc ch and ch, $07 jnz @R01 inc esi @R01: ror dl, 1 ror dh, 1 test dh, $80 jz @R00 inc edi jmp @R00 @left: // perform scroll neg edx mov ebx, edx shr ebx, 3 add esi, ebx and edx, $07 jnz @bitwise_left // bytewise move mov edx, ecx shr ecx, 3 rep movsb and dl, $07 jz @exit mov cl, dl mov al, [esi] rol eax, cl mov al, [edi] ror eax, cl mov [edi], al jmp @exit @bitwise_left: // bitwise move mov ebx, ecx mov cl, dl mov ch, cl mov dl, $7F mov dh, dl not dh @L00: mov ah, [esi] rol ah, cl and ah, dh mov al, [edi] and al, dl or al, ah mov [edi], al dec ebx jz @exit inc ch and ch, $07 jnz @L01 inc esi @L01: ror dl, 1 ror dh, 1 test dh, $80 jz @L00 inc edi jmp @L00 @exit: // pop the preserved registers pop ebx pop edi pop esi end; var BitOffset, J, Size, XOR1, XOR2, AND1, AND2, X, Y, HOffset, VOffset: Integer; PID: PKIconData; PBI: PBitmapInfoHeader; BIMask: TKMaskBitmapInfo; P: PByteArray; hBmp: HBITMAP; DC: HDC; begin PID := @FIconData[Index]; if PID.iXOR <> nil then begin PBI := PBitmapInfoHeader(PID.iXOR); P := nil; DC := GetDC(0); try try CalcByteWidths(PID.Width, PID.Bpp, XOR1, AND1); CalcByteWidths(Value.Width, PID.Bpp, XOR2, AND2); PBI.biWidth := Value.Width; PBI.biHeight := Value.Height; PBI.biSizeImage := XOR2 * Value.Height; if FAlignStyle = asCenter then begin HOffset := (Value.Width - PID.Width) div 2; VOffset := (Value.Height - PID.Height) div 2; end else begin HOffset := 0; VOffset := 0; end; Y := Min(PID.Height, Value.Height); BitOffset := HOffset * PID.Bpp; hBmp := GDICheck(CreateDIBSection(DC, PBitmapInfo(PBI)^, DIB_RGB_COLORS, Pointer(P), 0, 0)); if P = nil then Error(SIconAllocationError); X := Min(PID.Width, Value.Width) * PID.Bpp; Size := XOR2 * Value.Height; FillChar(P^, Size, #0); for J := 1 to Y do begin if VOffset >= 0 then BitMove(PByteArray(PID.pXOR)[(PID.Height - J) * XOR1], P[(Value.Height - J - VOffset) * XOR2], X, BitOffset) else BitMove(PByteArray(PID.pXOR)[(PID.Height - J + VOffset) * XOR1], P[(Value.Height - J) * XOR2], X, BitOffset); end; DeleteObject(PID.hXOR); PID.pXOR := P; PID.pXORSize := Size; PID.hXOR := hBmp; CreateMaskInfo(PID.Width, PID.Height, BIMask); hBmp := GDICheck(CreateDIBSection(DC, PBitmapInfo(@BIMask)^, DIB_RGB_COLORS, Pointer(P), 0, 0)); if P = nil then Error(SIconAllocationError); X := Min(PID.Width, Value.Width); Size := AND2 * Value.Height; FillChar(P^, Size, #$FF); for J := 1 to Y do begin if VOffset >= 0 then BitMove(PByteArray(PID.pAND)[(PID.Height - J) * AND1], P[(Value.Height - J - VOffset) * AND2], X, HOffset) else BitMove(PByteArray(PID.pAND)[(PID.Height - J + VOffset) * AND1], P[(Value.Height - J) * AND2], X, HOffset); end; DeleteObject(PID.hAND); PID.pAND := P; PID.pANDSize := Size; PID.hAND := hBmp; PID.Width := Value.Width; PID.Height := Value.Height; except FreeSubimage(PID); Error(SIconResizingError); end; finally ReleaseDC(0, DC); end; end; end; procedure RegisterKIcon; begin TPicture.UnregisterGraphicClass(Graphics.TIcon); TPicture.RegisterFileFormat('ico', SVIcons, KIcon.TIcon); TPicture.RegisterFileFormat('cur', SVCursors, KIcon.TIcon); end; procedure UnregisterKIcon; begin TPicture.UnregisterGraphicClass(KIcon.TIcon); TPicture.RegisterFileFormat('ico', SVIcons, Graphics.TIcon); end; {$IFDEF TKICON_REGISTER} initialization RegisterKIcon; finalization //not necessary, but... UnregisterKIcon; {$ENDIF} {$ENDIF} end.