Solved

Cursor problem when I resize my canvas.

Posted on 2007-03-26
7
286 Views
Last Modified: 2010-04-05
Dear Experts,

I have an telnet-example, I have made a canvas devided in 80 columns and 25 rows.
I have draw a cursor on it. Everything works well, when i point a cell on the canvas
with the mouse the cursor moves to that cell. Perfect.

But now i have add a resize-event, that looks like this:

(*--------------------------------------*)
procedure TMainForm.Resize;
begin
  FontWidthPix :=ClientWidth  div (SCRCOLS);
  FontHeightPix:=(ClientHeight-2) div (SCRROWS+1);
end;
(*--------------------------------------*)

Now, when i move my cursor to another location (cell), the cursor gets copied
to the new location, in other words I get 2 cursor on the canvas. Who knows the
answer and is willing to help me?

The example is on my site: http://members.home.nl/peterkiers/
beneath the Under Construction bar you see a floppy disk.

Greetings,

Peter Kiers




0
Comment
Question by:peterkiers
  • 5
  • 2
7 Comments
 
LVL 17

Expert Comment

by:TheRealLoki
ID: 18796052
What you ned to do is clear teh cursor before you draw it in another location
add the following code

  private
    { Private declarations }
    lastcursorX, lastcursorY: integer;
...

  public
...
    procedure ClearCursor(x: integer; y: integer);
...



procedure TMainForm.FormCreate(Sender: TObject);
var
  TxMetric: TTextMetric;
begin
  MainForm.DoubleBuffered := True; // reduces flicker
  lastcursorX := -1;
  lastcursorY := -1;
...




procedure TMainForm.ClearCursor(x, y: integer);
var
  xpos, ypos: integer;
begin
  xpos := (x * FontWidthPix) - FontWidthPix;
  ypos := (y * FontHeightPix) - 1;
  with Canvas do
  begin
    if csrShape = csrUnderLine then
    begin
      Pen.Mode := pmBlack;
      Pen.Color := ColorBlack;
      Brush.Style := bsSolid;
      Brush.Color := ColorBlack;
      MoveTo(xpos, ypos);
      LineTo(xpos + FontWidthPix, ypos);
    end
    else
    begin // not sure about this part, you will have to tweak it to clear the cursor if it is not underline
      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;


and change this part

procedure TMainForm.DrawCursor(x, y: integer);
var
  xpos, ypos: integer;
begin
  if (lastcursorx <> -1) then // remove last cursor
    ClearCursor(lastcursorX, lastcursorY);
...

0
 
LVL 17

Expert Comment

by:TheRealLoki
ID: 18796061
also


procedure TMainForm.DrawCursor(x, y: integer);
var
  xpos, ypos: integer;
begin
...
  with Canvas do
  begin
...
  end;
  lastcursorX := x; // add tehse 2 lines to the end
  lastcursorY := y;
end;
0
 
LVL 17

Expert Comment

by:TheRealLoki
ID: 18796586
here's a better version i wrote for you that does a flashing cursor also

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, ExtCtrls;

const
  csrUnderLine = 0;
  csrEmptyBox = 1;
  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;
    Settings1: TMenuItem;
    ChangeFont1: TMenuItem;
    FontDialog1: TFontDialog;
    CursorFlashTimer: TTimer;
    procedure FormPaint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FillBuffer1Click(Sender: TObject);
    procedure ChangeFont1Click(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormResize(Sender: TObject);
    procedure CursorFlashTimerTimer(Sender: TObject);
    procedure FormDestroy(Sender: TObject);

  private
    { Private declarations }
    LastcursorX, LastcursorY: integer;
    fcursorVisible: boolean;
    procedure Resize;
    procedure SetCursorVisible(const Value: boolean);
  public
    { Public declarations }
    procedure ShowBuf;
    procedure DispCell(x: integer; y: integer; PaintBlanks: boolean);
    function ColorMapI2W(ic: char): TColor;
    procedure DrawCursor;
    procedure ClearCursor;
    property CursorVisible: boolean read fCursorVisible write SetCursorVisible;
  end;

var
  MainForm: TMainForm;
  SCRROWS: integer;
  SCRCOLS: integer;
  FontWidthPix: integer;
  FontHeightPix: integer;
  ScrBuf: TScrBuf;
  FontName: string;
  FontSize: integer;
  ColorRed: TColor;
  ColorGreen: TColor;
  ColorBlue: TColor;
  ColorYellow: TColor;
  ColorPink: TColor;
  ColorTurq: TColor;
  ColorWhite: TColor;
  ColorBlack: TColor;
  CsrCol: integer;
  CsrRow: integer;
  CsrShape: integer;
  CurCellColor: char;
  CurCellHilite: char;

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);
var
  TxMetric: TTextMetric;
begin
  MainForm.DoubleBuffered := True; // reduces flicker
  SCRCOLS := 80;
  SCRROWS := 24;
  ColorRed := clRed;
  ColorGreen := clLime;
  ColorBlue := clBlue;
  ColorYellow := clYellow;
  ColorPink := clFuchsia;
  ColorTurq := clAqua;
  ColorWhite := clWhite;
  ColorBlack := clBlack;
  CurCellColor := Char(ccDefault);
  CurCellHilite := Char(chDefault);
  CsrShape := csrEmptyBox; //csrUnderLine;
  CsrRow := 1;
  CsrCol := 1;
  FontName := 'Terminal';
  FontSize := 9;
  Font.Size := FontSize;
  Font.Name := FontName;
  GetTextMetrics(Canvas.Handle, TxMetric);
  FontWidthPix := TxMetric.tmMaxCharWidth;
  FontHeightPix := TxMetric.tmHeight;
  cursorVisible := False;
  LastcursorX := -1;
  LastcursorY := -1;
  CursorFlashTimer.Enabled := True;
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
  cursorVisible := false;
  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;
(*--------------------------------------*)
procedure TMainForm.ChangeFont1Click(Sender: TObject);
var
  TxMetric: TTextMetric;
begin
  Canvas.Font.Name := FontName;
  Canvas.Font.Size := FontSize;
  FontDialog1.Font := Canvas.Font;
  if FontDialog1.Execute() then
  begin
    Canvas.Font := FontDialog1.Font;
    FontSize := Canvas.Font.Size;
    FontName := Canvas.Font.Name;
    GetTextMetrics(Canvas.Handle, TxMetric);
    FontWidthPix := TxMetric.tmMaxCharWidth;
    FontHeightPix := TxMetric.tmHeight;
    Invalidate;
  end;
end;
(*--------------------------------------*)
procedure TMainForm.DrawCursor;
var
  xpos, ypos: integer;
begin
  xpos := (CsrCol * FontWidthPix) - FontWidthPix;
  ypos := (CsrRow * FontHeightPix) - 1;
  with 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[CsrRow, CsrCol].color);
      Brush.Style := bsSolid;
      Brush.Color := ColorMapI2W(ScrBuf[CsrRow, CsrCol].color);
      Rectangle(xpos, ypos - FontHeightPix + 1, xpos + FontWidthPix, ypos);
    end;
  end;
  LastcursorX := CsrCol;
  LastcursorY := CsrRow;
end;
(*--------------------------------------*)
procedure TMainForm.ClearCursor;
var
  xpos, ypos: integer;
begin
  if (Lastcursorx = -1) or (Lastcursory = -1) then exit;
  xpos := (Lastcursorx * FontWidthPix) - FontWidthPix;
  ypos := (Lastcursory * FontHeightPix) - 1;
  with Canvas do
  begin
    if csrShape = csrUnderLine then
    begin
      Pen.Mode := pmBlack;
      Pen.Color := ColorBlack;
      Brush.Style := bsSolid;
      Brush.Color := ColorBlack;
      MoveTo(xpos, ypos);
      LineTo(xpos + FontWidthPix, ypos);
    end
    else
    begin
      Pen.Mode := pmXor;
      Pen.Color := ColorMapI2W(ScrBuf[Lastcursory, Lastcursorx].color);
      Brush.Style := bsSolid;
      Brush.Color := ColorMapI2W(ScrBuf[Lastcursory, Lastcursorx].color);
      Rectangle(xpos, ypos - FontHeightPix + 1, xpos + FontWidthPix, ypos);
    end;
  end;
end;
(*--------------------------------------*)
procedure TMainForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  c, r: integer;
begin
  c := (x + FontWidthPix) div FontWidthPix;
  r := (y + FontHeightPix) div FontHeightPix;
  if (c <= SCRCOLS) and (r <= SCRROWS) then
  begin
    cursorVisible := false;
    DispCell(CsrCol, CsrRow, true);
    CsrCol := c;
    CsrRow := r;
        //  ShowStatus ;
  end;
