View Issue Details

IDProjectCategoryView StatusLast Update
0006105JEDI VCL00 JVCL Componentspublic2014-12-04 16:26
ReporterDecAssigned Toobones 
PrioritynormalSeverityminorReproducibilityalways
Status resolvedResolutionsuspended 
Product Version 
Target VersionFixed in Version 
Summary0006105: TJvCheckBox.CalcAutoSize
DescriptionIn 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 Informationfunction _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;
TagsNo tags attached.

Activities

2013-03-17 22:30

 

Gif.gif (1,908 bytes)
Gif.gif (1,908 bytes)

obones

2013-12-13 10:47

administrator   ~0020715

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.

obones

2014-12-04 16:26

administrator   ~0021096

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-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