• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 320
  • Last Modified:

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
0
peterkiers
Asked:
peterkiers
  • 3
2 Solutions
 
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.
0
 
peterkiersAuthor 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
0
 
peterkiersAuthor Commented:
I have increased the points because i think this is not an easy question.

Peter
0
 
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
0
 
peterkiersAuthor 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
0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now