Make a TImage component

I want to make a TImage -component with an empty bitmap
and draw on it's canvas!

Is that possible?

What do I have to put as ancestor: TImage or TGraphicControl.

I have tried myself, but I don't get further than this:

type
  ScrImage1= Class(TImage)
  private
    { Private declarations }
    BitMap: TBitmap;
    FontWidthPix: integer ;
    FontHeightPix: integer ;
    FontName: string ;
    FontSize: integer ;
  Public
   { Public declarations }
    Constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
   { Published declarations }
 end;

Procedure Register;

implementation

Procedure Register;
begin
  RegisterComponents('Samples',[TImage]);
end;

{TImage}

constructor TImage.Create(AOwner: TComponent);
begin
  inherited;
  Bitmap := TBitmap.Create ;
  ScrImage1.Canvas.Font.Size := FontSize ;
  ScrImage1.Canvas.Font.Name := FontName ;
  Bitmap.Height := SCRROWS * FontHeightPix + (FontHeightPix+2) ;
  Bitmap.Width := SCRCOLS * FontWidthPix ;
  ScrImage1.Picture.Graphic := Bitmap ;
  ScrImage1.Canvas.Font.Size := FontSize ;
  ScrImage1.Canvas.Font.Name := FontName ;
end;

destructor TImage.Destroy;
begin
  inherited Destroy;
end;

end:


Greetings,

Peter Kiers
LVL 1
Peter KiersOperatorAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

alijuniorCommented:
Hi Peter...

The following unit is a source file of a component inherited from TImage that creates an bitmap an draw text on it.
If you found some problem to fit it at your needs, please reply.

Regards...

unit ScrImage;

interface

uses
  Graphics,
  SysUtils, Classes, Controls, ExtCtrls;

type
  TScrImage = class(TImage)
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }

    constructor Create( AOwner : TComponent ); override;
    destructor Destroy; override;

  published
    { Published declarations }
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Standard', [TScrImage]);
end;

{ TScrImage }

constructor TScrImage.Create(AOwner: TComponent);
const
  cText = 'alijunior';
begin
  inherited;

  Picture.Bitmap := TBitmap.Create;
  Picture.Bitmap.Height := Picture.Bitmap.Canvas.TextHeight( cText );
  Picture.Bitmap.Width := Picture.Bitmap.Canvas.TextWidth( cText );
  Picture.Bitmap.Canvas.TextOut(0,0, cText );

end;

destructor TScrImage.Destroy;
begin
  Picture.Bitmap.Free;
  inherited;
end;

end.
Peter KiersOperatorAuthor Commented:
hi, thank you for the response.

One little thing, and I don't know how to explain it very well
because my English isn't very good. But i will try to explain:

I have found a programm with free source code on the internet that makes a
connection to a mainframe, the programm is an 3270-terminal programm.
The programm uses a TImage to create an 3270-screen. I wanted to use
that TImage in my multiple MDI-windows application, but because it isn't a
component, it doesn't work. So I thought i'll try to make a component using the
source of the programm. This is the source code of the programm:

procedure Tscreenf.FormCreate(Sender: TObject);
var
  TxMetric: TTextMetric ;
  Bitmap: TBitmap ;
begin
  { get the cell size based on the current font, calculate and set }
  { the client window size and the image area size }
  Bitmap := TBitmap.Create ;
  ScrImage1.Canvas.Font.Size := FontSize ;
  ScrImage1.Canvas.Font.Name := FontName ;
  GetTextMetrics(ScrImage1.Canvas.Handle,TxMetric) ;
  FontWidthPix := TxMetric.tmMaxCharWidth ;
  FontHeightPix := TxMetric.tmHeight ;
  Bitmap.Height := SCRROWS * FontHeightPix + (FontHeightPix+2) ;
  Bitmap.Width := SCRCOLS * FontWidthPix ;
  ScrImage1.Picture.Graphic := Bitmap ;
  ScrImage1.Canvas.Font.Size := FontSize ;
  ScrImage1.Canvas.Font.Name := FontName ;
end;

