Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1430
  • Last Modified:

Can I change the cursor Color?

Is there any way to change the cursor color in Delphi UI controls?

I have to implement a Night-Color Scheme and must have the cursor be visible.

Thanks
0
fbk2000
Asked:
fbk2000
  • 5
  • 4
  • 4
  • +2
1 Solution
 
fbk2000Author Commented:
I appologize.  What I meant to ask was this:  How do you color the cursor carret (the blinking bar in text boxes)?  That is what disappears when we set the box to grey.
0
 
DragonSlayerCommented:
0
Industry Leaders: 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!

 
Slick812Commented:
hello fbk2000 , , I would guess that your TMemo Color is a mid Grey color? This is the color I used that hid the caret and cursor of the memo, , Below is code I used to make this mid grey memo have a caret and cursor that are visible -


  private
    { Private declarations }
    CaretBmp: TBitmap;
    ReMemoProc: TWndMethod;
    procedure Memo1Proc(var Message: TMessage);


 = = = == = = = = = = = = = =



procedure TForm1.FormCreate(Sender: TObject); // Form1 OnCreate event
var
Size1: TSize;
sDC, clDC, mkDC, hCur, hPen: THandle;
IconInfo1: _IconInfo;
posY: Cardinal;
begin
Memo1.Color := $7F7F7F; // ?? with this "TEST" color, the normal claret was invisible
sDC := GetDC(0);
SelectObject(sDC, Memo1.Font.Handle);
GetTextExtentPoint32(sDC,'M',1, Size1);
ReleaseDC(0, sDC);

CaretBmp := TBitmap.Create;
CaretBmp.Canvas.Brush.Color := 0; // Invisible caret area is black
CaretBmp.Width := Size1.cx;
CaretBmp.Height := Size1.cy;
CaretBmp.Canvas.Pen.Color := $7F7F7F; { visible caret area is usually white,
   set to same Memo Color for Inverse to be seen}
CaretBmp.Canvas.Pen.Width := 2;
CaretBmp.Canvas.MoveTo(0,0);
CaretBmp.Canvas.LineTo(0,Size1.cy);
ReMemoProc := Memo1.WindowProc;
Memo1.WindowProc := Memo1Proc;

GetIconInfo(Screen.Cursors[crIBeam], IconInfo1);
clDC := CreateCompatibleDC(0);
mkDC := CreateCompatibleDC(0);
SelectObject(clDC, IconInfo1.hbmColor);
SelectObject(mkDC, IconInfo1.hbmMask);

patBlt(clDC,0,0,32,32, BLACKNESS);
patBlt(mkDC,0,0,32,32, WHITENESS);
hPen := SelectObject(clDC,CreatePen(PS_SOLID,1, $7F7F7F));

Size1.cy := (Size1.cy div 2)+2;
posY := Integer(IconInfo1.yHotspot)-Size1.cy;
MoveToEx(clDC,IconInfo1.xHotspot-3, posY, nil);
LineTo(clDC,IconInfo1.xHotspot+4, posY);

MoveToEx(mkDC,IconInfo1.xHotspot-3, posY, nil);
LineTo(mkDC,IconInfo1.xHotspot+4, posY);

posY := Integer(IconInfo1.yHotspot)+Size1.cy-1;
MoveToEx(clDC,IconInfo1.xHotspot-3, posY, nil);
LineTo(clDC,IconInfo1.xHotspot+4, posY);

MoveToEx(mkDC,IconInfo1.xHotspot-3, posY, nil);
LineTo(mkDC,IconInfo1.xHotspot+4, posY);

MoveToEx(clDC,IconInfo1.xHotspot, Integer(IconInfo1.yHotspot)-Size1.cy, nil);
LineTo(clDC,IconInfo1.xHotspot, Integer(IconInfo1.yHotspot)+Size1.cy);

MoveToEx(mkDC,IconInfo1.xHotspot, Integer(IconInfo1.yHotspot)-Size1.cy, nil);
LineTo(mkDC,IconInfo1.xHotspot, Integer(IconInfo1.yHotspot)+Size1.cy);

DeleteObject(SelectObject(clDC,hPen));

DeleteDC(clDC);
DeleteDC(mkDC);

hCur := CreateIconIndirect(IconInfo1);
DeleteObject(IconInfo1.hbmMask);
DeleteObject(IconInfo1.hbmColor);
if hCur <> 0 then
  begin
  Screen.Cursors[crIBeamGr] := hCur;
  Memo1.Cursor := crIBeamGr;
  end;
end;




procedure TForm1.FormDestroy(Sender: TObject); // Form1 OnDestroy Event
begin
FreeAndNil(CaretBmp);
end;




