thehomectrls.pas

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

      Result := False;
    end;
    if Result and Assigned(FOnValidate) then FOnValidate(Self, Result);
  end;
  if Result then
  begin
    FChanged := False;
    FSavedText := Text;
  end
  else SetFocus;
end;

procedure TCustomTHComboBox.Reset;
begin
  FChanged := True;
end;

{ TTHCheckCombo }

constructor TTHCheckCombo.Create(AOwner: TComponent);
begin
  inherited;
  FBtnControl := TWinControl.Create(Self);
  FBtnControl.Parent := Self;
  FButton := TComboButton.Create(Self);
  FButton.Parent := FBtnControl;
  FButton.Width := 17;
  FButton.Layout := blGlyphBottom; // Center the glyph
  FButton.Glyph.Handle := LoadBitmap(0, PChar(32738)); //	OBM_COMBO;

  FGrid := TPopupGrid.Create(Self);
  FGrid.Parent := Self;
  FGrid.Visible := False;
  FGrid.ParentCtl3D := False; //Disable 3D, more similar to TComboBox.
  FGrid.Ctl3D := False;
  FGrid.ParentColor := True;
  FGrid.Style := lbOwnerDrawFixed;
  FDropDownCount := 8;
  FDropDownWidth := 0;
  FMarkChar := '|';
  FNullable := False;
  FValueWidth := 12;
  FSeparator := ',';
  FChanged := True;
  FItemsAccessed := True;
  FNeverDropped := True;
  FSeparate := False;
  FSelectAll := True;
  FReadOnly := False;
end;

destructor TTHCheckCombo.Destroy;
begin
  DeleteObject(FButton.Glyph.Handle);
  inherited;
end;

procedure TTHCheckCombo.Clear;
begin
  inherited;
  FGrid.Items.Clear;
end;

procedure TTHCheckCombo.Reset;
begin
  FChanged := True;
end;

procedure TTHCheckCombo.DoEnter;
begin
  if THControlEnter(Self) then inherited;
end;

function TTHCheckCombo.Validate: Boolean;
begin
  Result := True;
  if FChanged then
  begin
    if not FNullable and (Length(Text) = 0) then
    begin
      MessageDlg(GetCaption(FCaption, FLeadLabel) + NotNull, mtWarning, [mbOK], 0);
      Result := False;
    end;
    if Result and Assigned(FOnValidate) then FOnValidate(Self, Result);
  end;
  if Result then FChanged := False
  else SetFocus;
end;

procedure TTHCheckCombo.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if (Shift = []) and (Key = VK_F4) or (Shift = [ssALT]) and (Key in [VK_UP, VK_DOWN]) then
  begin
    if FGrid.Visible then CloseUp
    else DropDown;
    Key := 0;
  end;
  if not FGrid.Visible and (Shift = []) and (Key in [VK_UP, VK_DOWN]) then
  begin
    THSelectNext(Self, Self, Key = VK_DOWN, True);
    Key := 0;
  end;
  if (not ReadOnly) and (Shift = [ssCtrl]) and (Key = Ord('A')) then
  begin
    CheckedAll(FSelectAll);
    FSelectAll := not FSelectAll;
    Key := 0;
  end;
  FGrid.KeyDown(Key, Shift);
  inherited;
end;

procedure TTHCheckCombo.KeyPress(var Key: Char);
begin
  RecalcSeparate; // 无法控制对Items的修改，只好如此，其他处同理。谁有高招？
  case Word(Key) of
    VK_SPACE:
      begin
        if FGrid.Visible and not ReadOnly then
        begin
          FGrid.Checked[FGrid.ItemIndex] := not FGrid.Checked[FGrid.ItemIndex];
          Text := FGrid.GetAllChecked;
        end;
        Key := #0;
      end;
    VK_RETURN:
      begin
        if FGrid.Visible then
        begin
          CloseUp;
        end
        else
          THSelectNext(Self, Self, True, True);
        Key := #0;
      end;
    VK_ESCAPE:
      begin
        if FGrid.Visible then
        begin
          CloseUp;
        end;
        Key := #0;
      end;
  end;
  inherited;
end;

procedure TTHCheckCombo.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.Style := Params.Style or WS_CLIPCHILDREN;
  // or ES_MULTILINE
end;

procedure TTHCheckCombo.CreateWnd;
begin
  inherited;
  SetEditRect;
  FGrid.HandleNeeded;
end;

procedure TTHCheckCombo.RecalcSeparate;
var
  Index: Integer;
  bSeparate: Boolean;
begin
  if FItemsAccessed then
  begin
    FItemsAccessed := False;
    bSeparate := False;
    for Index := 0 to FGrid.Items.Count - 1 do
      if Length(GetFront(FGrid.Items[Index], FMarkChar)) > 1 then
      begin
        bSeparate := True;
        Break;
      end;
    if bSeparate <> FSeparate then
    begin
      FSeparate := bSeparate;
      inherited ReadOnly := bSeparate;
      Text := FGrid.GetAllChecked;
      FChanged := True;
    end;
  end;
end;

procedure TTHCheckCombo.SetEditRect;
var
  Loc: TRect;
begin
  Loc.Bottom := ClientHeight;
  Loc.Right := FBtnControl.Left - 10;
  Loc.Top := 0;
  Loc.Left := 0;
  SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@Loc));
end;

procedure TTHCheckCombo.SetReadOnly(Value: Boolean);
begin
  FReadOnly := Value;
  inherited ReadOnly := Value;
  if FSeparate then
    inherited ReadOnly := True;
  FGrid.SetReadOnly(Value);
end;

procedure TTHCheckCombo.WMSize(var Message: TWMSize);
var
  MinHeight: Integer;
begin
  inherited;
  if (csDesigning in ComponentState) then
  begin
    FGrid.SetBounds(0, 0, 0, 0);
  end;
  MinHeight := GetMinHeight;
  if Height <> MinHeight then
    Height := MinHeight
  else
  begin
    if Ctl3D then
      FBtnControl.SetBounds(ClientWidth - FButton.Width, 0, FButton.Width, ClientHeight)
    else
      FBtnControl.SetBounds(ClientWidth - FButton.Width, GetSystemMetrics(SM_CXBORDER),
        FButton.Width, ClientHeight - GetSystemMetrics(SM_CYBORDER) * 2);
    FButton.Height := FBtnControl.Height;
    SetEditRect;
  end;
end;

procedure TTHCheckCombo.CNKeyDown(var Message: TWMKeyUp);
begin
 // 已下拉后禁止Tab，如同TCOmboBox，另外方式防止Tab至FGrid，造成FGrid不能正常关闭
  if (Message.CharCode = VK_TAB) and FGrid.Visible then Message.Result := 1
  else inherited;
end;

function TTHCheckCombo.GetMinHeight: Integer;
var
  DC: HDC;
  SaveFont: HFont;
  SysMetrics, Metrics: TTextMetric;
  I: Longint;
begin
  DC := GetDC(0);
  GetTextMetrics(DC, SysMetrics);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
  if Ctl3D then I := 8 else I := 6;
  I := GetSystemMetrics(SM_CYBORDER) * I;
  Result := Metrics.tmHeight + I;
end;

procedure TTHCheckCombo.WMKillFocus(var Message: TWMKillFocus);
begin
  inherited;
  CloseUp;
end;

procedure TTHCheckCombo.CMCancelMode(var Message: TCMCancelMode);
begin
  with Message do
    if (Sender <> Self) and (Sender <> FBtnControl) and
      (Sender <> FButton) and (Sender <> FGrid) then CloseUp;
end;

procedure TTHCheckCombo.CMHintShow(var Message: TMessage);
begin
 // FGrid显示时禁止Hint
  Message.Result := Integer(FGrid.Visible);
end;

procedure TTHCheckCombo.CMChanged(var Message: TMessage);
begin
  if (csDesigning in ComponentState) then Exit;
  FGrid.SetAllChecked(Text);
  Text := FGrid.GetAllChecked;
  FChanged := True;
  FItemsAccessed := True;
  RecalcSeparate;
end;

procedure TTHCheckCombo.DropDown;
var
  ItemCount: Integer;
  GridWidth, GridHeight: Integer;
  P: TPoint;
begin
  if not FGrid.Visible then
  begin
    if Assigned(FOnDropDown) then FOnDropDown(Self);
    ItemCount := Min(FDropDownCount, FGrid.Items.Count);
    if ItemCount <= 0 then ItemCount := 1;
    GridHeight := FGrid.ItemHeight * ItemCount + 2;
    GridWidth := FDropDownWidth;
    if GridWidth <= 0 then GridWidth := Width;
    P := ClientOrigin;
    if Ctl3D then
    begin
      P.X := P.X - GetSystemMetrics(SM_CXEDGE);
      P.Y := P.Y - GetSystemMetrics(SM_CYEDGE);
    end;
    if P.Y + Height + GridHeight <= Screen.Height then P.Y := P.Y + Height // 下拉
    else if P.Y > GridHeight then P.Y := P.Y - GridHeight // 上弹
    else P.Y := 0; // 屏幕顶部下拉
    SetWindowPos(FGrid.Handle, HWND_TOP, P.X, P.Y, GridWidth, GridHeight, SWP_NOACTIVATE);
    FGrid.Show;
    Windows.SetFocus(Handle);
    if FNeverDropped then FGrid.ItemIndex := 0; // 不管Items.Count是否为0
    FNeverDropped := False;
  end;
end;

procedure TTHCheckCombo.CheckedAll(Value: Boolean);
var
  Index: Integer;
