MultiInput.pas

{******************************************************************************}
{                                                                              }
{ Rejbrand Input Dialog Box                                                    }
{                                                                              }
{ Copyright © 2015-2016, 2024 Andreas Rejbrand                                 }
{                                                                              }
{ https://english.rejbrand.se/                                                 }
{                                                                              }
{******************************************************************************}

unit MultiInput;

interface

uses
  Windows, SysUtils, Messages, Types, Controls, Graphics, Forms, StdCtrls, ExtCtrls,
  CommCtrl, NumberBox;

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;
  TCharTransformProc = reference to procedure(var C: Char);

  TMID = class(TForm)
  protected
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure Paint; override;
    procedure VerifyText(Sender: TObject);
    procedure EditKeyPress(Sender: TObject; var Key: Char);
  private
    Edit: TEdit;
    NumEdit: TNumberBox;
    OkButton, CancelButton: TButton;
    MainText: string;
    InputVerifierFunc: TInputVerifierFunc;
    CharTransformProc: TCharTransformProc;
  protected
  public
  end;

  TMultiInputBox = class
  strict private
    class function SetupDialog(AOwner: TCustomForm; const ATitle, AText: string): TMID;
  public
    class function TextInputBox(AOwner: TCustomForm; const ATitle,
      AText: string; var Value: string; ACharCase: TEditCharCase = ecNormal;
      AAllowEmptyString: Boolean = True; AAllowOnly: TAllowOnlyOptions = [];
      AFixLength: Integer = 0): 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; AMaxLength: Integer = 0;
      ACharTransformProc: TCharTransformProc = 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, Character;

var
  GInvFS: TFormatSettings;

function GetParentFormSafe(AControl: TControl): TCustomForm;
begin
  if Assigned(AControl) then
    Result := GetParentForm(AControl)
  else
    Result := nil;
end;

function TryNaturalStrToFloat(const S: string; out X: Double): Boolean;
begin
  var T: string;
  SetLength(T, S.Length);
  var ActualLength := 0;
  for var i := 1 to S.Length do
  begin
    if (S[i] = '-') or (S[i] = '−') then
    begin
      Inc(ActualLength);
      T[ActualLength] := '-';
    end
    else if (S[i] = '.') or (S[i] = ',') then
    begin
      Inc(ActualLength);
      T[ActualLength] := '.';
    end
    else if S[i].IsWhiteSpace then
      Continue
    else
    begin
      Inc(ActualLength);
      T[ActualLength] := S[i];
    end;
  end;
  SetLength(T, ActualLength);
  Result := TryStrToFloat(T, X, GInvFS);
end;

{ TMultiInputBox }

class function TMultiInputBox.CharInputBox(AOwner: TCustomForm; const ATitle,
  AText: string; var Value: Char; ACharCase: TEditCharCase;
  AAllowOnly: TAllowOnlyOptions): Boolean;
begin
  var S: string := Value;
  Result := TextInputBox(
    AOwner,
    ATitle,
    AText,
    S,
    ACharCase,
    False,
    AAllowOnly,
    1
  );
  if Result then
    Value := S[1];
end;

class function TMultiInputBox.FloatInputBox(AOwner: TCustomForm; const ATitle,
  AText: string; var Value: Real; AMin, AMax: Real): Boolean;
begin

  var FDlg := SetupDialog(AOwner, ATitle, AText);
  try
    FDlg.InputVerifierFunc :=
      function(const S: string): Boolean
      begin
        var X: Double;
        Result := TryNaturalStrToFloat(S, X) and (X >= AMin) and (X <= AMax);
      end;
    FDlg.Edit := TEdit.Create(FDlg);
    FDlg.Edit.Parent := FDlg;
    FDlg.Edit.Top := FDlg.ScaleValue(11 + 25 + 25 + 11);
    FDlg.Edit.Left := FDlg.ScaleValue(16);
    FDlg.Edit.Width := FDlg.ClientWidth - FDlg.ScaleValue(16 + 16);
    FDlg.Edit.Text := FloatToStr(Value);
    FDlg.Edit.OnChange := FDlg.VerifyText;
    FDlg.VerifyText(FDlg.Edit);
    FDlg.ActiveControl := FDlg.Edit;
    Result := FDlg.ShowModal = mrOk;
    if Result then
    begin
      var X: Double := 0.0;
      if not TryNaturalStrToFloat(FDlg.Edit.Text, X) then
        raise EConvertError.CreateFmt('Couldn''t parse %s.', [FDlg.Edit.Text]);
      Value := X;
    end;
  finally
    FDlg.Free;
  end;

end;

class function TMultiInputBox.NumInputBox(AOwner: TCustomForm; const ATitle,
  AText: string; var Value: Integer; AMin, AMax: Integer): Boolean;
begin

  var FDlg := SetupDialog(AOwner, ATitle, AText);
  try
    FDlg.NumEdit := TNumberBox.Create(FDlg);
    FDlg.NumEdit.Parent := FDlg;
    FDlg.NumEdit.Top := FDlg.ScaleValue(11 + 25 + 25 + 11);
    FDlg.NumEdit.Left := FDlg.ScaleValue(16);
    //FDlg.NumEdit.Width := FDlg.ClientWidth - FDlg.ScaleValue(16 + 16);
    FDlg.NumEdit.Mode := nbmInteger;
    FDlg.NumEdit.MinValue := AMin;
    FDlg.NumEdit.MaxValue := AMax;
    FDlg.NumEdit.ValueInt := Value;
    FDlg.NumEdit.UseUpDownKeys := True;
    FDlg.NumEdit.UseMouseWheel := True;
    FDlg.NumEdit.SpinButtonOptions.Placement := nbspCompact;
    FDlg.ActiveControl := FDlg.NumEdit;
    Result := FDlg.ShowModal = mrOk;
    if Result then
      Value := FDlg.NumEdit.ValueInt;
  finally
    FDlg.Free;
  end;

end;

class function TMultiInputBox.SetupDialog(AOwner: TCustomForm; const ATitle, AText: string): TMID;
begin

  Result := TMID.CreateNew(GetParentFormSafe(AOwner));
  try
    Result.Position := poOwnerFormCenter;
    Result.ScaleForCurrentDPI;
    Result.Font.Size := 9;
    Result.Width := Result.ScaleValue(500);
    Result.ClientHeight := Result.ScaleValue(11 + 25 + 25 + 11 + 25 + 32 + 11 + 25 + 11);
    Result.BorderStyle := bsDialog;
    Result.Caption := ATitle;
    Result.MainText := AText;
    Result.OkButton := TButton.Create(Result);
    Result.OkButton.Parent := Result;
    Result.OkButton.Caption := 'OK';
    Result.OkButton.Default := True;
    Result.OkButton.ModalResult := mrOk;
    Result.OkButton.Anchors := [TAnchorKind.akRight, TAnchorKind.akBottom];
    Result.OkButton.Height := Result.ScaleValue(25);
    Result.OkButton.Top := Result.ClientHeight - Result.ScaleValue(11) - Result.OkButton.Height;
    Result.OkButton.Left := Result.ClientWidth - Result.ScaleValue(6) - Result.ScaleValue(16) - 2 * Result.OkButton.Width;
    Result.CancelButton := TButton.Create(Result);
    Result.CancelButton.Parent := Result;
    Result.CancelButton.Caption := 'Cancel';
    Result.CancelButton.Cancel := True;
    Result.CancelButton.ModalResult := mrCancel;
    Result.CancelButton.Anchors := [TAnchorKind.akRight, TAnchorKind.akBottom];
    Result.CancelButton.Height := Result.ScaleValue(25);
    Result.CancelButton.Top := Result.ClientHeight - Result.ScaleValue(11) - Result.CancelButton.Height;
    Result.CancelButton.Left := Result.ClientWidth - Result.ScaleValue(16) - Result.CancelButton.Width;
  except
    Result.Free;
    raise;
  end;

end;

class function TMultiInputBox.TextInputBox(AOwner: TCustomForm; const ATitle,
  AText: string; var Value: string; ACharCase: TEditCharCase;
  AAllowEmptyString: Boolean; AAllowOnly: TAllowOnlyOptions; AFixLength: Integer): Boolean;
begin

  var LTestFcn: TInputVerifierFunc;

  if AAllowEmptyString and (AAllowOnly = []) and (AFixLength = 0) then
    LTestFcn := nil
  else
    LTestFcn :=
      function(const S: string): Boolean
      begin

        Result :=
          (not S.IsEmpty or AAllowEmptyString)
            and
          ((AFixLength = 0) or (AFixLength = S.Length));

        if not Result then Exit;

        if AAllowOnly = [] then Exit;

        if aoLetters in AAllowOnly then
          Include(AAllowOnly, aoAZ);

        if aoAZ in AAllowOnly then
        begin
          Include(AAllowOnly, aoCapitalAZ);
          Include(AAllowOnly, aoSmallAZ);
        end;

        Result := True;
        for var i := 1 to S.Length do
          case S[i] of
            'a'..'z':
              if not (aoSmallAZ in AAllowOnly) then
                Exit(False);
            'A'..'Z':
              if not (aoCapitalAZ in AAllowOnly) then
                Exit(False);
            '0'..'9':
              if not (aoDigits in AAllowOnly) then
                Exit(False);
            ' ':
              if not (aoSpace in AAllowOnly) then
                Exit(False);
            '.':
              if not (aoPeriod in AAllowOnly) then
                Exit(False);
            ',':
              if not (aoComma in AAllowOnly) then
                Exit(False);
            ';':
              if not (aoSemicolon in AAllowOnly) then
                Exit(False);
            '-':
              if not (aoHyphenMinus in AAllowOnly) then
                Exit(False);
            '+':
              if not (aoPlus in AAllowOnly) then
                Exit(False);
            '_':
              if not (aoUnderscore in AAllowOnly) then
                Exit(False);
            '*':
              if not (aoAsterisk in AAllowOnly) then
                Exit(False);
          else
            if not (S[i].IsLetter and (aoLetters in AAllowOnly)) then
              Exit(False);
          end;

      end;

  Result :=
    TextInputBoxEx(
      AOwner,
      ATitle,
      AText,
      Value,
      ACharCase,
      LTestFcn,
      AFixLength
    );

end;

class function TMultiInputBox.TextInputBoxEx(AOwner: TCustomForm; const ATitle,
  AText: string; var Value: string; ACharCase: TEditCharCase;
  AInputVerifierFunc: TInputVerifierFunc; AMaxLength: Integer;
  ACharTransformProc: TCharTransformProc): Boolean;
begin

  var FDlg := SetupDialog(AOwner, ATitle, AText);
  try
    FDlg.InputVerifierFunc := AInputVerifierFunc;
    FDlg.CharTransformProc := ACharTransformProc;
    FDlg.Edit := TEdit.Create(FDlg);
    FDlg.Edit.Parent := FDlg;
    FDlg.Edit.Top := FDlg.ScaleValue(11 + 25 + 25 + 11);
    FDlg.Edit.Left := FDlg.ScaleValue(16);
    FDlg.Edit.Width := FDlg.ClientWidth - FDlg.ScaleValue(16 + 16);
    FDlg.Edit.CharCase := ACharCase;
    if AMaxLength > 0 then
      FDlg.Edit.MaxLength := AMaxLength;
    FDlg.Edit.Text := Value;
    if Assigned(AInputVerifierFunc) then
    begin
      FDlg.Edit.OnChange := FDlg.VerifyText;
      FDlg.VerifyText(FDlg.Edit);
    end;
    if Assigned(ACharTransformProc) then
      FDlg.Edit.OnKeyPress := FDlg.EditKeyPress;
    FDlg.ActiveControl := FDlg.Edit;
    Result := FDlg.ShowModal = mrOk;
    if Result then
      Value := FDlg.Edit.Text;
  finally
    FDlg.Free;
  end;

end;

{ TMID }

procedure TMID.EditKeyPress(Sender: TObject; var Key: Char);
begin
  if Assigned(CharTransformProc) then
    CharTransformProc(Key);
end;

procedure TMID.Paint;
begin
  inherited;
  Canvas.Brush.Color := clWhite;
  const LineY = ClientHeight - ScaleValue(25 + 11 + 11);
  Canvas.FillRect(Rect(
    0,
    0,
    ClientWidth,
    LineY
  ));
  Canvas.Brush.Color := clBtnFace;
  Canvas.FillRect(Rect(
    0,
    LineY,
    ClientWidth,
    ClientHeight
  ));
  Canvas.Pen.Color := $DFDFDF;
  Canvas.Pen.Width := ScaleValue(1);
  Canvas.MoveTo(0, LineY);
  Canvas.LineTo(ClientWidth, LineY);
  Canvas.Brush.Color := clWhite;
  Canvas.Font.Assign(Self.Font);
  Canvas.Font.PixelsPerInch := 96;
  Canvas.Font.Size := ScaleValue(12);
  Canvas.Font.Color := $00993300;
  var R := Rect(
    ScaleValue(16),
    ScaleValue(11),
    ClientWidth - ScaleValue(16),
    LineY - ScaleValue(11 + 25 + 11)
  );
  var S := MainText;
  Canvas.TextRect(R, S, [tfEndEllipsis, tfWordBreak]);
end;

procedure TMID.VerifyText(Sender: TObject);
begin

  OkButton.Enabled :=
    (Edit = nil)
      or
    not Assigned(InputVerifierFunc)
      or
    InputVerifierFunc(Edit.Text);

end;

procedure TMID.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

initialization
  GInvFS := TFormatSettings.Invariant;

end.