procedure TForm1.Memo1Proc(var Message: TMessage); // Memo1 Window Proc
begin
case Message.Msg of
  WM_SETFOCUS: begin
    ReMemoProc(Message);
    CreateCaret(Memo1.Handle, CaretBmp.Handle, 0, 0); // A caret for mid grey color memo
    ShowCaret(Memo1.Handle);
    Exit;
    end;

  WM_KILLFOCUS: begin
    HideCaret(Memo1.Handle);
    DestroyCaret;
    end;
  end;
ReMemoProc(Message);
end;


 = = = = = = = = = = = = = = = = = = = = = = = = =
the above code seems to work for me, but I used the color $7F7F7F, and it does seem to make a diference about the color.
ask questions if you need more info
0
 
EddieShipmanCommented:
You can "color" the caret, which is what it is called, by the way.

Windows uses "inverse" color values for its carets. Black for white,
white for black, etc. I made a blue caret by making a bitmap
7 pixels wide and 14 pixels tall with a black background and
yellow foreground.

Here's how I handled it: I'm not sure if I am handling the destruction
correctly or not, that is something I will leave up to you to figure out...

unit caret1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ComCtrls, ExtCtrls;

const
  MY_POST_ENTER = WM_USER + 500;

type

  TForm1 = class(TForm)
    Edit1: TEdit;
    Memo1: TMemo;
    procedure Memo1Exit(Sender: TObject);
    procedure Memo1Change(Sender: TObject);
    procedure Memo1KeyDown(Sender: TObject;
              var Key: Word; Shift: TShiftState);
    procedure Memo1Enter(Sender: TObject);
  private
    { Private declarations }
  public
    procedure MyPost_Enter(var Message: TMessage);
              message MY_POST_ENTER;
    { Public declarations }
  end;

var
  Form1: TForm1;
  hCaret: HBITMAP;

implementation

{$R *.DFM}
{$R caret2.res}

procedure TForm1.MyPost_Enter(var Message: TMessage);
var
  CaretHeight : Integer;
begin
  hCaret := LoadBitmap(hInstance, MAKEINTRESOURCE(150));
  CreateCaret(TWinControl(ActiveControl).Handle,hCaret,0,0);
  ShowCaret(TWinControl(ActiveControl).Handle);
end;

procedure TForm1.Memo1Exit(Sender: TObject);
begin
  DestroyCaret;
  CreateCaret(TWinControl(ActiveControl).Handle,1,1,1);
  ShowCaret(TWinControl(ActiveControl).Handle);
end;

procedure TForm1.Memo1Change(Sender: TObject);
begin
  PostMessage(Handle, MY_POST_ENTER, 0, 0);
end;

procedure TForm1.Memo1KeyDown(Sender: TObject;
                var Key: Word; Shift: TShiftState);
begin
  PostMessage(Handle, MY_POST_ENTER, 0, 0);
end;

procedure TForm1.Memo1Enter(Sender: TObject);
begin
  PostMessage(Handle, MY_POST_ENTER, 0, 0);
end;

end.

(*
DFMText:
object Form1: TForm1
  Left = 270
  Top = 97
  Width = 214
  Height = 192
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Edit1: TEdit
    Left = 16
    Top = 112
    Width = 121
    Height = 21
    TabOrder = 0
    Text = 'Edit1'
    OnChange = Memo1Change
    OnEnter = Memo1Enter
    OnExit = Memo1Exit
  end
  object Memo1: TMemo
    Left = 8
    Top = 8
    Width = 185
    Height = 89
    Lines.Strings = (
      'Memo1')
    TabOrder = 1
    OnChange = Memo1Change
    OnEnter = Memo1Enter
    OnExit = Memo1Exit
  end
end
*)
0
 
fbk2000Author Commented:
I can't use code to automatically change to inverse.

What I need is a function like this:

ColorCaretAndCursor(memo : TMemo; Color : TColor);

Such that I could specify the color of the Caret and Cursor specifically. I need to make the cursor color the same color as the text color.

Thanks
0
 
fbk2000Author Commented:
The IBeam Cursor and Caret, that is.
0
 
EddieShipmanCommented:
Well, you can use Slick812's code and make it a function and pass in a color vale and replace $7F7F7F in the
lines:
CaretBmp.Canvas.Pen.Color := $7F7F7F;  and hPen := SelectObject(clDC,CreatePen(PS_SOLID,1, $7F7F7F));

with your passed color value.

I load my cursor from a resource instead of creating it on the fly like his code.
(hCaret := LoadBitmap(hInstance, MAKEINTRESOURCE(150));)
0
 
fbk2000Author Commented:
I cannot load from a resource as the customer of the product may choose any color for the background of the Memo Box and Foreground text for their night colors
0
 