And this is what i have so far:


   private
    { Private declarations }
        SCRROWS: integer ;
        SCRCOLS: integer ;  
        FontName: string ;
        FontSize: integer ;
        FontWidthPix: integer ;
        FontHeightPix: integer ;

constructor TScrImage.Create(AOwner: TComponent);
const
  cText = 'alijunior';
begin
  inherited;
  Picture.Bitmap := TBitmap.Create;
  Picture.Bitmap.Height := SCRROWS * FontHeightPix + (FontHeightPix+2) ;
  Picture.Bitmap.Width := SCRCOLS * FontWidthPix ;
   Picture.Bitmap.Canvas.Font.Name := FontName;
   Picture.Bitmap.Canvas.Font.Size:= FontSize;
end;

In the first code there is something like a TTEXTMETRIC, what is that?
I have looked in Help but get nothing. En how can I put it in the Constructor-
procedure?

Peter
Peter KiersOperatorAuthor Commented:
I have increased the points because i think this is not an easy question.

Peter
Slick812Commented:
hello peterkiers , , not sure if I understand what you want your component to do? I see a TBitmap in your code above, but it is not used (sets the bitmap width and height) for drawing? ? I am not sure about using a base class of TImage, since I can not tell what the compponent is suppose to be doing? ? ? Seems like you could have given more info?

anyway, a TImage is based on a TGraphicControl, so I have some code below for a  TTextRowCol  as a TGraphicControl. - -



unit TextRowCol;

interface

uses
  Windows, Messages, Classes, Controls;

type

TTextRowCol = class(TGraphicControl)
  private
    { Private declarations }

  protected
    { Protected declarations }
    FdoDS: Boolean;
    FCols, FRows: Integer;
    //aBmp: TBitmap;
    procedure SetCols(Value: Integer);
    procedure SetRows(Value: Integer);
    procedure DoSize;
    procedure Loaded; override;
    procedure Paint; override;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    property Height;
    property Width;

  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    //destructor Destroy; override;

  published
    { Published declarations }
    property Caption;
    property Columbs: Integer read FCols write SetCols default 8;
    property Rows: Integer read FRows write SetRows default 2;
    property Cursor;
    property Font;
    property Enabled;
    property Visible;
    property Left;
    property Top;
    property Name;
    property Tag;
    property Hint;
    property ParentShowHint;
    property ShowHint;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnClick;

  end;

procedure Register;

implementation

uses SysUtils, Forms;

procedure Register; begin RegisterComponents('Samples', [TTextRowCol]); end;

constructor TTextRowCol.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FdoDS := True;
ControlStyle:= ControlStyle + [csClickEvents] - [csSetCaption];
FRows := 2;
FCols := 8;
Font.Name := 'Courier New';
// had inconsistant widths witn variable width fonts ?
Width := FCols*10;
Height := FRows*10;
//aBmp : TBitmap.Create; // no use for a bitmap ?
end;

{destructor TTextRowCol.Destroy;
begin
FreeAndNil(aBmp);
inherited Destroy;
end;}

procedure TTextRowCol.DoSize;
var
TxMetric: TTextMetric;
begin
Canvas.Font := Self.Font;
GetTextMetrics(Canvas.Handle,TxMetric);
Width := FCols*TxMetric.tmAveCharWidth;//TxMetric.tmMaxCharWidth;
  // you can change it back, this was more consistant
Height := FRows*TxMetric.tmHeight;
end;


procedure TTextRowCol.SetCols(Value: Integer);
begin
if Value = FCols then Exit;
if Value < 1 then Value := 1;
if value > 512 then Value := 512;
FCols := Value;
DoSize;
Invalidate;
end;


procedure TTextRowCol.SetRows(Value: Integer);
begin
if Value = FRows then Exit;
if Value < 1 then Value := 1;
if Value > 512 then Value := 512;
FRows := Value;
DoSize;
Invalidate;
end;


procedure TTextRowCol.CMFontChanged(var Message: TMessage);
begin
if (csLoading in ComponentState) then
  DoSize;
Invalidate;
end;
   
procedure TTextRowCol.CMTextChanged(var Message: TMessage);
begin
Invalidate;
end;


