thehomectrls.pas

67个控件,回车代替TAB,非空检查,记录数据库中记录的ID,也可自己定义关键字段,关联LABEL以便提示,

  TComboButton = class(TSpeedButton)
  private
    procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  end;

{ TTHCheckListBox }
  TTHCheckListBox = class(TCheckListBox)
  private
    FArrowExit: TArrowExit;
    FCaption: string;
    FLeadLabel: TLabel;
    FMarkChar: Char;
    FNullable: Boolean;
    FSavedText: string;
    FSeparator: Char;
    FValueWidth: Integer;
    FChanged: Boolean;
    FSelectAll: Boolean;
    FReadOnly: Boolean;
    FOnSetItemProperty: TSetItemPropertyEvent;
    FOnValidate: TCheckInputEvent;
    function GetSeparate: Boolean;
    function GetAllChecked: string;
    procedure SetAllChecked(const Value: string);
    procedure SetReadOnly(Value: Boolean);
  protected
    procedure DoEnter; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CheckedAll(Value: Boolean);
    procedure Reset;
    function Validate: Boolean;
  published
    property ArrowExit: TArrowExit read FArrowExit write FArrowExit;
    property LeadLabel: TLabel read FLeadLabel write FLeadLabel;
    property MarkChar: Char read FMarkChar write FMarkChar default '|';
    property Nullable: Boolean read FNullable write FNullable default False;
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
    property Separator: Char read FSeparator write FSeparator default ',';
    property Text: string read GetAllChecked write SetAllChecked;
    property ValueWidth: Integer read FValueWidth write FValueWidth default 12;
    property OnValidate: TCheckInputEvent read FOnValidate write FOnValidate;
    property OnSetItemProperty: TSetItemPropertyEvent read FOnSetItemProperty write FOnSetItemProperty;
  end;

{ TCustomTHListBox }
  TCustomTHListBox = class(TCustomListBox)
  private
    FArrowExit: TArrowExit;
    FCaption: string;
    FHeader: THeaderControl;
    FLeadLabel: TLabel;
    FMarkChar: Char;
    FNullable: Boolean;
    FOnSetItemProperty: TSetItemPropertyEvent;
    FOnValidate: TCheckInputEvent;
    procedure SetHeader(Value: THeaderControl);
    procedure FOnSectionResize(HeaderControl: THeaderControl; Section: THeaderSection);
    function GetCells(ACol, ARow: Integer): string;
    procedure SetCells(ACol, ARow: Integer; const Value: string);
  protected
    procedure DoEnter; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Validate: Boolean;
    property ArrowExit: TArrowExit read FArrowExit write FArrowExit;
    property Caption: string read FCaption write FCaption;
    property Cells[ACol, ARow: Integer]: string read GetCells write SetCells;
    property LeadLabel: TLabel read FLeadLabel write FLeadLabel;
    property MarkChar: Char read FMarkChar write FMarkChar default '|';
    property Nullable: Boolean read FNullable write FNullable default False;
    property Header: THeaderControl read FHeader write SetHeader;
    property OnValidate: TCheckInputEvent read FOnValidate write FOnValidate;
    property OnSetItemProperty: TSetItemPropertyEvent read FOnSetItemProperty write FOnSetItemProperty;
  end;

  TTHListBox = class(TCustomTHListBox)
  published
    property Align;
    property Anchors;
    property ArrowExit;
    property BiDiMode;
    property BorderStyle;
    property Caption;
    property Color;
    property Columns;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property ExtendedSelect;
    property Font;
    property Header;
    property ImeMode;
    property ImeName;
    property IntegralHeight;
    property ItemHeight;
    property Items;
    property LeadLabel;
    property MarkChar;
    property MultiSelect;
    property Nullable;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Sorted;
//    property Style;
    property TabOrder;
    property TabStop;
    property TabWidth;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnSetItemProperty;
    property OnStartDock;
    property OnStartDrag;
    property OnValidate;
  end;

procedure Register;

implementation

const
  NotNull = '不能为空。';

procedure Register;
begin
  RegisterComponents('THsoft', [TTHEdit]);
  RegisterComponents('THsoft', [TTHCheckBox]);
  RegisterComponents('THsoft', [TTHBitBtn]);
  RegisterComponents('THsoft', [TTHComboBox]);
  RegisterComponents('THsoft', [TTHCheckCombo]);
  RegisterComponents('THsoft', [TTHCheckListBox]);
  RegisterComponents('THsoft', [TTHListBox]);
end;

//function Encode(const Password: ShortString; Key: Integer): ShortString; stdcall; external 'Dogskin.dll';
function EncodeInt(lPassword: Longint): Longint;
var
  sCode: string[10];
  iCount: Integer;
  lMultiplier: Longint;
