Tag: Delphi

To create a transparent splashscreen, like for example the splash displayed when adobe acrobat reader starts, do the following:

1. Create the a new form
2. Set the Border Style to bsNone
3. Set the Position to poScreenCenter
4. Overide the create constuctor and add the line Brush.Style = bsClear
5. Override the createparams method and add the line
   Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT +WS_EX_TOPMOST;
   after the call to inherited
6. Add an image componet to the form and load your transparent image into it. I use PNG’s rather than bitmaps with a transparent color.  PNGImage (a PNG wrapper for TPicture is available at sourceforge).
7. Set the image and form’s Autosize to true.
8. Slap on a timer to close the form after a couple of seconds.

I can’t remember where I found this code, if I come across the site again, I’ll put a credit to it in this article. 
When trying to load / save PNG Images from a stream using GDI+ routines to load and save from IStream, there were problems, it turns out with the date/time information returned in the Istream Stats.
The following unit provides a Fixed Stream Adapter that correctly returns the stat information.

unit FixedStreamAdapter;
interface
uses
  classes, sysUtils, activex, windows;
type
  TFixedStreamAdapter = class(TStreamAdapter)
public
function Stat(out statstg: TStatStg;
      grfStatFlag: Longint): HResult; override; stdcall;
end;
implementation

function DateTimeToFileTime(DateTime: TDateTime): TFileTime;
// copied from JclDateTime.pas
const
  FileTimeBase      = -109205.0;
  FileTimeStep: Extended = 24.0 * 60.0 * 60.0 * 1000.0 * 1000.0 *10.0; // 100 nSek per Day
var
  E: Extended;
  F64: Int64;
begin
  E := (DateTime – FileTimeBase) * FileTimeStep;
  F64 := Round(E);
  Result := TFileTime(F64);
end;
function TFixedStreamAdapter.Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult;
Begin
  Result := S_OK;
try
if (@statstg <> nil) then
with statstg do
begin
        FillChar(statstg, sizeof(statstg), 0);
        dwType := STGTY_STREAM;
        cbSize := Stream.size;
        mTime := DateTimeToFileTime(now);
        cTime := DateTimeToFileTime(now);
        aTime := DateTimeToFileTime(now);
        grfLocksSupported := LOCK_WRITE;
end;
except
    Result := E_UNEXPECTED;
end;
end;
end.

When an interface returns a delegated object that causes an error, the factory or autofactory has not been assigned.

The default implementation of SafeCallException refers to FFactory which, in this case is NIL. Override SafeCallException to fix. In COMOBJ.pas, the SafeCallException procedure refers to FFactory.ErrorID, FFactory.ProgID, etc in the call to HandleSafeCallException. FFactory is nil, causing a AV in the error handler, which causes a Catastrophic Error to be raise.

If you descend your objects from a TFudgedAutoObject which simply overrides the SafeCallException message, you can solve the problem.

function TFudgedAutoObject.SafeCallException(ExceptObject: TObject;ExceptAddr: Pointer): HRESULT;
var
  E: TObject;
  CreateError: ICreateErrorInfo;
  ErrorInfo: IErrorInfo;
begin
  Result := E_UNEXPECTED;
  E := ExceptObject;
if Succeeded(CreateErrorInfo(CreateError)) then
begin
    CreateError.SetGUID(Class_EPO);
    CreateError.SetSource(PWideChar(‘MY ERROR SOURCE’));
    CreateError.SetHelpFile(PWideChar(‘MY HELPFILE NAME.HLP’));
if E is Exception then
begin
      CreateError.SetDescription(PWideChar(WideString(Exception(E).Message)));
      CreateError.SetHelpContext(Exception(E).HelpContext);
if (E is EOleSysError) and (EOleSysError(E).ErrorCode < 0) then
        Result := EOleSysError(E).ErrorCode;
end;
if CreateError.QueryInterface(IErrorInfo, ErrorInfo) = S_OK then
    SetErrorInfo(0, ErrorInfo);
end;
end;

Comments

Very cool tip!
Written by Guest on 2005-06-08 15:53:46

I’ve been stuck on this problem for a bit. Hopefully this will fix it. Thank you! 
In D7 I had to 
1. Add ActiveX to my uses clause 
2. Define a string constant GUID like this 
const 
MYGUID = ‘{678077B3-095F-4ECE-836D-7E1172C20979}’; 
3. Change the call to SetGUID to  
CreateError.SetGUID(StringToGUID(MYGUID)); 
4. Change the calls to SetSource and SetHelpFile to 
CreateError.SetSource(StringToOleStr(‘MY ERROR SOURCE’));

