rxgrdcpt.pas

RX Library contains a large number of components, objects and routines for Borland Delphi with full

    Canvas := TCanvas.Create;
    try
      Canvas.Handle := PS.hDC;
      Canvas.Font := FFont;
      Result := Canvas.TextWidth(FCaption);
    finally
      Canvas.Free;
    end;
  finally
    EndPaint(Application.Handle, PS);
  end;
end;

procedure TRxCaption.SetVisible(Value: Boolean);
begin
  if FVisible <> Value then begin
    FVisible := Value;
    Changed(False);
  end;
end;

procedure TRxCaption.SetInactiveColor(Value: TColor);
begin
  if FInactiveColor <> Value then begin
    FInactiveColor := Value;
    if (GradientCaption = nil) or not GradientCaption.FWindowActive then
      Changed(False);
  end;
end;

procedure TRxCaption.SetGlueNext(Value: Boolean);
begin
  if FGlueNext <> Value then begin
    FGlueNext := Value;
    Changed(False);
  end;
end;

{$IFNDEF RX_D4}
const
  COLOR_GRADIENTACTIVECAPTION   =    27;
  COLOR_GRADIENTINACTIVECAPTION =    28;
  SPI_GETGRADIENTCAPTIONS       = $1008;
{$ENDIF}

const
  clGradientActiveCaption = TColor(COLOR_GRADIENTACTIVECAPTION or $80000000);
  clGradientInactiveCaption = TColor(COLOR_GRADIENTINACTIVECAPTION or $80000000);

function SysGradient: Boolean;
var
  Info: BOOL;
begin
  if SystemParametersInfo(SPI_GETGRADIENTCAPTIONS, SizeOf(Info), @Info, 0) then
    Result := Info
  else Result := False;
end;

{ TRxGradientCaption }

constructor TRxGradientCaption.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FGradientSteps := 64;
  FGradientActive := True;
  FActive := True;
  FCaptions := TRxCaptionList.Create(Self);
  FWinHook := TRxWindowHook.Create(Self);
  FWinHook.BeforeMessage := BeforeMessage;
  FWinHook.AfterMessage := AfterMessage;
  FStartColor := clWindowText;
  FFontInactiveColor := clInactiveCaptionText;
  FFormCaption := '';
  FFont := TFont.Create;
  SetFontDefault;
end;

destructor TRxGradientCaption.Destroy;
begin
  FOnDeactivate := nil;
  FOnActivate := nil;
  if not (csDesigning in ComponentState) then
    ReleaseHook;
  FCaptions.Free;
  FCaptions := nil;
  FFont.Free;
  FFont := nil;
  inherited Destroy;
end;

procedure TRxGradientCaption.Loaded;
var
  Loading: Boolean;
begin
  Loading := csLoading in ComponentState;
  inherited Loaded;
  if not (csDesigning in ComponentState) then begin
    if Loading and (Owner is TCustomForm) then Update;
  end;
end;

procedure TRxGradientCaption.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = PopupMenu) and (Operation = opRemove) then
    PopupMenu := nil;
end;

procedure TRxGradientCaption.SetPopupMenu(Value: TPopupMenu);
begin
  FPopupMenu := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

procedure TRxGradientCaption.SetCaptions(Value: TRxCaptionList);
begin
  Captions.Assign(Value);
end;

procedure TRxGradientCaption.SetDefaultFont(Value: Boolean);
begin
  if FDefaultFont <> Value then begin
    if Value then SetFontDefault;
    FDefaultFont := Value;
    if Active then Update;
  end;
end;

procedure TRxGradientCaption.SetFontDefault;
var
  NCMetrics: TNonClientMetrics;
begin
  with FFont do begin
    OnChange := nil;
    try
      NCMetrics.cbSize := SizeOf(NCMetrics);
      if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NCMetrics, 0) then
      begin
        if (Owner is TForm) and
          ((Owner as TForm).BorderStyle in [bsToolWindow, bsSizeToolWin]) then
          Handle := CreateFontIndirect(NCMetrics.lfSmCaptionFont)
        else
          Handle := CreateFontIndirect(NCMetrics.lfCaptionFont);
      end
      else begin
        Name := 'MS Sans Serif';
        Size := 8;
        Style := [fsBold];
      end;
      Color := clCaptionText;
{$IFNDEF VER90}
      Charset := DEFAULT_CHARSET;
{$ENDIF}
    finally
      OnChange := FontChanged;
    end;
  end;
  FDefaultFont := True;
end;

function TRxGradientCaption.IsFontStored: Boolean;
begin
  Result := not DefaultFont;
end;

function TRxGradientCaption.GetForm: TForm;
begin
  if Owner is TCustomForm then
    Result := TForm(Owner as TCustomForm)
  else
    Result := nil;
end;

function TRxGradientCaption.GetFormCaption: string;
begin
  if (Form <> nil) and (csDesigning in ComponentState) then
    FFormCaption := Form.Caption;
  Result := FFormCaption;
end;

