Delphi 7 - Force InputBox to integer only? - delphi

Using Delphi 7, is there anyway to force inputbox to allow only numbers entry from 0 to 100 ?
Thanks!

You could easily write your own 'super dialog' like
type
TMultiInputBox = class
strict private
class var
frm: TForm;
lbl: TLabel;
edt: TEdit;
btnOK,
btnCancel: TButton;
shp: TShape;
FMin, FMax: integer;
FTitle, FText: string;
class procedure SetupDialog;
class procedure ValidateInput(Sender: TObject);
public
class function TextInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: string): boolean;
class function NumInputBox(AOwner: TCustomForm; const ATitle,
AText: string; AMin, AMax: integer; var Value: integer): boolean;
end;
class procedure TMultiInputBox.SetupDialog;
begin
frm.Caption := FTitle;
frm.Width := 512;
frm.Position := poOwnerFormCenter;
frm.BorderStyle := bsDialog;
lbl := TLabel.Create(frm);
lbl.Parent := frm;
lbl.Left := 8;
lbl.Top := 8;
lbl.Width := frm.ClientWidth - 16;
lbl.Caption := FText;
edt := TEdit.Create(frm);
edt.Parent := frm;
edt.Top := lbl.Top + lbl.Height + 8;
edt.Left := 8;
edt.Width := frm.ClientWidth - 16;
btnOK := TButton.Create(frm);
btnOK.Parent := frm;
btnOK.Default := true;
btnOK.Caption := 'OK';
btnOK.ModalResult := mrOk;
btnCancel := TButton.Create(frm);
btnCancel.Parent := frm;
btnCancel.Cancel := true;
btnCancel.Caption := 'Cancel';
btnCancel.ModalResult := mrCancel;
btnCancel.Top := edt.Top + edt.Height + 16;
btnCancel.Left := frm.ClientWidth - btnCancel.Width - 8;
btnOK.Top := btnCancel.Top;
btnOK.Left := btnCancel.Left - btnOK.Width - 4;
frm.ClientHeight := btnOK.Top + btnOK.Height + 8;
shp := TShape.Create(frm);
shp.Parent := frm;
shp.Brush.Color := clWhite;
shp.Pen.Style := psClear;
shp.Shape := stRectangle;
shp.Align := alTop;
shp.Height := btnOK.Top - 8;
shp.SendToBack;
end;
class function TMultiInputBox.TextInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: string): boolean;
begin
FTitle := ATitle;
FText := AText;
frm := TForm.Create(AOwner);
try
SetupDialog;
edt.NumbersOnly := false;
edt.Text := Value;
result := frm.ShowModal = mrOK;
if result then Value := edt.Text;
finally
frm.Free;
end;
end;
class procedure TMultiInputBox.ValidateInput(Sender: TObject);
var
n: integer;
begin
btnOK.Enabled := TryStrToInt(edt.Text, n) and InRange(n, FMin, FMax);
end;
class function TMultiInputBox.NumInputBox(AOwner: TCustomForm; const ATitle,
AText: string; AMin, AMax: integer; var Value: integer): boolean;
begin
FMin := AMin;
FMax := AMax;
FTitle := ATitle;
FText := AText;
frm := TForm.Create(AOwner);
try
SetupDialog;
edt.NumbersOnly := true;
edt.Text := IntToStr(value);
edt.OnChange := ValidateInput;
result := frm.ShowModal = mrOK;
if result then Value := StrToInt(edt.Text);
finally
frm.Free;
end;
end;
This dialog allows both text and integer input:
v := 55;
if TMultiInputBox.NumInputBox(Self, 'This is the title', 'Enter a number between 1 and 100:', 1, 100, v) then
ShowMessage(IntToStr(v));
or
s := 'Test';
if TMultiInputBox.TextInputBox(Self, 'This is the title', 'Enter some text:', s) then
ShowMessage(s);
Update
A commenter remarked that class procedures (etc.) had not been introduced yet as of Delphi 7. If this is the case (I don't really remember...), simply remove all this syntactic sugar:
var
frm: TForm;
lbl: TLabel;
edt: TEdit;
btnOK,
btnCancel: TButton;
shp: TShape;
FMin, FMax: integer;
FTitle, FText: string;
procedure SetupDialog;
begin
frm.Caption := FTitle;
frm.Width := 512;
frm.Position := poOwnerFormCenter;
frm.BorderStyle := bsDialog;
lbl := TLabel.Create(frm);
lbl.Parent := frm;
lbl.Left := 8;
lbl.Top := 8;
lbl.Width := frm.ClientWidth - 16;
lbl.Caption := FText;
edt := TEdit.Create(frm);
edt.Parent := frm;
edt.Top := lbl.Top + lbl.Height + 8;
edt.Left := 8;
edt.Width := frm.ClientWidth - 16;
btnOK := TButton.Create(frm);
btnOK.Parent := frm;
btnOK.Default := true;
btnOK.Caption := 'OK';
btnOK.ModalResult := mrOk;
btnCancel := TButton.Create(frm);
btnCancel.Parent := frm;
btnCancel.Cancel := true;
btnCancel.Caption := 'Cancel';
btnCancel.ModalResult := mrCancel;
btnCancel.Top := edt.Top + edt.Height + 16;
btnCancel.Left := frm.ClientWidth - btnCancel.Width - 8;
btnOK.Top := btnCancel.Top;
btnOK.Left := btnCancel.Left - btnOK.Width - 4;
frm.ClientHeight := btnOK.Top + btnOK.Height + 8;
shp := TShape.Create(frm);
shp.Parent := frm;
shp.Brush.Color := clWhite;
shp.Pen.Style := psClear;
shp.Shape := stRectangle;
shp.Align := alTop;
shp.Height := btnOK.Top - 8;
shp.SendToBack;
end;
function TextInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: string): boolean;
begin
FTitle := ATitle;
FText := AText;
frm := TForm.Create(AOwner);
try
SetupDialog;
edt.NumbersOnly := false;
edt.Text := Value;
result := frm.ShowModal = mrOK;
if result then Value := edt.Text;
finally
frm.Free;
end;
end;
type
TInputValidator = class
procedure ValidateInput(Sender: TObject);
end;
procedure TInputValidator.ValidateInput(Sender: TObject);
var
n: integer;
begin
btnOK.Enabled := TryStrToInt(edt.Text, n) and InRange(n, FMin, FMax);
end;
function NumInputBox(AOwner: TCustomForm; const ATitle,
AText: string; AMin, AMax: integer; var Value: integer): boolean;
var
iv: TInputValidator;
begin
FMin := AMin;
FMax := AMax;
FTitle := ATitle;
FText := AText;
frm := TForm.Create(AOwner);
try
SetupDialog;
edt.Text := IntToStr(value);
iv := TInputValidator.Create;
try
edt.OnChange := iv.ValidateInput;
result := frm.ShowModal = mrOK;
if result then Value := StrToInt(edt.Text);
finally
iv.Free;
end;
finally
frm.Free;
end;
end;
Update 2
I have written a new and much nicer version of the dialog. It now looks exactly like a Task Dialog (I followed Microsoft's guidelines in detail), and it offers many options to transform (e.g., to upper or lower case) and verify (many options) the input. It also adds an Up Down control in case of integer input (need not be natural numbers for that one).
Source code:
unit MultiInput;
interface
uses
Windows, SysUtils, Types, Controls, Graphics, Forms, StdCtrls, ExtCtrls,
CommCtrl;
type
TAllowOnlyOption = (aoCapitalAZ, aoSmallAZ, aoAZ, aoLetters, aoDigits, aoSpace,
aoPeriod, aoComma, aoSemicolon, aoHyphenMinus, aoPlus, aoUnderscore, aoAsterisk);
TAllowOnlyOptions = set of TAllowOnlyOption;
TInputVerifierFunc = reference to function(const S: string): boolean;
TMultiInputBox = class
strict private
class var
frm: TForm;
edt: TEdit;
btnOK,
btnCancel: TButton;
FMin, FMax: integer;
FFloatMin, FFloatMax: real;
FAllowEmptyString: boolean;
FAllowOnly: TAllowOnlyOptions;
FInputVerifierFunc: TInputVerifierFunc;
spin: HWND;
FTitle, FText: string;
lineat: integer;
R: TRect;
class procedure Paint(Sender: TObject);
class procedure FormActivate(Sender: TObject);
class procedure SetupDialog;
class procedure ValidateIntInput(Sender: TObject);
class procedure ValidateRealInput(Sender: TObject);
class procedure ValidateStrInput(Sender: TObject);
private
class procedure ValidateStrInputManual(Sender: TObject);
public
class function TextInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: string; ACharCase: TEditCharCase = ecNormal;
AAllowEmptyString: boolean = true; AAllowOnly: TAllowOnlyOptions = []): boolean;
class function CharInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: char; ACharCase: TEditCharCase = ecNormal;
AAllowOnly: TAllowOnlyOptions = []): boolean;
class function TextInputBoxEx(AOwner: TCustomForm; const ATitle,
AText: string; var Value: string; ACharCase: TEditCharCase = ecNormal;
AInputVerifierFunc: TInputVerifierFunc = nil): boolean;
class function NumInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: integer; AMin: integer = -MaxInt + 1;
AMax: integer = MaxInt): boolean;
class function FloatInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: real; AMin: real; AMax: real): boolean;
end;
implementation
uses Math, Messages, Character;
class procedure TMultiInputBox.Paint(Sender: TObject);
begin
with frm.Canvas do
begin
Pen.Style := psSolid;
Pen.Width := 1;
Pen.Color := $00DFDFDF;
Brush.Style := bsSolid;
Brush.Color := clWhite;
FillRect(Rect(0, 0, frm.ClientWidth, lineat));
MoveTo(0, lineat);
LineTo(frm.ClientWidth, lineat);
DrawText(frm.Canvas.Handle, FText, Length(FText), R,
DT_NOPREFIX or DT_WORDBREAK);
end;
end;
class procedure TMultiInputBox.SetupDialog;
begin
{ * = Metrics from }
{ https://msdn.microsoft.com/en-us/windows/desktop/dn742486 }
{ and }
{ https://msdn.microsoft.com/en-us/windows/desktop/dn742478 }
frm.Font.Name := 'Segoe UI';
frm.Font.Size := 9{*};
frm.Caption := FTitle;
frm.Width := 400;
frm.Position := poOwnerFormCenter;
frm.BorderStyle := bsDialog;
frm.OnPaint := Paint;
frm.OnActivate := FormActivate;
frm.Canvas.Font.Size := 12; { 'MainInstruction' }
frm.Canvas.Font.Color := $00993300;
R := Rect(11{*}, 11{*}, frm.Width - 11{*}, 11{*} + 2);
DrawText(frm.Canvas.Handle, FText, Length(FText),
R, DT_CALCRECT or DT_NOPREFIX or DT_WORDBREAK);
edt := TEdit.Create(frm);
edt.Parent := frm;
edt.Top := R.Bottom + 5{*};
edt.Left := 11{*};
edt.Width := frm.ClientWidth - 2*11{*};
lineat := edt.Top + edt.Height + 11{*};
btnOK := TButton.Create(frm);
btnOK.Parent := frm;
btnOK.Height := 23{*};
btnOK.Default := true;
btnOK.Caption := 'OK';
btnOK.ModalResult := mrOk;
btnCancel := TButton.Create(frm);
btnCancel.Parent := frm;
btnCancel.Height := 23{*};
btnCancel.Cancel := true;
btnCancel.Caption := 'Cancel';
btnCancel.ModalResult := mrCancel;
btnCancel.Top := edt.Top + edt.Height + 11{*} + 1{*} + 11{*};
btnCancel.Left := frm.ClientWidth - btnCancel.Width - 11{*};
btnOK.Top := btnCancel.Top;
btnOK.Left := btnCancel.Left - btnOK.Width - 7{*};
frm.ClientHeight := btnOK.Top + btnOK.Height + 11{*};
end;
class procedure TMultiInputBox.ValidateStrInputManual(Sender: TObject);
begin
btnOK.Enabled := (not Assigned(FInputVerifierFunc)) or FInputVerifierFunc(edt.Text);
end;
class function TMultiInputBox.TextInputBoxEx(AOwner: TCustomForm; const ATitle,
AText: string; var Value: string; ACharCase: TEditCharCase;
AInputVerifierFunc: TInputVerifierFunc): boolean;
begin
FTitle := ATitle;
FText := AText;
FInputVerifierFunc := AInputVerifierFunc;
frm := TForm.Create(AOwner);
try
SetupDialog;
edt.Text := Value;
edt.CharCase := ACharCase;
edt.OnChange := ValidateStrInputManual;
ValidateStrInputManual(nil);
result := frm.ShowModal = mrOK;
if result then Value := edt.Text;
finally
frm.Free;
end;
end;
class procedure TMultiInputBox.ValidateStrInput(Sender: TObject);
function IsValidStr: boolean;
var
S: string;
i: integer;
begin
S := edt.Text;
result := (Length(S) > 0) or FAllowEmptyString;
if not result then Exit;
if FAllowOnly = [] then Exit;
if aoLetters in FAllowOnly then
Include(FAllowOnly, aoAZ);
if aoAZ in FAllowOnly then
begin
Include(FAllowOnly, aoCapitalAZ);
Include(FAllowOnly, aoSmallAZ);
end;
result := true;
for i := 1 to Length(S) do
case S[i] of
'a'..'z':
if not (aoSmallAZ in FAllowOnly) then
Exit(false);
'A'..'Z':
if not (aoCapitalAZ in FAllowOnly) then
Exit(false);
'0'..'9':
if not (aoDigits in FAllowOnly) then
Exit(false);
' ':
if not (aoSpace in FAllowOnly) then
Exit(false);
'.':
if not (aoPeriod in FAllowOnly) then
Exit(false);
',':
if not (aoComma in FAllowOnly) then
Exit(false);
';':
if not (aoSemicolon in FAllowOnly) then
Exit(false);
'-':
if not (aoHyphenMinus in FAllowOnly) then
Exit(false);
'+':
if not (aoPlus in FAllowOnly) then
Exit(false);
'_':
if not (aoUnderscore in FAllowOnly) then
Exit(false);
'*':
if not (aoAsterisk in FAllowOnly) then
Exit(false);
else
if not (TCharacter.IsLetter(S[i]) and (aoLetters in FAllowOnly)) then
Exit(false);
end;
end;
begin
btnOK.Enabled := IsValidStr;
end;
class function TMultiInputBox.TextInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: string; ACharCase: TEditCharCase = ecNormal;
AAllowEmptyString: boolean = true; AAllowOnly: TAllowOnlyOptions = []): boolean;
begin
FTitle := ATitle;
FText := AText;
FAllowEmptyString := AAllowEmptyString;
FAllowOnly := AAllowOnly;
frm := TForm.Create(AOwner);
try
SetupDialog;
edt.Text := Value;
edt.CharCase := ACharCase;
edt.OnChange := ValidateStrInput;
ValidateStrInput(nil);
result := frm.ShowModal = mrOK;
if result then Value := edt.Text;
finally
frm.Free;
end;
end;
class procedure TMultiInputBox.ValidateIntInput(Sender: TObject);
var
n: integer;
begin
btnOK.Enabled := TryStrToInt(edt.Text, n) and InRange(n, FMin, FMax);
end;
class procedure TMultiInputBox.ValidateRealInput(Sender: TObject);
var
x: double;
begin
btnOK.Enabled := TryStrToFloat(edt.Text, x) and InRange(x, FFloatMin, FFloatMax);
end;
class function TMultiInputBox.CharInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: char; ACharCase: TEditCharCase;
AAllowOnly: TAllowOnlyOptions): boolean;
begin
FTitle := ATitle;
FText := AText;
FAllowEmptyString := false;
FAllowOnly := AAllowOnly;
frm := TForm.Create(AOwner);
try
SetupDialog;
edt.Text := Value;
edt.CharCase := ACharCase;
edt.OnChange := ValidateStrInput;
edt.MaxLength := 1;
ValidateStrInput(nil);
result := frm.ShowModal = mrOK;
if result then Value := edt.Text[1];
finally
frm.Free;
end;
end;
class function TMultiInputBox.FloatInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: real; AMin, AMax: real): boolean;
begin
FFloatMin := AMin;
FFloatMax := AMax;
FTitle := ATitle;
FText := AText;
frm := TForm.Create(AOwner);
try
SetupDialog;
edt.Text := FloatToStr(Value);
edt.OnChange := ValidateRealInput;
ValidateRealInput(nil);
result := frm.ShowModal = mrOK;
if result then Value := StrToFloat(edt.Text);
finally
frm.Free;
end;
end;
class procedure TMultiInputBox.FormActivate(Sender: TObject);
var
b: boolean;
begin
if SystemParametersInfo(SPI_GETSNAPTODEFBUTTON, 0, #b, 0) and b then
with btnOK do
with ClientToScreen(Point(Width div 2, Height div 2)) do
SetCursorPos(x, y);
frm.OnActivate := nil;
end;
class function TMultiInputBox.NumInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: integer; AMin: integer = -MaxInt + 1;
AMax: integer = MaxInt): boolean;
const
UDM_SETPOS32 = WM_USER + 113;
var
ICCX: TInitCommonControlsEx;
begin
FMin := AMin;
FMax := AMax;
FTitle := ATitle;
FText := AText;
frm := TForm.Create(AOwner);
try
SetupDialog;
ICCX.dwSize := sizeof(ICCX);
ICCX.dwICC := ICC_UPDOWN_CLASS;
InitCommonControlsEx(ICCX);
spin := CreateWindowEx(0, PChar(UPDOWN_CLASS), nil,
WS_CHILDWINDOW or WS_VISIBLE or UDS_NOTHOUSANDS or UDS_SETBUDDYINT or
UDS_ALIGNRIGHT or UDS_ARROWKEYS or UDS_HOTTRACK, 0, 0, 0, 0, frm.Handle,
0, HInstance, nil);
SendMessage(spin, UDM_SETRANGE32, FMin, FMax);
SendMessage(spin, UDM_SETPOS32, 0, Value);
SendMessage(spin, UDM_SETBUDDY, edt.Handle, 0);
if FMin >= 0 then
edt.NumbersOnly := true;
edt.Text := IntToStr(value);
edt.OnChange := ValidateIntInput;
ValidateIntInput(nil);
result := frm.ShowModal = mrOK;
if result then Value := StrToInt(edt.Text);
finally
frm.Free;
end;
end;
end.
Full documentation (and source code) will always be found at https://specials.rejbrand.se/dev/classes/multiinput/readme.html.

you can allow to the user only enter numbers in the input box adding to the style of the TEdit inside of the inputbox the ES_NUMBER value.
check this sample.
const
InputBoxNumberMessage = WM_USER + 666;// a custom message
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure InputBoxSetOnlyNumbers(var Msg: TMessage); message InputBoxNumberMessage;
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
InputString: string;
begin
PostMessage(Handle, InputBoxNumberMessage, 0, 0);
InputString := InputBox('Input', 'Enter a number', '');
ShowMessage(InputString);
end;
procedure TForm1.InputBoxSetOnlyNumbers(var Msg: TMessage);
var
hActiveForm : HWND;
hEdit : HWND;
dwLong : Longint;
begin
hActiveForm := Screen.ActiveForm.Handle;
if (hActiveForm <> 0) then
begin
hEdit := FindWindowEx(hActiveForm, 0, 'TEdit', nil);//determine the handle of the TEdit
dwLong := GetWindowLong(hEdit, GWL_STYLE);//get the current style of the control
SetWindowLong(hEdit, GWL_STYLE, dwLong or ES_NUMBER)//set the new style
end;
end;
Note : unfortunately this method doesn't allow to validate the range of the numbers.

You could use InputQuery from QDialogs unit, which has an overloaded version with Min and Max parameters for limiting the range of Integer input. Something like this:
var i:Integer;
begin
i:=0; // Initial value to show the user in the textbox
if InputQuery('Dialog Caption', 'Please enter the number between 0 and 100:', i, 0, 100) then ShowMessage('Entered: '+IntToStr(i));
end;
Do not forget to add QDialogs to the uses clause, otherwise this version of the function will not be found.
BUT this dialog will not prevent user from entering a value that is out of bounds; it will silently "trim" it to the nearest bound. For example, if the user enters -20, variable "i" will be set to 0. And if he enters 200, "i" will be set to 100. I'm not sure if that functionality would suit everybody, but it's one way to achieve it without writing any custom code. Hope this helps.

This work with D6. Function TryStrToInt is from SysUtils.
procedure TForm.ButtonClick(Sender: TObject);
var vInt:Integer;
vStr:String;
begin
Repeat
Repeat
vStr:=InputBox('Some title','Enter integer betwen 0-100','');
Until TryStrToInt(vStr, vInt);
Until (vInt>=0) and (vInt<=100);
end;

No, there is no way to do this. You should write your own dialog which validates the input to an edit control.

Related

Delphi: How do you control multiple alike objects?

Say that I have five TRectangle objects, and a function is going to pass a parameter in to make one of them blink.
I know how to control one object like the following code:
procedure TForm1.TimerTimer(Sender: TObject);
begin
if rect1.Visible then
rect1.Visible := false
else
rect1.Visible := true;
end;
procedure TForm1.Blink_Square;
begin
Timer := TTimer.Create(nil);
Timer.OnTimer := TimerTimer;
rect1.Fill.Color := TAlphacolors.Red;
rect1.fill.Kind := TBrushKind.bkSolid;
rect1.Stroke.Thickness := 1;
rect1.Stroke.Color := Talphacolors.Darkgray;
Timer.Interval := 500;
Timer.Enabled := True;
end;
But I really wonder if there is a way that I can use the blink square repeatedly like having a procedure as procedure TForm1.Blink_Square(rec_number: integer); And we can call Blink_Square(5); to make rect5 blink.
Thanks in Advance
You can store your objects in an array or list, then use your procedure parameter to index into it.
var
Blinks: array[1..5] of record
Rectangle: TRectangle;
Timer: TTimer;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Blinks[1].Rectangle := Rect1;
Blinks[1].Timer := nil;
Blinks[2].Rectangle := Rect2;
Blinks[2].Timer := nil;
Blinks[3].Rectangle := Rect3;
Blinks[3].Timer := nil;
Blinks[4].Rectangle := Rect4;
Blinks[4].Timer := nil;
Blinks[5].Rectangle := Rect5;
Blinks[5].Timer := nil;
end;
procedure TForm1.TimerTimer(Sender: TObject);
var
Timer: TTimer;
begin
Timer := TTimer(Sender);
Blinks[Timer.Tag].Visible := not Blinks[Timer.Tag].Visible;
end;
procedure TForm1.Blink_Square(Number: Integer);
begin
Blinks[Number].Rectangle.Fill.Color := TAlphacolors.Red;
Blinks[Number].Rectangle.fill.Kind := TBrushKind.bkSolid;
Blinks[Number].Rectangle.Stroke.Thickness := 1;
Blinks[Number].Rectangle.Stroke.Color := Talphacolors.Darkgray;
if Blinks[Number].Timer = nil then
begin
Blinks[Number].Timer := TTimer.Create(Self);
Blinks[Number].Timer.OnTimer := TimerTimer;
Blinks[Number].Timer.Interval := 500;
Blinks[Number].Timer.Tag := Number;
Blinks[Number].Timer.Enabled := True;
end;
end;
Alternatively:
var
Rects: array[1..5] of TRectangle;
procedure TForm1.FormCreate(Sender: TObject);
begin
Rects[1] := Rect1;
Rects[2] := Rect2;
Rects[3] := Rect3;
Rects[4] := Rect4;
Rects[5] := Rect5;
end;
procedure TForm1.TimerTimer(Sender: TObject);
begin
TRectangle(Sender).Visible := not TRectangle(Sender).Visible;
end;
procedure TForm1.Blink_Square(Number: Integer);
var
Rec: TRectangle;
Timer: TTimer;
M: TNotifyEvent;
begin
Rec := Rects[Number];
Rec.Fill.Color := TAlphacolors.Red;
Rec.fill.Kind := TBrushKind.bkSolid;
Rec.Stroke.Thickness := 1;
Rec.Stroke.Color := Talphacolors.Darkgray;
if Rec.Tag = 0 then
begin
M := TimerTimer;
TMethod(M).Data := Rec;
Timer := TTimer.Create(Rec);
Timer.OnTimer := M;
Timer.Interval := 500;
Timer.Enabled := True;
Rec.Tag := NativeInt(Timer);
end;
end;

Delphi XE3 Invalid Pointer when trying to free FSQL (TStringList)

I'm creating a new app in XE3 but using some units created in D2007.
I"m getting an error when freeing a TStringList data item. Here's the code that creates the data item FSQL:
procedure TPayorDM.DataModuleCreate(Sender: TObject);
begin
FPayorDRM := TDRM.Create;
FSQL := TStringList.Create;
end;
Here's the code that is getting the error:
procedure TPayorDM.DataModuleDestroy(Sender: TObject);
begin
FreeAndNil(FSQL);
if T_Payor.Active then T_Payor.Close;
FreeAndNil(FPayorDRM);
end;
The error occurs on 'FreeAndNil(FSQL);'. I have tried 'FSQL.Free' and I get the same result.
Here's the error I'm getting:
Project: PayorUpdate.exe raised exception class EInvalidPointer with message 'Invalid pointer operation.
When I break blue arrows (debug mode) is pointing to _FreeMem(Pointer(Self)); in the procedure TObject.FreeInstance in System unit as follows:
procedure TObject.FreeInstance;
begin
CleanupInstance;
_FreeMem(Pointer(Self));
end;
If I don't free the TStringList data item I would have a memory leak in the app.
Is there possibly a configuration option I need to set? I've search with google and have not found anything that explains what I am doing wrong other than one of the three possibilities:
It was allocated by some other memory manager.
It had already been freed once before.
It had never been allocated by anything.
If I put a try ... except... I'm able to get around the issue, but I prefer not to do this.
BTW, I have another TStringList in different unit and I create and FreeAndNil and I do not get any error.
Here is entire source:
unit PayorDataMgr;
interface
uses
SysUtils,
Classes,
Dialogs,
NativeXML,
adscnnct,
DB,
adsdata,
adsfunc,
adstable,
ace,
cbs.drm,
cbs.utils,
cbs.LogFiles;
const
POLICY_TYPES: array[1..3] of string = ('Primary','Secondary','Tertiary');
type
TPayorRecord = Record
ASSIGNBENEFITS: Boolean;
AUTHORIZE: Boolean;
BATCHBILL: Boolean;
CLAIMMAX: Integer;
DISCONTINUED: TDateTime;
DISPENSEUPDATE: Boolean;
EHRSIGNOFF: Boolean;
EMCDEST: String;
FORM: String;
GOVASSIGN: Boolean;
HIDE: Boolean;
IGRPUNIQUE: Integer;
LEGACYPLAN: String;
LEGACYTYPE: String;
LOCALATTN: String;
LOCALCITY: String;
LOCALNAME: String;
LOCALPHONE: String;
LOCALSTATE: String;
LOCALSTREET: String;
LOCALZIP: String;
MASTERATTN: String;
MASTERCITY: String;
MASTERNAME: String;
MASTERPHONE: String;
MASTERSTATE: String;
MASTERSTREET: String;
MASTERZIP: String;
MEDIGAPCODE: String;
MEDIGAPPAYOR: Boolean;
MEDPLANGUID: String;
MODIFIED: TDateTime;
NEICCODE: String;
NEICTYPESTDC: Integer;
OWNER: String;
PAYORGUID: String;
PAYORSUBTYPESTDC: Integer;
PAYORTYPESTDC: Integer;
PAYORUNIQUE: Integer;
PAYPERCENT: Integer;
RTCODE: String;
SRXPLANGUID: String;
STATEFILTER: String;
procedure Clear;
End;
TPayors = Record
private
function _pGetCount: Integer;
public
Items: Array of TPayorRecord;
procedure Add(const aItem:TPayorRecord);
function CarriersList:TStrings;
procedure Free;
function GetPayorGuid(const aPAYORUNIQUE:Integer):String;
function IndexOfIgrpUnique(Const aIGRPUNIQUE:Integer):Integer;
function IndexOfPayorUnique(Const aPAYORUNIQUE:Integer):Integer;
procedure SortByName;
property Count:Integer Read _pGetCount;
End;
TPayorDM = class(TDataModule)
CommonConnection: TAdsConnection;
T_Payor: TAdsTable;
Q_Payor: TAdsQuery;
procedure DataModuleDestroy(Sender: TObject);
procedure DataModuleCreate(Sender: TObject);
private
FPayorDRM: TDRM;
FSQL: TStringList;
function _LoadRecordFromTable:TPayorRecord;
function _newIDSTRING(const aFormat:String='F'):String;
{ Private declarations }
procedure _pSetConnectionHandle(const Value: Integer);
procedure _pSetErrorMessage(const Value: String);
procedure _psetSQL(const Value: TStringList);
{ Private properties }
property ErrorMessage:String Write _pSetErrorMessage;
public
function AddPayor(var aPAYORRECORD:TPAYORRECORD):Boolean;
function ExecuteScript(const aTo,aFrom:string):Boolean;
function FindPayor(const aPAYORGUID:String):Boolean;overload;
function FindPayor(const aPAYORUNIQUE:Integer):Boolean;overload;
function GetPayorData:TDRM;
function GetRecordCount(const aData:String):Integer;
function LoadCarriers(const aHide:boolean = False):TPayors;
function LoadPayor:TPayorRecord;
function OpenTable:Boolean;
function UpdateFromXML(const aPayorNode:TXMLNode):boolean;
{ Public declarations }
property ConnectionHandle:Integer Write _pSetConnectionHandle;
property DynamicPayorFields:TDRM Read FPayorDRM;
property SQL:TStringList Read FSQL Write _psetSQL;
end;
var
PayorDM: TPayorDM;
implementation
{$R *.dfm}
function TPayorDM.AddPayor(var aPAYORRECORD: TPAYORRECORD): Boolean;
begin
Result := False;
if IsNull(aPAYORRECORD.LOCALNAME) then Exit;
{ Create uniques }
{ Add Record }
if not T_Payor.Active then
if not OpenTable then Exit;
with T_Payor do
try
Insert;
FieldByName('PAYORGUID').AsString := _newIDSTRING;
FieldByName('MASTERNAME').AsString := aPAYORRECORD.MASTERNAME;
FieldByName('MASTERSTREET').AsString := aPAYORRECORD.MASTERSTREET;
FieldByName('MASTERCITY').AsString := aPAYORRECORD.MASTERCITY;
FieldByName('MASTERSTATE').AsString := aPAYORRECORD.MASTERSTATE;
FieldByName('PAYORTYPESTDC').AsInteger := aPAYORRECORD.PAYORTYPESTDC;
FieldByName('MASTERZIP').AsString := aPAYORRECORD.MASTERZIP;
FieldByName('MASTERATTN').AsString := aPAYORRECORD.MASTERATTN;
FieldByName('MASTERPHONE').AsString := aPAYORRECORD.MASTERPHONE;
FieldByName('NEICCODE').AsString := aPAYORRECORD.NEICCODE;
FieldByName('RTCODE').AsString := aPAYORRECORD.RTCODE;
FieldByName('STATEFILTER').AsString := aPAYORRECORD.STATEFILTER;
FieldByName('NEICTYPESTDC').AsInteger := aPAYORRECORD.NEICTYPESTDC;
FieldByName('PAYORSUBTYPESTDC').AsInteger := aPAYORRECORD.PAYORSUBTYPESTDC;
FieldByName('OWNER').AsString := aPAYORRECORD.OWNER;
FieldByName('HIDE').AsBoolean := aPAYORRECORD.HIDE;
FieldByName('IGRPUNIQUE').AsInteger := aPAYORRECORD.IGRPUNIQUE;
FieldByName('FORM').AsString := aPAYORRECORD.FORM;
FieldByName('GOVASSIGN').AsBoolean := aPAYORRECORD.GOVASSIGN;
FieldByName('CLAIMMAX').AsInteger := aPAYORRECORD.CLAIMMAX;
FieldByName('MEDIGAPCODE').AsString := aPAYORRECORD.MEDIGAPCODE;
FieldByName('EMCDEST').AsString := aPAYORRECORD.EMCDEST;
FieldByName('ASSIGNBENEFITS').AsBoolean := aPAYORRECORD.ASSIGNBENEFITS;
FieldByName('BATCHBILL').AsBoolean := aPAYORRECORD.BATCHBILL;
FieldByName('MEDIGAPPAYOR').AsBoolean := aPAYORRECORD.MEDIGAPPAYOR;
FieldByName('MEDPLANGUID').AsString := aPAYORRECORD.MEDPLANGUID;
FieldByName('SRXPLANGUID').AsString := aPAYORRECORD.SRXPLANGUID;
FieldByName('PAYPERCENT').AsInteger := aPAYORRECORD.PAYPERCENT;
FieldByName('LOCALNAME').AsString := aPAYORRECORD.LOCALNAME;
FieldByName('LOCALSTREET').AsString := aPAYORRECORD.LOCALSTREET;
FieldByName('LOCALCITY').AsString := aPAYORRECORD.LOCALCITY;
FieldByName('LOCALSTATE').AsString := aPAYORRECORD.LOCALSTATE;
FieldByName('LOCALZIP').AsString := aPAYORRECORD.LOCALZIP;
FieldByName('LOCALATTN').AsString := aPAYORRECORD.LOCALATTN;
FieldByName('LOCALPHONE').AsString := aPAYORRECORD.LOCALPHONE;
FieldByName('EHRSIGNOFF').AsBoolean := aPAYORRECORD.EHRSIGNOFF;
FieldByName('DISCONTINUED').AsDateTime := aPAYORRECORD.DISCONTINUED;
FieldByName('MODIFIED').AsDateTime := Now;
FieldByName('LEGACYPLAN').AsString := aPAYORRECORD.LEGACYPLAN;
FieldByName('LEGACYTYPE').AsString := aPAYORRECORD.LEGACYTYPE;
FieldByName('AUTHORIZE').AsBoolean := aPAYORRECORD.AUTHORIZE;
FieldByName('DISPENSEUPDATE').AsBoolean := aPAYORRECORD.DISPENSEUPDATE;
Post;
aPAYORRECORD.PAYORUNIQUE := FieldByName('PAYORUNIQUE').AsInteger;
aPAYORRECORD.PAYORGUID := FieldByName('PAYORGUID').AsString;
Close;
Result := True;
except on E: EADSDatabaseError do
begin
ErrorMessage := 'AddPayor: ERRORCODE: ' + IntToStr(e.ACEErrorCode) +
' ERROR: ' + e.Message;
end;
end;
end;
procedure TPayorDM.DataModuleCreate(Sender: TObject);
begin
FPayorDRM := TDRM.Create;
FSQL := TStringList.Create; { FSQL Created }
end;
procedure TPayorDM.DataModuleDestroy(Sender: TObject);
begin
try
FSQL.Free; { FSQL destroyed - work around to get unit to run without error}
except
end;
if T_Payor.Active then T_Payor.Close;
FreeAndNil(FPayorDRM);
end;
function TPayorDM.ExecuteScript(const aTo, aFrom: string):Boolean;
begin
Result := False;
if FSQL.Count = 0 then exit;
with Q_Payor do
try
if Active then Close;
SQL := FSQL;
ParamByName('to').Text := aTo;
ParambyName('from').Text := aFrom;
ExecSQL;
if Active then Close;
Result := True;
except on E: EADSDatabaseError do
begin
ErrorMessage := 'ExecuteScript: ERRORCODE: ' + IntToStr(e.ACEErrorCode) +
' ERROR: ' + e.Message + ' SQL: ' + Q_Payor.SQL.Text;
end;
end;
end;
function TPayorDM.FindPayor(const aPAYORUNIQUE: Integer): Boolean;
begin
T_Payor.IndexName := 'PAYORUNIQUE';
Result := T_Payor.FindKey([aPAYORUNIQUE]);
end;
function TPayorDM.FindPayor(const aPAYORGUID: String): Boolean;
begin
T_Payor.IndexName := 'PAYORGUID';
Result := T_Payor.FindKey([aPAYORGUID]);
end;
function TPayorDM.GetPayorData: TDRM;
begin
if FPayorDRM.Count = 0 then
FPayorDRM.BuildDRMList(T_Payor);
Result := FPayorDRM;
end;
function TPayorDM.GetRecordCount(const aData:string): Integer;
begin
Result := 0;
if FSQL.Count = 0 then exit;
with Q_Payor do
try
if Active then Close;
SQL := FSQL;
ParamByName('data').AsString := aData;
Open;
Result := RecordCount;
Close;
except on E: EADSDatabaseError do
begin
ErrorMessage := 'GetRecordCount: ERRORCODE: ' + IntToStr(e.ACEErrorCode) +
' ERROR: ' + e.Message;
end;
end;
end;
function TPayorDM.LoadCarriers(const aHide: boolean): TPayors;
begin
OpenTable;
Result.Free;
with T_Payor do
begin
First;
while not EOF do
begin
if T_Payor.FieldByName('HIDE').AsBoolean = aHide then
Result.Add(_LoadRecordFromTable);
Next;
end;
First;
Result.SortByName;
end;
end;
function TPayorDM.LoadPayor: TPayorRecord;
begin
Result.Clear;
try
if not T_Payor.active then exit;
if T_Payor.RecNo = 0 then exit;
Result := _LoadRecordFromTable;
except on E: EADSDatabaseError do
begin
ErrorMessage := 'LoadPayor: ERRORCODE: ' + IntToStr(e.ACEErrorCode) +
' ERROR: ' + e.Message;
end;
end;
end;
function TPayorDM.OpenTable: Boolean;
begin
Result := False;
with T_Payor do
try
if not Active then Open;
FPayorDRM.BuildDRMList(T_Payor);
FPayorDRM.LoadValues(T_Payor); { test }
FPayorDRM.ExportDRMList; { test }
Result := True;
except on E: EADSDatabaseError do
begin
ErrorMessage := 'OpenTable: ERRORCODE: ' + IntToStr(e.ACEErrorCode) +
' ERROR: ' + e.Message;
end;
end;
end;
function TPayorDM.UpdateFromXML(const aPayorNode: TXMLNode): boolean;
var
fKeyData:TXMLNode;
Idx,fPAYORUNIQUE:Integer;
begin
Result := False;
if not Assigned(aPayorNode) then Exit;
try
if FPayorDRM.Count = 0 then
FPayorDRM.BuildDRMList(T_Payor);
FPayorDRM.ClearValues;
fKeyData := aPayorNode.FindNode('KeyData');
FPayorDRM.FindRecordFromKeyData(fKeyData,T_Payor);
fPAYORUNIQUE := FPayorDRM.FieldByName('PAYORUNIQUE').AsInteger;
FPayorDRM.LoadValues(aPayorNode);
if fPAYORUNIQUE = 0 then
begin
FPayorDRM.FieldByName('PAYORUNIQUE').AsInteger := 0;
FPayorDRM.FieldByName('PAYORGUID').AsString := _newIDSTRING;
FPayorDRM.FieldByName('MODIFIED').AsDate := Now;
FPayorDRM.AddRecord(T_Payor)
end
else
begin
FPayorDRM.FieldByName('MODIFIED').AsDate := Now;
FPayorDRM.UpdateRecord(T_Payor);
end;
except on e:exception do
begin
ErrorMessage := 'UpdateFromXML: ERROR: ' + e.Message;
end;
end;
end;
function TPayorDM._LoadRecordFromTable: TPayorRecord;
begin
with T_Payor do
begin
Result.PAYORUNIQUE := FieldByName('PAYORUNIQUE').AsInteger;
Result.PAYORGUID := FieldByName('PAYORGUID').AsString;
Result.MASTERNAME := FieldByName('MASTERNAME').AsString;
Result.MASTERSTREET := FieldByName('MASTERSTREET').AsString;
Result.MASTERCITY := FieldByName('MASTERCITY').AsString;
Result.MASTERSTATE := FieldByName('MASTERSTATE').AsString;
Result.PAYORTYPESTDC := FieldByName('PAYORTYPESTDC').AsInteger;
Result.MASTERZIP := FieldByName('MASTERZIP').AsString;
Result.MASTERATTN := FieldByName('MASTERATTN').AsString;
Result.MASTERPHONE := FieldByName('MASTERPHONE').AsString;
Result.NEICCODE := FieldByName('NEICCODE').AsString;
Result.RTCODE := FieldByName('RTCODE').AsString;
Result.STATEFILTER := FieldByName('STATEFILTER').AsString;
Result.NEICTYPESTDC := FieldByName('NEICTYPESTDC').AsInteger;
Result.PAYORSUBTYPESTDC := FieldByName('PAYORSUBTYPESTDC').AsInteger;
Result.OWNER := FieldByName('OWNER').AsString;
Result.HIDE := FieldByName('HIDE').AsBoolean;
Result.IGRPUNIQUE := FieldByName('IGRPUNIQUE').AsInteger;
Result.FORM := FieldByName('FORM').AsString;
Result.GOVASSIGN := FieldByName('GOVASSIGN').AsBoolean;
Result.CLAIMMAX := FieldByName('CLAIMMAX').AsInteger;
Result.MEDIGAPCODE := FieldByName('MEDIGAPCODE').AsString;
Result.EMCDEST := FieldByName('EMCDEST').AsString;
Result.ASSIGNBENEFITS := FieldByName('ASSIGNBENEFITS').AsBoolean;
Result.BATCHBILL := FieldByName('BATCHBILL').AsBoolean;
Result.MEDIGAPPAYOR := FieldByName('MEDIGAPPAYOR').AsBoolean;
Result.MEDPLANGUID := FieldByName('MEDPLANGUID').AsString;
Result.SRXPLANGUID := FieldByName('SRXPLANGUID').AsString;
Result.PAYPERCENT := FieldByName('PAYPERCENT').AsInteger;
Result.LOCALNAME := FieldByName('LOCALNAME').AsString;
Result.LOCALSTREET := FieldByName('LOCALSTREET').AsString;
Result.LOCALCITY := FieldByName('LOCALCITY').AsString;
Result.LOCALSTATE := FieldByName('LOCALSTATE').AsString;
Result.LOCALZIP := FieldByName('LOCALZIP').AsString;
Result.LOCALATTN := FieldByName('LOCALATTN').AsString;
Result.LOCALPHONE := FieldByName('LOCALPHONE').AsString;
Result.EHRSIGNOFF := FieldByName('EHRSIGNOFF').AsBoolean;
Result.DISCONTINUED := FieldByName('DISCONTINUED').AsDateTime;
Result.MODIFIED := FieldByName('MODIFIED').AsDateTime;
Result.LEGACYPLAN := FieldByName('LEGACYPLAN').AsString;
Result.LEGACYTYPE := FieldByName('LEGACYTYPE').AsString;
Result.AUTHORIZE := FieldByName('AUTHORIZE').AsBoolean;
Result.DISPENSEUPDATE := FieldByName('DISPENSEUPDATE').AsBoolean;
end;
end;
function TPayorDM._newIDSTRING(const aFormat: String): String;
begin
Result := '';
try
with Q_Payor do
try
SQL.Clear;
SQL.Add('SELECT NEWIDSTRING( "' + aFormat + '" ) AS GUID FROM system.iota');
Open;
Result := FieldByName('GUID').AsString;
Close;
except on E: EADSDatabaseError do
begin
ErrorMessage := '_newIDSTRING: ERRORCODE: ' + IntToStr(e.ACEErrorCode) +
' ERROR: ' + e.Message;
end;
end;
finally
end;
end;
procedure TPayorDM._pSetConnectionHandle(const Value: Integer);
begin
if T_Payor.Active then T_Payor.Close;
CommonConnection.SetHandle(Value);
OpenTable;
end;
procedure TPayorDM._pSetErrorMessage(const Value: String);
begin
WriteError('[TPayorDM]' + Value,LogFilename);
end;
procedure TPayorDM._psetSQL(const Value: TStringList);
begin
FSQL := Value;
end;
{ TPayorRecord }
procedure TPayorRecord.Clear;
begin
PAYORUNIQUE := 0;
PAYORGUID := '';
MASTERNAME := '';
MASTERSTREET := '';
MASTERCITY := '';
MASTERSTATE := '';
PAYORTYPESTDC := 0;
MASTERZIP := '';
MASTERATTN := '';
MASTERPHONE := '';
NEICCODE := '';
RTCODE := '';
STATEFILTER := '';
NEICTYPESTDC := 0;
PAYORSUBTYPESTDC := 0;
OWNER := '';
HIDE := False;
IGRPUNIQUE := 0;
FORM := '';
GOVASSIGN := False;
CLAIMMAX := 0;
MEDIGAPCODE := '';
EMCDEST := '';
ASSIGNBENEFITS := False;
BATCHBILL := False;
MEDIGAPPAYOR := False;
MEDPLANGUID := '';
SRXPLANGUID := '';
PAYPERCENT := 0;
LOCALNAME := '';
LOCALSTREET := '';
LOCALCITY := '';
LOCALSTATE := '';
LOCALZIP := '';
LOCALATTN := '';
LOCALPHONE := '';
EHRSIGNOFF := False;
DISCONTINUED := 0;
MODIFIED := 0;
LEGACYPLAN := '';
LEGACYTYPE := '';
AUTHORIZE := False;
DISPENSEUPDATE := False;
end;
{ TPayors }
procedure TPayors.Add(const aItem: TPayorRecord);
begin
SetLength(Items,Count + 1);
Items[Count - 1] := aItem;
end;
function TPayors.CarriersList: TStrings;
var
I: Integer;
begin
Result := TStringList.Create;
Result.Clear;
SortbyName;
try
for I := 0 to Count - 1 do
Result.Add(Items[I].LOCALNAME);
finally
end;
end;
procedure TPayors.Free;
begin
Items := Nil;
end;
function TPayors.GetPayorGuid(const aPAYORUNIQUE: Integer): String;
var
Idx:Integer;
begin
Result := '';
Idx := IndexOfPayorUnique(aPAYORUNIQUE);
if not (Idx = -1) then
Result := Items[Idx].PAYORGUID;
end;
function TPayors.IndexOfIgrpUnique(const aIGRPUNIQUE: Integer): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to Count - 1 do
if Items[I].IGRPUNIQUE = aIGRPUNIQUE then
begin
Result := I;
Break;
end;
end;
function TPayors.IndexOfPayorUnique(const aPAYORUNIQUE: Integer): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to Count - 1 do
if Items[I].PAYORUNIQUE = aPAYORUNIQUE then
begin
Result := I;
Break;
end;
end;
procedure TPayors.SortByName;
var
fSort:TStringList;
fParse:TStrings;
I,Idx: Integer;
fTempPayor:TPayors;
begin
fSort := TStringList.Create;
fParse := TStringList.Create;
fTempPayor.Items := Self.Items;
fSort.Sorted := True;
try
for I := 0 to Count - 1 do
fSort.Add(Items[I].LOCALNAME + #9 + IntToStr(I));
Items := Nil;
for I := 0 to fSort.Count - 1 do
begin
cbs.utils.ParseDelimited(fParse,fSort[I],#9);
Idx := StrToInt(fParse[1]);
Add(fTempPayor.Items[Idx]);
end;
finally
fTempPayor.Free;
fParse.Free;
fSort.Free;
end;
end;
function TPayors._pGetCount: Integer;
begin
Result := Length(Items);
end;
end.
You are (most probably) double freeing a stringlist (and never freeing at least one). The problem is in the setter of your 'SQL' property (which is backed by the 'FSQL' field):
procedure TPayorDM._psetSQL(const Value: TStringList);
begin
FSQL := Value;
end;
Here you are loosing the reference to the already existing stringlist (LHS). Consider the below scenario:
You call
PayorDM.SQL := AStringList;
and the reference to the private field you created in the constructor is gone, instead you keep a reference to 'AStringList'. After that at some point you destroy 'AStringList', now the 'FSQL' field is a stale pointer. When in the destructor you call
FSQL.Free;
you get an invalid pointer operation.
Change your setter to:
procedure TPayorDM._psetSQL(const Value: TStringList);
begin
FSQL.Assign(Value);
end;

SendKeys from WM_HOTKEY handler

Have AppActivate and SendKeys functions.
When use: AppActivate('*WordPad'); SendKeys('Test");
this works fine - application activated and text pasted
but then use it from WM_HOTKEY handler from the same program,
this is not worked.
Any ideas?
procedure wm_hotkeyhandler(var Msg: TWMHotkey); message WM_HOTKEY;
...
procedure TFormMain.wm_hotkeyhandler(var Msg: TWMHotkey);
var
Pt: TPoint;
begin
inherited;
if (Msg.HotKey = HotKeyId_L) then SendKeys('Test'); // not pasted to active app
if (Msg.HotKey = HotKeyId_M) then begin
// invoke context menu and paste text after click to menu item, works fine
GetCursorPos(Pt);
popPaste.Popup(Pt.x, Pt.y);
end;
end;
Update 1:
// this code works fine
procedure TFormTest.btnAppActivateClick(Sender: TObject);
var
sTitle, sKeys: string;
begin
sTitle := '*WordPad';
sKeys := 'Hello{ENTER}World!';
AppActivate(sTitle);
SendKeys(PChar(sKeys), False);
end;
menu item handler (which invoked by hotkey HotKeyId_M):
procedure TFormMain.mnPasteLoginClick(Sender: TObject);
begin
SendKeys('Hello{ENTER}World!', False);
end;
hotkeys:
HotKeyId_L: Integer;
HotKeyId_M: Integer;
initialization of hotkeys:
HotKeyId_L := GlobalAddAtom('HotKeyL');
RegisterHotKey(Handle, HotKeyId_L, MOD_CONTROL + MOD_ALT, Byte('L'));
HotKeyId_M := GlobalAddAtom('HotKeyM');
RegisterHotKey(Handle, HotKeyId_L, MOD_CONTROL + MOD_ALT, Byte('M'));
Update 2: (full code for test)
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Menus;
type
TForm2 = class(TForm)
btnActivate: TButton;
popPopup: TPopupMenu;
Paste1: TMenuItem;
procedure btnActivateClick(Sender: TObject);
procedure Paste1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
HotKeyId_L: Integer;
HotKeyId_M: Integer;
procedure wm_hotkeyhandler(var Msg: TWMHotkey); message WM_HOTKEY;
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.DFM}
type
TCompareDirection = (cdHead, cdTail, cdNone);
TWindowObj = class(TObject)
private
targetTitle : PChar;
compareLength: Integer;
FCompareDirection: TCompareDirection;
FWindowHandle: THandle;
public
constructor Create;
destructor Destroy; override;
function Equal(ATitle: PChar): Boolean;
function SetTitle(const Title: string ): Boolean;
property WindowHandle: THandle read FWindowHandle write FWindowHandle;
end;
function EnumWindowsProc(hWnd: HWND; lParam: LPARAM):Bool; export; stdcall;
var
WinObj: TWindowObj;
aWndName: array[0..MAX_PATH] of Char;
begin
Result := True;
WinObj := TWindowObj(lParam);
GetWindowText(hWnd, aWndName, MAX_PATH);
if WinObj.Equal(aWndName) then begin
WinObj.WindowHandle := hWnd;
Result := False; // Stop Enumerate
end;
end;
function GetWindowHandleByTitle(const Title: string): THandle;
var
WinObj: TWindowObj;
begin
Result := 0;
WinObj := TWindowObj.Create;
try
if WinObj.SetTitle(Title) then begin
EnumWindows(#EnumWindowsProc, Integer(WinObj));
Result := WinObj.WindowHandle;
end;
finally
WinObj.Free;
end;
end;
function AppActivate(const Title: string ): Boolean;
var
hWnd: THandle;
begin
hWnd := GetWindowHandleByTitle(Title);
Result := (hWnd > 0);
if Result then begin
SendMessage(hWnd, WM_SYSCOMMAND, SC_HOTKEY, hWnd);
SendMessage(hWnd, WM_SYSCOMMAND, SC_RESTORE, hWnd);
SetForegroundWindow(hWnd);
end;
end;
constructor TWindowObj.Create;
begin
TargetTitle := nil;
FWindowHandle := 0;
end;
destructor TWindowObj.Destroy;
begin
inherited Destroy;
if Assigned(TargetTitle) then
StrDispose(TargetTitle) ;
end;
function TWindowObj.Equal(ATitle: PChar): Boolean;
var
p : Pchar;
stringLength : integer;
begin
Result := False;
if (TargetTitle = nil) then
Exit;
case FCompareDirection of
cdHead: begin
if StrLIComp(ATitle, TargetTitle, compareLength) = 0 then
Result := True;
end;
cdTail: begin
stringLength := StrLen(ATitle);
p := #ATitle[stringLength - compareLength];
if (StrLIComp(p, Targettitle, compareLength) = 0) then
Result := True;
end;
cdNone: begin
Result := True;
end;
end;
end;
function TWindowObj.SetTitle(const Title: string ): Boolean;
var
pTitle, p: PChar;
begin
Result := False;
pTitle := StrAlloc(Length(Title) + 1);
StrPCopy(pTitle, Title);
p := StrScan(pTitle, '*');
if Assigned(p) then begin
if StrLen(pTitle) = 1 then begin {full matching }
FCompareDirection := cdNone;
compareLength := 0;
TargetTitle := nil;
StrDispose(pTitle);
end
else
if (p = pTitle) then begin {tail matching }
Inc(p);
if StrScan(p, '*') <> nil then begin
{MessageDlg( 'Please 1 wild char ', mtError, [mbOK],0 ); }
StrDispose( pTitle);
TargetTitle := nil;
FCompareDirection := cdNone;
Comparelength := 0;
exit;
end;
FCompareDirection := cdTail;
CompareLength := StrLen(PTitle) - 1;
TargetTitle := StrAlloc(StrLen(p) + 1 );
StrCopy(targetTitle, p);
StrDispose(PTitle);
end
else begin
p^ := #0;
FCompareDirection := cdHead;
CompareLength := Strlen( pTitle );
Targettitle := pTitle;
end;
end
else begin
FCompareDirection := cdHead;
compareLength := Strlen( pTitle );
TargetTitle := pTitle;
end;
Result := True;
end;
//========================================
// SendKeys
//
// Converts a string of characters and key names to keyboard events and passes them to Windows.
//
// Example syntax:
// SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True);
function SendKeys(SendStr: PChar; Wait: Boolean): Boolean;
type
WBytes = array[0..pred(SizeOf(Word))] of Byte;
TSendKey = record
Name : ShortString;
VKey : Byte;
end;
const
// Array of keys that SendKeys recognizes.
// If you add to this list, you must be sure to keep it sorted alphabetically
// by Name because a binary search routine is used to scan it.}
MaxSendKeyRecs = 41;
SendKeyRecs : array[1..MaxSendKeyRecs] of TSendKey = (
(Name:'BACKSPACE'; VKey:VK_BACK),
(Name:'BKSP'; VKey:VK_BACK),
(Name:'BREAK'; VKey:VK_CANCEL),
(Name:'BS'; VKey:VK_BACK),
(Name:'CAPSLOCK'; VKey:VK_CAPITAL),
(Name:'CLEAR'; VKey:VK_CLEAR),
(Name:'DEL'; VKey:VK_DELETE),
(Name:'DELETE'; VKey:VK_DELETE),
(Name:'DOWN'; VKey:VK_DOWN),
(Name:'END'; VKey:VK_END),
(Name:'ENTER'; VKey:VK_RETURN),
(Name:'ESC'; VKey:VK_ESCAPE),
(Name:'ESCAPE'; VKey:VK_ESCAPE),
(Name:'F1'; VKey:VK_F1),
(Name:'F10'; VKey:VK_F10),
(Name:'F11'; VKey:VK_F11),
(Name:'F12'; VKey:VK_F12),
(Name:'F13'; VKey:VK_F13),
(Name:'F14'; VKey:VK_F14),
(Name:'F15'; VKey:VK_F15),
(Name:'F16'; VKey:VK_F16),
(Name:'F2'; VKey:VK_F2),
(Name:'F3'; VKey:VK_F3),
(Name:'F4'; VKey:VK_F4),
(Name:'F5'; VKey:VK_F5),
(Name:'F6'; VKey:VK_F6),
(Name:'F7'; VKey:VK_F7),
(Name:'F8'; VKey:VK_F8),
(Name:'F9'; VKey:VK_F9),
(Name:'HELP'; VKey:VK_HELP),
(Name:'HOME'; VKey:VK_HOME),
(Name:'INS'; VKey:VK_INSERT),
(Name:'LEFT'; VKey:VK_LEFT),
(Name:'NUMLOCK'; VKey:VK_NUMLOCK),
(Name:'PGDN'; VKey:VK_NEXT),
(Name:'PGUP'; VKey:VK_PRIOR),
(Name:'PRTSC'; VKey:VK_PRINT),
(Name:'RIGHT'; VKey:VK_RIGHT),
(Name:'SCROLLLOCK'; VKey:VK_SCROLL),
(Name:'TAB'; VKey:VK_TAB),
(Name:'UP'; VKey:VK_UP)
);
{Extra VK constants missing from Delphi's Windows API interface}
VK_NULL=0;
VK_SemiColon=186;
VK_Equal=187;
VK_Comma=188;
VK_Minus=189;
VK_Period=190;
VK_Slash=191;
VK_BackQuote=192;
VK_LeftBracket=219;
VK_BackSlash=220;
VK_RightBracket=221;
VK_Quote=222;
VK_Last=VK_Quote;
ExtendedVKeys : set of byte =
[VK_Up,
VK_Down,
VK_Left,
VK_Right,
VK_Home,
VK_End,
VK_Prior, {PgUp}
VK_Next, {PgDn}
VK_Insert,
VK_Delete];
const
INVALIDKEY = $FFFF {Unsigned -1};
VKKEYSCANSHIFTON = $01;
VKKEYSCANCTRLON = $02;
VKKEYSCANALTON = $04;
UNITNAME = 'SendKeys';
var
UsingParens, ShiftDown, ControlDown, AltDown, FoundClose : Boolean;
PosSpace : Byte;
I, L : Integer;
NumTimes, MKey : Word;
KeyString : String[20];
procedure DisplayMessage(Msg: PChar);
begin
MessageBox(0, Msg, UNITNAME, 0);
end;
function BitSet(BitTable, BitMask: Byte): Boolean;
begin
Result := ByteBool(BitTable and BitMask);
end;
procedure SetBit(var BitTable : Byte; BitMask : Byte);
begin
BitTable:=BitTable or Bitmask;
end;
procedure KeyboardEvent(VKey, ScanCode: Byte; Flags: DWORD);
var
KeyboardMsg : TMsg;
begin
keybd_event(VKey, ScanCode, Flags, 0);
if Wait then
while PeekMessage(KeyboardMsg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE) do begin
TranslateMessage(KeyboardMsg);
DispatchMessage(KeyboardMsg);
end;
end;
procedure SendKeyDown(VKey: Byte; NumTimes: Word; GenUpMsg: Boolean);
var
Cnt: Word;
ScanCode: Byte;
NumState: Boolean;
KeyBoardState: TKeyboardState;
begin
if (VKey = VK_NUMLOCK) then begin
NumState := ByteBool(GetKeyState(VK_NUMLOCK) and 1);
GetKeyBoardState(KeyBoardState);
if NumState then
KeyBoardState[VK_NUMLOCK] := (KeyBoardState[VK_NUMLOCK] and not 1)
else
KeyBoardState[VK_NUMLOCK] := (KeyBoardState[VK_NUMLOCK] or 1);
SetKeyBoardState(KeyBoardState);
Exit;
end;
ScanCode := Lo(MapVirtualKey(VKey, 0));
for Cnt := 1 to NumTimes do
if (VKey in ExtendedVKeys) then begin
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY);
if GenUpMsg then
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)
end
else begin
KeyboardEvent(VKey, ScanCode, 0);
if GenUpMsg then
KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end;
end;
procedure SendKeyUp(VKey: Byte);
var
ScanCode : Byte;
begin
ScanCode := Lo(MapVirtualKey(VKey, 0));
if (VKey in ExtendedVKeys)then
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)
else
KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end;
procedure SendKey(MKey: Word; NumTimes: Word; GenDownMsg: Boolean);
begin
if BitSet(Hi(MKey), VKKEYSCANSHIFTON) then SendKeyDown(VK_SHIFT, 1, False);
if BitSet(Hi(MKey), VKKEYSCANCTRLON) then SendKeyDown(VK_CONTROL, 1, False);
if BitSet(Hi(MKey), VKKEYSCANALTON) then SendKeyDown(VK_MENU, 1, False);
SendKeyDown(Lo(MKey), NumTimes, GenDownMsg);
if BitSet(Hi(MKey), VKKEYSCANSHIFTON) then SendKeyUp(VK_SHIFT);
if BitSet(Hi(MKey), VKKEYSCANCTRLON) then SendKeyUp(VK_CONTROL);
if BitSet(Hi(MKey), VKKEYSCANALTON) then SendKeyUp(VK_MENU);
end;
// Implements a simple binary search to locate special key name strings
function StringToVKey(KeyString: ShortString): Word;
var
Found, Collided : Boolean;
Bottom, Top, Middle : Byte;
begin
Result := INVALIDKEY;
Bottom := 1;
Top := MaxSendKeyRecs;
Found := False;
Middle := (Bottom + Top) div 2;
repeat
Collided:=((Bottom=Middle) or (Top=Middle));
if (KeyString=SendKeyRecs[Middle].Name) then begin
Found:=True;
Result:=SendKeyRecs[Middle].VKey;
end
else begin
if (KeyString>SendKeyRecs[Middle].Name) then
Bottom:=Middle
else
Top:=Middle;
Middle:=(Succ(Bottom+Top)) div 2;
end;
until (Found or Collided);
if (Result = INVALIDKEY) then
DisplayMessage('Invalid Key Name');
end;
procedure PopUpShiftKeys;
begin
if (not UsingParens) then begin
if ShiftDown then SendKeyUp(VK_SHIFT);
if ControlDown then SendKeyUp(VK_CONTROL);
if AltDown then SendKeyUp(VK_MENU);
ShiftDown := False;
ControlDown := False;
AltDown := False;
end;
end;
var
AllocationSize : integer;
begin
AllocationSize := MaxInt;
Result := False;
UsingParens := False;
ShiftDown := False;
ControlDown := False;
AltDown := False;
I := 0;
L := StrLen(SendStr);
if (L > AllocationSize) then
L := AllocationSize;
if (L = 0) then
Exit;
while (I < L) do begin
case SendStr[I] of
'(': begin
UsingParens := True;
Inc(I);
end;
')': begin
UsingParens := False;
PopUpShiftKeys;
Inc(I);
end;
'%': begin
AltDown := True;
SendKeyDown(VK_MENU, 1, False);
Inc(I);
end;
'+': begin
ShiftDown := True;
SendKeyDown(VK_SHIFT, 1, False);
Inc(I);
end;
'^': begin
ControlDown := True;
SendKeyDown(VK_CONTROL, 1, False);
Inc(I);
end;
'{': begin
NumTimes := 1;
if (SendStr[Succ(I)] = '{') then begin
MKey := VK_LEFTBRACKET;
SetBit(WBytes(MKey)[1], VKKEYSCANSHIFTON);
SendKey(MKey, 1, True);
PopUpShiftKeys;
Inc(I, 3);
Continue;
end;
KeyString := '';
FoundClose := False;
while (I <= L) do begin
Inc(I);
if (SendStr[I] = '}') then begin
FoundClose := True;
Inc(I);
Break;
end;
KeyString := KeyString + Upcase(SendStr[I]);
end;
if Not FoundClose then begin
DisplayMessage('No Close');
Exit;
end;
if (SendStr[I] = '}') then begin
MKey := VK_RIGHTBRACKET;
SetBit(Wbytes(MKey)[1], VKKEYSCANSHIFTON);
SendKey(MKey, 1, True);
PopUpShiftKeys;
Inc(I);
Continue;
end;
PosSpace:=Pos(' ', KeyString);
if (PosSpace <> 0) then begin
NumTimes := StrToInt(Copy(KeyString, Succ(PosSpace), Length(KeyString) - PosSpace));
KeyString := Copy(KeyString, 1, Pred(PosSpace));
end;
If (Length(KeyString)=1) then
MKey := vkKeyScan(KeyString[1])
else
MKey := StringToVKey(KeyString);
If (MKey <> INVALIDKEY) then begin
SendKey(MKey, NumTimes, True);
PopUpShiftKeys;
Continue;
end;
end;
'~': begin
SendKeyDown(VK_RETURN, 1, True);
PopUpShiftKeys;
Inc(I);
end;
else
MKey := vkKeyScan(SendStr[I]);
if (MKey <> INVALIDKEY) then begin
SendKey(MKey, 1, True);
PopUpShiftKeys;
end
else
DisplayMessage('Invalid KeyName');
Inc(I);
end;
end;
Result := True;
PopUpShiftKeys;
end;
procedure TForm2.btnActivateClick(Sender: TObject);
var
sTitle, sKeys: string;
begin
sTitle := '*WordPad';
sKeys := 'Hello{ENTER}World!';
AppActivate(sTitle);
SendKeys(PChar(sKeys), False);
end;
procedure TForm2.Paste1Click(Sender: TObject);
begin
SendKeys('Hello{ENTER}World!', False);
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
HotKeyId_L := GlobalAddAtom('HotKeyP');
RegisterHotKey(Handle, HotKeyId_L, MOD_CONTROL or MOD_ALT, Byte('L'));
HotKeyId_M := GlobalAddAtom('HotKeyM');
RegisterHotKey(Handle, HotKeyId_M, MOD_CONTROL or MOD_ALT, Byte('M'));
end;
procedure TForm2.FormDestroy(Sender: TObject);
begin
UnregisterHotKey(Handle, HotKeyId_L);
GlobalDeleteAtom(HotKeyId_L);
end;
procedure TForm2.wm_hotkeyhandler(var Msg: TWMHotkey);
var
Pt: TPoint;
begin
inherited;
if (Msg.HotKey = HotKeyId_L) then SendKeys('Hello{ENTER}World!', False);
if (Msg.HotKey = HotKeyId_M) then begin
GetCursorPos(Pt);
popPopup.Popup(Pt.x, Pt.y);
end;
end;
end.

Tag editor component for Delphi/C++Builder

I need a VCL tag editor component for Delphi or C++Builder, similar to what's available for JavaScript: e.g. this one, or this one or StackOverflow's own tags editor.
Is there something like this available or do I need to make it from scratch?
Some specific things that I need are:
Editor should allow either scrolling or become multi-line if more tags are present than the editor's width allows. If multi-line, there should be an option to define some maximum height however, preventing it from becoming too tall
Option to select whether tags are created when pressing space or comma key
Prompt text in the editor, when it is not focused (for example "Add new tag")
Ideally, you should be able to move between tags (highlighting them) using the keyboard arrows, so you can delete any tag using the keyboard only
Of course you want to do this yourself! Writing GUI controls is fun and rewarding!
You could do something like
unit TagEditor;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, StdCtrls, Forms, Graphics,
Types, Menus;
type
TClickInfo = cardinal;
GetTagIndex = word;
const TAG_LOW = 0;
const TAG_HIGH = MAXWORD - 2;
const EDITOR = MAXWORD - 1;
const NOWHERE = MAXWORD;
const PART_BODY = $00000000;
const PART_REMOVE_BUTTON = $00010000;
function GetTagPart(ClickInfo: TClickInfo): cardinal;
type
TTagClickEvent = procedure(Sender: TObject; TagIndex: integer;
const TagCaption: string) of object;
TRemoveConfirmEvent = procedure(Sender: TObject; TagIndex: integer;
const TagCaption: string; var CanRemove: boolean) of object;
TTagEditor = class(TCustomControl)
private
{ Private declarations }
FTags: TStringList;
FEdit: TEdit;
FBgColor: TColor;
FBorderColor: TColor;
FTagBgColor: TColor;
FTagBorderColor: TColor;
FSpacing: integer;
FTextColor: TColor;
FLefts, FRights, FWidths,
FTops, FBottoms: array of integer;
FCloseBtnLefts, FCloseBtnTops: array of integer;
FCloseBtnWidth: integer;
FSpaceAccepts: boolean;
FCommaAccepts: boolean;
FSemicolonAccepts: boolean;
FTrimInput: boolean;
FNoLeadingSpaceInput: boolean;
FTagClickEvent: TTagClickEvent;
FAllowDuplicates: boolean;
FPopupMenu: TPopupMenu;
FMultiLine: boolean;
FTagHeight: integer;
FEditPos: TPoint;
FActualTagHeight: integer;
FShrunk: boolean;
FEditorColor: TColor;
FTagAdded: TNotifyEvent;
FTagRemoved: TNotifyEvent;
FOnChange: TNotifyEvent;
FOnRemoveConfirm: TRemoveConfirmEvent;
FMouseDownClickInfo: TClickInfo;
FCaretVisible: boolean;
FDragging: boolean;
FAutoHeight: boolean;
FNumRows: integer;
procedure SetBorderColor(const Value: TColor);
procedure SetTagBgColor(const Value: TColor);
procedure SetTagBorderColor(const Value: TColor);
procedure SetSpacing(const Value: integer);
procedure TagChange(Sender: TObject);
procedure SetTags(const Value: TStringList);
procedure SetTextColor(const Value: TColor);
procedure ShowEditor;
procedure HideEditor;
procedure EditKeyPress(Sender: TObject; var Key: Char);
procedure mnuDeleteItemClick(Sender: TObject);
procedure SetMultiLine(const Value: boolean);
procedure SetTagHeight(const Value: integer);
procedure EditExit(Sender: TObject);
function Accept: boolean;
procedure SetBgColor(const Value: TColor);
function GetClickInfoAt(X, Y: integer): TClickInfo;
function GetSeparatorIndexAt(X, Y: integer): integer;
procedure CreateCaret;
procedure DestroyCaret;
function IsFirstOnRow(TagIndex: integer): boolean; inline;
function IsLastOnRow(TagIndex: integer): boolean;
procedure SetAutoHeight(const Value: boolean);
protected
{ Protected declarations }
procedure Paint; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure KeyPress(var Key: Char); override;
procedure WndProc(var Message: TMessage); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property TabOrder;
property TabStop;
property Color;
property Anchors;
property Align;
property Tag;
property Cursor;
property BgColor: TColor read FBgColor write SetBgColor;
property BorderColor: TColor read FBorderColor write SetBorderColor;
property TagBgColor: TColor read FTagBgColor write SetTagBgColor;
property TagBorderColor: TColor read FTagBorderColor
write SetTagBorderColor;
property Spacing: integer read FSpacing write SetSpacing;
property Tags: TStringList read FTags write SetTags;
property TextColor: TColor read FTextColor write SetTextColor;
property SpaceAccepts: boolean read FSpaceAccepts write FSpaceAccepts
default true;
property CommaAccepts: boolean read FCommaAccepts write FCommaAccepts
default true;
property SemicolonAccepts: boolean read FSemicolonAccepts
write FSemicolonAccepts default true;
property TrimInput: boolean read FTrimInput write FTrimInput default true;
property NoLeadingSpaceInput: boolean read FNoLeadingSpaceInput
write FNoLeadingSpaceInput default true;
property AllowDuplicates: boolean read FAllowDuplicates write FAllowDuplicates
default false;
property MultiLine: boolean read FMultiLine write SetMultiLine default false;
property TagHeight: integer read FTagHeight write SetTagHeight default 32;
property EditorColor: TColor read FEditorColor write FEditorColor
default clWindow;
property AutoHeight: boolean read FAutoHeight write SetAutoHeight;
property OnTagClick: TTagClickEvent read FTagClickEvent write FTagClickEvent;
property OnTagAdded: TNotifyEvent read FTagAdded write FTagAdded;
property OnTagRemoved: TNotifyEvent read FTagRemoved write FTagRemoved;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnRemoveConfirm: TRemoveConfirmEvent read FOnRemoveConfirm
write FOnRemoveConfirm;
end;
procedure Register;
implementation
uses Math, Clipbrd;
procedure Register;
begin
RegisterComponents('Rejbrand 2009', [TTagEditor]);
end;
function IsKeyDown(const VK: integer): boolean;
begin
IsKeyDown := GetKeyState(VK) and $8000 <> 0;
end;
function GetTagPart(ClickInfo: TClickInfo): cardinal;
begin
result := ClickInfo and $FFFF0000;
end;
{ TTagEditor }
constructor TTagEditor.Create(AOwner: TComponent);
var
mnuItem: TMenuItem;
begin
inherited;
FEdit := TEdit.Create(Self);
FEdit.Parent := Self;
FEdit.BorderStyle := bsNone;
FEdit.Visible := false;
FEdit.OnKeyPress := EditKeyPress;
FEdit.OnExit := EditExit;
FTags := TStringList.Create;
FTags.OnChange := TagChange;
FBgColor := clWindow;
FBorderColor := clWindowFrame;
FTagBgColor := clSkyBlue;
FTagBorderColor := clNavy;
FSpacing := 8;
FTextColor := clWhite;
FSpaceAccepts := true;
FCommaAccepts := true;
FSemicolonAccepts := true;
FTrimInput := true;
FNoLeadingSpaceInput := true;
FAllowDuplicates := false;
FMultiLine := false;
FTagHeight := 32;
FShrunk := false;
FEditorColor := clWindow;
FCaretVisible := false;
FDragging := false;
FPopupMenu := TPopupMenu.Create(Self);
mnuItem := TMenuItem.Create(PopupMenu);
mnuItem.Caption := 'Delete';
mnuItem.OnClick := mnuDeleteItemClick;
mnuItem.Hint := 'Deletes the selected tag.';
FPopupMenu.Items.Add(mnuItem);
TabStop := true;
end;
procedure TTagEditor.EditExit(Sender: TObject);
begin
if FEdit.Text <> '' then
Accept
else
HideEditor;
end;
procedure TTagEditor.mnuDeleteItemClick(Sender: TObject);
begin
if Sender is TMenuItem then
begin
FTags.Delete(TMenuItem(Sender).Tag);
if Assigned(FTagRemoved) then
FTagRemoved(Self);
end;
end;
procedure TTagEditor.TagChange(Sender: TObject);
begin
Invalidate;
if Assigned(FOnChange) then
FOnChange(Self);
end;
procedure TTagEditor.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
WM_SETFOCUS:
Invalidate;
WM_KILLFOCUS:
begin
if FCaretVisible then DestroyCaret;
FDragging := false;
Invalidate;
end;
WM_COPY:
Clipboard.AsText := FTags.DelimitedText;
WM_CLEAR:
FTags.Clear;
WM_CUT:
begin
Clipboard.AsText := FTags.DelimitedText;
FTags.Clear;
end;
WM_PASTE:
begin
if Clipboard.HasFormat(CF_TEXT) then
if FTags.Count = 0 then
FTags.DelimitedText := Clipboard.AsText
else
FTags.DelimitedText := FTags.DelimitedText + ',' + Clipboard.AsText;
end;
end;
end;
function TTagEditor.Accept: boolean;
begin
Assert(FEdit.Visible);
result := false;
if FTrimInput then
FEdit.Text := Trim(FEdit.Text);
if (FEdit.Text = '') or
((not AllowDuplicates) and (FTags.IndexOf(FEdit.Text) <> -1)) then
begin
beep;
Exit;
end;
FTags.Add(FEdit.Text);
result := true;
HideEditor;
if Assigned(FTagAdded) then
FTagAdded(Self);
Invalidate;
end;
procedure TTagEditor.EditKeyPress(Sender: TObject; var Key: Char);
begin
if (Key = chr(VK_SPACE)) and (FEdit.Text = '') and FNoLeadingSpaceInput then
begin
Key := #0;
Exit;
end;
if ((Key = chr(VK_SPACE)) and FSpaceAccepts) or
((Key = ',') and FCommaAccepts) or
((Key = ';') and FSemicolonAccepts) then
Key := chr(VK_RETURN);
case ord(Key) of
VK_RETURN:
begin
Accept;
ShowEditor;
Key := #0;
end;
VK_BACK:
begin
if (FEdit.Text = '') and (FTags.Count > 0) then
begin
FTags.Delete(FTags.Count - 1);
if Assigned(FTagRemoved) then
FTagRemoved(Sender);
end;
end;
VK_ESCAPE:
begin
HideEditor;
Self.SetFocus;
Key := #0;
end;
end;
end;
destructor TTagEditor.Destroy;
begin
FPopupMenu.Free;
FTags.Free;
FEdit.Free;
inherited;
end;
procedure TTagEditor.HideEditor;
begin
FEdit.Text := '';
FEdit.Hide;
// SetFocus;
end;
procedure TTagEditor.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited;
case Key of
VK_END:
ShowEditor;
VK_DELETE:
Perform(WM_CLEAR, 0, 0);
VK_INSERT:
Perform(WM_PASTE, 0, 0);
end;
end;
procedure TTagEditor.KeyPress(var Key: Char);
begin
inherited;
case Key of
^C:
begin
Perform(WM_COPY, 0, 0);
Key := #0;
Exit;
end;
^X:
begin
Perform(WM_CUT, 0, 0);
Key := #0;
Exit;
end;
^V:
begin
Perform(WM_PASTE, 0, 0);
Key := #0;
Exit;
end;
end;
ShowEditor;
FEdit.Perform(WM_CHAR, ord(Key), 0);
end;
function TTagEditor.GetClickInfoAt(X, Y: integer): TClickInfo;
var
i: integer;
begin
result := NOWHERE;
if (X >= FEditPos.X) and (Y >= FEditPos.Y) then
Exit(EDITOR);
for i := 0 to FTags.Count - 1 do
if InRange(X, FLefts[i], FRights[i]) and InRange(Y, FTops[i], FBottoms[i]) then
begin
result := i;
if InRange(X, FCloseBtnLefts[i], FCloseBtnLefts[i] + FCloseBtnWidth) and
InRange(Y, FCloseBtnTops[i], FCloseBtnTops[i] + FActualTagHeight) and
not FShrunk then
result := result or PART_REMOVE_BUTTON;
break;
end;
end;
function TTagEditor.IsFirstOnRow(TagIndex: integer): boolean;
begin
result := (TagIndex = 0) or (FTops[TagIndex] > FTops[TagIndex-1]);
end;
function TTagEditor.IsLastOnRow(TagIndex: integer): boolean;
begin
result := (TagIndex = FTags.Count - 1) or (FTops[TagIndex] < FTops[TagIndex+1]);
end;
function TTagEditor.GetSeparatorIndexAt(X, Y: integer): integer;
var
i: Integer;
begin
result := FTags.Count;
Y := Max(Y, FSpacing + 1);
for i := FTags.Count - 1 downto 0 do
begin
if Y < FTops[i] then Continue;
if (IsLastOnRow(i) and (X >= FRights[i])) or
((X < FRights[i]) and (IsFirstOnRow(i) or (FRights[i-1] < X))) then
begin
result := i;
if (IsLastOnRow(i) and (X >= FRights[i])) then inc(result);
Exit;
end;
end;
end;
procedure TTagEditor.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
FMouseDownClickInfo := GetClickInfoAt(X, Y);
if GetTagIndex(FMouseDownClickInfo) <> EDITOR then
SetFocus;
end;
procedure TTagEditor.CreateCaret;
begin
if not FCaretVisible then
FCaretVisible := Windows.CreateCaret(Handle, 0, 0, FActualTagHeight);
end;
procedure TTagEditor.DestroyCaret;
begin
if not FCaretVisible then Exit;
Windows.DestroyCaret;
FCaretVisible := false;
end;
procedure TTagEditor.MouseMove(Shift: TShiftState; X, Y: Integer);
var
SepIndex: integer;
begin
inherited;
if IsKeyDown(VK_LBUTTON) and
InRange(GetTagIndex(FMouseDownClickInfo), TAG_LOW, TAG_HIGH) then
begin
FDragging := true;
Screen.Cursor := crDrag;
SepIndex := GetSeparatorIndexAt(X, Y);
TForm(Parent).Caption := IntToStr(SepIndex);
CreateCaret;
if SepIndex = FTags.Count then
SetCaretPos(FLefts[SepIndex - 1] + FWidths[SepIndex - 1] + FSpacing div 2,
FTops[SepIndex - 1])
else
SetCaretPos(FLefts[SepIndex] - FSpacing div 2, FTops[SepIndex]);
ShowCaret(Handle);
Exit;
end;
case GetTagIndex(GetClickInfoAt(X,Y)) of
NOWHERE: Cursor := crArrow;
EDITOR: Cursor := crIBeam;
TAG_LOW..TAG_HIGH: Cursor := crHandPoint;
end;
end;
procedure TTagEditor.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
var
pnt: TPoint;
CanRemove: boolean;
ClickInfo: TClickInfo;
i: word;
p: cardinal;
SepIndex: integer;
begin
inherited;
if FDragging then
begin
DestroyCaret;
FDragging := false;
Screen.Cursor := crDefault;
SepIndex := GetSeparatorIndexAt(X, Y);
if not InRange(SepIndex, GetTagIndex(FMouseDownClickInfo),
GetTagIndex(FMouseDownClickInfo) + 1) then
FTags.Move(GetTagIndex(FMouseDownClickInfo), SepIndex -
IfThen(SepIndex > GetTagIndex(FMouseDownClickInfo), 1, 0));
Exit;
end;
ClickInfo := GetClickInfoAt(X, Y);
if ClickInfo <> FMouseDownClickInfo then Exit;
i := GetTagIndex(ClickInfo);
p := GetTagPart(ClickInfo);
case i of
EDITOR:
ShowEditor;
NOWHERE: ;
else
case Button of
mbLeft:
begin
case p of
PART_BODY:
if Assigned(FTagClickEvent) then
FTagClickEvent(Self, i, FTags[i]);
PART_REMOVE_BUTTON:
begin
if Assigned(FOnRemoveConfirm) then
begin
CanRemove := false;
FOnRemoveConfirm(Self, i, FTags[i], CanRemove);
if not CanRemove then Exit;
end;
FTags.Delete(i);
if Assigned(FTagRemoved) then
FTagRemoved(Self);
end;
end;
end;
mbRight:
begin
FPopupMenu.Items[0].Tag := i;
pnt := ClientToScreen(Point(X,Y));
FPopupMenu.Items[0].Caption := 'Delete tag "' + FTags[i] + '"';
FPopupMenu.Popup(pnt.X, pnt.Y);
end;
end;
end;
end;
procedure TTagEditor.Paint;
var
i: integer;
w: integer;
x, y: integer;
R: TRect;
MeanWidth: integer;
S: string;
DesiredHeight: integer;
begin
inherited;
Canvas.Brush.Color := FBgColor;
Canvas.Pen.Color := FBorderColor;
Canvas.Rectangle(ClientRect);
Canvas.Font.Assign(Self.Font);
SetLength(FLefts, FTags.Count);
SetLength(FRights, FTags.Count);
SetLength(FTops, FTags.Count);
SetLength(FBottoms, FTags.Count);
SetLength(FWidths, FTags.Count);
SetLength(FCloseBtnLefts, FTags.Count);
SetLength(FCloseBtnTops, FTags.Count);
FCloseBtnWidth := Canvas.TextWidth('×');
FShrunk := false;
// Do metrics
FNumRows := 1;
if FMultiLine then
begin
FActualTagHeight := FTagHeight;
x := FSpacing;
y := FSpacing;
for i := 0 to FTags.Count - 1 do
begin
FWidths[i] := Canvas.TextWidth(FTags[i] + ' ×') + 2*FSpacing;
FLefts[i] := x;
FRights[i] := x + FWidths[i];
FTops[i] := y;
FBottoms[i] := y + FTagHeight;
if x + FWidths[i] + FSpacing > ClientWidth then
{ no need to make room for the editor, since it can reside on the next row! }
begin
x := FSpacing;
inc(y, FTagHeight + FSpacing);
inc(FNumRows);
FLefts[i] := x;
FRights[i] := x + FWidths[i];
FTops[i] := y;
FBottoms[i] := y + FTagHeight;
end;
FCloseBtnLefts[i] := x + FWidths[i] - FCloseBtnWidth - FSpacing;
FCloseBtnTops[i] := y;
inc(x, FWidths[i] + FSpacing);
end;
end
else // i.e., not FMultiLine
begin
FActualTagHeight := ClientHeight - 2*FSpacing;
x := FSpacing;
y := FSpacing;
for i := 0 to FTags.Count - 1 do
begin
FWidths[i] := Canvas.TextWidth(FTags[i] + ' ×') + 2*FSpacing;
FLefts[i] := x;
FRights[i] := x + FWidths[i];
FTops[i] := y;
FBottoms[i] := y + FActualTagHeight;
inc(x, FWidths[i] + FSpacing);
FCloseBtnLefts[i] := FRights[i] - FCloseBtnWidth - FSpacing;
FCloseBtnTops[i] := y;
end;
FShrunk := x + 64 {FEdit} > ClientWidth;
if FShrunk then
begin
// Enough to remove close buttons?
x := FSpacing;
y := FSpacing;
for i := 0 to FTags.Count - 1 do
begin
FWidths[i] := Canvas.TextWidth(FTags[i]) + 2*FSpacing;
FLefts[i] := x;
FRights[i] := x + FWidths[i];
FTops[i] := y;
FBottoms[i] := y + FActualTagHeight;
inc(x, FWidths[i] + FSpacing);
FCloseBtnLefts[i] := FRights[i] - FCloseBtnWidth - FSpacing;
FCloseBtnTops[i] := y;
end;
if x + 64 {FEdit} > ClientWidth then // apparently no
begin
MeanWidth := (ClientWidth - 2*FSpacing - 64 {FEdit}) div FTags.Count - FSpacing;
x := FSpacing;
for i := 0 to FTags.Count - 1 do
begin
FWidths[i] := Min(FWidths[i], MeanWidth);
FLefts[i] := x;
FRights[i] := x + FWidths[i];
inc(x, FWidths[i] + FSpacing);
end;
end;
end;
end;
FEditPos := Point(FSpacing, FSpacing + (FActualTagHeight - FEdit.Height) div 2);
if FTags.Count > 0 then
FEditPos := Point(FRights[FTags.Count - 1] + FSpacing,
FTops[FTags.Count - 1] + (FActualTagHeight - FEdit.Height) div 2);
if FMultiLine and (FEditPos.X + 64 > ClientWidth) and (FTags.Count > 0) then
begin
FEditPos := Point(FSpacing,
FTops[FTags.Count - 1] + FTagHeight + FSpacing +
(FActualTagHeight - FEdit.Height) div 2);
inc(FNumRows);
end;
DesiredHeight := FSpacing + FNumRows*(FTagHeight+FSpacing);
if FMultiLine and FAutoHeight and (ClientHeight <> DesiredHeight) then
begin
ClientHeight := DesiredHeight;
Invalidate;
Exit;
end;
// Draw
for i := 0 to FTags.Count - 1 do
begin
x := FLefts[i];
y := FTops[i];
w := FWidths[i];
R := Rect(x, y, x + w, y + FActualTagHeight);
Canvas.Brush.Color := FTagBgColor;
Canvas.Pen.Color := FTagBorderColor;
Canvas.Rectangle(R);
Canvas.Font.Color := FTextColor;
Canvas.Brush.Style := bsClear;
R.Left := R.Left + FSpacing;
S := FTags[i];
if not FShrunk then
S := S + ' ×';
DrawText(Canvas.Handle, PChar(S), -1, R, DT_SINGLELINE or DT_VCENTER or
DT_LEFT or DT_END_ELLIPSIS or DT_NOPREFIX);
Canvas.Brush.Style := bsSolid;
end;
if FEdit.Visible then
begin
FEdit.Left := FEditPos.X;
FEdit.Top := FEditPos.Y;
FEdit.Width := ClientWidth - FEdit.Left - FSpacing;
end;
if Focused then
begin
R := Rect(2, 2, ClientWidth - 2, ClientHeight - 2);
SetBkColor(Canvas.Handle, clWhite);
SetTextColor(clBlack);
Canvas.DrawFocusRect(R);
end;
end;
procedure TTagEditor.SetAutoHeight(const Value: boolean);
begin
if FAutoHeight <> Value then
begin
FAutoHeight := Value;
Invalidate;
end;
end;
procedure TTagEditor.SetBgColor(const Value: TColor);
begin
if FBgColor <> Value then
begin
FBgColor := Value;
Invalidate;
end;
end;
procedure TTagEditor.SetBorderColor(const Value: TColor);
begin
if FBorderColor <> Value then
begin
FBorderColor := Value;
Invalidate;
end;
end;
procedure TTagEditor.SetMultiLine(const Value: boolean);
begin
if FMultiLine <> Value then
begin
FMultiLine := Value;
Invalidate;
end;
end;
procedure TTagEditor.SetTagBgColor(const Value: TColor);
begin
if FTagBgColor <> Value then
begin
FTagBgColor := Value;
Invalidate;
end;
end;
procedure TTagEditor.SetTagBorderColor(const Value: TColor);
begin
if FTagBorderColor <> Value then
begin
FTagBorderColor := Value;
Invalidate;
end;
end;
procedure TTagEditor.SetTagHeight(const Value: integer);
begin
if FTagHeight <> Value then
begin
FTagHeight := Value;
Invalidate;
end;
end;
procedure TTagEditor.SetTags(const Value: TStringList);
begin
FTags.Assign(Value);
Invalidate;
end;
procedure TTagEditor.SetTextColor(const Value: TColor);
begin
if FTextColor <> Value then
begin
FTextColor := Value;
Invalidate;
end;
end;
procedure TTagEditor.ShowEditor;
begin
FEdit.Left := FEditPos.X;
FEdit.Top := FEditPos.Y;
FEdit.Width := ClientWidth - FEdit.Left - FSpacing;
FEdit.Color := FEditorColor;
FEdit.Text := '';
FEdit.Show;
FEdit.SetFocus;
end;
procedure TTagEditor.SetSpacing(const Value: integer);
begin
if FSpacing <> Value then
begin
FSpacing := Value;
Invalidate;
end;
end;
initialization
Screen.Cursors[crHandPoint] := LoadCursor(0, IDC_HAND); // Get the normal hand cursor
end.
which yields
Sample video
Demo (Compiled EXE)
If I get more time later on today I will do some more work on this control, e.g., button highlighting on mouse hover, tag click event, button max width etc.
Update: Added a lot of features.
Update: Added multi-line feature.
Update: More features.
Update: Added clipboard interface, fixed some issues, etc.
Update: Added drag-and-drop reordering and fixed some minor issues. By the way, this is the last version I'll post here. Later versions (if there will be any) will be posted at http://specials.rejbrand.se/dev/controls/.
Update: Added AutoHeight property, made edit box vertically centred, and changed the drag cursor. (Yeah, I couldn't resist making yet another update.)

How do I conceal the password text in an edit box?

I have an inputbox and would like the user to enter a password, but at the same time hide it.
Is this possible?
This is my code so far:
var password : string;
begin
password := InputBox('Password: ', 'Please enter your password: ', password)
end;
You 'cannot' use InputBox for this, because, well... clearly this function doesn't hide the text.
The standard Windows edit control has a 'password mode', though. To test this, simply add a TEdit to a form and set its PasswordChar to *.
If you want to use such an edit in an input box, you have to write this dialog yourself, like my 'super input dialog':
type
TMultiInputBox = class
strict private
class var
frm: TForm;
lbl: TLabel;
edt: TEdit;
btnOK,
btnCancel: TButton;
shp: TShape;
FMin, FMax: integer;
FTitle, FText: string;
class procedure SetupDialog;
class procedure ValidateInput(Sender: TObject);
public
class function TextInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: string): boolean;
class function NumInputBox(AOwner: TCustomForm; const ATitle,
AText: string; AMin, AMax: integer; var Value: integer): boolean;
class function PasswordInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: string): boolean;
end;
class procedure TMultiInputBox.SetupDialog;
begin
frm.Caption := FTitle;
frm.Width := 512;
frm.Position := poOwnerFormCenter;
frm.BorderStyle := bsDialog;
lbl := TLabel.Create(frm);
lbl.Parent := frm;
lbl.Left := 8;
lbl.Top := 8;
lbl.Width := frm.ClientWidth - 16;
lbl.Caption := FText;
edt := TEdit.Create(frm);
edt.Parent := frm;
edt.Top := lbl.Top + lbl.Height + 8;
edt.Left := 8;
edt.Width := frm.ClientWidth - 16;
btnOK := TButton.Create(frm);
btnOK.Parent := frm;
btnOK.Default := true;
btnOK.Caption := 'OK';
btnOK.ModalResult := mrOk;
btnCancel := TButton.Create(frm);
btnCancel.Parent := frm;
btnCancel.Cancel := true;
btnCancel.Caption := 'Cancel';
btnCancel.ModalResult := mrCancel;
btnCancel.Top := edt.Top + edt.Height + 16;
btnCancel.Left := frm.ClientWidth - btnCancel.Width - 8;
btnOK.Top := btnCancel.Top;
btnOK.Left := btnCancel.Left - btnOK.Width - 4;
frm.ClientHeight := btnOK.Top + btnOK.Height + 8;
shp := TShape.Create(frm);
shp.Parent := frm;
shp.Brush.Color := clWhite;
shp.Pen.Style := psClear;
shp.Shape := stRectangle;
shp.Align := alTop;
shp.Height := btnOK.Top - 8;
shp.SendToBack;
end;
class function TMultiInputBox.TextInputBox(AOwner: TCustomForm; const ATitle,
AText: string; var Value: string): boolean;
begin
FTitle := ATitle;
FText := AText;
frm := TForm.Create(AOwner);
try
SetupDialog;
edt.NumbersOnly := false;
edt.PasswordChar := #0;
edt.Text := Value;
edt.OnChange := nil;
result := frm.ShowModal = mrOK;
if result then Value := edt.Text;
finally
frm.Free;
end;
end;
class function TMultiInputBox.PasswordInputBox(AOwner: TCustomForm;
const ATitle, AText: string; var Value: string): boolean;
begin
FTitle := ATitle;
FText := AText;
frm := TForm.Create(AOwner);
try
SetupDialog;
edt.NumbersOnly := false;
edt.PasswordChar := '*';
edt.Text := Value;
edt.OnChange := nil;
result := frm.ShowModal = mrOK;
if result then Value := edt.Text;
finally
frm.Free;
end;
end;
class procedure TMultiInputBox.ValidateInput(Sender: TObject);
var
n: integer;
begin
btnOK.Enabled := TryStrToInt(edt.Text, n) and InRange(n, FMin, FMax);
end;
class function TMultiInputBox.NumInputBox(AOwner: TCustomForm; const ATitle,
AText: string; AMin, AMax: integer; var Value: integer): boolean;
begin
FMin := AMin;
FMax := AMax;
FTitle := ATitle;
FText := AText;
frm := TForm.Create(AOwner);
try
SetupDialog;
edt.NumbersOnly := true;
edt.PasswordChar := #0;
edt.Text := IntToStr(value);
edt.OnChange := ValidateInput;
result := frm.ShowModal = mrOK;
if result then Value := StrToInt(edt.Text);
finally
frm.Free;
end;
end;
Try it:
procedure TForm1.Button1Click(Sender: TObject);
var
str: string;
begin
str := '';
if TMultiInputBox.PasswordInputBox(Self, 'Password',
'Please enter your password:', str) then
ShowMessageFmt('You entered %s.', [str]);
end;
This looks like it was answered here:
Delphi InputBox for password entry?
Don't use an InputBox. Create a dialog yourself and make sure to set TEdit.PasswordChar to something other than #0.
It may also be possible to get a handle to the InputBox's Edit control and set the PasswordChar via a Windows message, but I don't know how to do that off the top of my head (especially since the InputBox is a blocking call).
Delphi XE also has a Password Dialog form available to use when creating a new form. Older versions probably do too, XE just happens to be what I have running right now. (Edit Delphi 2007 also has it. 2007 & XE are the only versions of Delphi I have installed right now though, so I can't verify any other versions.)
const
InputBoxMessage = WM_USER + 200;
type
TForm1 = class(TForm)
...
procedure InputBoxSetPasswordChar(var Msg: TMessage); message InputBoxMessage;
function GetPassword: String;
...
end;
...
procedure TForm1.InputBoxSetPasswordChar(var Msg: TMessage);
var
hInputForm, hEdit: HWND;
begin
hInputForm := Screen.Forms[0].Handle;
if (hInputForm <> 0) then
begin
hEdit := FindWindowEx(hInputForm, 0, 'TEdit', nil);
SendMessage(hEdit, EM_SETPASSWORDCHAR, Ord('*'), 0);
end;
end;
function TForm1.GetPassword: String;
begin
PostMessage(Handle, InputBoxMessage, 0, 0);
Result := InputBox('Title', 'Password:', '');
end;
I think you also need to set:
Echomode := eemPassword
At least for TdlcxLabeledDBTextEdit.
procedure TForm1.Edit1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if checkbox1.checked = true then
edit1.passwordchar := '*'
else
edit1.PasswordChar := #0;
end;
end;

Resources