Slick812Commented:
?????
I do not really understand your last comment?
But maybe my knowledge of the cursor and Caret display in a system edit control is different than yours?
As far as I know the system edit control (like a TEdit or TMemo)  will have a Caret that is NOT a specific color, it will INVERSE (change to oposite color) the color of all the pixels under the "line" in the caret bitmap of whatever the edit display is. since the normal edit is a white color, the caret will be a black.  So I am not sure of any specific way to set only one color for the caret.  The normal memo cursor also inverses the color, but you have more control in cursors, so you can have a cursor with a certain color line, but the inverse color has proven effective for many many years of developement.

as far as a function -    ColorCaretAndCursor(memo : TMemo; Color : TColor);

I do not see how to do that kind of thing easily, , , , aside from the trouble of the caret color described above,  I could not get that caret to work effectively without sub-classing the TMemo, although you could subclass all memos and add a boolean to the Memo1Proc(  ) and set the boolen to true to have the alternate cursor.
0
 
EddieShipmanCommented:
Slick, look at my last comment. You CAN change the color of the cursor like you did and pass in the color.
If you don't mind, I will take your code and modify it to do what he needs.

fbk2000, I did not mean to use a resource, I said my code used one.
0
 
fbk2000Author Commented:
Gotcha, and please do modift the code, I'm lost.

0
 
Slick812Commented:
??????
I very well know what is in my code, and the line
CaretBmp.Canvas.Pen.Color := $7F7F7F;
does NOT make the caret color to be neutral grey color, the color of the memo was set to  $7F7F7F, so if the caret color was  $7F7F7F then it would be invisible! ! ! I worked on my code above to get a visible cursor in a neutral grey memo. . . Almost every other color will show the usual caret somewhat. . .
There is an XOR color operation which will change the memo caret so you can see it, ,  and I guess you never wondered --> How does it change the color back, so you get a blinking effect? ?, It does the same XOR raster operation with the caret bitmap to change memo back and get blinking effect. . . .
I guess I'm just to stupid to rework my own code
0
 
EddieShipmanCommented:
I never said you could not rework your own code. In fact,
I think I'm just gonna unsub from this question, anyway...
0
 
Slick812Commented:
I worked on this a long time, yesterday and today, , need some sleep, ,  unfortunately I was unable to do much with the memo caret, I was not able to coordinate the XOR raster op and any predicable color result,  based on the display color and the caret color and the font color, too many factors to deal with even after hours and many hours of trying. But I was able to insure that it would be visible even if you set the memo color to a neutral gray.
I was able to make a cursor for the memos that is the same color as the memo font color. Inorder to have more than one memo I have created a diferent method of sub-classing and I have an  aryMemoCB  array to hold all of the memos information.

code for form below -



type
  TCaretBmp = record
    hMemo: Integer;
    Bmp: TBitmap;
    pEditProc: Pointer;
    end;

  TForm1 = class(TForm)


  private
    { Private declarations }
    aryMemoCB: Array of TCaretBmp;
    procedure MemoCursor(memo: tmemo; color: TColorRef);





procedure TForm1.FormDestroy(Sender: TObject);
var
i: Integer;
begin
FreeAndNil(CaretBmp);
for i := 0 to High(aryMemoCB) do
  FreeAndNil(aryMemoCB[i].Bmp);
end;



function MemoFunc(hWnd, iMsg, WParam, LParam: Integer): Integer; stdcall;
var
i, memoI: Integer;
begin
memoI := -1;
for i := 0 to High(Form1.aryMemoCB) do
  if Form1.aryMemoCB[i].hMemo = hWnd then
    begin
    memoI := i;
    Break;
    end;

if memoI = -1 then
  begin
  Result := DefWindowProc(hWnd,iMsg,WParam,LParam);
  exit;
  end;

case iMsg of
  WM_SETFOCUS: begin
      Result := CallWindowProc(Form1.aryMemoCB[memoI].pEditProc,hWnd,iMsg,wParam,lParam);
      CreateCaret(hWnd, Form1.aryMemoCB[memoI].Bmp.Handle, 0, 0);
      ShowCaret(hWnd);
      Exit;
    end;

  WM_KILLFOCUS: begin
    HideCaret(hWnd);
    DestroyCaret;
    end;
  end;

Result := CallWindowProc(Form1.aryMemoCB[memoI].pEditProc,hWnd,iMsg,wParam,lParam);
end;



procedure TForm1.MemoCursor(memo: tmemo; color: tcolorref);
var
sDC, clDC, mkDC, hPen, hCur: THandle;
Size1: TSize;
iconI: _IconInfo;
BmpI: tagBitmap;
i, iR, iG, iB, gotIt: Integer;
acl, memoC: tcolorref;
new1: Boolean;
begin
gotIt := -1;
new1 := True;
for i := 0 to High(aryMemoCB) do
  if Integer(memo.Handle) = aryMemoCB[i].hMemo then
  begin
  gotIt := i;
  new1 := False;
  Break;
  end;

