Solved

Display characters and numbers on the canvas

Posted on 2007-03-24
5
220 Views
Last Modified: 2010-04-05
Dear Experts,

I have a procedure called FillBuffer1Click that fills the whole canvas with characters and numbers.
But when I click on the menu-item, I see nothing, what do I do wrong:

Const
  cdDefault = $00;
  cdFieldAttr = $01;
  caDefault = $00;
  caProtect = $20;
  caNumeric = $10;
  caSelPen = $04;
  caIntens = $08;
  caNonDisp = $0C;
  caMDT = $01;
  ccDefault = $00;
  ccBlue = $F1;
  ccRed = $F2;
  ccPink = $F3;
  ccGreen = $F4;
  ccTurquoise = $F5;
  ccYellow = $F6;
  ccWhite = $F7;
  chDefault = $00;
  chBlink = $F1;
  chReverse = $F2;
  chUnderLine = $F4;
  csDefault = $00;
  csAPL = $F1;

type
  TScrCell = record
    Data: char;
    Attrib: char;
    Hilite: char;
    CharSet: char;
    Color: char;
    OldColor: char;
    IsOldColorSet: Boolean;
  end;

  TScrBuf = array[1..25, 1..80] of TScrCell;
  PScrBuf = ^TScrBuf;

 
  TCharSet = set of char;
const ValidChars: TCharSet = ['A'..'Z', 'a'..'z', '0'..'9'];

type
  TMainForm = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    FillBuffer1: TMenuItem;
    procedure FormPaint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FillBuffer1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
      procedure ShowBuf;
      procedure DispCell(x: integer; y: integer; PaintBlanks: boolean);
      function ColorMapI2W(ic: char): TColor;
  end;

var
  MainForm: TMainForm;
  SCRROWS: integer;      
  SCRCOLS: integer;      
  FontWidthPix: integer;  
  FontHeightPix: integer;  
  ScrBuf: TScrBuf;        
  ColorRed: TColor;
  ColorGreen: TColor;
  ColorBlue: TColor;
  ColorYellow: TColor;
  ColorPink: TColor;
  ColorTurq: TColor;
  ColorWhite: TColor;
  ColorBlack: TColor;

implementation

{$R *.dfm}

procedure TMainForm.FormPaint(Sender: TObject);
begin
  ShowBuf;
end;
(*---------------------------------------------------*)
procedure TMainForm.ShowBuf;
var
  i,j:integer;
begin
  Canvas.Lock;  
  try
    with Canvas do
    begin
    Brush.Style := bsSolid;    
    Brush.Color := ColorBlack;  
    FillRect(ClientRect);    
    end;
     for i := 1 to SCRROWS do  
    for j := 1 to SCRCOLS do    
      DispCell(j, i, false);
 // DrawCursor(CsrCol, CsrRow);
 // ShowStatus ;
  finally
    Canvas.Unlock;    
    end;
 end;
(*---------------------------------------------------*)
procedure TMainForm.FormCreate(Sender: TObject);
begin
  SCRCOLS := 80;    
  SCRROWS := 24;  
  ColorRed := clRed;
  ColorGreen := clLime;
  ColorBlue := clBlue;
  ColorYellow := clYellow;
  ColorPink := clFuchsia;
  ColorTurq := clAqua;
  ColorWhite := clWhite;
  ColorBlack := clBlack;
end;
(*--------------------------------------*)
procedure TMainForm.DispCell(x, y: integer; PaintBlanks: boolean);
var
  xpos, ypos: integer;
begin
  xpos := (x * FontWidthPix) - FontWidthPix;
  ypos := (y * FontHeightPix) - FontHeightPix;
  with Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := ColorBlack;
    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
    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;
(*--------------------------------------*)
function TMainForm.ColorMapI2W(ic: char): TColor;
begin
  if Byte(ic) = ccDefault then Result := ColorGreen
  else if Byte(ic) = ccBlue then Result := ColorBlue
  else if Byte(ic) = ccRed then Result := ColorRed
  else if Byte(ic) = ccPink then Result := ColorPink
  else if Byte(ic) = ccGreen then Result := ColorGreen
  else if Byte(ic) = ccYellow then Result := ColorYellow
  else if Byte(ic) = ccTurquoise then Result := ColorTurq
  else if Byte(ic) = ccWhite then Result := ColorWhite
  else Result := ColorGreen;
end;
(*--------------------------------------*)
procedure TMainForm.FillBuffer1Click(Sender: TObject);
var
  i, j, k: integer;
  ch: char;
begin
  k := 0;
  i := 1;
  while i <= SCRROWS do
  begin
    j := 1;
    while j <= SCRCOLS do
    begin
      ch := chr(k);
      if ch in ValidChars then
      begin
        ScrBuf[i, j].data := ch;
        inc(j);
      end;
      k := k + 1;
      if k > 255 then
        k := 0;
    end;
    inc(i);
  end;
