Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

Cursor problem when I resize my canvas.

Posted on 2007-03-26
7
Medium Priority
?
299 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
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
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 2000 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

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

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…
The uses clause is one of those things that just tends to grow and grow. Most of the time this is in the main form, as it's from this form that all others are called. If you have a big application (including many forms), the uses clause in the in…
Add bar graphs to Access queries using Unicode block characters. Graphs appear on every record in the color you want. Give life to numbers. Hopes this gives you ideas on visualizing your data in new ways ~ Create a calculated field in a query: …
In response to a need for security and privacy, and to continue fostering an environment members can turn to for support, solutions, and education, Experts Exchange has created anonymous question capabilities. This new feature is available to our Pr…
Suggested Courses

715 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