Solved

Cursor problem when I resize my canvas.

Posted on 2007-03-26
7
283 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
Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

 
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

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

This article explains how to create forms/units independent of other forms/units object names in a delphi project. Have you ever created a form for user input in a Delphi project and then had the need to have that same form in a other Delphi proj…
Introduction Raise your hands if you were as upset with FireMonkey as I was when I discovered that there was no TListview.  I use TListView in almost all of my applications I've written, and I was not going to compromise by resorting to TStringGrid…
In this tutorial you'll learn about bandwidth monitoring with flows and packet sniffing with our network monitoring solution PRTG Network Monitor (https://www.paessler.com/prtg). If you're interested in additional methods for monitoring bandwidt…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

760 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

20 Experts available now in Live!

Get 1:1 Help Now