📄 unitexicon.pas
字号:
| Get the size of the info (incl the colortable), and the bitmap bits |
*----------------------------------------------------------------------------*)
procedure GetBitmapInfoSizes (const BI : TBitmapInfoHeader; var InfoHeaderSize, ImageSize : DWORD; iconInfo : boolean);
var
numColors : Integer;
height : Integer;
begin
InfoHeaderSize := SizeOf (TBitmapInfoHeader);
numColors := GetBitmapInfoNumColors (bi);
if numColors > 0 then
Inc (InfoHeaderSize, SizeOf(TRGBQuad) * NumColors)
else
if (BI.biCompression and BI_BITFIELDS) <> 0 then
Inc(InfoHeaderSize, 12);
height := Abs(BI.biHeight);
if iconInfo then height := height shr 1;
ImageSize := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Height
end;
(*----------------------------------------------------------------------------*
| procedure InternalGetDIBSizes () |
| |
| Get size of bitmap header (incl. color table) and bitmap bits. |
*----------------------------------------------------------------------------*)
procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
var ImageSize: DWORD; PixelFormat : TPixelFormat);
var
BI: TBitmapInfoHeader;
begin
InitializeBitmapInfoHeader(Bitmap, BI, PixelFormat);
GetBitmapInfoSizes (BI, InfoHeaderSize, ImageSize, False);
end;
(*----------------------------------------------------------------------------*
| procedure InternalGetDIB () |
| |
| Get bitmap bits. Note that we *always* call this on a bitmap with the |
| required colour depth - ie. we don't use this to do mapping. |
| |
| We (therefore) don't use GetDIBits here to get the colour table. |
*----------------------------------------------------------------------------*)
function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
BitmapInfo : PBitmapInfo; var Bits; PixelFormat : TPixelFormat): Boolean;
var
OldPal: HPALETTE;
DC: HDC;
begin
InitializeBitmapInfoHeader(Bitmap, BitmapInfo^.bmiHeader, PixelFormat);
OldPal := 0;
DC := CreateCompatibleDC(0);
try
if Palette <> 0 then
begin
OldPal := SelectPalette(DC, Palette, False);
RealizePalette(DC);
end;
Result := GetDIBits(DC, Bitmap, 0, BitmapInfo^.bmiHeader.biHeight, @Bits, BitmapInfo^, DIB_RGB_COLORS) <> 0;
finally
if OldPal <> 0 then SelectPalette(DC, OldPal, False);
DeleteDC(DC);
end;
end;
(*----------------------------------------------------------------------------*
| procedure CreateDIBPalette () |
| |
| Create the palette from bitmap info. |
*----------------------------------------------------------------------------*)
function CreateDIBPalette (const bmi : TBitmapInfo) : HPalette;
var
lpPal : PLogPalette;
i : Integer;
numColors : Integer;
r : RGBQUAD;
begin
result := 0;
NumColors := GetBitmapInfoNumColors (bmi.bmiHeader);
if NumColors > 0 then
begin
if NumColors = 1 then
result := CopyPalette (SystemPalette2)
else
begin
GetMem (lpPal, sizeof (TLogPalette) + sizeof (TPaletteEntry) * NumColors);
try
lpPal^.palVersion := $300;
lpPal^.palNumEntries := NumColors;
{$R-}
for i := 0 to NumColors -1 do
begin
r := bmi.bmiColors [i];
lpPal^.palPalEntry[i].peRed := bmi.bmiColors [i].rgbRed;
lpPal^.palPalEntry[i].peGreen := bmi.bmiColors[i].rgbGreen;
lpPal^.palPalEntry[i].peBlue := bmi.bmiColors[i].rgbBlue;
lpPal^.palPalEntry[i].peFlags := 0 // not bmi.bmiColors[i].rgbReserved !!
end;
{$R+}
result := CreatePalette (lpPal^)
finally
FreeMem (lpPal)
end
end
end
end;
(*----------------------------------------------------------------------------*
| procedure CreateMappedBitmap |
| |
| Copy a graphic to a DIB bitmap with the specified palette or color |
| format, and size. |
| |
| If the palette is 0, the returned bitmap's pixelformat is hiPixelFormat |
| otherwise the returned bitmap's pixel format is set so it's correct for |
| the number of colors in the palette. |
*----------------------------------------------------------------------------*)
function CreateMappedBitmap (source : TGraphic; palette : HPALETTE; hiPixelFormat : TPixelFormat; Width, Height : Integer) : TBitmap;
var
colorCount : Integer;
begin
result := TBitmap.Create;
result.Width := source.Width;
result.Height := source.Height;
if palette <> 0 then
begin
colorCount := 0;
if GetObject (palette, sizeof (colorCount), @colorCount) = 0 then
RaiseLastOSError;
case colorCount of
1..2 : result.PixelFormat := pf1Bit;
3..16 : result.PixelFormat := pf4Bit;
17..256 : result.PixelFormat := pf8Bit;
else
result.PixelFormat := hiPixelFormat;
end;
result.Palette := CopyPalette (palette);
result.Canvas.StretchDraw (rect (0, 0, Width, Height), source);
end
else
begin
result.PixelFormat := hiPixelFormat;
result.Canvas.StretchDraw (rect (0, 0, Width, Height), source);
end
end;
(*----------------------------------------------------------------------------*
| procedure MaskBitmapBits |
| |
| Kinda like MaskBlt - but without the bugs. SLOW. Maybe I'll revisit this |
| use bitblt instead... |
| |
| But see MSDN PRB: Trouble Using DIBSection as a Monochrome Mask |
*----------------------------------------------------------------------------*)
procedure MaskBitmapBits (bits : PChar; pixelFormat : TPixelFormat; mask : PChar; width, height : DWORD; palette : HPalette);
var
bpScanline, maskbpScanline : Integer;
bitsPerPixel, i, j : Integer;
maskbp, bitbp : byte;
maskp, bitp : PChar;
maskPixel : boolean;
maskByte: dword;
maskU : UINT;
maskColor : byte;
maskColorByte : byte;
begin
// Get 'black' color index. This is usually 0
// but some people play jokes...
if palette <> 0 then
begin
maskU := GetNearestPaletteIndex (palette, RGB (0, 0, 0));
if maskU = CLR_INVALID then
RaiseLastOSError;
maskColor := maskU
end
else
maskColor := 0;
bitsPerPixel := GetPixelFormatBitCount (PixelFormat);
if bitsPerPixel = 0 then
raise EInvalidGraphic.Create (rstInvalidPixelFormat);
// Get byte count for mask and bitmap
// scanline. Can be weird because of padding.
bpScanline := BytesPerScanLine(width, bitsPerPixel, 32);
maskbpScanline := BytesPerScanline (width, 1, 32);
maskByte := $ffffffff; // Set constant values for 8bpp masks
maskColorByte := maskColor;
for i := 0 to height - 1 do // Go thru each scanline...
begin
maskbp := 0; // Bit offset in current mask byte
bitbp := 0; // Bit offset in current bitmap byte
maskp := mask; // Pointer to current mask byte
bitp := bits; // Pointer to current bitmap byte;
for j := 0 to width - 1 do // Go thru each pixel
begin
// Pixel should be masked?
maskPixel := (byte (maskp^) and ($80 shr maskbp)) <> 0;
if maskPixel then
begin
case bitsPerPixel of
1, 4, 8 :
begin
case bitsPerPixel of // Calculate bit mask and 'black' color bits
1 :
begin
maskByte := $80 shr bitbp;
maskColorByte := maskColor shl (7 - bitbp);
end;
4 :
begin
maskByte := $f0 shr bitbp;
maskColorByte := maskColor shl (4 - bitbp)
end
end;
// Apply the mask
bitp^ := char ((byte (bitp^) and (not maskByte)) or maskColorByte);
end;
15, 16 :
PWORD (bitp)^ := $0000;
24 :
begin
PWORD (bitp)^ := $0000;
PBYTE (bitp + sizeof (WORD))^ := $00
end;
32 :
PDWORD (bitp)^ := $ffffffff;
end
end;
Inc (maskbp); // Next mask bit
if maskbp = 8 then
begin
maskbp := 0;
Inc (maskp) // Next mask byte
end;
Inc (bitbp, bitsPerPixel); // Next bitmap bit(s)
while bitbp >= 8 do
begin
Dec (bitbp, 8);
Inc (bitp) // Next bitmap byte
end
end;
Inc (mask, maskbpScanline); // Set mask for start of next line
Inc (bits, bpScanLine) // Set bits to start of next line
end
end;
{ TExIconCursor }
(*----------------------------------------------------------------------------*
| procedure TExIcon.Assign |
| |
| Assign an TExIcon from another graphic. |
| |
| A bit of a compromise this... |
| |
| ... if source is a TExIcon then all images get replaced by the source |
| images. |
| |
| ... Otherwise only the CurrentImage gets replaced |
*----------------------------------------------------------------------------*)
procedure TExIconCursor.Assign(source: TPersistent);
var
i : Integer;
src : TExIconCursor;
image : TExIconImage;
// data : THandle;
begin
if source is TExIconCursor then
begin // Share all images from the source TExIcon
src := TExIconCursor (source);
FTransparentColor := src.TransparentColor;
ReleaseImages;
SetLength (fImages, src.ImageCount);
for i := 0 to ImageCount - 1 do
begin
src.Images [i].Reference;
fImages [i] := src.Images [i]
end;
fCurrentImage := src.FCurrentImage;
Changed(Self);
end
else
if source = Nil then // Clear the current image.
begin
image := TExIconImage.Create;
image.FIsIcon := Images [FCurrentImage].FIsIcon;
image.FWidth := Images [FCurrentImage].Width;
image.FHeight := Images [FCurrentImage].Height;
image.FPixelFormat := Images [FCurrentImage].PixelFormat;
Images [fCurrentImage].Release;
FImages [FCurrentImage] := image;
image.Reference;
Changed(Self);
end
else
if source is TGraphic then // Copy from other graphic (TBitmap, etc)
AssignFromGraphic (TGraphic (source))
else
{ if source is TClipboard then
begin
clipboard.Open;
try
Data := GetClipboardData(CF_DIB);
LoadFromClipboardFormat(CF_DIB, Data, 0);
finally
clipboard.Close
end;
end
else }
inherited Assign (source)
end;
(*----------------------------------------------------------------------------*
| procedure TExIconCursor.AssignFromGraphic |
| |
| Assign an TExIcon from another graphic, converting it to our pixel format |
| and palette. |
| |
| Internal use only! |
*----------------------------------------------------------------------------*)
procedure TExIconCursor.AssignFromGraphic (source : TGraphic);
var
src, maskBmp : TBitmap;
offset, infoHeaderSize, imageSize, maskImageSize : DWORD;
colorBits, maskBits : PChar;
image : TExIconImage;
info : PBitmapInfo;
maskInfo : PBitmapInfo;
dc : HDC;
begin
src := Nil;
maskBmp := TBitmap.Create;
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -