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

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;

Related

Caption Buttons not respond to mouse clicks after Non - Client painting with DWM in Delphi

I am painting my Application's non-client area with the help of Desktop Window Manager, adding a new button for testing purposes.
After compiling, my custom button is clickable, but the default caption buttons (Minimize, Maximize and Close) do nothing when I hover over them or click on them.
The repainted Title Bar responds to dragging and double-clicks. The Form
maximizes when I double-click the Title Bar as default. And the Close button responds to the very corner of it near Form's Right Border.
I have written my painting procedure as described in this post.
The new codes I added:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ImgList, Buttons;
type
TForm1 = class(TForm)
ImageList1: TImageList;
SpeedButton1: TSpeedButton;
function GetSysIconRect: TRect;
procedure PaintWindow(DC: HDC);
procedure InvalidateTitleBar;
procedure FormCreate(Sender: TObject);
procedure WndProc(var Message: TMessage);
procedure FormPaint(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
protected
procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
procedure CMTextChanged(var Message: TMessage);
procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
procedure WMNCRButtonUp(var Message: TWMNCRButtonUp); message WM_NCRBUTTONUP;
private
{ Private declarations }
FWndFrameSize: Integer;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
DWMAPI, CommCtrl, Themes, UXTheme, StdCtrls;
{$R *.dfm}
{$IF not Declared(UnicodeString)}
type
UnicodeString = WideString;
{$IFEND}
procedure DrawGlassCaption(Form: TForm; const Text: UnicodeString;
Color: TColor; var R: TRect; HorzAlignment: TAlignment = taLeftJustify;
VertAlignment: TTextLayout = tlCenter; ShowAccel: Boolean = False); overload;
const
BasicFormat = DT_SINGLELINE or DT_END_ELLIPSIS;
HorzFormat: array[TAlignment] of UINT = (DT_LEFT, DT_RIGHT, DT_CENTER);
VertFormat: array[TTextLayout] of UINT = (DT_TOP, DT_VCENTER, DT_BOTTOM);
AccelFormat: array[Boolean] of UINT = (DT_NOPREFIX, 0);
var
DTTOpts: TDTTOpts;
Element: TThemedWindow;
IsVistaAndMaximized: Boolean;
NCM: TNonClientMetrics;
ThemeData: HTHEME;
procedure DoTextOut;
begin
with ThemeServices.GetElementDetails(Element) do
DrawThemeTextEx(ThemeData, Form.Canvas.Handle, Part, State, PWideChar(Text),
Length(Text), BasicFormat or AccelFormat[ShowAccel] or
HorzFormat[HorzAlignment] or VertFormat[VertAlignment], #R, DTTOpts);
end;
begin
if Color = clNone then Exit;
IsVistaAndMaximized := (Form.WindowState = wsMaximized) and
(Win32MajorVersion = 6) and (Win32MinorVersion = 0);
ThemeData := OpenThemeData(0, 'CompositedWindow::Window');
Assert(ThemeData <> 0, SysErrorMessage(GetLastError));
Try
NCM.cbSize := SizeOf(NCM);
if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, #NCM, 0) then
if Form.BorderStyle in [bsToolWindow, bsSizeToolWin] then
Form.Canvas.Font.Handle := CreateFontIndirect(NCM.lfSmCaptionFont)
else
Form.Canvas.Font.Handle := CreateFontIndirect(NCM.lfCaptionFont);
ZeroMemory(#DTTOpts, SizeOf(DTTOpts));
DTTOpts.dwSize := SizeOf(DTTOpts);
DTTOpts.dwFlags := DTT_COMPOSITED or DTT_TEXTCOLOR;
if Color <> clDefault then
DTTOpts.crText := ColorToRGB(Color)
else if IsVistaAndMaximized then
DTTOpts.dwFlags := DTTOpts.dwFlags and not DTT_TEXTCOLOR
else if Form.Active then
DTTOpts.crText := GetSysColor(COLOR_CAPTIONTEXT)
else
DTTOpts.crText := GetSysColor(COLOR_INACTIVECAPTIONTEXT);
if not IsVistaAndMaximized then
begin
DTTOpts.dwFlags := DTTOpts.dwFlags or DTT_GLOWSIZE;
DTTOpts.iGlowSize := 15;
end;
if Form.WindowState = wsMaximized then
if Form.Active then
Element := twMaxCaptionActive
else
Element := twMaxCaptionInactive
else if Form.BorderStyle in [bsToolWindow, bsSizeToolWin] then
if Form.Active then
Element := twSmallCaptionActive
else
Element := twSmallCaptionInactive
else
if Form.Active then
Element := twCaptionActive
else
Element := twCaptionInactive;
DoTextOut;
if IsVistaAndMaximized then DoTextOut;
Finally
CloseThemeData(ThemeData);
end;
end;
function GetDwmBorderIconsRect(Form: TForm): TRect;
begin
if DwmGetWindowAttribute(Form.Handle, DWMWA_CAPTION_BUTTON_BOUNDS, #Result, SizeOf(Result)) <> S_OK then SetRectEmpty(Result);
end;
procedure DrawGlassCaption(Form: TForm; var R: TRect;
HorzAlignment: TAlignment = taLeftJustify; VertAlignment: TTextLayout = tlCenter;
ShowAccel: Boolean = False); overload;
begin
DrawGlassCaption(Form, Form.Caption, clDefault, R,
HorzAlignment, VertAlignment, ShowAccel);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
R: TRect;
begin
if DwmCompositionEnabled then
begin
SetRectEmpty(R);
AdjustWindowRectEx(R, GetWindowLong(Handle, GWL_STYLE), False,
GetWindowLong(Handle, GWL_EXSTYLE));
FWndFrameSize := R.Right;
GlassFrame.Top := -R.Top;
GlassFrame.Enabled := True;
SetWindowPos(Handle, 0, Left, Top, Width, Height, SWP_FRAMECHANGED);
DoubleBuffered := True;
end;
end;
procedure TForm1.InvalidateTitleBar;
var
R: TRect;
begin
if not HandleAllocated then Exit;
R.Left := 0;
R.Top := 0;
R.Right := Width;
R.Bottom := GlassFrame.Top;
InvalidateRect(Handle, #R, False);
end;
procedure TForm1.CMTextChanged(var Message: TMessage);
begin
inherited;
InvalidateTitleBar;
end;
procedure TForm1.WMActivate(var Message: TWMActivate);
begin
inherited;
InvalidateTitleBar;
end;
procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
var
ClientPos: TPoint;
IconRect: TRect;
begin
inherited;
if not GlassFrame.Enabled then Exit;
case Message.Result of
HTCLIENT:
HTMINBUTTON, HTMAXBUTTON, HTCLOSE:
begin
Message.Result := HTCAPTION;
Exit;
end;
else
Exit;
end;
ClientPos := ScreenToClient(Point(Message.XPos, Message.YPos));
if ClientPos.Y > GlassFrame.Top then Exit;
if ControlAtPos(ClientPos, True) <> nil then Exit;
IconRect := GetSysIconRect;
if (ClientPos.X < IconRect.Right) and ((WindowState = wsMaximized) or
((ClientPos.Y >= IconRect.Top) and (ClientPos.Y < IconRect.Bottom))) then
Message.Result := HTSYSMENU
else if ClientPos.Y < FWndFrameSize then
Message.Result := HTTOP
else
Message.Result := HTCAPTION;
end;
procedure ShowSystemMenu(Form: TForm; const Message: TWMNCRButtonUp);
var
Cmd: WPARAM;
Menu: HMENU;
procedure UpdateItem(ID: UINT; Enable: Boolean; MakeDefaultIfEnabled: Boolean = False);
const
Flags: array[Boolean] of UINT = (MF_GRAYED, MF_ENABLED);
begin
EnableMenuItem(Menu, ID, MF_BYCOMMAND or Flags[Enable]);
if MakeDefaultIfEnabled and Enable then
SetMenuDefaultItem(Menu, ID, MF_BYCOMMAND);
end;
begin
Menu := GetSystemMenu(Form.Handle, False);
if Form.BorderStyle in [bsSingle, bsSizeable, bsToolWindow, bsSizeToolWin] then
begin
SetMenuDefaultItem(Menu, UINT(-1), 0);
UpdateItem(SC_RESTORE, Form.WindowState <> wsNormal, True);
UpdateItem(SC_MOVE, Form.WindowState <> wsMaximized);
UpdateItem(SC_SIZE, (Form.WindowState <> wsMaximized) and
(Form.BorderStyle in [bsSizeable, bsSizeToolWin]));
UpdateItem(SC_MINIMIZE, (biMinimize in Form.BorderIcons) and
(Form.BorderStyle in [bsSingle, bsSizeable]));
UpdateItem(SC_MAXIMIZE, (biMaximize in Form.BorderIcons) and
(Form.BorderStyle in [bsSingle, bsSizeable]) and
(Form.WindowState <> wsMaximized), True);
end;
if Message.HitTest = HTSYSMENU then
SetMenuDefaultItem(Menu, SC_CLOSE, MF_BYCOMMAND);
Cmd := WPARAM(TrackPopupMenu(Menu, TPM_RETURNCMD or
GetSystemMetrics(SM_MENUDROPALIGNMENT), Message.XCursor,
Message.YCursor, 0, Form.Handle, nil));
PostMessage(Form.Handle, WM_SYSCOMMAND, Cmd, 0)
end;
procedure TForm1.WMWindowPosChanging(var Message: TWMWindowPosChanging);
const
SWP_STATECHANGED = $8000;
begin
if GlassFrame.Enabled then
if (Message.WindowPos.flags and SWP_STATECHANGED) = SWP_STATECHANGED then
Invalidate
else
InvalidateTitleBar;
inherited;
end;
procedure TForm1.WMNCRButtonUp(var Message: TWMNCRButtonUp);
begin
if not GlassFrame.Enabled or not (biSystemMenu in BorderIcons) then
inherited
else
case Message.HitTest of
HTCAPTION, HTSYSMENU: ShowSystemMenu(Self, Message);
else
inherited;
end;
end;
procedure TForm1.WndProc(var Message: TMessage);
begin
if GlassFrame.Enabled and HandleAllocated and DwmDefWindowProc(Handle,
Message.Msg, Message.WParam, Message.LParam, Message.Result) then
Exit;
inherited;
end;
procedure TForm1.PaintWindow(DC: HDC);
begin
with GetClientRect do
ExcludeClipRect(DC, 0, GlassFrame.Top, Right, Bottom);
inherited;
end;
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
IconHandle: HICON;
R: TRect;
begin
if ImageList1.Count = 0 then
begin
ImageList1.Width := GetSystemMetrics(SM_CXSMICON);
ImageList1.Height := GetSystemMetrics(SM_CYSMICON);
{$IF NOT DECLARED(TColorDepth)}
ImageList1.Handle := ImageList_Create(ImageList1.Width,
ImageList1.Height, ILC_COLOR32 or ILC_MASK, 1, 1);
{$IFEND}
IconHandle := Icon.Handle;
if IconHandle = 0 then IconHandle := Application.Icon.Handle;
ImageList_AddIcon(ImageList1.Handle, IconHandle);
end;
R := GetSysIconRect;
ImageList1.Draw(Canvas, R.Left, R.Top, 0);
R.Left := R.Right + FWndFrameSize - 3;
if WindowState = wsMaximized then
R.Top := FWndFrameSize
else
R.Top := 0;
R.Right := GetDwmBorderIconsRect(Self).Left - FWndFrameSize - 1;
R.Bottom := GlassFrame.Top;
DrawGlassCaption(Self, R);
end;
function TForm1.GetSysIconRect: TRect;
begin
if not (biSystemMenu in BorderIcons) or not (BorderStyle in [bsSingle, bsSizeable]) then
SetRectEmpty(Result)
else
begin
Result.Left := 0;
Result.Right := GetSystemMetrics(SM_CXSMICON);
Result.Bottom := GetSystemMetrics(SM_CYSMICON);
if WindowState = wsMaximized then
Result.Top := GlassFrame.Top - Result.Bottom - 2
else
Result.Top := 6;
Inc(Result.Bottom, Result.Top);
end;
end;
procedure TForm1.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
if not GlassFrame.Enabled then
inherited
else
with Message.CalcSize_Params.rgrc[0] do
begin
Inc(Left, FWndFrameSize);
Dec(Right, FWndFrameSize);
Dec(Bottom, FWndFrameSize);
end;
end;
end.
Please help me find what is causing the Caption Buttons to become unresponsive to mouse clicks.
The standard buttons do not work because your WM_NCHITTEST handler is returning HTCAPTION for them. You are lying to Windows, telling it that the mouse is not over the buttons even if it really is. If the inherited handler returns HTMINBUTTON, HTMAXBUTTON, or HTCLOSE, just Exit without modifying the Message.Result:
procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
var
ClientPos: TPoint;
IconRect: TRect;
begin
inherited;
if not GlassFrame.Enabled then Exit;
case Message.Result of
HTCLIENT:
HTMINBUTTON, HTMAXBUTTON, HTCLOSE:
begin
//Message.Result := HTCAPTION; // <-- here
Exit;
end;
else
Exit;
end;
...
end;

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;

Delphi 7 - Force InputBox to integer only?

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.

How to display a table in ShowMessage?

I am trying to display a table using ShowMessage that looks like this:
short | Description for "short"
verylongtext | Description for "verylongtext"
How do I get two correctly aligned columns like that in a simple message dialog?
I tried to align the columns using spaces, but the font of ShowMessage is variable. Then I tried to align them using tab characters, but I do not know how to calculate the proper tab count for each row.
Is there a reliable way to calculate the tab count?
PS: I would like to avoid writing a custom dialog for this purpose.
You could use a list view in a custom dialog box, as well.
My class supports the standard Windows icons (and sounds): information, warning, error, confirmation, none. Here is the icon-less version:
It is easy to use:
TTableDialog.ShowTable
(
Self,
'Audio Properties',
['Duration', 'Samples per channel', 'Total data size', 'Channels', 'Bits per sample', 'Sample rate', 'Bitrate'],
['1 h 15 min 0 s', '216 000 000', '824 MB', '1', '32', '48 kHz', '1 536 kbit/sec'],
mtInformation
)
It supports DPI scaling (high DPI) and all Windows versions from Windows XP (it might work on Windows 2000 as well, I just haven't tested that) to Windows 10:
The table is a list view, so you get all its benefits, like a scrollbar, truncation ellipses, and tooltips:
You can also specify the dialog's size to make it fit the contents:
TTableDialog.ShowTable
(
Self,
'Audio Properties',
['Duration', 'Samples per channel', 'Total data size', 'Channels', 'Bits per sample', 'Sample rate', 'Bitrate', 'Maximum fractional sample value'],
['1 h 15 min 0 s', '216 000 000', '824 MB', '1', '32', '48 kHz', '1 536 kbit/sec', '0.1'],
mtInformation,
360,
240
)
Of course, the OK button is both Default and Cancel, so you can dismiss the dialog with Enter or Escape.
Finally, pressing Ctrl+C will copy the table to clipboard.
Full source code:
uses
ComCtrls, Math, Clipbrd;
type
TTableDialog = class
strict private
type TFormData = class(TComponent)
public
ListView: TListView;
IconKind: PWideChar;
Icon: HICON;
LIWSD: Boolean;
end;
class function Scale(X: Integer): Integer;
class procedure FormShow(Sender: TObject);
class procedure FormDestroy(Sender: TObject);
class procedure FormPaint(Sender: TObject);
class procedure FormKeyPress(Sender: TObject; var Key: Char);
class procedure LVToClipboard(AListView: TListView);
public
class procedure ShowTable(AOwner: TCustomForm; const ACaption: string;
const ANames, AValues: array of string;
ADialogType: TMsgDlgType = mtInformation;
const AWidth: Integer = 360; const AHeight: Integer = 200);
end;
class procedure TTableDialog.FormShow(Sender: TObject);
var
FormData: TFormData;
ComCtl: HMODULE;
LoadIconWithScaleDown: function(hinst: HINST; pszName: LPCWSTR; cx: Integer;
cy: Integer; var phico: HICON): HResult; stdcall;
begin
if not (Sender is TForm) then
Exit;
if not (TObject(TForm(Sender).Tag) is TFormData) then
Exit;
TForm(Sender).OnShow := nil;
FormData := TFormData(TForm(Sender).Tag);
if FormData.IconKind = nil then
Exit;
ComCtl := LoadLibrary('ComCtl32.dll');
if ComCtl <> 0 then
begin
try
LoadIconWithScaleDown := GetProcAddress(ComCtl, 'LoadIconWithScaleDown');
if Assigned(LoadIconWithScaleDown) then
FormData.LIWSD := Succeeded(LoadIconWithScaleDown(0, FormData.IconKind,
Scale(32), Scale(32), FormData.Icon));
finally
FreeLibrary(ComCtl);
end;
end;
if not FormData.LIWSD then
FormData.Icon := LoadIcon(0, FormData.IconKind);
end;
class procedure TTableDialog.FormDestroy(Sender: TObject);
var
FormData: TFormData;
begin
if not (Sender is TForm) then
Exit;
if not (TObject(TForm(Sender).Tag) is TFormData) then
Exit;
FormData := TFormData(TForm(Sender).Tag);
if (FormData.Icon <> 0) and FormData.LIWSD then
DestroyIcon(FormData.Icon);
end;
class procedure TTableDialog.FormKeyPress(Sender: TObject; var Key: Char);
var
FormData: TFormData;
begin
if not (Sender is TForm) then
Exit;
if not (TObject(TForm(Sender).Tag) is TFormData) then
Exit;
FormData := TFormData(TForm(Sender).Tag);
case Key of
^C:
LVToClipboard(FormData.ListView);
end;
end;
class procedure TTableDialog.FormPaint(Sender: TObject);
var
FormData: TFormData;
Frm: TForm;
Y: Integer;
begin
if not (Sender is TForm) then
Exit;
if not (TObject(TForm(Sender).Tag) is TFormData) then
Exit;
Frm := TForm(Sender);
FormData := TFormData(TForm(Sender).Tag);
Y := Frm.ClientHeight - Scale(25 + 8 + 8);
Frm.Canvas.Brush.Color := clWhite;
Frm.Canvas.FillRect(Rect(0, 0, Frm.ClientWidth, Y));
Frm.Canvas.Pen.Color := $00DFDFDF;
Frm.Canvas.MoveTo(0, Y);
Frm.Canvas.LineTo(Frm.ClientWidth, Y);
if FormData.Icon <> 0 then
DrawIconEx(Frm.Canvas.Handle, Scale(8), Scale(8), FormData.Icon,
Scale(32), Scale(32), 0, 0, DI_NORMAL);
end;
class procedure TTableDialog.LVToClipboard(AListView: TListView);
function GetRow(AIndex: Integer): string;
begin
if InRange(AIndex, 0, AListView.Items.Count - 1) and (AListView.Items[AIndex].SubItems.Count = 1) then
Result := AListView.Items[AIndex].Caption + #9 + AListView.Items[AIndex].SubItems[0]
else
Result := '';
end;
var
S: string;
i: Integer;
begin
if AListView = nil then
Exit;
S := GetRow(0);
for i := 1 to AListView.Items.Count - 1 do
S := S + sLineBreak + GetRow(i);
Clipboard.AsText := S;
end;
class function TTableDialog.Scale(X: Integer): Integer;
begin
Result := MulDiv(X, Screen.PixelsPerInch, 96);
end;
class procedure TTableDialog.ShowTable(AOwner: TCustomForm; const ACaption: string;
const ANames, AValues: array of string;
ADialogType: TMsgDlgType = mtInformation;
const AWidth: Integer = 360; const AHeight: Integer = 200);
const
Sounds: array[TMsgDlgType] of Integer =
(MB_ICONWARNING, MB_ICONERROR, MB_ICONINFORMATION, MB_ICONQUESTION, 0);
Icons: array[TMsgDlgType] of MakeIntResource =
(IDI_WARNING, IDI_ERROR, IDI_INFORMATION, IDI_QUESTION, nil);
var
dlg: TForm;
lv: TListView;
btn: TButton;
i: Integer;
snd: Integer;
begin
if Length(ANames) <> Length(AValues) then
raise Exception.Create('The lengths of the columns don''t match.');
dlg := TForm.Create(AOwner);
try
dlg.BorderStyle := bsDialog;
dlg.Caption := ACaption;
dlg.Width := Scale(AWidth);
dlg.Height := Scale(AHeight);
dlg.Position := poOwnerFormCenter;
dlg.Scaled := False;
dlg.Font.Name := 'Segoe UI';
dlg.Font.Size := 9;
dlg.Tag := NativeInt(TFormData.Create(dlg));
TFormData(dlg.Tag).IconKind := Icons[ADialogType];
dlg.OnShow := FormShow;
dlg.OnDestroy := FormDestroy;
dlg.OnPaint := FormPaint;
dlg.OnKeyPress := FormKeyPress;
dlg.KeyPreview := True;
btn := TButton.Create(dlg);
btn.Parent := dlg;
btn.Caption := 'OK';
btn.Default := True;
btn.Cancel := True;
btn.ModalResult := mrOk;
btn.Width:= Scale(75);
btn.Height := Scale(25);
btn.Left := dlg.ClientWidth - btn.Width - Scale(8);
btn.Top := dlg.ClientHeight - btn.Height - Scale(8);
lv := TListView.Create(dlg);
TFormData(dlg.Tag).ListView := lv;
lv.Parent := dlg;
lv.DoubleBuffered := True;
lv.ReadOnly := True;
lv.BorderStyle := bsNone;
lv.Left := Scale(8) + IfThen(Icons[ADialogType] <> nil, Scale(32 + 8));
lv.Top := Scale(8);
lv.Width := dlg.ClientWidth - Scale(16) - IfThen(Icons[ADialogType] <> nil, Scale(32 + 8));
lv.Height := dlg.ClientHeight - Scale(16 + 8 + 4) - btn.Height;
lv.ViewStyle := vsReport;
lv.RowSelect := True;
lv.ShowColumnHeaders := False;
with lv.Columns.Add do
begin
Caption := 'Name';
Width := Scale(150);
end;
with lv.Columns.Add do
begin
Caption := 'Value';
Width := lv.ClientWidth - lv.Columns[0].Width -
GetSystemMetricsForWindow(SM_CXVSCROLL, dlg.Handle) - scale(2);
end;
for i := 0 to High(ANames) do
with lv.Items.Add do
begin
Caption := ANames[i];
SubItems.Add(AValues[i]);
end;
snd := Sounds[ADialogType];
if snd <> 0 then
MessageBeep(snd);
dlg.ShowModal;
finally
dlg.Free;
end;
end;
If you're not writing a custom dialog for this, when will you? It's not that hard. Just create a form, drop a TMemo on it and make that memo readonly. You can set a monospaced font like Courier New, and your problem is solved. You got the advantage of scrollbars and selection too, and you can choose to make it non-modal.
I would even recommend showing this type of data in a grid (like TStringGrid) instead of a memo or label.
Calculating how to display this text in a messagebox will require much more effort than just creating a custom dialog.
Just created something that shows a popup like this:
Just call the procedure below, and add a TStringList as a parameter.
Of course you could pimp this by using a TListView, icons, scrollbars, etc.
Put it in a separate unit, and you'll always be able to easily show stuff like this.
uses ..., StdCtrls, ExtCtrls;
procedure ShowTablePopup(SL:TStringList);
var
LButtonOK: TButton;
LMemo: TMemo;
LPanel: TPanel;
LForm: TForm;
begin
LForm := TForm.Create(Application);
LMemo := TMemo.Create(LForm);
LPanel := TPanel.Create(LForm);
LButtonOK := TButton.Create(LForm);
LForm.Left := 0;
LForm.Top := 0;
LForm.Caption := 'Values';
LForm.ClientHeight := 250;
LForm.ClientWidth := 400;
LMemo.Parent := LForm;
LMemo.AlignWithMargins := True;
LMemo.Left := 3;
LMemo.Top := 3;
LMemo.Width := 295;
LMemo.Height := 226;
LMemo.Align := alClient;
LMemo.Font.Name := 'Courier New';
LMemo.Lines.Assign(SL);
LPanel.Parent := LForm;
LPanel.Caption := '';
LPanel.Left := 0;
LPanel.Top := 232;
LPanel.Width := 301;
LPanel.Height := 37;
LPanel.Align := alBottom;
LPanel.BevelOuter := bvNone;
LButtonOK.Parent := LPanel;
LButtonOK.AlignWithMargins := True;
LButtonOK.Left := 223;
LButtonOK.Top := 3;
LButtonOK.Width := 75;
LButtonOK.Height := 31;
LButtonOK.Align := alRight;
LButtonOK.Caption := '&OK';
LButtonOK.ModalResult := mrOk;
LButtonOK.Default := True;
LForm.ShowModal;
end;
Example on how to use it:
var
SL:TStringList;
begin
SL := TStringList.Create;
try
SL.Add('short | Description for "short"');
SL.Add('verylongtext | Description for "verylongtext"');
ShowTablePopup(SL);
finally
SL.Free;
end;
end;

Resources