sDC := GetDC(0);
SelectObject(sDC, memo.Font.Handle);
GetTextExtentPoint32(sDC,'M',1, Size1);
ReleaseDC(0, sDC);

memoC := ColorToRGB(memo.Color);
iR := memoC and $FF;
iG := (memoC and $FF00) shr 8;
iB := (memoC and $FF0000) shr 16;
if ((iR>110) and (iR<145))and((iG>110) and (iG<145))and((iB>110) and (iB<145)) then
  acl := $A0A0A0
  else
  acl := $FFFFFF;

if gotIt = -1 then
  begin
  SetLength(aryMemoCB, Length(aryMemoCB)+1);
  aryMemoCB[High(aryMemoCB)].hMemo := memo.Handle;
  aryMemoCB[High(aryMemoCB)].Bmp := TBitmap.Create;
  gotIt := High(aryMemoCB);
  end;

with aryMemoCB[gotIt].Bmp do
  begin
  Canvas.Brush.Color := 0;
  Width := Size1.cx;
  Height := Size1.cy;
  Canvas.Pen.Color := acl;
  Canvas.Pen.Width := 2;
  Canvas.MoveTo(1,0);
  Canvas.LineTo(1,Size1.cy);
  end;

GetIconInfo(Screen.Cursors[crArrow], iconI);
if GetObject(iconI.hbmMask, SizeOf(BmpI), @BmpI) = 0 then
  begin
  BmpI.bmWidth := 32;
  BmpI.bmHeight := 32;
  end;

if iconI.hbmColor = 0 then
  begin
  clDC := GetDC(0);
  iconI.hbmColor := CreateCompatibleBitmap(clDC, BmpI.bmWidth, BmpI.bmWidth);
  ReleaseDC(0, clDC);
  end;

iconI.xHotspot := 10;
iconI.yHotspot := 10;
DeleteObject(iconI.hbmMask);
iconI.hbmMask := CreateBitmap(BmpI.bmWidth,BmpI.bmWidth,1,1, nil);

clDC := CreateCompatibleDC(0);
mkDC := CreateCompatibleDC(0);
SelectObject(clDC, iconI.hbmColor);
SelectObject(mkDC, iconI.hbmMask);

patBlt(clDC,0,0,32,32, BLACKNESS);
patBlt(mkDC,0,0,32,32, WHITENESS);
hPen := SelectObject(clDC,CreatePen(PS_SOLID,1, color));

MoveToEx(clDC,7, 3, nil);
LineTo(clDC,14, 3);

MoveToEx(mkDC,7, 3, nil);
LineTo(mkDC,14, 3);

MoveToEx(clDC,7, 16, nil);
LineTo(clDC,14, 16);

MoveToEx(mkDC,7, 16, nil);
LineTo(mkDC,14, 16);

MoveToEx(clDC,10, 3, nil);
LineTo(clDC,10, 17);

MoveToEx(mkDC,10, 3, nil);
LineTo(mkDC,10, 17);

DeleteObject(SelectObject(clDC,hPen));

DeleteDC(clDC);
DeleteDC(mkDC);
hCur := CreateIconIndirect(iconI);
DeleteObject(iconI.hbmMask);
DeleteObject(iconI.hbmColor);
if hCur <> 0 then
  begin
  Screen.Cursors[crIBeamGr+gotIt] := hCur;
  Memo.Cursor := crIBeamGr+gotIt;
  end;
if new1 then
  aryMemoCB[High(aryMemoCB)].pEditProc := Pointer(SetWindowLong(memo.Handle,
                                              GWL_WNDPROC, Integer(@MemoFunc)));
if memo.Focused then PostMessage(memo.Handle, WM_SETFOCUS, 0,0);
end;


 = = = = = = = = = = = = = = = = = = = = = = = = = =
// below is button click event to test this


procedure TForm1.sbut_MemoCaretClick(Sender: TObject);
begin
if Length(aryMemoCB) = 0 then
  begin
  Memo1.Color := $339933;
  Memo1.Font.Color := $F0F0;
  MemoCursor(Memo1, ColorToRGB(Memo1.Font.Color));
  end else
  begin
  Memo2.Color := $C0EBC0;
  Memo2.Font.Color := $E9;
  MemoCursor(Memo2, ColorToRGB(Memo2.Font.Color));
  end;

end;

= = = = = = = = = = = = = = =
this seems to work for me in win XP and win 98, but I did not test it very much
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!

  • 5
  • 4
  • 4
  • +2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now