Related
I'm trying implement IP edit. This my code:
unit Main;
interface
uses
System.SysUtils, System.Classes,
Winapi.Windows, Winapi.Messages, Winapi.CommCtrl,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.StdCtrls, Vcl.ComCtrls;
type
TIpEdit = class(TWinControl)
strict protected
procedure CreateParams(var Params: TCreateParams); override;
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
procedure WMSetFont(var Message: TWMSetFont); message WM_SETFONT;
end;
TMainForm = class(TForm)
Btn1: TButton;
procedure FormCreate(Sender: TObject);
procedure Btn1Click(Sender: TObject);
private
FIpEdit: TIpEdit;
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.dfm}
{ TIPEdit }
procedure TIPEdit.CreateParams(var Params: TCreateParams);
begin
InitCommonControl(ICC_INTERNET_CLASSES);
inherited CreateParams(Params);
CreateSubClass(Params, WC_IPADDRESS);
Params.Style := Params.Style or WS_TABSTOP or WS_CHILD;
end;
procedure TIPEdit.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
inherited;
Message.Result := Message.Result or DLGC_WANTARROWS;
end;
procedure TIPEdit.WMSetFont(var Message: TWMSetFont);
var
LF: LOGFONT;
begin
if GetObject(Message.Font, SizeOf(LF), #LF) <> 0 then
begin
Message.Font := CreateFontIndirect(LF);
inherited;
end;
end;
{ TMainForm }
procedure TMainForm.Btn1Click(Sender: TObject);
begin
FIpEdit.Width := FIpEdit.Width + 100;
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
FIpEdit := TIpEdit.Create(Self);
FIpEdit.Parent := Self;
FIpEdit.SetBounds(10, 10, 120, 21);
end;
end.
Before Btn1.Click
After Btn1.Click
As a result: Control change own width but not change width internal edits.
I try fix by two ways
Use RecreateWnd. This works, but IMHO its ugly solution.
Fix internal edits width manualy. This works, but it is difficult to
implement, due to the internal work of the control
Maybe I missed something and there is a simpler solution?
Edit:
I tested the RecreateWnd, but it can not be used when using DevExpress layout control. It seems that layout control uses the direct call of the API bypassing the SetBounds method. In this case RecreateWnd can not be using.
The final conclusion is:
RecreateWnd is simple solution with some ristrictions
RepeatUntil answer more difficult, but always working
The control does not provide a mechanism to update its layout after it has been created. Yes you could hack at the internal edit controls, but that is dangerous. You'd be relying on undocumented implementation detail that is subject to change.
In summary, I would say that recreating the window is the best solution available.
You can use TPanel with child TEdit controls to create your own IP Edit, That will give you more control of their property.
This how its look at run time:
I wrote this time ago, its not completed work but may give an idea of what i mean.
unit IPEdit;
interface
uses
System.SysUtils, System.Classes, Vcl.Controls, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.Forms,
Vcl.Graphics, System.UITypes;
type
TExitType = (etNone, etNext);
type
TIPEdit = class(TCustomPanel)
private
FPart1 : TEdit;
FPart2 : TEdit;
FPart3 : TEdit;
FPart4 : TEdit;
FSplitter1 : TPanel;
FSplitter2 : TPanel;
FSplitter3 : TPanel;
FRiseErr : Boolean;
FErrMsg : string;
FExitType : TExitType;
FBevelInner : TPanelBevel;
FLeadingzero: Boolean;
procedure SetExitType(Value : TExitType);
procedure SetBevelInner(Value: TPanelBevel);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
protected
procedure EditOnKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure EditOnChange(Sender: TObject);
procedure OnPanelResize(Sender: TObject);
procedure EditOnExit(Sender: TObject);
published
property ShowError: Boolean read FRiseErr write FRiseErr default False;
property Leadingzero: Boolean read FLeadingzero write FLeadingzero default False;
property ErrorText: string read FErrMsg write FErrMsg;
property ExitType: TExitType read FExitType write SetExitType default etNext;
property BevelInner: TPanelBevel read FBevelInner write SetBevelInner default bvNone;
end;
implementation
const
Msg_Err_Value_Exceeded = 'Value cannot be greater than 255';
SplitterWidth = 5;
{ TIPEdit }
constructor TIPEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
if AOwner is TWinControl then
Parent := TWinControl(AOwner);
{ Main Panle Style }
ParentBackground := False;
BevelKind := bkFlat;
BevelOuter := bvNone;
Color := clWindow;
Height := 25;
Width := 165;
Caption := '';
/////////////////////////////
{ Set Handlers}
OnResize := OnPanelResize;
{ Create child controls }
FPart1 := TEdit.Create(Self);
FPart1.Name := 'IPEditPart1';
FPart1.Visible := False;
FSplitter1 := TPanel.Create(Self);
FSplitter1.Name := 'IPSplitter1';
FSplitter1.Visible:= False;
FPart2 := TEdit.Create(Self);
FPart2.Name := 'IPEditPart2';
FPart2.Visible := False;
FSplitter2 := TPanel.Create(Self);
FSplitter2.Name := 'IPSplitter2';
FSplitter2.Visible:= False;
FPart3 := TEdit.Create(Self);
FPart3.Name := 'IPEditPart3';
FPart3.Visible := False;
FSplitter3 := TPanel.Create(Self);
FSplitter3.Name := 'IPSplitter3';
FSplitter3.Visible:= False;
FPart4 := TEdit.Create(Self);
FPart4.Name := 'IPEditPart4';
FPart4.Visible := False;
FPart1.Align := alLeft;
FSplitter1.Align := alLeft;
FPart2.Align := alLeft;
FSplitter2.Align := alLeft;
FPart3.Align := alLeft;
FSplitter3.Align := alLeft;
FPart4.Align := alLeft;
/////////////////////////////
{ Set Child Style }
// This order is very important //
FPart1.Parent := TWinControl(Self);
FSplitter1.Parent := TWinControl(Self);
FPart2.Parent := TWinControl(Self);
FSplitter2.Parent := TWinControl(Self);
FPart3.Parent := TWinControl(Self);
FSplitter3.Parent := TWinControl(Self);
FPart4.Parent := TWinControl(Self);
FPart1.Visible := True;
FSplitter1.Visible := True;
FPart2.Visible := True;
FSplitter2.Visible := True;
FPart3.Visible := True;
FSplitter3.Visible := True;
FPart4.Visible := True;
//////////////////////////////////
FPart1.Alignment := taCenter;
FPart2.Alignment := taCenter;
FPart3.Alignment := taCenter;
FPart4.Alignment := taCenter;
FPart1.Margins.Left := 0;
FPart2.Margins.Left := 0;
FPart3.Margins.Left := 0;
FPart4.Margins.Left := 0;
FSplitter1.Margins.Left := 0;
FSplitter2.Margins.Left := 0;
FSplitter3.Margins.Left := 0;
FPart1.Margins.Right := 0;
FPart2.Margins.Right := 0;
FPart3.Margins.Right := 0;
FPart4.Margins.Right := 0;
FSplitter1.Margins.Right := 0;
FSplitter2.Margins.Right := 0;
FSplitter3.Margins.Right := 0;
FPart1.AlignWithMargins := True;
FSplitter1.AlignWithMargins := True;
FPart2.AlignWithMargins := True;
FSplitter2.AlignWithMargins := True;
FPart3.AlignWithMargins := True;
FSplitter3.AlignWithMargins := True;
FPart4.AlignWithMargins := True;
FPart1.AutoSize := False;
FPart2.AutoSize := False;
FPart3.AutoSize := False;
FPart4.AutoSize := False;
FPart1.BorderStyle := bsNone;
FPart2.BorderStyle := bsNone;
FPart3.BorderStyle := bsNone;
FPart4.BorderStyle := bsNone;
FPart1.NumbersOnly := True;
FPart2.NumbersOnly := True;
FPart3.NumbersOnly := True;
FPart4.NumbersOnly := True;
FPart1.MaxLength := 3;
FPart2.MaxLength := 3;
FPart3.MaxLength := 3;
FPart4.MaxLength := 3;
FPart1.Width := 36;
FPart2.Width := 36;
FPart3.Width := 36;
FPart4.Width := 36;
FSplitter1.Alignment := taCenter;
FSplitter2.Alignment := taCenter;
FSplitter3.Alignment := taCenter;
FSplitter1.Caption := '.';
FSplitter2.Caption := '.';
FSplitter3.Caption := '.';
FSplitter1.BevelOuter := bvNone;
FSplitter2.BevelOuter := bvNone;
FSplitter3.BevelOuter := bvNone;
FSplitter1.Color := clWindow;
FSplitter2.Color := clWindow;
FSplitter3.Color := clWindow;
FSplitter1.ParentBackground := False;
FSplitter2.ParentBackground := False;
FSplitter3.ParentBackground := False;
FSplitter1.TabStop := False;
FSplitter2.TabStop := False;
FSplitter3.TabStop := False;
FSplitter1.Width := SplitterWidth;
FSplitter2.Width := SplitterWidth;
FSplitter3.Width := SplitterWidth;
FSplitter1.Font.Style := FSplitter1.Font.Style + [fsBold];
FSplitter2.Font.Style := FSplitter2.Font.Style + [fsBold];
FSplitter3.Font.Style := FSplitter3.Font.Style + [fsBold];
//////////////////////////////
{Set Child handlers}
FPart1.OnChange := EditOnChange;
FPart2.OnChange := EditOnChange;
FPart3.OnChange := EditOnChange;
FPart4.OnChange := EditOnChange;
FPart1.OnKeyDown := EditOnKeyDown;
FPart2.OnKeyDown := EditOnKeyDown;
FPart3.OnKeyDown := EditOnKeyDown;
FPart4.OnKeyDown := EditOnKeyDown;
FPart1.OnExit := EditOnExit;
FPart2.OnExit := EditOnExit;
FPart3.OnExit := EditOnExit;
FPart4.OnExit := EditOnExit;
{Set Child control tab order for the handlers work}
FPart1.TabOrder := 0;
FPart2.TabOrder := 1;
FPart3.TabOrder := 2;
FPart4.TabOrder := 3;
FPart1.Text := '1';
FPart2.Text := '2';
FPart3.Text := '3';
FPart4.Text := '4';
FExitType := etNext;
FErrMsg := Msg_Err_Value_Exceeded;
end;
destructor TIPEdit.Destroy;
begin
FPart1.Free;
FPart2.Free;
FPart3.Free;
FPart4.Free;
FSplitter1.Free;
FSplitter2.Free;
FSplitter3.Free;
inherited;
end;
procedure TIPEdit.EditOnChange(Sender: TObject);
var
iValue : Integer;
bValGrater : Boolean;
I: Integer;
begin
if NOT (Sender is TEdit) then Exit;
bValGrater := False;
if TryStrToInt(TEdit(Sender).Text, iValue) then begin
if (iValue > 255) then begin
iValue := 255;
bValGrater := True;
TEdit(Sender).Text := iValue.ToString;
if (FRiseErr and bValGrater) then
raise Exception.Create(FErrMsg);
end;
end;
if Length(TEdit(Sender).Text) = 3 then begin
case FExitType of
etNone: ;
etNext: FindNextControl(TEdit(Sender), True, False, False).SetFocus;
end;
end;
end;
procedure TIPEdit.EditOnKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
const
vkReturn = $0D;
begin
if not (Sender is TEdit) then Exit;
if Key = vkReturn then
FindNextControl(TEdit(Sender), True, False, False).SetFocus;
end;
procedure TIPEdit.OnPanelResize(Sender: TObject);
const
EditCount = 4;
SplitterCount = 3;
var
EditWidth : Integer;
FSplitterWidth : Integer;
EditMargin : Integer;
begin
EditWidth := Trunc(((Width) / EditCount) - (SplitterCount * (SplitterWidth)));
FPart1.Width := EditWidth;
FPart2.Width := EditWidth;
FPart3.Width := EditWidth;
FPart4.Width := EditWidth;
FSplitterWidth := Trunc(( (Width) - ( EditWidth * EditCount) ) / SplitterCount);
FSplitter1.Width := FSplitterWidth;
FSplitter2.Width := FSplitterWidth;
FSplitter3.Width := FSplitterWidth;
{Center edits text vertically == this is a temporary workaround}
FPart1.Margins.Top := 0;
FPart2.Margins.Top := 0;
FPart3.Margins.Top := 0;
FPart4.Margins.Top := 0;
EditMargin := Round( ((Height / 5)));
FPart1.Margins.Top := EditMargin;
FPart2.Margins.Top := EditMargin;
FPart3.Margins.Top := EditMargin;
FPart4.Margins.Top := EditMargin;
FSplitter1.Margins.Top := EditMargin + SplitterWidth; { the +lblWidth to make it lower than the edits}
FSplitter2.Margins.Top := EditMargin + SplitterWidth;
FSplitter3.Margins.Top := EditMargin + SplitterWidth;
end;
procedure TIPEdit.SetBevelInner(Value: TPanelBevel);
begin
TPanel(Self).BevelInner := Value;
end;
procedure TIPEdit.SetExitType(Value: TExitType);
begin
FExitType := Value;
end;
procedure TIPEdit.EditOnExit(Sender: TObject);
var
I: Integer;
begin
if not (Sender IS TEdit) then Exit;
if FLeadingzero then begin
if Length(TEdit(Sender).Text) >= 1 then
for I := Length(TEdit(Sender).Text) to 2 do begin
TEdit(Sender).Text := '0' + TEdit(Sender).Text;
end;
end;
end;
end.
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;
I'm having trouble creating a new procedure for a dynamic button. When the button is clicked, it supposed to send items to a RichEdit.
I have declared all my objects and my procedures.
Here's my code:
type
TfrmSale = class(TForm)
redOutput: TRichEdit;
btnBuy: TButton;
procedure btnBuyClick(Sender: TObject);
private
pnlSale : TPanel;
edtQuantity : TEdit;
rgpOptions : TRadioGroup;
btnSelect : TButton;
procedure btnSelectCick(Sender: TObject);
public
{ Public declarations }
end;
var
frmSale: TfrmSale;
implementation
{$R *.dfm}
procedure TfrmSale.btnBuyClick(Sender: TObject);
begin
pnlSale := TPanel.Create(frmSale);
pnlSale.Parent := frmSale;
pnlSale.Left := 10;
pnlSale.Top := 10;
pnlSale.Width := 350;
pnlSale.Height := 250;
pnlSale.Visible := True;
edtQuantity := TEdit.Create(pnlSale);
edtQuantity.Parent := pnlSale;
edtQuantity.Left := 50;
edtQuantity.Top := 60;
edtQuantity.Width := 80;
edtQuantity.Height := 20;
edtQuantity.Text := 'Quantity';
edtQuantity.Visible := True;
rgpOptions := TRadioGroup.Create(pnlSale);
rgpOptions.Parent := pnlSale;
rgpOptions.Left := 30;
rgpOptions.Top := 100;
rgpOptions.Width := 300;
rgpOptions.Height := 140;
rgpOptions.Visible := True;
rgpOptions.Caption := 'Options';
rgpOptions.Items.Add('Screws 12mm');
rgpOptions.Items.Add('Canned Peaches 250g');
rgpOptions.Items.Add('Tomatoes');
rgpOptions.Items.Add('Spaghetti 500g');
rgpOptions.Items.Add('Twin Flex 5m');
rgpOptions.Items.Add('Clear Glue 250ml');
btnSelect := TButton.Create(frmSale);
btnSelect.Parent := frmSale;
btnSelect.Left := 130;
btnSelect.Top := 260;
btnSelect.Width := 80;
btnSelect.Height := 40;
btnSelect.Caption := 'Select';
end;
procedure TfrmSale.btnSelectClick(Sender: TObject);
case rgpOptions.ItemIndex of
1 := redOutput.Lines.Add('Screws 12mm');
2 := redOutput.Lines.Add('Canned Peaches 250g');
3 := redOutput.Lines.Add('Refil Blue Pen');
4 := redOutput.Lines.Add('Tomatoes');
5 := redOutput.Lines.Add('Spaghetti 500g');
6 := redOutput.Lines.Add('Twin Flex 5m');
7 := redOutput.Lines.Add('Clear Glue 250ml');
end
Please can someone help me make a OnClick procedure.
AS TLama said. If you're going to create your buttons in code,you need to also assign the OnClick handler in code.
type
TfrmSale = class(TForm)
redOutput: TRichEdit;
btnBuy: TButton;
procedure btnBuyClick(Sender: TObject); <<--- link made in designer
private VVVVV-- from here on it's
pnlSale : TPanel; your responsibility
edtQuantity : TEdit;
rgpOptions : TRadioGroup;
btnSelect : TButton;
procedure btnSelectCick(Sender: TObject); <<-- link must be made in code
public
{ Public declarations }
end;
var
frmSale: TfrmSale;
implementation
{$R *.dfm}
procedure TfrmSale.btnBuyClick(Sender: TOBject);
begin
pnlSale := TPanel.Create(frmSale);
pnlSale.Parent := frmSale;
pnlSale.Left := 10;
pnlSale.Top := 10;
pnlSale.Width := 350;
pnlSale.Height := 250;
pnlSale.Visible := True;
edtQuantity := TEdit.Create(pnlSale);
edtQuantity.Parent := pnlSale;
edtQuantity.Left := 50;
edtQuantity.Top := 60;
edtQuantity.Width := 80;
edtQuantity.Height := 20;
edtQuantity.Text := 'Quantity';
edtQuantity.Visible := True;
rgpOptions := TRadioGroup.Create(pnlSale);
rgpOptions.Parent := pnlSale;
rgpOptions.Left := 30;
rgpOptions.Top := 100;
rgpOptions.Width := 300;
rgpOptions.Height := 140;
rgpOptions.Visible := True;
rgpOptions.Caption := 'Options';
rgpOptions.Items.Add('Screws 12mm');
rgpOptions.Items.Add('Canned Peaches 250g');
rgpOptions.Items.Add('Tomatoes');
rgpOptions.Items.Add('Spaghetti 500g');
rgpOptions.Items.Add('Twin Flex 5m');
rgpOptions.Items.Add('Clear Glue 250ml');
btnSelect := TButton.Create(frmSale);
btnSelect.OnClick:= btnSelectCick; <<-- Assign the button handler
btnSelect.Parent := frmSale;
btnSelect.Left := 130;
btnSelect.Top := 260;
btnSelect.Width := 80;
btnSelect.Height := 40;
btnSelect.Caption := 'Select';
end;
procedure TfrmSale.btnSelectClick(Sender: TOBject);
begin
redOutput.Lines.Add(rgpOptions.Lines[rgpOptions.ItemIndex]); <<-- DRY
end;
Note that I've tweaked btnSelectClick so that it reuses the data you've stored into rgpOptions previously.
See also: http://en.wikipedia.org/wiki/Don%27t_repeat_yourself
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;
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.