Question

i have an example descendant of TBitmap:

TMyBitmap = class(TBitmap)
public
    constructor Create; override;
end;

constructor TMyBitmap.Create;
begin
   inherited;
   Beep;
end;

At run-time i construct one of these TMyBitmap objects, load an image into it, and place it into a TImage on the form:

procedure TForm1.Button1Click(Sender: TObject);
var
   g1: TGraphic;
begin
   g1 := TMyBitmap.Create;
   g1.LoadFromFile('C:\...\example.bmp');

   Image1.Picture.Graphic := g1;
end;

Inside of TPicture.SetGraphic you can see that it makes a copy of the graphic, by constructing a new one, and calling .Assign on the newly constructed clone:

procedure TPicture.SetGraphic(Value: TGraphic);
var
   NewGraphic: TGraphic;
begin
   ...
   NewGraphic := TGraphicClass(Value.ClassType).Create;
   NewGraphic.Assign(Value);
   ...
end;

The line where the new graphic class is constructed:

NewGraphic := TGraphicClass(Value.ClassType).Create;

correctly calls my constructor, and all is well.

---

i want to do something similar, i want to clone a TGraphic:

procedure TForm1.Button1Click(Sender: TObject);
var
   g1: TGraphic;
   g2: TGraphic;
begin
   g1 := TMyBitmap.Create;
   g1.LoadFromFile('C:\...\example.bmp');

   //Image1.Picture.Graphic := g1;
   g2 := TGraphicClass(g1.ClassType).Create;
end;

Except this never calls my constructor, nor is it calling TBitmap constructor. It’s only calling TObject constructor. After construction:

g2.ClassName: 'TMyBitmap'
g2.ClassType: TMyBitmap

The type is right, but it doesn’t call my constructor, but identical code elsewhere does.

Why?

---

Even in this hypothethetical contrived example it’s still a problem, because the constructor of TBitmap isn’t being called; internal state variables are not being initialized to valid values:

constructor TBitmap.Create;
begin
  inherited Create;
  FTransparentColor := clDefault;
  FImage := TBitmapImage.Create;
  FImage.Reference;
  if DDBsOnly then HandleType := bmDDB;
end;

---

The version in TPicture:

NewGraphic := TGraphicClass(Value.ClassType).Create;

decompiles to:

mov eax,[ebp-$08]
call TObject.ClassType
mov dl,$01
call dword ptr [eax+$0c]
mov [ebp-$0c],eax

My version:

g2 := TGraphicClass(g1.ClassType).Create;

decompiles to:

mov eax,ebx
call TObject.ClassType
mov dl,$01
call TObject.Create
mov ebx,eax

Update One

Pushing the “cloning” to a separate function:

function CloneGraphic(Value: TGraphic): TGraphic;
var
    NewGraphic: TGraphic;
begin
   NewGraphic := TGraphicClass(Value.ClassType).Create;
   Result := NewGraphic;
end;

doesn’t help.

Update Two

Clearly, i’m clearly providing a clear screenshot clearly of my clearly code that clearly shows that my clearly code is clearly all there clearly is. Clearly:

Update Three

Here’s an unambigious version with OutputDebugStrings:

{ TMyGraphic }

constructor TMyBitmap.Create;
begin
  inherited Create;
    OutputDebugStringA('Inside TMyBitmap.Create');
end;

function CloneGraphic(Value: TGraphic): TGraphic;
var
    NewGraphic: TGraphic;
begin
    NewGraphic := TGraphicClass(Value.ClassType).Create;
    Result := NewGraphic;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
    g1: TGraphic;
    g2: TGraphic;
begin
    OutputDebugString('Creating g1');
    g1 := TMyBitmap.Create;
    g1.LoadFromFile('C:\Archive\-=Images=-\ChessvDanCheckmateIn38.bmp');
    OutputDebugString(PChar('g1.ClassName: '+g1.ClassName));

    OutputDebugStringA('Assigning g1 to Image.Picture.Graphic');
    Image1.Picture.Graphic := g1;

    OutputDebugString('Creating g2');
    g2 := Graphics.TGraphicClass(g1.ClassType).Create;
    OutputDebugString(PChar('g2.ClassName: '+g2.ClassName));

    OutputDebugString(PChar('Cloning g1 into g2'));
    g2 := CloneGraphic(g1);
    OutputDebugString(PChar('g2.ClassName: '+g2.ClassName));
end;

And the raw results:

ODS: Creating g1 Process Project2.exe ($1138)
ODS: Inside TMyBitmap.Create Process Project2.exe ($1138)
ODS: g1.ClassName: TMyBitmap Process Project2.exe ($1138)
ODS: Assigning g1 to Image.Picture.Graphic Process Project2.exe ($1138)
ODS: Inside TMyBitmap.Create Process Project2.exe ($1138)
ODS: Creating g2 Process Project2.exe ($1138)
ODS: g2.ClassName: TMyBitmap Process Project2.exe ($1138)
ODS: Cloning g1 into g2 Process Project2.exe ($1138)
ODS: g2.ClassName: TMyBitmap Process Project2.exe ($1138)
ODS: g1.ClassName: TMyBitmap Process Project2.exe ($1138)

And the formatted results:

Creating g1
   Inside TMyBitmap.Create
g1.ClassName: TMyBitmap

Assigning g1 to Image.Picture.Graphic
   Inside TMyBitmap.Create

Creating g2
g2.ClassName: TMyBitmap

Cloning g1 into g2
g2.ClassName: TMyBitmap

g1.ClassName: TMyBitmap

Update Four

i tried turning off all compilers options i could:

Note: Don’t turn off Extended syntax. Without it you cannot assign the Result of a function (Undeclared identifier Result).

Update Five

Following @David’s suggestion, i tried compiling the code on some other machines (all Delphi 5):

• Ian Boyd (me): Fails (Windows 7 64-bit)
• Dale: Fails (Windows 7 64-bit)
• Dave: Fails (Windows 7 64-bit)
• Chris: Fails (Windows 7 64-bit)
• Jamie: Fails (Windows 7 64-bit)
• Jay: Fails (Windows XP 32-bit)
• Customer Build Server: Fails (Windows 7 32-bit)

Here’s the source.

Answer 1

This seems to be a scoping problem (the following is from D5 Graphics.pas):

TGraphic = class(TPersistent)
...
protected
  constructor Create; virtual;
...
end;

TGraphicClass = class of TGraphic;

You don’t have any problems overriding Create, and you don’t have any problems when TGraphicClass(Value.ClassType).Create; is called from within the Graphics.pas unit.

However, in another unit TGraphicClass(Value.ClassType).Create; does not have access to protected members of TGraphic. So therefore you end up calling TObject.Create; (which is non-virtual).

Possible Solutions

• Edit and recompile Graphics.pas
• Ensure your clone method subclasses lower down the hierarchy. (e.g. TBitmap.Create is public)

EDIT: Additional Solution

This is a variation on the technique to gain access to the protected members of a class.
No guarantees on the robustness of the solution, but it does seem to work. 🙂
You’ll have to do your own extensive testing I’m afraid.

type
  TGraphicCracker = class(TGraphic)
  end;

  TGraphicCrackerClass = class of TGraphicCracker;

procedure TForm1.Button1Click(Sender: TObject);
var
  a: TGraphic;
  b: TGraphic;
begin
  a := TMyBitmap.Create;
  b := TGraphicCrackerClass(a.ClassType).Create;
  b.Free;
  a.Free;
end;