procedure TRxGradientCaption.SetFormCaption(const Value: string);
begin
  if FFormCaption <> Value then begin
    FFormCaption := Value;
    if (Form <> nil) and (csDesigning in ComponentState) then
      Form.Caption := FFormCaption;
    if Active then Update;
  end;
end;

procedure TRxGradientCaption.SetHook;
begin
  if not (csDesigning in ComponentState) and (Owner <> nil) and
    (Owner is TCustomForm) then
    FWinHook.WinControl := Form;
end;

procedure TRxGradientCaption.ReleaseHook;
begin
  FWinHook.WinControl := nil;
end;

procedure TRxGradientCaption.CheckToggleHook;
begin
  if Active then SetHook
  else ReleaseHook;
end;

function TRxGradientCaption.CheckMenuPopup(X, Y: Integer): Boolean;
begin
  Result := False;
  if not (csDesigning in ComponentState) and Assigned(FPopupMenu) and
    FPopupMenu.AutoPopup then
  begin
    FPopupMenu.PopupComponent := Self;
    if Form <> nil then begin
      Form.SendCancelMode(nil);
      FPopupMenu.Popup(X, Y);
      Result := True;
    end;
  end;
end;

procedure TRxGradientCaption.BeforeMessage(Sender: TObject; var Msg: TMessage;
  var Handled: Boolean);
var
  DrawRgn: HRgn;
  R: TRect;
  Icons: TBorderIcons;
begin
  if Active then begin
    case Msg.Msg of
      WM_NCACTIVATE:
        begin
          FWindowActive := (Msg.wParam <> 0);
        end;
      WM_NCRBUTTONDOWN:
        if Assigned(FPopupMenu) and FPopupMenu.AutoPopup then begin
          FClicked := True;
          Msg.Result := 0;
          Handled := True;
        end;
      WM_NCRBUTTONUP:
        with TWMMouse(Msg) do
          if FClicked then begin
            FClicked := False;
            if CheckMenuPopup(XPos, YPos) then begin
              Result := 0;
              Handled := True;
            end;
          end;
      WM_NCPAINT:
        begin
          FSaveRgn := Msg.wParam;
          FRgnChanged := False;
          CalculateGradientParams(R, Icons);
          if RectInRegion(FSaveRgn, R) then begin
            DrawRgn := CreateRectRgn(R.Left, R.Top, R.Right, R.Bottom);
            try
              Msg.WParam := CreateRectRgn(0, 0, 1, 1);
              FRgnChanged := True;
              CombineRgn(Msg.WParam, FSaveRgn, DrawRgn, RGN_DIFF);
            finally
              DeleteObject(DrawRgn);
            end;
          end;
        end;
    end;
  end;
end;

procedure TRxGradientCaption.AfterMessage(Sender: TObject; var Msg: TMessage;
  var Handled: Boolean);
var
  DC: HDC;
  S: string;
begin
  if Active then begin
    case Msg.Msg of
      WM_NCACTIVATE:
        begin
          DC := GetWindowDC(Form.Handle);
          try
            DrawGradientCaption(DC);
          finally
            ReleaseDC(Form.Handle, DC);
          end;
        end;
      WM_NCPAINT:
        begin
          if FRgnChanged then begin
            DeleteObject(Msg.WParam);
            Msg.WParam := FSaveRgn;
            FRgnChanged := False;
          end;
          DC := GetWindowDC(Form.Handle);
          try
            DrawGradientCaption(DC);
          finally
            ReleaseDC(Form.Handle, DC);
          end;
        end;
      WM_GETTEXT:
        { Delphi doesn't send WM_SETTEXT to form's window procedure,
          so we need to handle WM_GETTEXT to redraw non-client area
          when form's caption changed }
        begin
          if csDesigning in ComponentState then begin
            SetString(S, PChar(Msg.LParam), Msg.Result);
            if AnsiCompareStr(S, FFormCaption) <> 0 then begin
              FormCaption := S;
              PostMessage(Form.Handle, WM_NCPAINT, 0, 0);
            end;
          end;
        end;
    end;
  end;
end;

procedure TRxGradientCaption.SetStartColor(Value: TColor);
begin
  if FStartColor <> Value then begin
    FStartColor := Value;
    if Active then Update;
  end;
end;

function TRxGradientCaption.GetActive: Boolean;
begin
  Result := FActive;
  if not (csDesigning in ComponentState) then
    Result := Result and NewStyleControls and (Owner is TCustomForm);
end;

procedure TRxGradientCaption.SetActive(Value: Boolean);
begin
  if FActive <> Value then begin
    FActive := Value;
    FClicked := False;
    Update;
    if ([csDestroying, csReading] * ComponentState = []) then begin
      if FActive then begin
        if Assigned(FOnActivate) then FOnActivate(Self);
      end
      else begin
        if Assigned(FOnDeactivate) then FOnDeactivate(Self);
      end;
    end;
  end;
end;

procedure TRxGradientCaption.Clear;
begin
  if FCaptions <> nil then FCaptions.Clear;
end;

procedure TRxGradientCaption.MoveCaption(FromIndex, ToIndex: Integer);
begin
  Captions[FromIndex].Index := ToIndex;
end;