Written by lummie on 2005-06-09 11:19:00

Ah yes I left my application GUID in SetGUID. 
Customize it to your application as above. Thanks Guest

Use the following function to return them. A quck adaption and you should be able to set them as well. For more values to pass into the function check the current contents of the registry key.

function GetSpecialDir(ValueName : string): String;
//  gets the path to a windows special folder and ensures the trailing backslash is on the path.
//  Some Valid ValueNames are
//  ‘Personal’ – My Documents
//  ‘Desktop’ – User’s Desktop
//  ‘Favorites’ – The User Favorites store
var
  Reg: TRegistry;
begin
  result := ”;
  Reg := TRegistry.Create;
try
    Reg.RootKey := HKey_Current_User;
if Reg.OpenKeyReadOnly(‘SoftwareMicrosoftWindowsCurrentVersionExplo
rerShell Folders’) then
      result := IncludeTrailingPathDelimiter(Reg.ReadString(ValueName));
finally
    Reg.Free;
end;
end;

Having written your nice COM Object model to allow access to your application, how do you find out if you have neen clearing up the objects correctly and check you are handling zombie objects correctly too.

If you add the following unit to your aplication and descend your comobjects from TTracker instead of TAutoObject, this unit will count the number of addrefs and releases that occur on the object.

All you need to do is call TTrackerlog.dump to get a list of all the objects, the maximum number of instances ever alive and the current number alive.

All we are doing, is overriding the addref and release implementation, and maintaing a list of stats based up on the objects classname.

unit ObjectTracker;
interface
uses
   Classes, SysUtils, ComObj, Contnrs, SyncObjs, ActiveX;
type
   TTrackedItemInfo = (iiCreationOnAdd, iiCreationOnRelease);
   TTrackedItemInfos = set of TTrackedItemInfo;
   TTracker = class (TAutoObject)
     FTrackedClassName: string;
public
constructor create; virtual;
function ObjAddRef: Integer; override; stdcall;
function ObjRelease: Integer; override; stdcall;
end;
   TTrackedItem = class (TObject)
private
     FDesc: string;
     FInfo: TTrackedItemInfos;
     FMaxCount: Integer;
     FMinCount: Integer;
     FObjAddress: Pointer;
     FRefCount: Integer;
public
constructor Create(AnObj : pointer);
procedure AddReference;
procedure RemoveReference;
property Desc: string read FDesc write FDesc;
property Info: TTrackedItemInfos read FInfo write FInfo;
property MaxCount: Integer read FMaxCount;
property MinCount: Integer read FMinCount;
property ObjAddress: Pointer read FObjAddress write FObjAddress;
property RefCount: Integer read FRefCount;
end;
   TTrackerLog = class (TObject)
     FList: TObjectList;
     FLock: TMultiReadExclusiveWriteSynchronizer;
protected
constructor CreateInstance;
class function AccessInstance(Request: Integer): TTrackerLog;
public
constructor Create; virtual;
destructor Destroy; override;
procedure AddReference(AnObj : TObject; TrackedClassName : string);
procedure Dump(const AFilename : widestring);
class function Instance: TTrackerLog;
class procedure ReleaseInstance;
procedure ReleaseReference(AnObj : TObject; TrackedClassName : string);
end;
implementation
{ TTracker }
{
*************************** TTracker ***************************
}
constructor TTracker.create;
begin
inherited;
   FTrackedClassName := Classname;
end;
function TTracker.ObjAddRef: Integer;
begin
   result := inherited ObjAddRef;
   TTrackerLog.Instance.AddReference(self,FTrackedClassName);
end;
function TTracker.ObjRelease: Integer;
begin
   result := inherited ObjRelease;
   TTrackerLog.Instance.ReleaseReference(self,FTrackedClassName);
end;
{ TTrackerLog }
{
**************************** TTrackedItem *************************
}
constructor TTrackedItem.Create(AnObj : pointer);
begin
inherited Create;
   FMinCount := 0;
   FMaxCount := 0;
   FObjAddress := Anobj;
   FRefCount := 0;
   FInfo := [];
end;
procedure TTrackedItem.AddReference;
begin
   inc(FRefCount);