begin
  if lPassword > 99999999 then Result := lPassword
  else
  begin
    sCode := IntToStr(542880742 - lPassword);
    sCode[1] := '5';
    Result := 0;
    lMultiplier := 10000000;
    for iCount := 1 to 8 do
    begin
      Result := Result + ((Ord(sCode[iCount]) + Ord(sCode[iCount + 1]) - 96) mod 10) * lMultiplier;
      lMultiplier := lMultiplier div 10;
    end;
  end;
end;

function Encode(const Password: ShortString; Key: Integer): string;
var
  lPassword, iCount: integer;
  sPass: string;
begin
  lPassword := EncodeInt(StrToIntDef(Password, 0));
  sPass := IntToStr(lPassword);
  Result := '';
  for iCount := 1 to Length(sPass) do
    Result := Result + Chr(StrToInt(sPass[iCount]) + 58);
end;

// 取字符串第一个分界符的前半部分, 若分界符不存在则返回整个字符串

function GetFront(const sSource: string; cDelimiter: Char): string;
var
  iPos: Integer;
begin
  iPos := Pos(cDelimiter, sSource);
  if iPos > 0 then Result := Copy(sSource, 1, iPos - 1)
  else Result := sSource;
end;

// 取字符串第一个分界符的后半部分, 若分界符不存在则返回空串

function GetBack(const sSource: string; cDelimiter: Char): string;
var
  iPos: Integer;
begin
  iPos := Pos(cDelimiter, sSource);
  if iPos > 0 then Result := Copy(sSource, iPos + 1, Length(sSource))
  else Result := '';
end;

// 取字符串第 iPart 部分, iPart >= 1

function GetPart(const sSource: string; cDelimiter: Char; iPart: Integer): string;
var
  iCount: Integer;
  sNew: string;
begin
  sNew := sSource + cDelimiter;
  if iPart > 0 then
  begin
    for iCount := 2 to iPart do
      sNew := GetBack(sNew, cDelimiter);
    Result := GetFront(sNew, cDelimiter);
  end
  else Result := '';
end;

// 替换字符串第 iPart 部分, iPart >= 1

function SetPart(const sSource: string; cDelimiter: Char; iPart: Integer; const sSubstitute: string): string;
var
  iMarkCount: Integer;
  iCount, iPos1, iPos2, iLen: Integer;
begin
  iMarkCount := 0;
  iLen := Length(sSource);
  iPos1 := 0;
  iPos2 := iLen + 1;
  for iCount := 1 to iLen do
    if sSource[iCount] = cDelimiter then
    begin
      Inc(iMarkCount);
      if iMarkCount + 1 = iPart then
        iPos1 := iCount
      else if iMarkCount = iPart then
      begin
        iPos2 := iCount;
        Break;
      end;
    end;
  if (iPos1 = 0) and (iPos2 = iLen + 1) then Result := sSource
  else Result := Copy(sSource, 1, iPos1) + sSubstitute + Copy(sSource, iPos2, iLen);
end;

// 字符串转换为浮点数

function StrToFloatDef(const sValue: string; lfDefault: Extended = 0): Extended;
begin
  try
    Result := StrToFloat(sValue);
  except
    Result := lfDefault;
  end;
end;

// 字符串转换为整数日期，格式YYYYMMDD，否则返回0

function StrToIntDate(const sDate: string): Longint;
begin
  Result := StrToIntDef(sDate, 0);
  if Length(IntToStr(Result)) = 8 then
  try
    StrToDate(Copy(sDate, 1, 4) + DateSeparator + Copy(sDate, 5, 2) + DateSeparator + Copy(sDate, 7, 2));
  except
    Result := 0;
  end
  else Result := 0;
end;

// 字符串转换为整数时间，格式HHMMSS，否则返回-1

function StrToIntTime(const sTime: string): Longint;
begin
  Result := StrToIntDef(sTime, -1);
  if (Result <> -1) and (Length(sTime) = 6) and (Copy(sTime, 1, 1) <> ' ') then
  try
    StrToTime(Copy(sTime, 1, 2) + TimeSeparator + Copy(sTime, 3, 2) + TimeSeparator + Copy(sTime, 5, 2));
  except
    Result := -1;
  end
  else Result := -1;
end;

function GetCaption(const Caption: string; LeadLabel: TLabel): string;
begin
  Result := '';
  if Length(Caption) > 0 then Result := Caption
  else if LeadLabel <> nil then Result := LeadLabel.Caption;
end;

// 找下一个控件，参看Controls.FindNextControl