end;
(*--------------------------------------*)
end.

Greetings,

Peter Kiers
0
Comment
Question by:peterkiers
  • 3
  • 2
5 Comments
 
LVL 10

Accepted Solution

by:
dinilud earned 500 total points
ID: 18784801
First thing you have to set values of tese variables
   FontWidthPix,FontHeightPix


Second Use invalide function after filling the buffer

(*--------------------------------------*)
procedure TMainForm.FillBuffer1Click(Sender: TObject);
var
  i, j, k: integer;
  ch: char;
begin
  k := 0;
  i := 1;
  while i <= SCRROWS do
  begin
    j := 1;
    while j <= SCRCOLS do
    begin
      ch := chr(k);
      if ch in ValidChars then
      begin
        ScrBuf[i, j].data := ch;
        inc(j);
      end;
      k := k + 1;
      if k > 255 then
        k := 0;
    end;
    inc(i);
  end;
  Invalidate;
end;
(*--------------------------------------*)
0
 
LVL 1

Author Comment

by:peterkiers
ID: 18785956
Thanks for the answer.

1. What does Invalidate?

2. First I have used a Timage as a display of text. Now I have
    choose to use the Form's canvas. This was what I had
    when i used the Timage canvas:

procedure TMainForm.FormCreate(Sender: TObject);
var
  TxMetric: TTextMetric;
  Bitmap: TBitmap;
begin
  ColorRed := clRed;
  ColorGreen := clLime;
  ColorBlue := clBlue;
  ColorYellow := clYellow;
  ColorPink := clFuchsia;
  ColorTurq := clAqua;
  ColorWhite := clWhite;
  ColorBlack := clBlack;
  SCRCOLS := 80;
  SCRROWS := 24;
  CurCellColor := Char(ccDefault);
  CurCellHilite := Char(chDefault);
  CsrShape := csrUnderLine;
  CsrRow := 1;
  CsrCol := 1;
  SocOpen := False;
  FontName := 'Terminal';
  FontSize := 10;
  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;
  ClientHeight := SCRROWS * FontHeightPix + (FontHeightPix + 2);
  ClientWidth := SCRCOLS * FontWidthPix;
  ClearBuf;
  ShowBuf;
end;

In this procedure above i used to specify the font in the TImage canvas
Now I use the form's canvas. What do I have to change about the procedure?

Peter

0
 
LVL 1

Author Comment

by:peterkiers
ID: 18785961
Or do I need to change event.
0
 
LVL 1

Author Comment

by:peterkiers
ID: 18786107
I allready did it myself:

procedure TMainForm.FormCreate(Sender: TObject);
var
  TxMetric: TTextMetric;
begin
  SCRCOLS := 80;          
  SCRROWS := 24;          
  ColorRed := clRed;
  ColorGreen := clLime;
  ColorBlue := clBlue;
  ColorYellow := clYellow;
  ColorPink := clFuchsia;
  ColorTurq := clAqua;
  ColorWhite := clWhite;
  ColorBlack := clBlack;
  FontName := 'Terminal';  
  FontSize := 10;          
  Font.Size := FontSize;
  Font.Name := FontName;
  GetTextMetrics(Canvas.Handle, TxMetric);
  FontWidthPix := TxMetric.tmMaxCharWidth;
  FontHeightPix := TxMetric.tmHeight;
end;

500 points are comming your way, but I still wanna know
what Invalidate means.

Greetings,

Peter Kiers
0
 
LVL 10

Expert Comment

by:dinilud
ID: 18790831
Invalidate procedure will repaint the control.

After changing the character buffer you have to rapaint the window.


0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
problem when i try to pack my dll file with upx 9 72
Wininet read php file from internet issue 6 82
Internet Explorer View Settings Question 15 107
Performance of SQL statement 37 101
In this tutorial I will show you how to use the Windows Speech API in Delphi. I will only cover basic functions such as text to speech and controlling the speed of the speech. SAPI Installation First you need to install the SAPI type library, th…
Introduction I have seen many questions in this Delphi topic area where queries in threads are needed or suggested. I know bumped into a similar need. This article will address some of the concepts when dealing with a multithreaded delphi database…
Internet Business Fax to Email Made Easy - With eFax Corporate (http://www.enterprise.efax.com), you'll receive a dedicated online fax number, which is used the same way as a typical analog fax number. You'll receive secure faxes in your email, fr…
As a trusted technology advisor to your customers you are likely getting the daily question of, ‘should I put this in the cloud?’ As customer demands for cloud services increases, companies will see a shift from traditional buying patterns to new…

867 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

21 Experts available now in Live!

Get 1:1 Help Now