if FMaxCount < FRefCount then FMaxCount := FRefCount;
end;
procedure TTrackedItem.RemoveReference;
begin
   Dec(FRefCount);
if FMinCount > FRefCount then FMinCount := FRefCount;
end;
{
**************************** TTrackerLog ****************************
}
constructor TTrackerLog.Create;
begin
raise Exception.CreateFmt(‘Access class %s through Instance only’, [ClassName]);
inherited create;
end;
constructor TTrackerLog.CreateInstance;
begin
inherited Create;
   FList := TObjectList.create(true);
   FLock := TMultiReadExclusiveWriteSynchronizer.create;
end;
destructor TTrackerLog.Destroy;
begin
if AccessInstance(0) = Self then AccessInstance(2);
   FreeAndNil(FLock);
   FreeAndNil(FList);
inherited Destroy;
end;
class function TTrackerLog.AccessInstance(Request: Integer): TTrackerLog;
{$WRITEABLECONST ON}
const FInstance: TTrackerLog = nil;
{$WRITEABLECONST OFF}
begin
case Request of
0 : ;
1 : if not Assigned(FInstance) then FInstance := CreateInstance;
2 : FInstance := nil;
else
raise Exception.CreateFmt(‘Illegal request %d in AccessInstance’, [Request]);
end;
   Result := FInstance;
end;
procedure TTrackerLog.AddReference(AnObj : TObject; TrackedClassName : string);
var
   i: Integer;
   Item: TTrackedItem;
begin
   FLock.BeginWrite;
try
     i := FList.count -1;
while (i >= 0) and (TTrackedItem(FList.items[i]).ObjAddress <> AnObj) do dec(i);
if i = -1 then // not found
begin
       item := TTrackedItem.create(AnObj);
       item.Info := Item.Info + [iiCreationOnAdd];
       item.Desc := TrackedClassName;
       Flist.add(item);
end
else
       item := TTrackedItem(FList.items[i]);
     item.AddReference;
finally
   &nbsp
; FLock.EndWrite
end;
end;
procedure TTrackerLog.Dump(const AFilename : widestring);
var
   FName: string;
   i: Integer;
   Item: TTrackedItem;
   fs: TFileStream;
   t: string;
begin
   FLock.BeginRead;
try
//  FName := GetModuleName(HInstance);
//  FName := ChangeFileExt(FName,formatdatetime(‘.hhnnss’,now)) + ‘.csv’;
     FName := AFilename;
if FList.Count > 0 then
begin
       fs := TFileStream.create(fname,fmCreate);
       t := ‘”Address”,”ClassName”,”RefCount&quo
t;,”Max”,”Min”‘ + #13#10;
       fs.Write(t[1],length(t));
for i := 0 to FList.count -1 do
begin
         item := TTrackedItem(FList.items[i]);
         t := format(‘”%x”,”%s”,%d,%d,%d’,[integer(item.
ObjAddress),item.Desc, item.RefCount, item.MaxCount, item.MinCount]) + #13#10;
         fs.Write(t[1],length(t));
end;
       fs.free;
end;
finally
     FLock.EndRead;
end;
end;
class function TTrackerLog.Instance: TTrackerLog;
begin
   Result := AccessInstance(1);
end;
class procedure TTrackerLog.ReleaseInstance;
begin
   AccessInstance(0).Free;
end;
procedure TTrackerLog.ReleaseReference(AnObj : TObject; TrackedClassName : string);
var
   i: Integer;
   Item: TTrackedItem;
begin
   FLock.BeginWrite;
try
     i := FList.count – 1;
while (i >= 0) and (TTrackedItem(FList.items[i]).ObjAddress <> AnObj) do dec(i);
if i = -1 then // not found
begin
       item := TTrackedItem.create(AnObj);
       item.Info := Item.Info + [iiCreationOnRelease];
       item.Desc := TrackedClassName;
       Flist.add(item);
end
else
       item := TTrackedItem(FList.items[i]);
     item.RemoveReference;
finally
     FLock.EndWrite
end;
end;
initialization
finalization
if TTrackerLog.Instance <> nil then TTrackerLog.ReleaseInstance;
end.

The object inspector has an inbuilt ability to edit any TPersistent based object.
It uses RTTI to inspect the published properties of the TPersistent descendant and displays them as an expandable property. This is how the constraints property is implemented for example.

The following unit provides an implementation of an editable TRect. I use this in controls for specifing margins for example.

