Solved

Cursor problem when I resize my canvas.

Posted on 2007-03-26
7
285 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
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.

 
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

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
Delphi Dbf export problem to a Visual Foxpro application 6 162
JAudiorecorder record freezing the app 29 60
update joined tables 2 31
PHP preg_replace code convert to Delphi 14 35
A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
Creating an auto free TStringList The TStringList is a basic and frequently used object in Delphi. On many occasions, you may want to create a temporary list, process some items in the list and be done with the list. In such cases, you have to…
This tutorial gives a high-level tour of the interface of Marketo (a marketing automation tool to help businesses track and engage prospective customers and drive them to purchase). You will see the main areas including Marketing Activities, Design …
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, f…

920 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

15 Experts available now in Live!

Get 1:1 Help Now