Project JEDI - Issue Tracker
Mantis Bugtracker

Viewing Issue Simple Details Jump to Notes ] View Advanced ] Issue History ] Print ]
ID Category Severity Reproducibility Date Submitted Last Update
0006105 [JEDI VCL] 00 JVCL Components minor always 2013-03-17 22:30 2014-12-04 16:26
Reporter Dec View Status public  
Assigned To obones
Priority normal Resolution suspended  
Status resolved   Product Version
Summary 0006105: TJvCheckBox.CalcAutoSize
Description In some Windows themes checkboxes (and radiobutton) has its own font. Even if you assign the font you want to see nothing changes and Windows paint control with its "personal" font. In this case procedure TJvCheckBox.CalcAutoSize calculates wrong size because it use font assigned by user but must use "personal" font of control. There is a screenshot in the attached file which show current result of TJvCheckBox.CalcAutoSize and result of function which I want to offer. My source code in the Additional Information.
Additional Information function _CalcAutoSize(AControl: TControl; ACanvas: TCanvas; const ACaption: string; AWordWrap: Boolean; APartID, AStateID: Integer): Boolean;
const Flags: array [Boolean] of Cardinal = (DT_SINGLELINE, DT_WORDBREAK);

var ASize: TSize;

  procedure Process;
  var R: TRect;
      AWidth, AHeight: Integer;
  begin
    R := Rect(0, 0, AControl.ClientWidth, AControl.ClientHeight);
    if ACaption <> '' then
      begin
        DrawText(ACanvas.Handle, ACaption, -1, R,
          Flags[AWordWrap] or DT_LEFT or DT_NOCLIP or DT_CALCRECT);
        AWidth := (R.Right - R.Left) + ASize.cx + 4;
        AHeight := R.Bottom - R.Top;
      end
    else
      begin
        AWidth := ASize.cx;
        AHeight := ASize.cy;
      end;
    if AWidth < ASize.cx then
      AWidth := ASize.cx;
    if AHeight < ASize.cy then
      AHeight := ASize.cy;
    AControl.ClientWidth := AWidth;
    AControl.ClientHeight := AHeight;
    Result := True;
  end;

var Font: TLogFont;
    HF: HFONT;
    Save: TFont;
begin
  Result := False;
  if StyleServices.Enabled and (StyleServices is TUxThemeStyle) then
    begin
      if GetThemePartSize(StyleServices.Theme[teButton], ACanvas.Handle, APartID, AStateID, nil, TS_TRUE, ASize) <> S_OK then
        ASize := GetDefaultCheckBoxSize;
      Inc(ASize.cy, 4);

      if GetThemeFont(TUxThemeStyle(StyleServices).Theme[teButton], ACanvas.Handle, APartID, AStateID, TMT_FONT, Font) = S_OK then
        begin
          HF := CreateFontIndirect(Font);
          if HF <> 0 then
            begin
              Save := TFont.Create;
              try
                Save.Assign(ACanvas.Font);
                try
                  ACanvas.Font.Handle := HF;
                  Process;
                finally
                  ACanvas.Font := Save;
                end;
              finally
                Save.Free;
              end;
            end;
        end
      else
        Process;
    end;
end;

procedure TJvdecCheckBox.CalcAutoSize;
begin
  if (Parent = nil) or not AutoSize or (csDestroying in ComponentState) or (csLoading in ComponentState) then Exit;

  if not _CalcAutoSize(Self, Canvas, Caption, WordWrap, BP_CHECKBOX, CBS_CHECKEDNORMAL) then
    inherited CalcAutoSize;
end;

procedure TJvdecRadioButton.CalcAutoSize;
begin
  if (Parent = nil) or not AutoSize or (csDestroying in ComponentState) or (csLoading in ComponentState) then Exit;

  if not _CalcAutoSize(Self, Canvas, Caption, WordWrap, BP_RADIOBUTTON, CBS_CHECKEDNORMAL) then
    inherited CalcAutoSize;
end;
Tags No tags attached.
Attached Files gif file icon Gif.gif [^] (1,908 bytes) 2013-03-17 22:30

- Relationships

-  Notes
(0020715)
obones (administrator)
2013-12-13 10:47

Please try with the latest JVCL version in GIT (or daily zip) and then send us a zipped file containing the sources of an application showing the issue.
(0021096)
obones (administrator)
2014-12-04 16:26

No news, suspending the issue

- Issue History
Date Modified Username Field Change
2013-03-17 22:30 Dec New Issue
2013-03-17 22:30 Dec File Added: Gif.gif
2013-03-17 22:32 Dec Issue Monitored: Dec
2013-12-13 10:47 obones Note Added: 0020715
2013-12-13 10:47 obones Status new => feedback
2014-12-04 16:26 obones Note Added: 0021096
2014-12-04 16:26 obones Status feedback => resolved
2014-12-04 16:26 obones Resolution open => suspended
2014-12-04 16:26 obones Assigned To => obones


Mantis 1.1.6[^]
Copyright © 2000 - 2008 Mantis Group
Powered by Mantis Bugtracker