TRichEdit color problems - delphi

ans:= RichEdit1.Text
for i:=1 to Length(ans) do
begin
RichEdit1.SelStart := i-1;
RichEdit1.SelLength:= 1;
if ans[i] = correct[i] then
RichEdit1.SelAttributes.Color := clRed
else
RichEdit1.SelAttributes.Color := clBlue;
If the letter in ans matches the letter in the same position as the letter in correct string, it is colored red otherwise, it is blue.
My problem is when I type again the whole RichEdit1 text is colored as the same as the first letter (if the first letter of RichEdit1 is blue then the whole text becomes blue).
By the way, this is not the the actual code I just simplified it because there are mutiple TRichEdits.
The TRichEdits are read-only and I assign the letters by something like RichEdit1.Text := RichEdit1.Text+Key;
(doing this because it's a multiple keyboard program and I need to separate user inputs)
Is this the correct behavior? How can I stop my color changes from overriding the default color?
update: Solved it... in a sloppy way (applying the default color whenever someone types), but I'm keeping this open in case someone comes up with a better solution.

As you already discovered, you have to reset the default color when you are done, eg:
ans := RichEdit1.Text;
for i := 1 to Length(ans) do
begin
RichEdit1.SelStart := i-1;
RichEdit1.SelLength := 1;
if ans[i] = correct[i] then
RichEdit1.SelAttributes.Color := clRed
else
RichEdit1.SelAttributes.Color := clBlue;
end;
RichEdit1.SelStart := RichEdit1.GetTextLen;
RichEdit1.SelLength := 0;
RichEdit1.SelAttributes.Color := RichEdit1.Font.Color;
There are more efficient ways to handle this than coloring one letter at a time, eg:
const
colors: array[Boolean] of TColor = (clRed, clBlue);
var
ans: string;
start, len: Integer;
cur_state: Boolean;
procedure ColorRange(AStart, ALength: Integer; AColor: TColor);
begin
RichEdit1.SelStart := AStart;
RichEdit1.SelLength := ALength;
RichEdit1.SelAttributes.Color := AColor;
end;
begin
RichEdit1.Lines.BeginUpdate;
try
ans := RichEdit1.Text;
start := 0;
len := 0;
cur_start := False;
for i := 1 to Length(ans) do
begin
if (ans[i] = correct[i]) = cur_state then
Inc(len)
else begin
if len > 0 then
ColorRange(start, len, colors[cur_state]);
start := i-1;
len := 1;
cur_state := not cur_state;
end;
end;
if len > 0 then
ColorRange(start, len, colors[cur_state]);
ColorRange(RichEdit1.GetTextLen, 0, RichEdit1.Font.Color);
finally
RichEdit1.Lines.EndUpdate;
end;
end;
Also, using the Text property to append a single Char is very inefficient. Use the SelText property instead, eg:
RichEdit1.SelStart := RichEdit1.GetTextLen;
RichEdit1.SelLength := 0;
RichEdit1.SelAttributes.Color := ...; // optional
RichEdit1.SelText := Key;

Related

FASTREPORT Adding objects dynamically in report script

I try to add TLineView objects to a report.
The number of lines is depending on a certain number, retrieved by the reports dataset.
I have put my code into the scripts initialization part and in a very experimental test version it looks like this:
var nol, i: integer;
child, newChild: TfrxChild;
noteLine1, noteLine2: TfrxLineView;
page: TfrxPage;
begin
page := ReportName;
nol := <DS_MAIN."VOLUME"> /2;
nol := nol + <DS_MAIN."VOLUME"> mod 2;
child3.child := TfrxChild.create(nil);
newchild := child3.child;
newChild.Visible := true;
noteLine1 := TfrxLineView.create(newChild);
noteLine1.name := 'nl1000';
noteLine1.Top := 0.73;
noteLine1.Width := 7.5;
noteLine1.Left := 3;
noteLine1.Visible := true;
noteLine1.Parent.Objects.Remove(noteLine1);
noteLine1.Parent.Objects.Add(noteLine1);
// newChild.Objects.Add(noteLine1);
noteLine2 := TfrxLineView.create(newChild);
noteLine2.name := 'nl1001';
noteLine2.Top := 0.73;
noteLine2.Width := 7.5;
noteLine2.Left := 11.2;
newChild.Objects.Add(noteLine2);
noteLine2.Visible := true;
for i := 1 to nol do begin
Child := TfrxChild.create(nil);
NewChild.child := Child;
newChild := child;
end;
end.
Instead of getting two lines side by side, with a gap between them, I get only a single short line of a length of around 3-4 mm.
The above code is just a snap of my trial-and-error session.
Hope now that there could be anyone to give me some clues.
If I understand your question correctly, you need to consider at least the following:
With your for loop you create bands, not lines. You may try to change the logic and create objects (memos, lines, shapes) with bands as owners.
The objects’ coordinates and sizes are set in pixels, so you need an additional calculation.
From documentation:
Objects’ coordinates and sizes are set in pixels. Since the «Left,»
«Top,» «Width,» and «Height» properties of all objects have the
«Extended» type, you can point out non-integer values. The following
constants are defined for converting pixels into centimeters and
inches:
fr01cm = 3.77953;
fr1cm = 37.7953;
fr01in = 9.6;
fr1in = 96;
The following working example generates five TfrxLineView objects. Just put an empty report on your form and add report title band:
procedure TfrmMain.btnPreviewClick(Sender: TObject);
var
nol, i: integer;
left: Extended;
band: TfrxReportTitle;
line: TfrxLineView;
begin
// Band
band := (report.Report.FindObject('ReportBand') as TfrxReportTitle);
// Lines generation
left := 3;
nol := 5;
for i := 1 to nol do begin
line := TfrxLineView.Create(band);
line.CreateUniqueName;
line.Top := 0.73;
line.Width := fr1cm * 2;
line.Left := left;
left := left + line.Width + 30;
end;
// Report preview
report.ShowReport(False);
end;
This is my final solution:
procedure Child8OnBeforePrint(Sender: TfrxComponent);
var nol, i: integer;
left1, left2: extended;
child, newChild: TfrxChild;
noteLine1, noteLine2, line: TfrxLineView;
page: TfrxPage;
band: TfrxChild;
begin
nol := <DS_MAIN."VOLUME"> /2;
nol := nol + <DS_MAIN."VOLUME"> mod 2;
band := TfrxChild(TRP_ORDER_NOTE.FindObject('Child9'));
// Lines generation
left1 := 3*fr1cm;
left2 := 11.2*fr1cm;
for i := 1 to nol do begin
line := TfrxLineView.Create(band);
line.Name := 'noteLine'+intToStr(1+2*(i-1+trunc(random*1000000))); //Panic solution
line.Top := fr1cm*(0.73 + (i-1)*0.75);
line.Width := 7.5*fr1cm;
line.Left := left1;
if (<DS_MAIN."VOLUME"> mod 2 > 0 ) and (i = nol) then
exit
else
begin
line := TfrxLineView.Create(band);
line.Name := 'noteLine'+intToStr(2*i+trunc(random*1000000));
line.Top := fr1cm*(0.73 + (i-1)*0.75);
line.Width := 7.5*fr1cm;
line.Left := left2;
end;
end;
end;

Why is my TListBox getting blank when its last TListBoxItem is checked?

Problem
My TListBox is getting blank when its last TListBoxItem is programatically checked. To illustrate it better, hereby what I mean by getting blank:
Context
I'm generating a list from a TJSONArray. Each item looks like {"event_code","event_name"}.
Then, I compare if the event_code is written on a second TJSONArray : json_response_available_events. If it does, the ListBoxItem will be checked.
Code
procedure TFormHome.TimerGetEventsTimer(Sender: TObject);
var
K : Integer;
Z : Integer;
ListCount : Integer;
AvailableList_Count: Integer;
lb_item: TListBoxItem;
event_code_first_array: string;
event_code : string;
event_name : string;
begin
// Disable this timer for now
TimerGetEvents.Enabled := false;
// Get List of Notifications
json_response_events := DM_Auth0.ServerMethods1Client.GetEventsCodeAndDescription(communication_token);
json_response_available_events := DM_Auth0.ServerMethods1Client.GetAllowedNotificationsList(communication_token, genset_id);
ListCount := json_response_events.Count -1;
AvailableList_Count := json_response_available_events.Count - 1;
for K := 0 to (ListCount) do
begin
// Get complete Event Code and Name
event_name := json_response_events.Items[K].toString;
// Get Event Code
event_code_first_array := StringReplace(event_name.Split([':'])[0], '"', '', [rfReplaceAll]);
// Get Event Name
event_name := StringReplace(event_name.Split([':'])[1], '"', '', [rfReplaceAll]);
// Create ListBoxItem
lb_item := TListBoxItem.Create(self);
lb_item.Parent := lb_notifications;
lb_item.Text := event_name;
lb_item.StyleLookup := 'listboxitemleftdetail';
// Check if this Item code is available
for Z := 0 to (AvailableList_Count) do
begin
if json_response_available_events.Items[Z] <> nil then
begin
// Get Event Code
event_code := json_response_available_events.Items[Z].toString;
// Format
event_code := StringReplace(event_code, '"', '', [rfReplaceAll]);
if event_code_first_array.Contains(event_code) then
begin
if K <= ListCount then
begin
lb_item.IsChecked := true;
lb_item.IsSelected := false;
end;
end;
end;
end;
end;
end;
Analysis
If we set to < only, it displays the list correctly but the last item will remain unchecked.
if K < ListCount then
begin
lb_item.IsChecked := true;
lb_item.IsSelected := false;
end;
I can even change it's properties when its = like
if K = ListCount then
begin
lb_item.Text := 'Deadpool for President';
end;
and lb_item.isChecked := false works fine, but when setting lb_item.isChecked := true it gets all weirdly blank.
Why is it happening? And if there's a better way to do what I'm doing, the help will be appreciated.

Find number of lines in label with fixed length and word wrap property true

I have a label with fixed length and word wrap property set to true. At run time that label has two lines e.g.:
test := 'quick brown fox jumps over the lazy dog';
On Label this text displayed as two lines
quick brown fox jumps
over the lazy dog
I want to know number of lines at run time:
#13#10 does not work.
The DrawText function can be used for this purpose.
The rest of the procedure doesn't differ so much from what David Heffernan proposes in his comment.
The key here is to adopt the flags DT_WORDBREAK to automatically break the lines and the DT_EDITCONTROL to mimic the caption's text behaviour.
function TForm1.getNumberOfLinesInCaption(ALabel: TLabel): Integer;
var
r: TRect;
h: Integer;
begin
h := ALabel.Canvas.TextHeight(ALabel.Caption);
if h = 0 then
Exit(0);//empty caption
if not ALabel.WordWrap then
Exit(1);//WordWrap = False
FillChar(r, SizeOf(TRect), 0);
r.Width := ALabel.Width;
r.Height := ALabel.Height;
if 0 = DrawText(ALabel.Canvas.Handle, ALabel.Caption, Length(ALabel.Caption), r, DT_EDITCONTROL or DT_WORDBREAK or DT_CALCRECT) then
Exit(-1);//function call has failed
Result := r.Height div h;
//Assert(r.Height mod h = 0);
end;
Function NumberOfLines(MyLabel: TLabel): Integer;
var
TempLabel: TLabel;
Pint1: Integer;
Begin
TempLabel := TLabel.Create(Self);
TempLabel.Caption := MyLabel.Caption;
TempLabel.WordWrap := True;
TempLabel.AutoSize := True;
TempLabel.Width := MyLabel.Width;
TempLabel.Font := MyLabel.Font;
PInt1 := TempLabel.Height;
TempLabel.Caption := '';
TempLabel.WordWrap := False;
TempLabel.AutoSize := True;
Result := PInt1 div TempLabel.Height;
TempLabel.Free;
End;

How to get icon for hidden file (like Explorer) for ListView in Delphi?

I useSHGetFileInfo('', 0, aFileInfo, SizeOf(TSHFileInfo), SHGFI_ICON or SHGFI_SYSICONINDEX) to extract an icon list in TImageList and then associate index with TListView. Which flag I must use to get hidden style like Explorer?
To the best of my knowledge, the system does not offer such functionality. You need to create faded icons yourself, based on the original icon. You can use a function along these lines to do that:
function CreateFadedIcon(Icon: HICON): HICON;
type
TRGBA = record
B,G,R,A: Byte
end;
procedure InitialiseBitmapInfoHeader(Width, Height: Integer; var bih: BITMAPINFOHEADER);
begin
bih.biSize := SizeOf(BITMAPINFOHEADER);
bih.biWidth := Width;
bih.biHeight := 2*Height;//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
i, j: Integer;
begin
for i := 0 to sbih.biHeight-1 do begin
for j := 0 to sbih.biWidth-1 do begin
dptr^ := sptr^;
TRGBA(dptr^).A := TRGBA(dptr^).A div 3;
inc(dptr);//relies on the fact that no padding is needed for RGBA scanlines
inc(sptr);//likewise
end;
end;
end;
var
IconInfo: 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(Icon, IconInfo) then begin
exit;
end;
Try
GetDIBheaderAndBits(IconInfo.hbmColor, sbih, Pointer(sBits));
if Assigned(sBits) then begin
Try
if (sbih.biPlanes<>1) or (sbih.biBitCount<>32) then begin
exit;
end;
xorScanSize := BytesPerScanline(sbih.biWidth, 32, 32);
Assert(xorScanSize=SizeOf(DWORD)*sbih.biWidth);
andScanSize := BytesPerScanline(sbih.biWidth, 1, 32);
xorBitsSize := sbih.biHeight*xorScanSize;
andBitsSize := sbih.biHeight*andScanSize;
resbitsSize := SizeOf(BITMAPINFOHEADER) + xorBitsSize + andBitsSize;
resbits := AllocMem(resbitsSize);//AllocMem zeroises the memory
Try
dbih := resbits;
InitialiseBitmapInfoHeader(sbih.biWidth, sbih.biHeight, 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, sbih.biWidth, sbih.biHeight, LR_DEFAULTCOLOR);
Finally
FreeMem(resbits);
End;
Finally
FreeMem(sBits);
End;
end;
Finally
if IconInfo.hbmMask<>0 then begin
DeleteObject(IconInfo.hbmMask);
end;
if IconInfo.hbmColor<>0 then begin
DeleteObject(IconInfo.hbmColor);
end;
End;
Finally
DestroyIcon(Icon);
End;
end;

Combination of Canvas.TransparentColor and Canvas.Draw with Opacity

i want to draw a bitmap on a canvas with opacity where the bitmap has a transparent color.
i could create a bitmap with transparent color and draw it to a
canvas i could create a bitmap and draw it to a canvas with opacity
but i couldn't combine it. if i combine it the opacity is ignored.
here is the code i wrote:
procedure TForm1.FormPaint(Sender: TObject);
var b1,b2:TBitmap;
begin
// Example how it opacity works:
b1 := TBitmap.Create;
b1.SetSize(20,20);
b1.Canvas.Brush.Color := clBlue;
b1.Canvas.Rectangle(0,0,20,20);
Canvas.Draw(10,10,b1,$ff); // Works
Canvas.Draw(40,10,b1,$66); // Works
// I need it in combination with TransparentColor:
b2 := TBitmap.Create;
// next 3 lines are different from above
b2.Transparent := true;
b2.TransparentColor := clFuchsia;
b2.Canvas.Brush.Color := clFuchsia;
b2.SetSize(20,20);
b2.Canvas.Brush.Color := clBlue;
b2.Canvas.Ellipse(0,0,20,20);
Canvas.Draw(10,40,b2,$ff); // Works (full opacity)
Canvas.Draw(40,40,b2,$66); // Ignores the $66 Opacity
b1.Free;
b2.Free;
end;
produces:
how could i draw (f.e. a blue circle) with transparent background and just 40% opacity?
i would prefere a solution without direct winapi (like bitblt, ...) if possible.
i tried a few hacks like bitshifting a alpha channel to a TColor value but it didn't work.
here i what i tried:
procedure TForm1.FormPaint(Sender: TObject);
var b:TBitmap;
begin
b := TBitmap.Create;
b.PixelFormat := pf32bit;
b.AlphaFormat := afDefined;
b.Canvas.Brush.Color := 0 and ($ff shl 32); // Background Transperency
b.SetSize(20,20);
b.Canvas.Brush.Color := clBlue + (($ff-$66) shl 32);
b.Canvas.Ellipse(0,0,20,20);
Canvas.Draw(10,10,b);
b.Free;
end;
produces:
thanks in advance!
EDIT: my system: delphi xe 5 on windows 7 64bit (but using the 32bit compiler)
What happens can be seen in procedure TBitmap.DrawTransparent in the unit Graphics.
If the property of the image is set to transparent as show for b2 in your example the Bitmap will be drawn with
Graphics.TransparentStretchBlt which is using StretchBlt with differnt masks to draw the image and is not able to use the alpha channel.
A not tranparent Bitmap , your b1, will be draw with
AlphaBlend.
To reach your goal you might use another bitmap b2, set the Alphachannel to 0, paint b2 with opacity $66 on b3, set set the Alphachannel to 255 for every pixel which is clFuchsia in b2 and then paint this bitmap with the desired opacity
type
pRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray = ARRAY [0 .. 0] OF TRGBQuad;
TRefChanel=(rcBlue,rcRed,rcGreen);
procedure SetBitmapAlpha(ABitmap: TBitMap; Alpha: Byte);
var
pscanLine32: pRGBQuadArray;
nScanLineCount, nPixelCount : Integer;
begin
with ABitmap do
begin
PixelFormat := pf32Bit;
HandleType := bmDIB;
ignorepalette := true;
alphaformat := afDefined;
for nScanLineCount := 0 to Height - 1 do
begin
pscanLine32 := Scanline[nScanLineCount];
for nPixelCount := 0 to Width - 1 do
with pscanLine32[nPixelCount] do
begin
rgbReserved := Alpha;
end;
end;
end;
end;
procedure AdaptBitmapAlpha(ABitmap,TranspBitmap:TBitmap);
var
pscanLine32,pscanLine32_2: pRGBQuadArray;
nScanLineCount, nPixelCount : Integer;
begin
with ABitmap do
begin
PixelFormat := pf32Bit;
HandleType := bmDIB;
ignorepalette := true;
alphaformat := afDefined;
for nScanLineCount := 0 to Height - 1 do
begin
pscanLine32 := Scanline[nScanLineCount];
pscanLine32_2 := TranspBitmap.Scanline[nScanLineCount];
for nPixelCount := 0 to Width - 1 do
with pscanLine32[nPixelCount] do
begin
// all picels with are not clFuchsia in the transparent bitmap
if NOT ((pscanLine32_2[nPixelCount].rgbBlue=255) AND (pscanLine32_2[nPixelCount].rgbRed=255) AND (pscanLine32_2[nPixelCount].rgbGreen=0) ) then
begin
rgbReserved := 255;
end
else
begin
rgbBlue := 0;
rgbRed := 0;
rgbGreen := 0;
end;
end;
end;
end;
end;
procedure TAForm.FormPaint(Sender: TObject);
var b1,b2,b3:TBitmap;
BF: TBlendFunction;
begin
// Example how it opacity works:
b1 := TBitmap.Create;
b1.SetSize(20,20);
b1.Canvas.Brush.Color := clBlue;
b1.Canvas.Rectangle(0,0,20,20);
Canvas.Draw(10,10,b1,$ff); // Works
Canvas.Draw(40,10,b1,$66); // Works
// I need it in combination with TransparentColor:
b3 := TBitmap.Create;
b3.PixelFormat := pf32Bit;
b2 := TBitmap.Create;
b2.PixelFormat := pf32Bit;
// next 3 lines are different from above
b2.Transparent := true;
b2.TransparentColor := clFuchsia;
b2.Canvas.Brush.Color := clFuchsia;
b2.SetSize(20,20);
b2.Canvas.Brush.Color := clBlue;
b2.Canvas.Ellipse(0,0,20,20);
Canvas.Draw(10,40,b2,$ff); // Works (full opacity)
b3.SetSize(20,20);
SetBitmapAlpha(b3,0);
b3.Canvas.Draw(0,0,b2,$66);
AdaptBitmapAlpha(b3,b2);
Canvas.Draw(40,40,b3,$66);
b1.Free;
b2.Free;
b3.Free;
end;
thanks to bummi (accepted answer)!
i put his solution in a class helper. here is the code if anybody need it:
unit uBitmapHelper;
interface
uses
Vcl.Graphics;
type
TBitmapHelper = class Helper for TBitmap
private
type
TRgbaRec = packed record
r,g,b,a:Byte;
end;
PRgbaRec = ^TRgbaRec;
PRgbaRecArray = ^TRgbaRecArray;
TRgbaRecArray = array [0 .. 0] of TRgbaRec;
public
procedure TransparentMaskedDraw(ACanvas:TCanvas;AX:Integer;AY:Integer;AMask:TColor;AOpacity:Byte);
end;
implementation
{ TBitmapHelper }
procedure TBitmapHelper.TransparentMaskedDraw(ACanvas:TCanvas;AX,AY:Integer;AMask:TColor;AOpacity:Byte);
var i,j:Integer;
line1,line2:PRgbaRecArray;
mask:PRgbaRec;
tmp:TBitmap;
begin
mask := #AMask;
tmp := TBitmap.Create;
tmp.SetSize(self.Width,self.Height);
tmp.PixelFormat := pf32Bit;
tmp.HandleType := bmDIB;
tmp.IgnorePalette := true;
tmp.AlphaFormat := afDefined;
for i := 0 to tmp.Height - 1 do begin
line1 := tmp.Scanline[i];
for j := 0 to tmp.Width - 1 do begin
line1[j].a := 0;
end;
end;
tmp.Canvas.Draw(0,0,self,AOpacity);
for i := 0 to tmp.Height - 1 do begin
line1 := tmp.ScanLine[i];
line2 := self.ScanLine[i];
for j := 0 to tmp.Width - 1 do begin
if not((line2[j].r = mask.r) and (line2[j].g = mask.g) and (line2[j].b = mask.b)) then begin
line1[j].a := $ff;
end else begin
line1[j].r := 0;
line1[j].g := 0;
line1[j].b := 0;
end;
end;
end;
ACanvas.Draw(AX,AY,tmp,AOpacity);
tmp.Free;
end;
end.
The oldest answer is fine, please find some easy reshuffle.
This example also shows how to put one png-image with opacity on another by respecting the transparency.
procedure TForm2.FormCreate(Sender: TObject);
//define your own transparent color by setting RGB-values
const cTransR=255; cTransG=255; cTransB=255;
clTrans= $10000*cTransB + $100*cTransG + cTransR;
var bmp1,bmp2:TBitmap;
pngTemp: TPngImage;
I:integer;
procedure SetAlphaTransparent(VAR LBitmap:TBitmap);
type TRGBQuadArray = ARRAY [0..0] OF TRGBQuad;
var I, J: integer;
LscanLine32:^TRGBQuadArray;
begin
// I found no other way than scanning pixel by pixel to recover default opacity
for I := 0 to LBitmap.Height - 1 do begin
LscanLine32:=LBitmap.ScanLine[I];
for J := 0 to LBitmap.Width - 1 do
with LscanLine32[J] do
if NOT((rgbRed=cTransR)AND(rgbGreen=cTransG)AND(rgbBlue=cTransB)) then
rgbReserved := 255; // make pixel visible, since transparent is default
end;
end;
Procedure SetAlphaProperty(Var LBitmap:TBitmap; LWidth, LHeight:integer);
begin
// You will need a different format Bitmap to allow alpha values
LBitmap.PixelFormat := pf32Bit;
LBitmap.HandleType := bmDIB;
LBitmap.alphaformat := afDefined;
LBitmap.Canvas.Brush.Color := clTrans;
LBitmap.SetSize(LWidth,LHeight);
end;
begin
// create any background on your Form, by placing IMG:Timage on the From
pngTemp := TPngImage.Create;
pngTemp.LoadFromFile( GetCurrentDir()+'\figure1.png' );
IMG.Canvas.Draw((IMG.Width-pngTemp.Width) div 2, // fit png into the center
(IMG.Height-pngTemp.Height) div 2,pngTemp);
pngTemp.Free;
// First example how it opacity works with transparency
bmp1 := TBitmap.Create;
SetAlphaProperty(bmp1,35,35);
// a circle has a surrouding area, to make transparent
bmp1.Canvas.Brush.Color := clBlue;
bmp1.Canvas.Ellipse(5,5,30,30);
SetAlphaTransparent(bmp1);
// show some circles with different opacity
for I := 0 to 7 do
IMG.Canvas.Draw(I*40-30,10,bmp1,(8-I)*32);
bmp1.Free;
// Another example using a different png-file
bmp2 := TBitmap.Create;
SetAlphaProperty(bmp2,Img.Width,Img.Height);
// load a transparent png-file and put it into the alpha bitmap:
pngTemp := TPngImage.Create;
pngTemp.LoadFromFile( GetCurrentDir()+'\figure2.png' );
pngTemp.Transparent := true;
bmp2.Canvas.Draw((bmp2.Width-pngTemp.Width) div 2,// fit png into the center
(bmp2.Height-pngTemp.Height) div 2,pngTemp);
pngTemp.Free;
// draw the second image with transparancy and opacity onto the first one
SetAlphaTransparent(bmp2);
IMG.Canvas.Draw(0,0,bmp2,$66);
bmp2.Free;
end;

Resources