I can load and save image files using Skia4Delphi.
Here is my code:
var
LImage: ISkImage;
LSurface: ISkSurface;
LPaint: ISkPaint;
begin
LImage := TSkImage.MakeFromEncodedFile('C:\IMAGE-OLD.PNG');
LPaint := TSkPaint.Create;
LSurface := TSkSurface.MakeRaster(LImage.Width, LImage.Height);
LSurface.Canvas.DrawImage(LImage, 0, 0, LPaint);
LSurface.MakeImageSnapshot.EncodeToFile('C:\IMAGE-NEW.PNG');
end;
How can I resize the image to a defined size (width and height) before saving? (Delphi 10.3.3 VCL)
Here is the code for a simple (stretched) resize:
uses
System.UITypes, Skia;
function GetResizedImage(const AImage: ISkImage; const ANewWidth, ANewHeight: Integer): ISkImage;
var
LSurface: ISkSurface;
begin
LSurface := TSkSurface.MakeRaster(ANewWidth, ANewHeight);
LSurface.Canvas.Clear(TAlphaColors.Null);
LSurface.Canvas.Scale(ANewWidth / AImage.Width, ANewHeight / AImage.Height);
LSurface.Canvas.DrawImage(AImage, 0, 0, TSkSamplingOptions.High);
Result := LSurface.MakeImageSnapshot;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
LImage: ISkImage;
begin
LImage := TSkImage.MakeFromEncodedFile('a.png');
LImage := GetResizedImage(LImage, 24, 24);
LImage.EncodeToFile('a.png', 100);
end;
Related
The code following makes a screenshot of desktop every time that mouse left button is clicked.
But i'm wanting make a screenshot only of region where happens mouse click, for example if some button is clicked on some website, the screenshot must be only of this button.
GIF
This is possible?
if yes, i will very happy if someone show a code example! Thanks in advance.
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows,
Messages,
SysUtils,
Graphics,
Imaging.PngImage;
type
MouseLLHookStruct = record
end;
const
WH_MOUSE_LL = 14;
var
Msg: TMsg;
mHook: Cardinal;
procedure GetCursor(ScreenShotBitmap: TBitmap);
var
R: TRect;
Icon: TIcon;
II: TIconInfo;
CI: TCursorInfo;
begin
R := ScreenShotBitmap.Canvas.ClipRect;
Icon := TIcon.Create;
try
CI.cbSize := SizeOf(CI);
if GetCursorInfo(CI) then
if CI.Flags = CURSOR_SHOWING then
begin
Icon.Handle := CopyIcon(CI.hCursor);
if GetIconInfo(Icon.Handle, II) then
begin
ScreenShotBitmap.Canvas.Draw(CI.ptScreenPos.X - Integer(II.xHotspot) -
R.Left, CI.ptScreenPos.Y - Integer(II.yHotspot) - R.Top, Icon);
end;
end;
finally
Icon.Free;
end;
end;
procedure ScreenCapture;
var
DC: HDC;
Rect: TRect;
png: TPngImage;
Bitmap: TBitmap;
begin
png := TPngImage.Create;
Bitmap := TBitmap.Create;
GetWindowRect(GetDesktopWindow, Rect);
DC := GetWindowDC(GetDesktopWindow);
try
Bitmap.Width := Rect.Right - Rect.Left;
Bitmap.Height := Rect.Bottom - Rect.Top;
BitBlt(Bitmap.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height, DC, 0,
0, SRCCOPY);
GetCursor(Bitmap);
png.Assign(Bitmap);
png.SaveToFile('screenshot.png');
finally
ReleaseDC(GetDesktopWindow, DC);
png.Free;
Bitmap.Free;
end;
end;
function LowLevelMouseHookProc(nCode: LongInt; WPARAM: WPARAM; lParam: lParam)
: LRESULT; stdcall;
var
info: ^MouseLLHookStruct absolute lParam;
begin
Result := CallNextHookEx(mHook, nCode, WPARAM, lParam);
if (WPARAM = WM_LBUTTONUP) then
ScreenCapture;
end;
begin
mHook := SetWindowsHookEx(WH_MOUSE_LL, #LowLevelMouseHookProc, HInstance, 0);
while GetMessage(Msg, 0, 0, 0) do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
UnhookWindowsHookEx(mHook);
end.
EDIT:
I found a alternative in VB.NET. But how could be a solution with Delphi code?
Private Shared Function CaptureCursor(ByRef x As Integer, ByRef y As Integer) As Bitmap
Dim bmp As Bitmap
Dim hicon As IntPtr
Dim ci As New CURSORINFO()
Dim icInfo As ICONINFO
ci.cbSize = Marshal.SizeOf(ci)
If GetCursorInfo(ci) Then
hicon = CopyIcon(ci.hCursor)
If GetIconInfo(hicon, icInfo) Then
x = ci.ptScreenPos.X - CInt(icInfo.xHotspot)
y = ci.ptScreenPos.Y - CInt(icInfo.yHotspot)
Dim ic As Icon = Icon.FromHandle(hicon)
bmp = ic.ToBitmap()
ic.Dispose()
Return bmp
End If
End If
Return Nothing
End Function
'Insert on Timer tick event
Private Sub Screenshot()
Dim x As Integer
Dim y As Integer
Dim cursorBmp As Bitmap = CaptureCursor(x, y)
Dim bmp As New Bitmap(Cursor.Size.Width, Cursor.Size.Height)
Dim sourceLocation As Point = Control.MousePosition
sourceLocation.Offset(-16, -16)
Using g As Graphics = Graphics.FromImage(bmp)
g.CopyFromScreen(sourceLocation, Point.Empty, bmp.Size)
g.DrawImage(cursorBmp, x - sourceLocation.X, y - sourceLocation.Y)
cursorBmp.Dispose()
End Using
Me.PictureBox1.Image = bmp
End Sub
There is a simple way, you can refer to the code in this thread,
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils, Windows, Graphics;
procedure DrawCursor (ACanvas:TCanvas; Position:TPoint) ;
var
HCursor : THandle;
begin
HCursor := GetCursor;
DrawIconEx(ACanvas.Handle, Position.X, Position.Y,
HCursor, 32, 32, 0, 0, DI_NORMAL) ;
end;
function CaptureWindow(const WindowHandle: HWnd): TBitmap;
var
DC: HDC;
wRect: TRect;
CurPos: TPoint;
begin
DC := GetWindowDC(WindowHandle);
Result := TBitmap.Create;
try
GetWindowRect(WindowHandle, wRect);
Result.Width := wRect.Right - wRect.Left;
Result.Height := wRect.Bottom - wRect.Top;
BitBlt(Result.Canvas.Handle,
0,
0,
Result.Width,
Result.Height,
DC,
0,
0,
SRCCOPY);
GetCursorPos(CurPos);
DrawCursor(Result.Canvas, CurPos);
finally
ReleaseDC(WindowHandle, DC);
end;
end;
// Sample usage starts here
var
Bmp: TBitmap;
begin
Bmp := CaptureWindow(GetDesktopWindow);
Bmp.SaveToFile('D:\TempFiles\FullScreenCap.bmp');
Bmp.Free;
WriteLn('Screen captured.');
ReadLn;
end.
This code can get the screen capture containing the mouse position, just use BitBlt to specify the mouse coordinates and rectangle size (button size), and finally get the BMP image you need. Use DrawImage to draw the BMP image into a rectangular box, as shown in GIF.
Mouse coordinates can be obtained by calling GetCursorInfo, and the size of the rectangle can be specified according to your needs.
Note that after you have the mouse coordinates, you need to subtract the size of half a rectangle to the left and up respectively when you pass them into BitBlt.
For example,
BitBlt(Newhdc,
0,
0,
rect_x, //size of the rect
rect_y,
HDC,
x - half_rect_x, //x,y => mouse coordinates
y - half_rect_y, //half_rect_x, half_rect_y => the size of half the rectangle
SRCCOPY);
I tried this function, but it only caputre the visible client area... It is possible to capture the whole area of the control, like it is expanded that no vertical scroll bar is needed ?
function CaptureWinCtrlImage(AWinControl: TWinControl; AImg: TGraphic): Boolean;
var
vBmp: Graphics.TBitmap;
vControlDC: HDC;
begin
Result:= False;
if not AWinControl.HandleAllocated then Exit;
vControlDC:= GetWindowDC(AWinControl.Handle);
try
vBmp:= Graphics.TBitmap.Create;
try
vBmp.PixelFormat := pf24bit;
vBmp.Height := AWinControl.Height;
vBmp.Width := AWinControl.Width;
BitBlt(vBmp.Canvas.Handle, 0, 0, vBmp.Width, vBmp.Height, vControlDC, 0, 0, SRCCOPY);
AImg.Assign(vBmp);
Result:= True;
finally
vBmp.Free;
end;
finally
ReleaseDC(AWinControl.Handle, vControlDC);
end;
end;
I did it by scrolling the box and making a capture every time. It's not nice to see that flicker on the screen, but at least it works. And it might capture something else if some window appears on the screen at that time...
procedure CaptureScrollBox(ABox: TScrollBox; FileName: String);
var vBmp: Graphics.TBitmap;
vControlDC: HDC;
Org: TPoint;
PngImg: TPngImage;
Y, P: Integer;
begin
PngImg:= TPngImage.Create;
vControlDC:= GetWindowDC(ABox.Handle);
vBmp:= Graphics.TBitmap.Create;
vBmp.PixelFormat := pf24bit;
vBmp.Width := ABox.ClientWidth;
vBmp.Height := ABox.VertScrollBar.Range;
Org.X:= ABox.Left; Org.Y:= ABox.Top;
Org:= ABox.Parent.ClientToScreen(Org);
Org.X:= ABox.ClientOrigin.X - Org.X;
Org.Y:= ABox.ClientOrigin.Y - Org.Y;
P:= ABox.VertScrollBar.Position;
Y:= 0;
repeat
ABox.VertScrollBar.Position:= Y; ABox.Repaint;
if ABox.VertScrollBar.Position <> Y then begin
Org.Y:= Org.Y + ( Y - ABox.VertScrollBar.Position );
BitBlt(vBmp.Canvas.Handle, 0, Y, vBmp.Width, vBmp.Height, vControlDC, Org.X, Org.Y, SRCCOPY);
Break;
end
else begin
BitBlt(vBmp.Canvas.Handle, 0, Y, vBmp.Width, vBmp.Height, vControlDC, Org.X, Org.Y, SRCCOPY);
Inc(Y, ABox.ClientHeight);
end;
until False;
ABox.VertScrollBar.Position:= P;
PngImg.Assign(vBmp);
PngImg.SaveToFile(FileName);
vBmp.Free;
ReleaseDC(ABox.Handle, vControlDC);
PngImg.Free;
end;
I'm using Delphi XE and TWICImage class for image processing.
I would like to know if any way to set jpeg compression quality with TWICImage?
procedure TfrmMain.Button2Click(Sender: TObject);
var
wic: TWICImage;
begin
wic := TWICImage.Create;
try
wic.LoadFromFile('sample-BMP.bmp');
wic.ImageFormat := wifJpeg;
// ... before saving I want to set low compression quality
wic.SaveToFile('sample-JPG.jpg');
finally
wic.Free;
end;
end;
The VCL wrapper of WIC is somewhat limited. It doesn't offer you any means to specify the image quality. And I'm going to turn a blind eye to the total absence of error checking in that code. Ergh!
I think you are going to need to roll your own code, using the raw COM API. It might look something like this:
uses
System.SysUtils,
System.Variants,
System.Win.ComObj,
Winapi.Windows,
Winapi.Wincodec,
Winapi.ActiveX,
Vcl.Graphics;
procedure SaveBitmapAsJpeg(Bitmap: TBitmap; ImageQuality: Single; FileName: string);
const
PROPBAG2_TYPE_DATA = 1;
var
ImagingFactory: IWICImagingFactory;
Width, Height: Integer;
Stream: IWICStream;
Encoder: IWICBitmapEncoder;
Frame: IWICBitmapFrameEncode;
PropBag: IPropertyBag2;
PropBagOptions: TPropBag2;
V: Variant;
PixelFormat: TGUID;
Buffer: TBytes;
BitmapInfo: TBitmapInfo;
hBmp: HBITMAP;
WICBitmap: IWICBitmap;
Rect: WICRect;
begin
Width := Bitmap.Width;
Height := Bitmap.Height;
OleCheck(
CoCreateInstance(CLSID_WICImagingFactory, nil, CLSCTX_INPROC_SERVER
or CLSCTX_LOCAL_SERVER, IUnknown, ImagingFactory)
);
OleCheck(ImagingFactory.CreateStream(Stream));
OleCheck(Stream.InitializeFromFilename(PChar(FileName), GENERIC_WRITE));
OleCheck(ImagingFactory.CreateEncoder(GUID_ContainerFormatJpeg, GUID_NULL, Encoder));
OleCheck(Encoder.Initialize(Stream, WICBitmapEncoderNoCache));
OleCheck(Encoder.CreateNewFrame(Frame, PropBag));
PropBagOptions := Default(TPropBag2);
PropBagOptions.pstrName := 'ImageQuality';
PropBagOptions.dwType := PROPBAG2_TYPE_DATA;
PropBagOptions.vt := VT_R4;
V := VarAsType(ImageQuality, varSingle);
OleCheck(PropBag.Write(1, #PropBagOptions, #V));
OleCheck(Frame.Initialize(PropBag));
OleCheck(Frame.SetSize(Width, Height));
if Bitmap.AlphaFormat=afDefined then begin
PixelFormat := GUID_WICPixelFormat32bppBGRA
end else begin
PixelFormat := GUID_WICPixelFormat32bppBGR;
end;
Bitmap.PixelFormat := pf32bit;
SetLength(Buffer, 4*Width*Height);
BitmapInfo := Default(TBitmapInfo);
BitmapInfo.bmiHeader.biSize := SizeOf(BitmapInfo);
BitmapInfo.bmiHeader.biWidth := Width;
BitmapInfo.bmiHeader.biHeight := -Height;
BitmapInfo.bmiHeader.biPlanes := 1;
BitmapInfo.bmiHeader.biBitCount := 32;
hBmp := Bitmap.Handle;
GetDIBits(Bitmap.Canvas.Handle, hBmp, 0, Height, #Buffer[0], BitmapInfo,
DIB_RGB_COLORS);
OleCheck(ImagingFactory.CreateBitmapFromMemory(Width, Height, PixelFormat,
4*Width, Length(Buffer), #Buffer[0], WICBitmap));
Rect.X := 0;
Rect.Y := 0;
Rect.Width := Width;
Rect.Height := Height;
OleCheck(Frame.WriteSource(WICBitmap, #Rect));
OleCheck(Frame.Commit);
OleCheck(Encoder.Commit);
end;
Pass an image quality value between 0 and 1, with 0 being the lowest quality (highest compression) and 1 being the highest quality (lowest compression).
I have made extensive use of both the question and answer found here: How to create a lossless jpg using WIC in Delphi
I have also borrowed liberally from the VCL source for the code to create the IWICBitmap. If you wished to continue to use TWICBitmap you could do so and use its Handle property to obtain the IWICBitmap. That would yield code like this:
uses
System.Variants,
System.Win.ComObj,
Winapi.Windows,
Winapi.Wincodec,
Winapi.ActiveX,
Vcl.Graphics;
procedure SaveWICImageAsJpeg(WICImage: TWICImage; ImageQuality: Single;
FileName: string);
const
PROPBAG2_TYPE_DATA = 1;
var
ImagingFactory: IWICImagingFactory;
Width, Height: Integer;
Stream: IWICStream;
Encoder: IWICBitmapEncoder;
Frame: IWICBitmapFrameEncode;
PropBag: IPropertyBag2;
PropBagOptions: TPropBag2;
V: Variant;
PixelFormat: TGUID;
Rect: WICRect;
begin
Width := WICImage.Width;
Height := WICImage.Height;
ImagingFactory := WICImage.ImagingFactory;
OleCheck(ImagingFactory.CreateStream(Stream));
OleCheck(Stream.InitializeFromFilename(PChar(FileName), GENERIC_WRITE));
OleCheck(ImagingFactory.CreateEncoder(GUID_ContainerFormatJpeg, GUID_NULL, Encoder));
OleCheck(Encoder.Initialize(Stream, WICBitmapEncoderNoCache));
OleCheck(Encoder.CreateNewFrame(Frame, PropBag));
PropBagOptions := Default(TPropBag2);
PropBagOptions.pstrName := 'ImageQuality';
PropBagOptions.dwType := PROPBAG2_TYPE_DATA;
PropBagOptions.vt := VT_R4;
V := VarAsType(ImageQuality, varSingle);
OleCheck(PropBag.Write(1, #PropBagOptions, #V));
OleCheck(Frame.Initialize(PropBag));
OleCheck(Frame.SetSize(Width, Height));
Rect.X := 0;
Rect.Y := 0;
Rect.Width := Width;
Rect.Height := Height;
OleCheck(Frame.WriteSource(WICImage.Handle, #Rect));
OleCheck(Frame.Commit);
OleCheck(Encoder.Commit);
end;
I am trying to assign a bitmap to a speedbutton in FMX Delphi. In design time, I create a TImageList, load my image and then assign one to the speedbutton.
How do I do it programmatically?
var
Size: TSizeF;
begin
Size := TSize.Create(64,64)
Bitmap1.Assign(Imagelist1.Bitmap(Size, Index));
end
In the TSpeedButton you should set Images and ImageIndex.
To load pictures into TImageList you can use AddOrSet
or you can use this example
procedure TForm11.Button2Click(Sender: TObject);
const
SourceName = 'Картинка';
procedure LoadPicture(const Source: TCustomSourceItem; const Scale: Single; const FileName: string);
var
BitmapItem: TCustomBitmapItem;
TmpBitmap: TBitmap;
begin
BitmapItem := Source.MultiResBitmap.ItemByScale(Scale, True, True);
if BitmapItem = nil then
begin
BitmapItem := Source.MultiResBitmap.Add;
BitmapItem.Scale := Scale;
end;
BitmapItem.FileName := FileName;
TmpBitmap := BitmapItem.CreateBitmap;
try
if TmpBitmap <> nil then
BitmapItem.Bitmap.Assign(TmpBitmap);
finally
TmpBitmap.Free;
end;
end;
var
NewSource: TCustomSourceItem;
NewDestination: TCustomDestinationItem;
NewLayer: TLayer;
begin
if ImageList1.Source.IndexOf(SourceName) = -1 then
begin
NewSource := ImageList1.Source.Add;
NewSource.Name := SourceName;
NewSource.MultiResBitmap.TransparentColor := TColorRec.Fuchsia;
NewSource.MultiResBitmap.SizeKind := TSizeKind.Custom;
NewSource.MultiResBitmap.Width := 16;
NewSource.MultiResBitmap.Height := 16;
LoadPicture(NewSource, 1, 'D:\Мои веселые картинки\Icons\16x16\alarm16.bmp');
LoadPicture(NewSource, 1.5, 'D:\Мои веселые картинки\Icons\24x24\alarm24.bmp');
NewDestination := ImageList1.Destination.Add;
NewLayer := NewDestination.Layers.Add;
NewLayer.SourceRect.Rect := TRectF.Create(TPoint.Zero, NewSource.MultiResBitmap.Width,
NewSource.MultiResBitmap.Height);
NewLayer.Name := SourceName;
ControlAction1.ImageIndex := NewDestination.Index;
end;
end;
I have ImageList sized 72x72, handle to the icon (HICON), obtained by SHGetFileInfo (for example a large icon sized 32x32). How to add it to this ImageList keeping transparency, but without stretching? Now I draw the icon in the middle of a temporary bitmap desired size, then add it to the ImageList.
SHGetFileInfo(PChar(Path + sr.Name), sr.FindData.dwFileAttributes, fi, SizeOf(fi), SHGFI_ICON or SHGFI_LARGEICON or SHGFI_USEFILEATTRIBUTES);
Bmp:=TBitmap.Create;
Bmp.PixelFormat:=pf32bit;
Bmp.SetSize(72, 72);
DrawIcon(Bmp.Canvas.Handle, 20, 20, fi.hIcon);
iIcon:=ImageList_AddMasked(ilThumbs.Handle, Bmp.Handle, 0);
Bmp.Free;
But I think a way faster exists (without drawing on temporary bitmap). Also image in ImageList loses transparency and when I set index of this Image in ImageList for ListView item.ImageIndex it looks not pretty (when this item is selected, white background around is present). Is any way to solve this problem?
Thanks.
This is the code that I use to perform this task.
Note that I am assuming that the original icon uses 32 bit colour, with alpha channel. That's reasonable in the settings that I use this code, but I can't be sure whether or not it's reasonable for you.
uses
Windows, Graphics;
function CreateIconFromSmallerIcon(IconSize: Integer; SmallerIcon: HICON): HICON;
procedure GetDIBheaderAndBits(bmp: HBITMAP; out bih: BITMAPINFOHEADER; out bits: Pointer);
var
pbih: ^BITMAPINFOHEADER;
bihSize, bitsSize: DWORD;
begin
bits := nil;
GetDIBSizes(bmp, bihSize, bitsSize);
pbih := AllocMem(bihSize);
Try
bits := AllocMem(bitsSize);
GetDIB(bmp, 0, pbih^, bits^);
if pbih.biSize<SizeOf(bih) then begin
FreeMem(bits);
bits := nil;
exit;
end;
bih := pbih^;
Finally
FreeMem(pbih);
End;
end;
procedure InitialiseBitmapInfoHeader(var bih: BITMAPINFOHEADER);
begin
bih.biSize := SizeOf(BITMAPINFOHEADER);
bih.biWidth := IconSize;
bih.biHeight := 2*IconSize;//height of xor bitmap plus height of and bitmap
bih.biPlanes := 1;
bih.biBitCount := 32;
bih.biCompression := BI_RGB;
end;
procedure CreateXORbitmap(const sbih, dbih: BITMAPINFOHEADER; sptr, dptr: PDWORD);
var
line, xOffset, yOffset: Integer;
begin
xOffset := (IconSize-sbih.biWidth) div 2;
yOffset := (IconSize-sbih.biHeight) div 2;
inc(dptr, xOffset + IconSize*yOffset);
for line := 0 to sbih.biHeight-1 do begin
Move(sptr^, dptr^, sbih.biWidth*SizeOf(DWORD));
inc(dptr, IconSize);//relies on the fact that no padding is needed for RGBA scanlines
inc(sptr, sbih.biWidth);//likewise
end;
end;
var
SmallerIconInfo: TIconInfo;
sBits, xorBits: PDWORD;
xorScanSize, andScanSize: Integer;
xorBitsSize, andBitsSize: Integer;
sbih: BITMAPINFOHEADER;
dbih: ^BITMAPINFOHEADER;
resbitsSize: DWORD;
resbits: Pointer;
begin
Result := 0;
Try
if not GetIconInfo(SmallerIcon, SmallerIconInfo) then begin
exit;
end;
Try
GetDIBheaderAndBits(SmallerIconInfo.hbmColor, sbih, Pointer(sBits));
if Assigned(sBits) then begin
Try
if (sbih.biWidth>IconSize) or (sbih.biHeight>IconSize) or (sbih.biPlanes<>1) or (sbih.biBitCount<>32) then begin
exit;
end;
xorScanSize := BytesPerScanline(IconSize, 32, 32);
Assert(xorScanSize=SizeOf(DWORD)*IconSize);
andScanSize := BytesPerScanline(IconSize, 1, 32);
xorBitsSize := IconSize*xorScanSize;
andBitsSize := IconSize*andScanSize;
resbitsSize := SizeOf(BITMAPINFOHEADER) + xorBitsSize + andBitsSize;
resbits := AllocMem(resbitsSize);//AllocMem zeroises the memory
Try
dbih := resbits;
InitialiseBitmapInfoHeader(dbih^);
xorBits := resbits;
inc(PByte(xorBits), SizeOf(BITMAPINFOHEADER));
CreateXORbitmap(sbih, dbih^, sBits, xorBits);
//don't need to fill in the mask bitmap when using RGBA
Result := CreateIconFromResourceEx(resbits, resbitsSize, True, $00030000, IconSize, IconSize, LR_DEFAULTCOLOR);
Finally
FreeMem(resbits);
End;
Finally
FreeMem(sBits);
End;
end;
Finally
if SmallerIconInfo.hbmMask<>0 then begin
DeleteObject(SmallerIconInfo.hbmMask);
end;
if SmallerIconInfo.hbmColor<>0 then begin
DeleteObject(SmallerIconInfo.hbmColor);
end;
End;
Finally
DestroyIcon(SmallerIcon);
End;
end;
Ok, my solution below:
procedure SetAlpha(Bitmap: TBitmap);
type
PPixelRec = ^TPixelRec;
TPixelRec = packed record
B, G, R, Alpha: Byte;
end;
var
X, Y: Integer;
Pixel: PPixelRec;
begin
for Y := 0 to (Bitmap.Height - 1) do
begin
Pixel := Bitmap.ScanLine[Y];
for X := 0 to (Bitmap.Width - 1) do
begin
Pixel.Alpha:=255;
Inc(Pixel);
end;
end;
end;
//skipped
var Bmp: TBitmap;
fi: TSHFileInfo;
ImageList1: TImageList;
begin
ImageList1:=TImageList.CreateSize(72, 72);
ImageList1.DrawingStyle:=dsTransparent;
ImageList1.ColorDepth:=cd32Bit;
SHGetFileInfo('c:\Windows\notepad.exe', FILE_ATTRIBUTE_NORMAL, fi, SizeOf(fi), SHGFI_ICON or SHGFI_LARGEICON or SHGFI_USEFILEATTRIBUTES);
Bmp:=TBitmap.Create;
Bmp.SetSize(72, 72);
SetAlpha(Bmp);
Bmp.Canvas.Brush.Color:=clWhite;
Bmp.Canvas.FillRect(Rect(0, 0, 72, 72));
DrawIcon(Bmp.Canvas.Handle, 20, 20, fi.hIcon);
fi.iIcon:=ImageList1.Add(Bmp, nil);
ImageList1.Draw(Canvas, 0, 0, fi.iIcon); //just to see that's alright
end;