begin
  for Index := 0 to FGrid.Items.Count - 1 do
    SetChecked(Index, Value);
end;

procedure TTHCheckCombo.CloseUp;
begin
  if FGrid.Visible then
  begin
    FGrid.Hide;
    RecalcSeparate;
  end;
end;

procedure TTHCheckCombo.CMEnter(var Message: TCMGotFocus);
begin
  RecalcSeparate;
  if AutoSelect then SelectAll;
  inherited;
end;

procedure TTHCheckCombo.CMExit(var Message: TCMLostFocus);
begin
  RecalcSeparate;
  inherited;
end;

function TTHCheckCombo.GetChecked(Index: Integer): Boolean;
begin
  Result := FGrid.Checked[Index];
end;

procedure TTHCheckCombo.SetChecked(Index: Integer; Checked: Boolean);
begin
  FGrid.Checked[Index] := Checked;
  Text := FGrid.GetAllChecked;
end;

function TTHCheckCombo.GetItemHeight: Integer;
begin
  Result := FGrid.ItemHeight;
end;

procedure TTHCheckCombo.SetItemHeight(Value: Integer);
begin
  FGrid.ItemHeight := Value;
end;

function TTHCheckCombo.GetItems: TStrings;
begin
  Result := FGrid.Items;
  FItemsAccessed := True;
end;

procedure TTHCheckCombo.SetItems(Value: TStrings);
begin
  FGrid.Items.Assign(Value);
  FItemsAccessed := True;
end;

function TTHCheckCombo.GetFlat: Boolean;
begin
  Result := FGrid.Flat;
end;

procedure TTHCheckCombo.SetFlat(Value: Boolean);
begin
  FGrid.Flat := Value;
end;

function TTHCheckCombo.GetSorted: Boolean;
begin
  Result := FGrid.Sorted;
end;

procedure TTHCheckCombo.SetSorted(Value: Boolean);
begin
  FGrid.Sorted := Value;
end;

{ TTHCheckCombo.TPopupGrid }

procedure TPopupGrid.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.WindowClass.Style := CS_SAVEBITS;
end;

procedure TPopupGrid.CreateWnd;
begin
  inherited;
  if not (csDesigning in ComponentState) then
    Windows.SetParent(Handle, 0);
  CallWindowProc(DefWndProc, Handle, WM_SETFOCUS, 0, 0);
end;

procedure TPopupGrid.WMLButtonDown(var Message: TWMLButtonDown);
begin
  inherited;
  (Parent as TTHCheckCombo).Text := GetAllChecked;
end;

procedure TPopupGrid.CMHintShow(var Message: TMessage);
begin
  Message.Result := 1;
end;

function TPopupGrid.GetAllChecked: string;
var
  Index, I: Integer;
begin
  I := 0;
  Result := '';
  for Index := 0 to Items.Count - 1 do
    if Checked[Index] then
    begin
      Inc(I);
      if (Parent as TTHCheckCombo).FSeparate and (I > 1) then
        Result := Result + (Parent as TTHCheckCombo).FSeparator
          + GetFront(Items[Index], (Parent as TTHCheckCombo).FMarkChar)
      else
        Result := Result + GetFront(Items[Index], (Parent as TTHCheckCombo).FMarkChar);
    end;
end;

procedure TPopupGrid.SetAllChecked(const Value: string);
var
  Index: Integer;
  Separator: Char;
begin
  if (Parent as TTHCheckCombo).FSeparate then
  begin
    Separator := (Parent as TTHCheckCombo).FSeparator;
    for Index := 0 to Items.Count - 1 do
      Checked[Index] :=
        Pos(Separator + GetFront(Items[Index], (Parent as TTHCheckCombo).FMarkChar) + Separator,
        Separator + Value + Separator) > 0;
  end
  else
    for Index := 0 to Items.Count - 1 do
      Checked[Index] := Pos(GetFront(Items[Index], (Parent as TTHCheckCombo).FMarkChar), Value) > 0;
end;

procedure TPopupGrid.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
  inherited;
  if (Index < 0) or (Index > Items.Count - 1) then Exit;
  if Assigned((Parent as TTHCheckCombo).FOnSetItemProperty) then
    (Parent as TTHCheckCombo).FOnSetItemProperty(Canvas, Index, State);
  Canvas.FillRect(Rect);
  if (Parent as TTHCheckCombo).FValueWidth > 0 then
    Canvas.TextOut(Rect.Left + 2, Rect.Top, GetFront(Items[Index], (Parent as TTHCheckCombo).FMarkChar));
  Canvas.TextOut(Rect.Left + Max((Parent as TTHCheckCombo).FValueWidth, 0) + 2, Rect.Top,
    GetBack(Items[Index], (Parent as TTHCheckCombo).FMarkChar));