end;
(*--------------------------------------*)
procedure TMainForm.FormResize(Sender: TObject);
begin
  Resize;
  invalidate;
end;
(*--------------------------------------*)
procedure TMainForm.Resize;
begin
  FontWidthPix :=ClientWidth  div (SCRCOLS);
  FontHeightPix:=(ClientHeight-2) div (SCRROWS+1);
end;
(*--------------------------------------*)
procedure TMainForm.CursorFlashTimerTimer(Sender: TObject);
begin
  CursorFlashTimer.Enabled := False;
  try
    CursorVisible := not CursorVisible;
  finally
    CursorFlashTimer.Enabled := True;
  end;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  CursorFlashTimer.Enabled := False;
end;

procedure TMainForm.SetCursorVisible(const Value: boolean);
var
  oldvalue: boolean;
begin
  oldvalue := fCursorVisible;
  if value <> oldvalue then
  begin
    if value then
      DrawCursor
    else
      ClearCursor;
  end;
  fCursorVisible := Value;
end;

end.


****
Add a TTimer on the form called "CursorFlashTimer" with a 200 interval, and enabled false.. hook up the OnTimer event
0
Announcing the Most Valuable Experts of 2016

MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.

 
LVL 1

Author Comment

by:peterkiers
ID: 18798108
You are a genius.

I have tested your example and you have
solved multiple problems.

Before I send you the 500 points, I have one
little question, I want to make a new feature
where there user can switch on/off (checkbox)
the cursor blinking. How can I do that.

Grz,

PK
0
 
LVL 17

Expert Comment

by:TheRealLoki
ID: 18803335
The changes required to do this are:-

procedure TMainForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  c, r: integer;
begin
  c := (x + FontWidthPix) div FontWidthPix;
  r := (y + FontHeightPix) div FontHeightPix;
  if (c <= SCRCOLS) and (r <= SCRROWS) then
  begin
    cursorVisible := false;
    DispCell(CsrCol, CsrRow, true);
    CsrCol := c;
    CsrRow := r;
        //  ShowStatus ;
    cursorVisible := true; // <--add this line
  end;
end;

I created a new menuitem called "miFlashCursor" and set its "Checked" property to true. I created an Onclick event for it like this :-

procedure TMainForm.miFlashCursorClick(Sender: TObject);
begin
  miFlashCursor.Checked := not miFlashCursor.Checked; // toggle checkmark. this is picked up in the flash timer
end;

I also changed the FlashTimer to notice it like this

procedure TMainForm.CursorFlashTimerTimer(Sender: TObject);
begin
  CursorFlashTimer.Enabled := False;
  try
    CursorVisible := not CursorVisible;
  finally
    if (not CursorVisible) or (miFlashCursor.Checked) then CursorFlashTimer.Enabled := True;
  end;
end;
0
 
LVL 17

Accepted Solution

by:
TheRealLoki earned 500 total points
ID: 18803356
oops
procedure TMainForm.miFlashCursorClick(Sender: TObject);
begin
  miFlashCursor.Checked := not miFlashCursor.Checked; // toggle checkmark. this is picked up in the flash timer
  CursorFlashTimer.Enabled := True;
end;
0
 
LVL 1

Author Comment

by:peterkiers
ID: 18805920
Thanks for everything, You have helped me alot.

Greetings,

Peter Kiers
0

Featured Post

Courses: Start Training Online With Pros, Today

Brush up on the basics or master the advanced techniques required to earn essential industry certifications, with Courses. Enroll in a course and start learning today. Training topics range from Android App Dev to the Xen Virtualization Platform.

Question has a verified solution.

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

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…
In my programming career I have only very rarely run into situations where operator overloading would be of any use in my work.  Normally those situations involved math with either overly large numbers (hundreds of thousands of digits or accuracy re…
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…
In a recent question (https://www.experts-exchange.com/questions/28997919/Pagination-in-Adobe-Acrobat.html) here at Experts Exchange, a member asked how to add page numbers to a PDF file using Adobe Acrobat XI Pro. This short video Micro Tutorial sh…

813 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

12 Experts available now in Live!

Get 1:1 Help Now