Solved

Cursor problem when I resize my canvas.

Posted on 2007-03-26
7
297 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
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

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

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…
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…
In this video, viewers are given an introduction to using the Windows 10 Snipping Tool, how to quickly locate it when it's needed and also how make it always available with a single click of a mouse button, by pinning it to the Desktop Task Bar. Int…
Michael from AdRem Software outlines event notifications and Automatic Corrective Actions in network monitoring. Automatic Corrective Actions are scripts, which can automatically run upon discovery of a certain undesirable condition in your network.…
Suggested Courses
Course of the Month6 days, 7 hours left to enroll

636 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