thehomectrls.pas

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

end;

procedure TPopupGrid.KeyDown(var Key: Word; Shift: TShiftState);
var
  ItemCount: Integer;
begin
  if (Shift <> [ssAlt]) and (Key in [VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT]) then
  begin
    ItemCount := Min((Parent as TTHCheckCombo).FDropDownCount, Items.Count);
    if ItemCount <= 0 then ItemCount := 1;
    if (Key = VK_UP) then
    begin
      if ItemIndex > 0 then ItemIndex := ItemIndex - 1;
    end
    else if (Key = VK_DOWN) then
    begin
      if ItemIndex < Items.Count - 1 then ItemIndex := ItemIndex + 1;
    end
    else if (Key = VK_PRIOR) then
    begin
      if ItemIndex = TopIndex then ItemIndex := Max(ItemIndex - ItemCount + 1, 0)
      else ItemIndex := TopIndex;
    end
    else
    begin
      if ItemIndex = TopIndex + ItemCount - 1 then
        ItemIndex := Min(ItemIndex + ItemCount - 1, Items.Count - 1)
      else ItemIndex := TopIndex + ItemCount - 1;
    end;
    Key := 0;
  end
  else inherited;
end;

procedure TPopupGrid.SetReadOnly(Value: Boolean);
var
  Index: Integer;
begin
  for Index := 0 to Items.Count - 1 do
    ItemEnabled[Index] := not Value;
  Refresh;
end;

{ TTHCheckCombo.TComboButton }

procedure TComboButton.CMHintShow(var Message: TMessage);
begin
  TTHCheckCombo(Parent.Parent).CMHintShow(Message);
end;

procedure TComboButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if Button <> mbLeft then Exit;
  with TTHCheckCombo(Parent.Parent) do
  begin
    if (not FGrid.Visible) and (Handle <> GetFocus) and CanFocus then
    begin
      SetFocus;
      if GetFocus <> Handle then Exit;
    end;
    if FGrid.Visible then CloseUp
    else
    begin
      inherited;
      DropDown;
    end;
  end;
end;

{ TTHCheckListBox }

constructor TTHCheckListBox.Create(AOwner: TComponent);
begin
  inherited;
  FArrowExit := TArrowExit.Create;
  FMarkChar := '|';
  FNullable := False;
  FValueWidth := 12;
  FSeparator := ',';
  FChanged := True;
  FSelectAll := True;
  FReadOnly := False;
end;

destructor TTHCheckListBox.Destroy;
begin
  FArrowExit.Free;
  inherited;
end;

function TTHCheckListBox.GetSeparate: Boolean;
var
  Index: Integer;
begin
  Result := False;
  for Index := 0 to Items.Count - 1 do
    if Length(GetFront(Items[Index], FMarkChar)) > 1 then
    begin
      Result := True;
      Break;
    end;
end;

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

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

procedure TTHCheckListBox.SetReadOnly(Value: Boolean);
var
  Index: Integer;
begin
  FReadOnly := Value;
  for Index := 0 to Items.Count - 1 do
    ItemEnabled[Index] := not Value;
  Refresh;
end;

procedure TTHCheckListBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if (not FReadOnly) and (Shift = [ssCtrl]) and (Key = Ord('A')) then
  begin
    CheckedAll(FSelectAll);
    FSelectAll := not FSelectAll;
  end;
  HandleArrowExit(Key, Shift, FArrowExit, Self);
  inherited;
end;

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

procedure TTHCheckListBox.DoEnter;
begin
  if THControlEnter(Self) then inherited;
//  if (ItemIndex = -1) and (Items.Count > 0) then ItemIndex := 0;
end;

function TTHCheckListBox.Validate: Boolean;
var
  CurText: string;
begin
  Result := True;
  CurText := GetAllChecked;
  if FChanged or (FSavedText <> CurText) then
  begin
    if not FNullable and (Length(GetAllChecked) = 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
  begin
    FChanged := False;
    FSavedText := CurText;
  end
  else SetFocus;
end;

procedure TTHCheckListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
  inherited;
  if (Index >= 0) and (Index < Items.Count) then
  begin
    if Assigned(FOnSetItemProperty) then FOnSetItemProperty(Canvas, Index, State);
    Canvas.FillRect(Rect);
    if FValueWidth > 0 then
      Canvas.TextOut(Rect.Left, Rect.Top, GetFront(Items[Index], FMarkChar));
    Canvas.TextOut(Rect.Left + Max(FValueWidth, 0), Rect.Top, GetBack(Items[Index], FMarkChar));
  end;
end;

procedure TTHCheckListBox.CheckedAll(Value: Boolean);
var
  i: Integer;
begin
  for i := 0 to Items.Count - 1 do
    Checked[i] := Value;
end;

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

{ TStockEdit }
{
procedure TPopupList.CreateParams(var Params: TCreateParams);
begin
  inherited;
  //Params.WindowClass.Style := CS_SAVEBITS or CS_BYTEALIGNWINDOW;
end;

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

procedure TPopupList.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
 StockIndex: Integer;
begin
  StockIndex := StrToInt(Items[Index]);
  Canvas.FillRect(Rect);
  Canvas.TextOut(Rect.Left, Rect.Top, (Parent as TTHStockEdit).FStock[StockIndex].InterCode);
  Canvas.TextOut(Rect.Left + 50, Rect.Top, (Parent as TTHStockEdit).FStock[StockIndex].StockName);
end;

constructor TTHStockEdit.Create;
begin
 inherited;
  FListBox := TPopupList.Create(Self);
  FListBox.Parent := Self;
  FListBox.Hide;
  FListBox.ParentCtl3D := False;
  FListBox.Ctl3D := False;
  FListBox.ParentColor := True;
  FListBox.Style := lbOwnerDrawFixed;
  MaxLength := 6;
end;

procedure TTHStockEdit.WMKillFocus(var Message: TWMKillFocus);
begin
  inherited;
  FListBox.Hide;
end;

procedure TTHStockEdit.CNKeyDown(var Message: TWMKeyUp);
begin
 if (Message.CharCode = VK_TAB) and FListBox.Visible then Message.Result := 1
  else inherited;
end;

procedure TTHStockEdit.CMCancelMode(var Message: TCMCancelMode);
begin
 inherited;
  with Message do
    if (Sender <> Self) and (Sender <> FListBox) then FListBox.Hide;
end;

procedure TTHStockEdit.CMChanged(var Message: TMessage);
var
  P: TPoint;
  GridHeight, Index: Integer;
begin
  if (csDesigning in ComponentState) then Exit;
  if (Length(Text) > 0) then
  begin
   if not FListBox.Visible then
    begin
      GridHeight := FListBox.ItemHeight * 12 + 2;
      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(FListBox.Handle, HWND_TOP, P.X, P.Y, Width, GridHeight, SWP_NOACTIVATE);
      FListBox.Show;
      Windows.SetFocus(Handle);
    end;
   FListBox.Items.BeginUpdate;
    FListBox.Items.Clear;
    for Index := 0 to 1999 do
    begin
      if (Pos(Text, FStock[Index].InterCode) > 0)
        or (Pos(Text, FStock[Index].SpellCode) > 0) then FListBox.Items.Add(IntToStr(Index));
    end;
    FListBox.Items.EndUpdate;
    if FListBox.Items.Count = 0 then
    begin
   Index := Max(Length(Text) - Length(FSavedText), 1);
      SelStart := SelStart - Index;
      SelLength := Index;
      Beep;
    end
    else FListBox.ItemIndex := 0;
  end
  else
  begin
   FListBox.Hide;
  end;
  FSavedText := Text;
end;

// for Test only
procedure TTHStockEdit.Loaded;
var
 Index: Integer;
begin
  for Index := 0 to 1999 do
  begin
   FStock[Index].InterCode := IntToStr(Index);
   FStock[Index].SpellCode := IntToStr(Index);
   FStock[Index].StockName := IntToStr(Index);
  end;
end;

procedure TTHStockEdit.SetPos;
var
  P: TPoint;
  GridHeight: Integer;
begin
 try
    P := ClientOrigin;
      if Ctl3D then
      begin
        P.X := P.X - GetSystemMetrics(SM_CXEDGE);
        P.Y := P.Y - GetSystemMetrics(SM_CYEDGE);
      end;
      GridHeight := FListBox.ItemHeight * 12 + 2;
      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(FListBox.Handle, HWND_TOP, P.X, P.Y, 0, 0, SWP_NOSIZE);
 except
  end;
end;
}
{ TCustomTHListBox }

constructor TCustomTHListBox.Create(AOwner: TComponent);
begin
  inherited;
  FArrowExit := TArrowExit.Create;
  FMarkChar := '|';
  FNullable := False;
  Style := lbOwnerDrawFixed;
end;

destructor TCustomTHListBox.Destroy;
begin
  FArrowExit.Free;
  inherited;
end;

procedure TCustomTHListBox.SetHeader(Value: THeaderControl);
begin
  FHeader := Value;
  if Assigned(FHeader) then
  begin
    if not Assigned(FHeader.OnSectionResize) then FHeader.OnSectionResize := FOnSectionResize;
    if (csDesigning in ComponentState) then
    begin
     //FHeader.Align := alNone;
      FHeader.Left := Left;
      FHeader.Top := Top - FHeader.Height;
      FHeader.Width := Width;
      FHeader.ParentFont := False;
      FHeader.Font := Font;
    end;
  end;
end;

procedure TCustomTHListBox.FOnSectionResize(HeaderControl: THeaderControl; Section: THeaderSection);
begin
  Invalidate;
end;

function TCustomTHListBox.GetCells(ACol, ARow: Integer): string;
begin
  Result := GetPart(Items[ARow], FMarkChar, ACol + 1);
end;

procedure TCustomTHListBox.SetCells(ACol, ARow: Integer; const Value: string);
begin
  Items[ARow] := SetPart(Items[ARow], FMarkChar, ACol + 1, Value);
end;

procedure TCustomTHListBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
  HandleArrowExit(Key, Shift, FArrowExit, Self);
  inherited;
end;

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

procedure TCustomTHListBox.DoEnter;
begin
  if THControlEnter(Self) then inherited;
  if (ItemIndex = -1) and (Items.Count > 0) then ItemIndex := 0;
end;

function TCustomTHListBox.Validate: Boolean;
begin
  Result := True;
  if not FNullable and (ItemIndex = -1) then
  begin
    MessageDlg(GetCaption(FCaption, FLeadLabel) + NotNull, mtWarning, [mbOK], 0);
    Result := False;
  end;
  if Result and Assigned(FOnValidate) then FOnValidate(Self, Result);
  if not Result then SetFocus;
end;

procedure TCustomTHListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  rcRect: TRect;
  sText, sBack: string;
  iPos, iColIndex, X: Integer;
begin
  if Assigned(FHeader) and (FHeader.Sections.Count > 0) and (Index >= 0) and (Index < Items.Count) then
  begin
    if Assigned(FOnSetItemProperty) then FOnSetItemProperty(Canvas, Index, State);
    Canvas.FillRect(Rect);
    rcRect := Rect;
    sBack := Items[Index] + FMarkChar;
    for iColIndex := 0 to FHeader.Sections.Count - 1 do
    begin
      rcRect.Left := FHeader.Sections.Items[iColIndex].Left + 4;
      rcRect.Right := FHeader.Sections.Items[iColIndex].Right - 8;
      iPos := Pos(FMarkChar, sBack);
      if iPos > 0 then
      begin
        sText := Copy(sBack, 1, iPos - 1);
        sBack := Copy(sBack, iPos + 1, Length(sBack));
      end
      else sText := '';
      X := rcRect.Right - Canvas.TextWidth(sText);