unit PersistentRect;
interface
uses
   Classes, SysUtils, types;
type
   TPersistentRect = class(TPersistent)
private
     FRect : TRect;
     FOnChange: TNotifyEvent;
function GetRect: TRect;
procedure SetRect(const Value: TRect);
procedure SetRectBottom(const Value: integer);
procedure SetRectLeft(const Value: integer);
procedure SetRectRight(const Value: integer);
procedure SetRectTop(const Value: integer);
protected
procedure AssignTo(Dest: TPersistent); override;
public
property AsRect : TRect read GetRect Write SetRect;
constructor create; virtual;
published
property Left : integer read FRect.Left write SetRectLeft;
property Top : integer read FRect.Top write SetRectTop;
property Right : integer read FRect.Right write SetRectRight;
property Bottom : integer read FRect.Bottom write SetRectBottom;
property OnChange : TNotifyEvent read FOnChange write FOnChange;
end;
implementation
{ TPersistentRect }
procedure TPersistentRect.AssignTo(Dest: TPersistent);
begin
if Dest is TPersistentRect then
with TPersistentRect(Dest) do
begin
       AsRect := Self.AsRect;
end
else inherited AssignTo(Dest);
end;
constructor TPersistentRect.create;
begin
inherited;
   FOnChange := nil;
end;
function TPersistentRect.GetRect: TRect;
begin
   result := FRect;
end;
procedure TPersistentRect.SetRect(const Value: TRect);
begin
   FRect.Left := value.left;
   FRect.top := value.top;
   FRect.right := value.right;
   FRect.bottom := value.bottom;
if assigned(FOnChange) then FOnChange(self);
end;
procedure TPersistentRect.SetRectBottom(const Value: integer);
begin
   FRect.Bottom := Value;
if assigned(FOnChange) then FOnChange(self);
end;
procedure TPersistentRect.SetRectLeft(const Value: integer);
begin
   FRect.Left := Value;
if assigned(FOnChange) then FOnChange(self);
end;
procedure TPersistentRect.SetRectRight(const Value: integer);
begin
   FRect.Right := Value;
if assigned(FOnChange) then FOnChange(self);
end;
procedure TPersistentRect.SetRectTop(const Value: integer);
begin
   FRect.Top := Value;
if assigned(FOnChange) then FOnChange(self);
end;
end.

Example of usage
In the Component that you want an editable rect for add the following :

 TPanelWithMargins = class(TCustomPanel)
private
{ Private declarations }
     FMargins: TPersistentRect;
protected
{ Protected declarations }
procedure MarginsChanged(Sender : TObject);
procedure AdjustClientRect(var Rect: TRect); override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property Margins : TPersistentRect read FMargins write FMargins;
end;
procedure TPanelWithMargins.AdjustClientRect(var Rect: TRect);
begin
inherited;
   Rect.Left := rect.Left + FMargins.Left;
   Rect.Top := rect.top + FMargins.Top;
   Rect.Right := rect.Right – FMargins.Right;
   Rect.Bottom := rect.Bottom – FMargins.Bottom;
end;
constructor TPanelWithMargins.Create(AOwner: TComponent);
begin
inherited;
   FMargins := TPersistentRect.create;
   FMargins.OnChange := MarginsChanged;
   FMargins.AsRect := Rect(2,2,2,2);
end;
destructor TPanelWithMargins.Destroy;
begin
   FreeAndNil(FMargins);
inherited;
end;
procedure TPanelWithMargins.MarginsChanged(Sender: TObject);
begin
   Realign;
end;

For the purposes of this example please assume there is no primary key or constraints on the table. In reallity you would probably want to duplicate a record then change one of the field values, before it is appended.

The problem is that to use dataset.append, dataset.setthefieldvalues, dataset.post, as soon as the append is called, you loose the current record which pointed to the record you want to duplicate. So you could use two datasets and copy one to the other, but this uses extra memory, etc. or you could copy the contents of the current record into a temporary place then call the append.