function THFindNextControl(SelfControl, CurControl: TWinControl;
  GoForward, CheckTabStop: Boolean): TWinControl;
var
  Form: TCustomForm;
  I, StartIndex: Integer;
  List: TList;
begin
  Result := nil;
  Form := GetParentForm(SelfControl);
  if Form = nil then Exit;
  List := TList.Create;
  try
    Form.GetTabOrderList(List);
    if List.Count > 0 then
    begin
      StartIndex := List.IndexOf(CurControl);
      if StartIndex = -1 then
        if GoForward then StartIndex := List.Count - 1 else StartIndex := 0;
      I := StartIndex;
      repeat
        if GoForward then
        begin
          Inc(I);
          if I = List.Count then I := 0;
        end else
        begin
          if I = 0 then I := List.Count;
          Dec(I);
        end;
        CurControl := List[I];
        if CurControl.CanFocus and
          (not CheckTabStop or CurControl.TabStop) then
          Result := CurControl;
      until (Result <> nil) or (I = StartIndex);
    end;
  finally
    List.Free;
  end;
end;

// 找下一个控件并设置焦点，参看Controls.SelectNext

procedure THSelectNext(SelfControl, CurControl: TWinControl; GoForward, CheckTabStop: Boolean);
var
  Control: TWinControl;
begin
  Control := THFindNextControl(SelfControl, CurControl, GoForward, CheckTabStop);
  if Control <> nil then Control.SetFocus;
end;

// 控件值是否有效

function THControlValidate(Control: TWinControl): Boolean;
begin
  Result := False;
  if Control is TCustomTHEdit then
    if not (Control as TCustomTHEdit).Validate then Exit;
  if Control is TCustomTHComboBox then
    if not (Control as TCustomTHComboBox).Validate then Exit;
  if Control is TCutomTHCheckBox then
    if not (Control as TCutomTHCheckBox).Validate then Exit;
  if Control is TTHCheckListBox then
    if not (Control as TTHCheckListBox).Validate then Exit;
  if Control is TTHCheckCombo then
    if not (Control as TTHCheckCombo).Validate then Exit;
  if Control is TTHListBox then
    if not (Control as TTHListBox).Validate then Exit;
  Result := True;
end;

function THControlEnter(SelfControl: TWinControl): Boolean;
var
  Control: TWinControl;
begin
  Result := True;
  Control := THFindNextControl(SelfControl, nil, True, False);
  while (Control <> nil) and (SelfControl <> Control) do
  begin
    if not THControlValidate(Control) then
    begin
      Result := False;
      Break;
    end;
    Control := THFindNextControl(SelfControl, Control, True, False);
    if not SelfControl.CanFocus then
    begin
      if (Control <> nil) and (Control.CanFocus)
        then Control.SetFocus;
      Break;
    end;
  end;
end;

procedure HandleArrowExit(var Key: Word; Shift: TShiftState; ArrowExit: TArrowExit; Self: TCustomListBox);
begin
  with Self do
    case Key of
      VK_LEFT:
        if (ArrowExit.LeftRight = asAlways)
          or ((ArrowExit.LeftRight = asTopBottomOnly) and (ItemIndex = 0)) then
        begin
          THSelectNext(Self, Self, False, True);
          Key := 0;
        end;
      VK_RIGHT:
        if (ArrowExit.LeftRight = asAlways)
          or ((ArrowExit.LeftRight = asTopBottomOnly) and (ItemIndex = Items.Count - 1)) then
        begin
          THSelectNext(Self, Self, True, True);
          Key := 0;
        end;
      VK_UP:
        if (ArrowExit.UpDown = asAlways)
          or ((ArrowExit.UpDown = asTopBottomOnly) and (ItemIndex <= 0)) then
        begin
          THSelectNext(Self, Self, False, True);
          Key := 0;
        end;
      VK_DOWN:
        if (ArrowExit.UpDown = asAlways)
          or ((ArrowExit.UpDown = asTopBottomOnly) and (ItemIndex = Items.Count - 1)) then
        begin
          THSelectNext(Self, Self, True, True);
          Key := 0;
        end;
    end;
end;

{ TCustomTHEdit }

constructor TCustomTHEdit.Create(AOwner: TComponent);
begin
  inherited;
  SetStyle(esString);
end;

procedure TCustomTHEdit.KeyPress(var Key: Char);
begin
  inherited;
  if Key = Char(VK_RETURN) then
  begin
    THSelectNext(Self, Self, True, True);
    Key := #0;
  end;
end;

procedure TCustomTHEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if Shift = [] then
    case Key of
      VK_UP:
        begin
          THSelectNext(Self, Self, False, True);
          Key := 0;
        end;
      VK_DOWN: