tntdbctrlsex.pas

TntExUpdate 是 流行的 TntUnicodeControls控件的扩展包.包括很难找到的 TntJVCL 也在里面. TntSysUtils2.pas/TntSysUtilsEx.pa

      Key := #0;
    end;
    case Key of
      ^H, ^I, ^J, ^M, ^V, ^X, #32..#255:
        FDataLink.Edit;
      #27:
        FDataLink.Reset;
    end;
  end
  else
  begin
    if Key = #13 then
      LoadMemo;
    Key := #0;
  end;
end;

procedure TTntDBMemo.Change;
begin
  if FMemoLoaded and (not ReadOnly) then
    FDataLink.Modified;
  FMemoLoaded := True;
  inherited Change;
end;

function TTntDBMemo.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TTntDBMemo.SetDataSource(Value: TDataSource);
begin
  if not (FDataLink.DataSourceFixed and (csLoading in ComponentState))
    then
    FDataLink.DataSource := Value;
  if Value <> nil then
    Value.FreeNotification(Self);
end;

function TTntDBMemo.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

procedure TTntDBMemo.SetDataField(const Value: string);
begin
  FDataLink.FieldName := Value;
end;

function TTntDBMemo.GetReadOnly: Boolean;
begin
  Result := FDataLink.ReadOnly;
end;

procedure TTntDBMemo.SetReadOnly(Value: Boolean);
begin
  FDataLink.ReadOnly := Value;
end;

function TTntDBMemo.GetField: TField;
begin
  Result := FDataLink.Field;
end;

procedure TTntDBMemo.LoadMemo;
begin
  if not FMemoLoaded and Assigned(FDataLink.Field) and
    FDataLink.Field.IsBlob then
  begin
    try
      Lines.Text := GetWideText(FDataLink.Field);
      FMemoLoaded := True;
    except
      { Memo too large }
      on E: EInvalidOperation do
        Lines.Text := WideFormat('(%s)', [E.Message]);
    end;
    EditingChange(Self);
  end;
end;

procedure TTntDBMemo.DataChange(Sender: TObject);
begin
  if FDataLink.Field <> nil then
    if FDataLink.Field.IsBlob then
    begin
      if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then
      begin
        FMemoLoaded := False;
        LoadMemo;
      end
      else
      begin
        Text := WideFormat('(%s)', [FDataLink.Field.DisplayLabel]);
        FMemoLoaded := False;
      end;
    end
    else
    begin
      if FFocused and FDataLink.CanModify then
        Text := GetWideText(FDataLink.Field)
      else
        Text := GetWideDisplayText(FDataLink.Field);
      FMemoLoaded := True;
    end
  else
  begin
    if csDesigning in ComponentState then
      Text := Name
    else
      Text := '';
    FMemoLoaded := False;
  end;
  if HandleAllocated then
    RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or
      RDW_FRAME);
end;

procedure TTntDBMemo.EditingChange(Sender: TObject);
begin
  inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded);
end;

procedure TTntDBMemo.UpdateData(Sender: TObject);
begin
  SetWideText(FDataLink.Field, Text);
end;

procedure TTntDBMemo.SetFocused(Value: Boolean);
begin
  if FFocused <> Value then
  begin
    FFocused := Value;
    if not Assigned(FDataLink.Field) or not FDataLink.Field.IsBlob then
      FDataLink.Reset;
  end;
end;

procedure TTntDBMemo.WndProc(var Message: TMessage);
begin
  with Message do
    if (Msg = WM_CREATE) or (Msg = WM_WINDOWPOSCHANGED) or
      (Msg = CM_FONTCHANGED) then
      FPaintControl.DestroyHandle;
  inherited;
end;

procedure TTntDBMemo.CMEnter(var Message: TCMEnter);
begin
  SetFocused(True);
  inherited;
end;

procedure TTntDBMemo.CMExit(var Message: TCMExit);
begin
  try
    FDataLink.UpdateRecord;
  except
    SetFocus;
    raise;
  end;
  SetFocused(False);
  inherited;
end;

procedure TTntDBMemo.SetAutoDisplay(Value: Boolean);
begin
  if FAutoDisplay <> Value then
  begin
    FAutoDisplay := Value;
    if Value then
      LoadMemo;
  end;
end;

procedure TTntDBMemo.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  if not FMemoLoaded then
    LoadMemo
  else
    inherited;
end;

procedure TTntDBMemo.WMCut(var Message: TMessage);
begin
  FDataLink.Edit;
  inherited;
end;

procedure TTntDBMemo.WMUndo(var Message: TMessage);
begin
  FDataLink.Edit;
  inherited;
end;

procedure TTntDBMemo.WMPaste(var Message: TMessage);
begin
  FDataLink.Edit;
  inherited;
end;

procedure TTntDBMemo.CMGetDataLink(var Message: TMessage);
begin
  Message.Result := Integer(FDataLink);
end;

procedure TTntDBMemo.WMPaint(var Message: TWMPaint);
var
  S: WideString;
begin
  if not (csPaintCopy in ControlState) then
    inherited
  else
  begin
    if FDataLink.Field <> nil then
      if FDataLink.Field.IsBlob then
      begin
        if FAutoDisplay then
          S := TntAdjustLineBreaks(GetWideText(FDataLink.Field))
        else
          S := WideFormat('(%s)', [FDataLink.Field.DisplayLabel]);
      end
      else
        S := GetWideDisplayText(FDataLink.Field);
    if Win32PlatformIsUnicode then
      SendMessageW(FPaintControl.Handle, WM_SETTEXT, 0,
        Integer(PWideChar(S)))
    else
      SendMessage(FPaintControl.Handle, WM_SETTEXT, 0,
        Integer(PChar(string(S))));
    SendMessage(FPaintControl.Handle, WM_ERASEBKGND, Message.DC, 0);
    SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
  end;
end;

function TTntDBMemo.ExecuteAction(Action: TBasicAction): Boolean;
begin
  Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and
    FDataLink.ExecuteAction(Action);
end;

function TTntDBMemo.UpdateAction(Action: TBasicAction): Boolean;
begin
  Result := inherited UpdateAction(Action) or (FDataLink <> nil) and
    FDataLink.UpdateAction(Action);
end;
*)

{ TTntDBNavigator }

var
  BtnHintId: array[TNavigateBtn] of Pointer;


type
  EAbortPaint = class(EAbort);
  THackDBNavigator = class(TCustomPanel)
  protected
    FDataLink: TNavDataLink;
    FVisibleButtons: TButtonSet;
    FHints: TStrings;
    FDefHints: TStrings;
    ButtonWidth: Integer;
    MinBtnSize: TPoint;
    FOnNavClick: ENavClick;
    FBeforeAction: ENavClick;
    FocusedButton: TNavigateBtn;
    FConfirmDelete: Boolean;
    FFlat: Boolean;
  end;

procedure TTntDBNavigator.CaptionsChanged(Sender: TObject);
begin
  InitCaptions;
end;

constructor TTntDBNavigator.Create(AOwner: TComponent);
begin
  inherited;
  FButtonLayout := blGlyphTop;
  FCaptions := TTntStringList.Create;
  TTntStringList(FCaptions).OnChange := CaptionsChanged;
  FHints := TTntStringList.Create;
  TTntStringList(FHints).OnChange := HintsChanged;

  InitButtons;
  InitHints;
  InitCaptions;
end;

destructor TTntDBNavigator.Destroy;
begin
  FHints.Free;
  FCaptions.Free;
  FDefHints.Free;
  inherited;
end;

function TTntDBNavigator.GetCaptions: TTntStrings;
begin
  Result := FCaptions;
end;

function TTntDBNavigator.GetHints: TTntStrings;
begin
  if (csDesigning in ComponentState) and not (csWriting in ComponentState) and
    not (csReading in ComponentState) and (FHints.Count = 0) then
    Result := FDefHints else
    Result := FHints;
end;

procedure TTntDBNavigator.HintsChanged(Sender: TObject);
begin
  InitHints;
end;

procedure TTntDBNavigator.InitButtons;
var
  BtnOnClick: TNotifyEvent;
  BtnMouseDown: TMouseEvent;
  i: TNavigateBtn;
  NewButton: TNavButton;
begin
  // Assumes that TDBNavigator.InitButtons has been called previously
  Assert(Length(Buttons) > 0, 'Internal TntDBNavigator Create error');
  BtnOnClick := Buttons[nbFirst].OnClick;
  BtnMouseDown := Buttons[nbFirst].OnMouseDown;
  for i := Low(Buttons) to High(Buttons) do
  begin
    NewButton := TTntNavButton.Create(Self);
    NewButton.Flat := Buttons[i].Flat;
    NewButton.Index := Buttons[i].Index;
    NewButton.Visible := Buttons[i].Visible;
    NewButton.Enabled := False;
    NewButton.SetBounds(Buttons[i].Left, Buttons[i].Top,
      Buttons[i].Width, Buttons[i].Height);
    NewButton.Glyph.Assign(Buttons[i].Glyph);
    NewButton.NumGlyphs := Buttons[i].NumGlyphs;
    NewButton.OnClick := BtnOnClick;
    NewButton.OnMouseDown := BtnMouseDown;
    NewButton.Parent := Self;
    NewButton.Enabled := True;
    NewButton.NavStyle := Buttons[i].NavStyle;
    Buttons[i].Free;
    Buttons[i] := NewButton;
  end;
end;

procedure TTntDBNavigator.InitCaptions;
var
  I: Integer;
  J: TNavigateBtn;
begin
  Assert(Buttons[nbFirst] is TTntNavButton, 'Internal TntDBNavigator InitCaptions error');
  if FShowCaption then
  begin
    for J := Low(Buttons) to High(Buttons) do
    begin
      TTntNavButton(Buttons[J]).Layout := FButtonLayout;
      TTntNavButton(Buttons[J]).Caption := FDefHints[Ord(J)]; // Use the hint values first
    end;
    J := Low(Buttons);
    for I := 0 to (FCaptions.Count - 1) do
    begin
      if FCaptions[I] <> '' then TTntNavButton(Buttons[J]).Caption := FCaptions[I];
      if J = High(Buttons) then Exit;
      Inc(J);
    end;
  end else
  begin
    for J := Low(Buttons) to High(Buttons) do
      TTntNavButton(Buttons[J]).Caption := '';
  end;
end;

procedure TTntDBNavigator.InitHints;
var
  J: TNavigateBtn;
  I: Integer;
begin
  if not Assigned(FDefHints) then
  begin
    FDefHints := TTntStringList.Create;
    for J := Low(Buttons) to High(Buttons) do
      FDefHints.Add(WideLoadResString(BtnHintId[J]));
  end;
  Assert(Buttons[nbFirst] is TTntNavButton, 'Internal TntDBNavigator InitHints error');
  for J := Low(Buttons) to High(Buttons) do
    TTntNavButton(Buttons[J]).Hint := FDefHints[Ord(J)];
  J := Low(Buttons);
  for I := 0 to (FHints.Count - 1) do
  begin
    if FHints[I] <> '' then
      TTntNavButton(Buttons[J]).Hint := FHints[I];
    if J = High(Buttons) then Exit;
    Inc(J);
  end;
end;

procedure TTntDBNavigator.Loaded;
begin
  inherited Loaded;
  InitHints;
end;

procedure TTntDBNavigator.SetButtonLayout(const Value: TButtonLayout);
begin
  FButtonLayout := Value;
  InitCaptions;
end;

procedure TTntDBNavigator.SetCaptions(const Value: TTntStrings);
begin
  FCaptions.Assign(Value)
end;

procedure TTntDBNavigator.SetHints(const Value: TTntStrings);
begin
  FHints.Assign(Value);
end;

procedure TTntDBNavigator.SetShowCaption(const Value: Boolean);
begin
  FShowCaption := Value;
  InitCaptions;
end;

{ TTntDBNavigatorEx }

function TTntDBNavigatorEx.GetNavButton(Btn: TNavigateBtn): TTntNavButton;
begin
  Result := Buttons[Btn] as TTntNavButton;
end;


{ TTntNavButton }

type
  THackSpeedButton = class(TGraphicControl)
  protected
    FxxxxGroupIndex: Integer;
    FGlyph: Pointer;
    FxxxxDown: Boolean;
    FDragging: Boolean;
  end;

function TTntNavButton.GetCaption: TWideCaption;
begin
  Result := TntControl_GetText(Self);
end;

function TTntNavButton.GetButtonGlyph: Pointer;
begin
  Result := THackSpeedButton(Self).FGlyph;
end;

function TTntNavButton.GetHint: WideString;
begin
  Result := TntControl_GetHint(Self);
end;

procedure TTntNavButton.NavButtonPaint;
const
  DownStyles: array[Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER);
  FillStyles: array[Boolean] of Integer = (BF_MIDDLE, 0);
var
  PaintRect: TRect;
  DrawFlags: Integer;
  Offset: TPoint;
{$IFDEF COMPILER_7_UP}
  Button: TThemedButton;
  ToolButton: TThemedToolBar;
  Details: TThemedElementDetails;
{$ENDIF}
begin
  try
    if not Enabled then
    begin
      FState := bsDisabled;
      THackSpeedButton(Self).FDragging := False;
    end
    else if FState = bsDisabled then
      if Down and (GroupIndex <> 0) then
        FState := bsExclusive
      else
        FState := bsUp;
    Canvas.Font := Self.Font;

{$IFDEF COMPILER_7_UP}
    if ThemeServices.ThemesEnabled then
    begin
      PerformEraseBackground(Self, Canvas.Handle);
      SelectObject(Canvas.Handle, Canvas.Font.Handle); { For some reason, PerformEraseBackground sometimes messes the font up. }

      if not Enabled then
        Button := tbPushButtonDisabled
      else
        if FState in [bsDown, bsExclusive] then
          Button := tbPushButtonPressed
        else
          if MouseInControl then
            Button := tbPushButtonHot
          else
            Button := tbPushButtonNormal;

      ToolButton := ttbToolbarDontCare;
      if Flat then
      begin
        case Button of
          tbPushButtonDisabled:
            Toolbutton := ttbButtonDisabled;
          tbPushButtonPressed:
            Toolbutton := ttbButtonPressed;
          tbPushButtonHot:
            Toolbutton := ttbButtonHot;
          tbPushButtonNormal:
            Toolbutton := ttbButtonNormal;
        end;
      end;

      PaintRect := ClientRect;
      if ToolButton = ttbToolbarDontCare then
      begin
        Details := ThemeServices.GetElementDetails(Button);
        ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect);
        PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect);
      end
      else
      begin
        Details := ThemeServices.GetElementDetails(ToolButton);
        ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect);
        PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect);
      end;

      if Button = tbPushButtonPressed then
      begin
        // A pressed speed button has a white text. This applies however only to flat buttons.
        if ToolButton <> ttbToolbarDontCare then
          Canvas.Font.Color := clHighlightText;
        Offset := Point(1, 0);