Taking this second option :
The first solution I came up with was to use VarArrayCreate, but this was slow. Another altenative was to go lower level and use the ActiveBuffer method, but then your getting into memory copies etc. and I didn`t know enough about the internal memory representation of a record.

So this is what I came up with, and has the added benefit of being faster than using the dataset.append dataset.setthefieldvalues dataset.post method. It simply copies the current record in to an array of variant (note NOT a variant array which needs redimsand the such) then uses the dataset.appendrecord method to add the record in one go.

procedure DuplicateCurrentRecord(aDataSet : TDataSet); 
var
  Data : array of variant; 
  aRecord : array of TVarRec; 
  i : integer; 
  max : integer; 
begin
  max := aDataSet.fields.count -1; 
// set the lenghth of the arecord array to be the same as the number of 
// elements in the data array 
  SetLength(arecord,max+1); 
  SetLength(data,max+1); 
// set the variant type pointers to the data array 
for i := 0 to max do
begin
    arecord[i].VType := vtVariant; 
    arecord[i].VVariant := @data[i]; 
end; 
// Copy the Record to the Array 
for i := 0 to max do
    Data[i] := aDataSet.fields[i].value; 
// finally append the record in one go
  aDataSet.AppendRecord(aRecord); 
end;

Some controls that create edit boxes or combos to allow editing of the information they display, for example the TVirtualStringTree, component do not loose the focus when a form is closed, and as such the changes to the edit are not applied. This can be fixed easily with a one-liner.

To ensure that popup edits, independant of the type of control have finished editing, i.e. have lost their focus when a form is closed, simply put the following line in the closequery event.

if assigned(ActiveControl) and (ActiveControl).Focused then DefocusControl(ActiveControl,false);

This line will ensure that the current control that has focus is defocused. It basically checks to see if a control is focused and if it is, Defocuses it.  This should work with all controls, e.g. dropdowns, edits and ensures that edit changes are committed.

TEdit is a fairly low level component utilizing the standard windows edit window. How on earth do we get the background to be something other than a color.. Can we make it transparent or put a picture in. I don’t know if the following works in versions previous to Delphi 6 but I can’t see why it would not.

This unit is a transparent TEdit descendant.

If you want to put your own background in instead of it being transparent change the else clause of the if Transparent in WMEraseBkGnd.

unit Z9Edit;
interface
uses
  Windows, Messages, SysUtils, Classes, Controls, StdCtrls, Graphics;
type
  TZ9Edit = class(TEdit)
private
{ Private declarations }
    FAlignText: TAlignment;
    FTransparent: Boolean;
    FPainting: Boolean;
procedure SetAlignText(Value: TAlignment);
procedure SetTransparent(Value: Boolean);
protected
{ Protected declarations }
procedure RepaintWindow;
procedure CreateParams(var Params: TCreateParams); override;
procedure Change; override;
procedure SetParent(AParent: TWinControl); override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMNCPaint (var Message: TMessage); message WM_NCPAINT;
procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND;
procedure CNCtlColorEdit(var Message: TWMCtlColorEdit); message CN_CTLCOLOREDIT;
procedure CNCtlColorStatic(var Message: TWMCtlColorStatic); message CN_CTLCOLORSTATIC;
procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMMove(var Message: TWMMove); message WM_MOVE;
procedure PaintParent(ACanvas: TCanvas);
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property Align;
property AlignText: TAlignment read FAlignText write SetAlignText default taLeftJustify;
property Transparent: Boolean read FTransparent write SetTransparent default false;
end;
implementation
{ TZ9Edit }
uses
  Forms;
type
  TParentControl = class(TWinControl);
const
  BorderRec: array[TBorderStyle] of Integer = (1, -1);
constructor TZ9Edit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
  FAlignText := taLeftJustify;
  FTransparent := false;
  FPainting := false;
end;
destructor TZ9Edit.Destroy;
begin
inherited Destroy;
end;
procedure TZ9Edit.SetAlignText(Value: TAlignment);
begin
if FAlignText <> Value then
begin
    FAlignText := Value;
    RecreateWnd;
     Invalidate;
end;
end;
procedure TZ9Edit.SetTransparent(Value: Boolean);
begin
if FTransparent <> Value then
begin
    FTransparent := Value;
    Invalidate;
end;
end;
procedure TZ9Edit.WMEraseBkGnd(var Message: TWMEraseBkGnd);
var
  DC: hDC;
  i: integer;
  p: TPoint;
  canvas : TCanvas;
begin
if FTransparent and not(csDesigning in componentstate) then
begin
    canvas := TCanvas.create;
try
      canvas.handle := message.dc;
      PaintParent(Canvas);
finally
      canvas.free;
end;
end
else
begin
    canvas := TCanvas.create;
try
      canvas.handle := message.dc;
      canvas.brush.color := Color;
      canvas.brush.style := bsSolid;
      canvas.fillrect(clientrect);
finally
      canvas.free;
end;
end;
end;
procedure TZ9Edit.WMPaint(var Message: TWMPaint);
begin
inherited;
if FTransparent then
if not FPainting then RepaintWindow;
end;
procedure TZ9Edit.WMNCPaint(var Message: TMessage);
begin
inherited;
end;
procedure TZ9Edit.CNCtlColorEdit(var Message: TWMCtlColorEdit);
begin
inherited;
if FTransparent then SetBkMode(Message.ChildDC, 1);
end;
procedure TZ9Edit.CNCtlColorStatic(var Message: TWMCtlColorStatic);
begin
inherited;
if FTransparent then SetBkMode(Message.ChildDC, 1);
end;
procedure TZ9Edit.CMParentColorChanged(var Message: TMessage);
begin
inherited;
if FTransparent then Invalidate;
end;
procedure TZ9Edit.WMSize(var Message: TWMSize);
var
  r : TRect;
begin
inherited;
  r := ClientRect;
  InvalidateRect(handle,@r,false);
end;
procedure TZ9Edit.WMMove(var Message: TWMMove);
var
  r : TRect;
begin
inherited;
  Invalidate;
  r := ClientRect;
  InvalidateRect(handle,@r,false);
end;
procedure TZ9Edit.RepaintWindow;
var
  DC: hDC;
  TmpBitmap, Bitmap: hBitmap;
begin
if FTransparent then
begin
    FPa
inting := true;
    HideCaret(Handle);
    DC := CreateCompatibleDC(GetDC(Handle));
    TmpBitmap := CreateCompatibleBitmap(GetDC(Handle), Succ(ClientWidth), Succ(ClientHeight));
    Bitmap := SelectObject(DC, TmpBitmap);
    PaintTo(DC, 0, 0);
    BitBlt(GetDC(Handle), BorderRec[BorderStyle] + BorderWidth, BorderRec[BorderStyle] + BorderWidth, ClientWidth, ClientHeight, DC, 1, 1, SRCCOPY);
    SelectObject(DC, Bitmap);
    DeleteDC(DC);
    ReleaseDC(Handle, GetDC(Handle));
    DeleteObject(TmpBitmap);
    ShowCaret(Handle);
    FPainting := false;
end;
end;
procedure TZ9Edit.CreateParams(var Params: TCreateParams);
const
  Alignments: array [TAlignment] of DWord = (ES_LEFT, ES_RIGHT, ES_CENTER);
begin
inherited CreateParams(Params);
  Params.Style := Params.Style or ES_MULTILINE or Alignments[FAlignText];
end;
procedure TZ9Edit.Change;
begin
  RepaintWindow;
inherited Change;
end;
procedure TZ9Edit.SetParent(AParent: TWinControl);
begin
inherited SetParent(AParent);
end;
procedure TZ9Edit.PaintParent(ACanvas: TCanvas);
var
  I, Count, X, Y, SaveIndex: integer;
  DC: cardinal;
  R, SelfR, CtlR: TRect;
  Control : TControl;
begin
  Control := Self;
if Control.Parent = nil then Exit;
  Count := Control.Parent.ControlCount;
  DC := ACanvas.Handle;
  SelfR := Bounds(Control.Left, Control.Top, Control.Width, Control.Height);
  X := -Control.Left; Y := -Control.Top;
// Copy parent control image
  SaveIndex := SaveDC(DC);
  SetViewportOrgEx(DC, X, Y, nil);
  IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight);
  TParentControl(Control.Parent).Perform(WM_ERASEBKGND,DC,0);
  TParentControl(Control.Parent).PaintWindow(DC);
  RestoreDC(DC, SaveIndex);
//Copy images of graphic controls
for I := 0 to Count – 1 do begin
if (Control.Parent.Controls[I] <> nil) then
begin
if Control.Parent.Controls[I] = Control then break;
with Control.Parent.Controls[I] do
begin
        CtlR := Bounds(Left, Top, Width, Height);
if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then
begin
          SaveIndex := SaveDC(DC);
          SetViewportOrgEx(DC, Left + X, Top + Y, nil);
          IntersectClipRect(DC, 0, 0, Width, Height);
          Perform(WM_ERASEBKGND,DC,0);
          Perform(WM_PAINT, integer(DC), 0);
          RestoreDC(DC, SaveIndex);
end;
end;
end;
end;
end;
end.