procedure TTextRowCol.Loaded;
begin
inherited Loaded;
DoSize;
FdoDS := False;
end;


procedure TTextRowCol.Paint;
var
aRect: TRect;
begin
if FdoDS then
  begin
  DoSize;
  FdoDS := False;
  end;
 
if Length(Caption) > 0 then
  begin
  Canvas.Font := Self.Font;
  aRect := ClientRect;
  DrawText(Canvas.Handle,PChar(Caption),-1,aRect,
           DT_LEFT or DT_NOPREFIX or DT_EDITCONTROL or DT_WORDBREAK);
  end;
end;


end.

= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

below is code I used to test it -


procedure TForm1.FormCreate(Sender: TObject);
begin
TextRowCol1 := TTextRowCol.Create(Self);
TextRowCol1.Parent := Self;
TextRowCol1.Top := 388;
TextRowCol1.Left := 40;
TextRowCol1.Caption := 'a b c d e f g h i j k l m n o';
TextRowCol1.Columbs := 9;
TextRowCol1.Rows := 3;
TextRowCol1.Font.Size := 11;
end;

 = = = = = = = = = = =  ==
I hope this can give you some Ideas on component creation, but I had no idea whatever for what this component is suppose to do. so I just drew some text?
ask questions if you need more info

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Peter KiersOperatorAuthor Commented:
Hi, these are the procedures that draws on the canvas, it draws an 3270-screen.


procedure Tscreenf.DispCell(x: integer; y: integer; PaintBlanks: boolean) ;
{
  Given a buffer cell location this routine displays the buffer contents
  for that cell on the screen window using that cells attributes.
}
var
  xpos, ypos: integer ;
begin
  xpos := (x * FontWidthPix)-FontWidthPix ;
  ypos := (y * FontHeightPix)-FontHeightPix ;
  with ScrImage1.Canvas do
    begin
      Brush.Style := bsSolid ;
      Brush.Color := ColorBlack ;

      { if null or attribute then paint as blank }
      if (ScrBuf[y,x].data = Char(cdDefault)) or
         (ScrBuf[y,x].data = Char(cdFieldAttr)) then
        begin
          if PaintBlanks then
            begin
              Font.Style := [] ;
              TextOut(xpos,ypos,' ') ;
            end ;
        end
      else   { paint presentation characters }
        begin
          if (Byte(ScrBuf[y,x].attrib) and caNonDisp) <> caNonDisp then
            begin
              Pen.Mode := pmCopy ;
              Font.Color := ColorMapI2W(ScrBuf[y,x].color) ;
              if ScrBuf[y,x].hilite = Char(chDefault) then
                Font.Style := []
              else if ScrBuf[y,x].hilite = Char(chReverse) then
                begin
                  Font.Style := [] ;
                  Pen.Mode := pmXor ;
                  Brush.Color := ColorMapI2W(ScrBuf[y,x].color) ;
                  Font.Color := ColorBlack ;
                end
              else if ScrBuf[y,x].hilite = Char(chUnderLine) then
                Font.Style := [fsUnderline]
              else if ScrBuf[y,x].hilite = Char(chBlink) then
                Font.Style := [fsStrikeout]
              else
                Font.Style := [] ;

              if (Byte(ScrBuf[y,x].attrib) and caIntens) = caIntens then
                Font.Style := Font.Style + [fsBold] ;

              TextOut(xpos,ypos,ScrBuf[y,x].data) ;
            end
          else
            TextOut(xpos,ypos,' ') ;
        end ;
    end ;
end ;

procedure Tscreenf.DispCells(scol, srow,              { start col/row }
                             ecol, erow: integer;     { end col/row }
                             PaintBlanks: boolean) ;  { paint blanks ? }
{
  Given two buffer cell locations this routine displays the buffer contents
  for those cells and all cells between them on the screen window using
  their cell attributes.
}
var
  r,c: integer ;
begin
  r := srow ;
  c := scol ;
  while not( (r = erow) and (c = ecol)) do
    begin
      DispCell(c,r,PaintBlanks) ;
      GetNextCell(c,r) ;
    end ;
  DispCell(c,r,PaintBlanks) ;
end ;

procedure Tscreenf.DrawCursor(x: integer; y: integer) ;
{
  Draws the cursor on the emulator screen window at the cell location
  specified, using the current cursor shape.
}
var
  xpos, ypos: integer ;
begin
  xpos := (x * FontWidthPix)-FontWidthPix ;
  ypos := (y * FontHeightPix)-1 ;
  with ScrImage1.Canvas do
    begin
      if csrShape = csrUnderLine then
        begin
          Pen.Mode := pmWhite ;
          Pen.Color := ColorWhite ;
          Brush.Style := bsSolid ;
          Brush.Color := ColorWhite ;
          MoveTo(xpos,ypos) ;
          LineTo(xpos+FontWidthPix,ypos) ;
        end
      else
        begin
          Pen.Mode := pmXor ;
          Pen.Color := ColorMapI2W(ScrBuf[y,x].color) ;
          Brush.Style := bsSolid ;
          Brush.Color := ColorMapI2W(ScrBuf[y,x].color) ;
          Rectangle(xpos,ypos-FontHeightPix+1,xpos+FontWidthPix,ypos) ;
        end ;
    end ;
end ;

procedure Tscreenf.DispLine(row: integer) ;
{
  Given a display row this routine displays the buffer contents
  for all the cells in that row upon the screen window using
  their cell attributes.
}
var
  i: integer ;
begin
  for i := 1 to SCRCOLS do
    DispCell(i,row,true) ;
end ;

procedure Tscreenf.ShowStatus ;
{
  Status Area format.

  +------------------------------------------------------------------------------+
  TTTTTT  EEEEEEEE    H B NNN I S KKKKKK   DDDDDDDDDDDDDDDDDDDDDDDDDD      RR/CCC
  1---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8

  T - Connection indicator or test.
  E - Error/status indication area.
      X -f     = The key pressed has no function.
      X <->    = The key pressed will not function in this cursor location.
      X Num    = Only numeric keys can be used in this location.
      X SYSTEM = Data is being transmitted to the host, and a response
                 has not been received yet.
      X ?+     = The keyboard was already locked, keypress discarded.
      X WAIT   = Keyboard locked while making connection to host.
  H - Current character hilite (normal, reverse, underline, or blink)
  B = Block showing currently selected color.
  N - Contains NUM - Indicates cursor is over a numeric field.
  I - Contains ^ - Indicates insert mode is on.
  S - Contains upward pointing arrow - Indicates caps is on.
  K - Contains K=a xx - Shows the key code (xx) of the last key pressed,
      and if Alt Shift or Ctrl were pressed as well (a). This is only
      displayed after the toggle key Ctrl-F1 is pressed.
  D - Shows information about the cell the cursor is over. The format of
      this is: D=dd A=aa H=hh S=ss C=cc
      Where: dd is the hex value of the data converted to ascii.
             aa is the hex value of the attributes as described in the
                3270 data stream ref.
                00 = Default
             hh is the hex value of the hilite as described in the
                3270 data stream ref.
                00 = Default
                F1 = Blink
                F2 = Reverse video
                F4 = Underscore
             ss is the hex value of the symbol set as described in the
                3270 data stream ref.
                00 = Default
             cc is the hex value of the color as described in the
                3270 data stream ref.
                00 = Default
                F1 = Blue
                F2 = Red
                F3 = Pink
                F4 = Green
                F5 = Turquoise
                F6 = Yellow
                F7 = White
      This is only displayed after the toggle key Ctrl-F1 is pressed.
  R - Cursor row.
  C - Cursor column.

}
var
  StatY, SepX, SepY: integer ;
  i,j: integer ;
begin
  SepX := SCRCOLS * FontWidthPix ;
  SepY := SCRROWS * FontHeightPix ;
  StatY := SCRROWS * FontHeightPix + (FontHeightPix+2) ;
  with ScrImage1.Canvas do
    begin
      { draw seperator line }
      Pen.Mode := pmCopy ;
      Pen.Color := ColorBlue ;
      Brush.Style := bsClear ;
      Brush.Color := ColorBlack ;
      MoveTo(0,SepY) ;
      LineTo(SepX,SepY) ;

      { draw status text }
      Font.Style := [] ;
      Font.Color := ColorBlue ;
      if test then
        begin
          { draw status box }
          Rectangle(0,SepY+2,FontWidthPix,StatY) ;
          TextOut(FontWidthPix*2,SepY+2,'TEST') ;
        end
      else
        begin
          TextOut(0,SepY+2,'4') ;
          { draw status box }    
          Pen.Mode := pmXor ;
          Rectangle(0,SepY+2,FontWidthPix,StatY) ;
          Pen.Mode := pmCopy ;

          { connected indicator face = stick man }
          TextOut(FontWidthPix*2,SepY+2,Char($02)) ;

          { display error indicator }
          Font.Color := ColorRed ;
          if KbdLocked then
            TextOut(FontWidthPix*8,SepY+2,'X '+LockReason)
          else
            TextOut(FontWidthPix*8,SepY+2,'        ') ;

          { display current character hilite }  
          Font.Color := ColorBlue ;
          if CurCellHilite = Char(chDefault) then
            Font.Style := []
          else if CurCellHilite = Char(chReverse) then
            begin
              Font.Style := [] ;
              Pen.Mode := pmXor ;
              Brush.Color := ColorBlue ;
              Font.Color := ColorBlack ;
            end
          else if CurCellHilite = Char(chUnderLine) then
            Font.Style := [fsUnderline]
          else if CurCellHilite = Char(chBlink) then
            Font.Style := [fsStrikeout]
          else
            Font.Style := [] ;
          TextOut(FontWidthPix*21,FontHeightPix*SCRROWS+2,'a') ;
          Pen.Mode := pmCopy ;
          Font.Style := [] ;
          Brush.Color := ColorBlack ;

          { display current character color as a block }
          Font.Color := ColorMapI2W(CurCellColor) ;
          TextOut(FontWidthPix*23,FontHeightPix*SCRROWS+2,#219) ;

          { display NUM indicator }
          Font.Color := ColorBlue ;
          if (Byte(ScrBuf[CsrRow,CsrCol].attrib) and caNumeric) = caNumeric then
            TextOut(FontWidthPix*25,FontHeightPix*SCRROWS+2,'NUM')
          else
            TextOut(FontWidthPix*25,SCRROWS*FontHeightPix+2,'   ') ;

          { display insert indicator }
          if insert then
            TextOut(FontWidthPix*29,SepY+2,#94)  { up arrow insert indicator }
          else
            TextOut(FontWidthPix*29,SepY+2,' ') ;

          { display caps indicator }
          if Caps then
            TextOut(FontWidthPix*31,SepY+2,#24)  { up arrow caps indicator }
          else
            TextOut(FontWidthPix*31,SepY+2,' ') ;

          { display debug information }
          if ExtStatus then
            begin
              i := CsrRow ;
              j := CsrCol ;
              TextOut(FontWidthPix*42,SepY+2,
                Format('D=%.2x A=%.2x H=%.2x S=%.2x C=%.2x',
                 [Byte(ScrBuf[i,j].data),
                  Byte(ScrBuf[i,j].Attrib),Byte(ScrBuf[i,j].Hilite),
                  Byte(ScrBuf[i,j].CharSet),Byte(ScrBuf[i,j].Color)
                 ]) ) ;
              TextOut(FontWidthPix*33,SepY+2,
                Format('K=%s %.2x',[LastAlt,LastKey])+'  ') ;
            end
          else
            begin
              TextOut(FontWidthPix*33,SepY+2,'      ') ;
              TextOut(FontWidthPix*42,SepY+2,'                         ') ;
            end ;

          { display row and column indicator }
          Font.Color := ColorWhite ;
          TextOut(FontWidthPix*74,SepY+2,Format('%.2d/%.3d',[CsrRow,CsrCol])) ;
        end ;
    end ;
end ;

greetings,

Peter Kiers
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Delphi

From novice to tech pro — start learning today.