flatutilitys.pas

FlatStyle控件

unit FlatUtilitys;

interface

{$I Version.inc}

uses Windows, Classes, Graphics, Buttons;

type
  TColorCalcType = (lighten, darken);
  TCheckBoxLayout = (checkboxLeft, checkboxRight);
  TRadioButtonLayout = (radioLeft, radioRight);
  {$IFNDEF D4CB4}
  TProgressBarOrientation = (pbHorizontal, pbVertical);
  {$ENDIF}
  TFlatTabPosition = (tpTop, tpBottom);
  TArrowPos = (NE, NW, SE, SW);
  TNumGlyphs = 1..4;
  TAdvColors = 0..100;
  THLSValue = 0..240;
  THLSVector = record
    Hue:	THLSValue;
    Luminance:	THLSValue;
    Saturation:	THLSValue;
  end;

function CreateDisabledBitmap (FOriginal: TBitmap; OutlineColor, BackColor, HighlightColor, ShadowColor: TColor; DrawHighlight: Boolean): TBitmap;

function RGBtoHLS (RGBColor: TColorRef): THLSVector;
function HLStoRGB (Hue, Luminance, Saturation: THLSValue): TColorRef;

function CalcAdvancedColor (ParentColor, OriginalColor: TColor; Percent: Byte; ColorType: TColorCalcType): TColor;
procedure CalcButtonLayout (Canvas: TCanvas; const Client: TRect; const Offset: TPoint; Layout: TButtonLayout;
  Spacing, Margin: Integer; FGlyph: TBitmap; FNumGlyphs: Integer;
  const Caption: string; var TextBounds: TRect; var GlyphPos: TPoint);
function Min(val1, val2: Word): Word;
function GetFontMetrics(Font: TFont): TTextMetric;
function GetFontHeight(Font: TFont): Integer;
function RectInRect(R1, R2: TRect): Boolean;

implementation

const
  HLSMAX = High(THLSValue);
  RGBMAX = 255;
  UNDEFINED = HLSMAX*2 div 3;

function CreateDisabledBitmap(FOriginal: TBitmap; OutlineColor, BackColor, HighlightColor, ShadowColor: TColor; DrawHighlight: Boolean): TBitmap;
const
  ROP_DSPDxax = $00E20746;
var
  MonoBmp: TBitmap;
  IRect: TRect;
begin
  IRect := Rect(0, 0, FOriginal.Width, FOriginal.Height);
  Result := TBitmap.Create;
  try
    Result.Width := FOriginal.Width;
    Result.Height := FOriginal.Height;
    MonoBmp := TBitmap.Create;
    try
      with MonoBmp do begin
        Width := FOriginal.Width;
        Height := FOriginal.Height;
        Canvas.CopyRect(IRect, FOriginal.Canvas, IRect);
{$IFDEF D4CB4}
        HandleType := bmDDB;
{$ENDIF}
        Canvas.Brush.Color := OutlineColor;
        if Monochrome then begin
          Canvas.Font.Color := clWhite;
          Monochrome := False;
          Canvas.Brush.Color := clWhite;
        end;
        Monochrome := True;
      end;
      with Result.Canvas do begin
        Brush.Color := BackColor;
        FillRect(IRect);
        if DrawHighlight then begin
          Brush.Color := HighlightColor;
          SetTextColor(Handle, clBlack);
          SetBkColor(Handle, clWhite);
          BitBlt(Handle, 1, 1, IRect.Right - IRect.Left, IRect.Bottom - IRect.Top, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
        end;
        Brush.Color := ShadowColor;
        SetTextColor(Handle, clBlack);
        SetBkColor(Handle, clWhite);
        BitBlt(Handle, 0, 0, IRect.Right - IRect.Left, IRect.Bottom - IRect.Top, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
      end;
    finally
      MonoBmp.Free;
    end;
  except
    Result.Free;
    raise;
  end;
end;

function RGBtoHLS (RGBColor: TColorRef): THLSVector;
var
  R, G, B: Integer; // input RGB values
  H, L, S: Integer;
  cMax, cMin: Byte; // max and min RGB values
  Rdelta, Gdelta, Bdelta: Integer; // intermediate value: % of spread from max
begin
  // get R, G, and B out of DWORD
  R := GetRValue(RGBColor);
  G := GetGValue(RGBColor);
  B := GetBValue(RGBColor);

  // calculate lightness
  cMax := R;
  if G > cMax then cMax := G;
  if B > cMax then cMax := B;

  cMin := R;
  if G < cMin then cMin := G;
  if B < cMin then cMin := B;

  L := ( ((cMax+cMin)*HLSMAX) + RGBMAX ) div (2*RGBMAX);

  if (cMax = cMin) then // r=g=b --> achromatic case
  begin
    S := 0;          // saturation
    H := UNDEFINED;  // hue
  end
  else
  begin
    // chromatic case
    // saturation
    if L <= (HLSMAX div 2) then
      S := ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin) div 2) )  div  (cMax+cMin)
    else
      S := ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin) div 2) ) div (2*RGBMAX-cMax-cMin);

    // hue
    Rdelta := ( ((cMax-R)*(HLSMAX div 6)) + ((cMax-cMin) div 2) ) div (cMax-cMin);
    Gdelta := ( ((cMax-G)*(HLSMAX div 6)) + ((cMax-cMin) div 2) ) div (cMax-cMin);
    Bdelta := ( ((cMax-B)*(HLSMAX div 6)) + ((cMax-cMin) div 2) ) div (cMax-cMin);

    if R = cMax then
      H := Bdelta - Gdelta
    else
      if G = cMax then
        H := (HLSMAX div 3) + Rdelta - Bdelta
      else // B = cMax
        H := ((2*HLSMAX) div 3) + Gdelta - Rdelta;

    H := H mod HLSMAX;
    if H < 0 then
      Inc(H, HLSMAX);
  end;
  Result.Hue        := H;
  Result.Luminance  := L;
  Result.Saturation := S;
end;

// utility routine for HLStoRGB
function HueToRGB (n1, n2, hue: Integer): Integer;
begin
  Hue := Hue mod HLSMAX;
  // range check: note values passed add div subtract thirds of range
  if hue < 0 then
    Inc(hue, HLSMAX);

  // return r,g, or b value from this tridrant
  if hue < (HLSMAX div 6) then
    Result := ( n1 + (((n2-n1)*hue+(HLSMAX div 12)) div (HLSMAX div 6)) )
  else
    if hue < (HLSMAX div 2) then
      Result := n2
    else
      if hue < ((HLSMAX*2) div 3) then
        Result := ( n1 + (((n2-n1)*(((HLSMAX*2) div 3)-hue)+(HLSMAX div 12)) div (HLSMAX div 6)))
      else
        Result := n1;
end;

function HLStoRGB (Hue, Luminance, Saturation: THLSValue): TColorRef;
var
  R, G, B: Integer; // RGB component values
  Magic1, Magic2: Integer; // calculated magic numbers (really!)
begin
  if Saturation = 0 then // achromatic case
  begin
    R :=(Luminance*RGBMAX) div HLSMAX;
     G := R;
     B := R;
     if Hue <> UNDEFINED then
     begin
       // ERROR
     end
  end
  else
  begin
    // chromatic case
    // set up magic numbers
    if (Luminance <= (HLSMAX div 2)) then
      Magic2 := (Luminance*(HLSMAX + Saturation) + (HLSMAX div 2)) div HLSMAX
    else
      Magic2 := Luminance + Saturation - ((Luminance*Saturation) + (HLSMAX div 2)) div HLSMAX;
    Magic1 := 2*Luminance-Magic2;
    // get RGB, change units from HLSMAX to RGBMAX
    R := (HueToRGB(Magic1, Magic2, Hue+(HLSMAX div 3))*RGBMAX +(HLSMAX div 2)) div HLSMAX;
    G := (HueToRGB(Magic1, Magic2, Hue)               *RGBMAX +(HLSMAX div 2)) div HLSMAX;
    B := (HueToRGB(Magic1, Magic2, Hue-(HLSMAX div 3))*RGBMAX +(HLSMAX div 2)) div HLSMAX;
  end;
  Result :=  RGB(R, G, B);
end;

function CalcAdvancedColor (ParentColor, OriginalColor: TColor; Percent: Byte; ColorType: TColorCalcType): TColor;
var
  HLS: THLSVector;
begin
  if Percent <> 0 then
  begin
    HLS := RGBtoHLS(ColorToRGB(ParentColor));

    if ColorType = lighten then
      if HLS.Luminance + Percent > 234 then
        HLS.Luminance := 234
      else
        HLS.Luminance := HLS.Luminance + Percent
    else
      if HLS.Luminance - Percent < 0 then
        HLS.Luminance := 0
      else
        HLS.Luminance := HLS.Luminance - Percent;

    Result := HLStoRGB(HLS.Hue, HLS.Luminance, HLS.Saturation);
  end
  else
    Result := OriginalColor;
end;

procedure CalcButtonLayout (Canvas: TCanvas; const Client: TRect; const Offset: TPoint; Layout: TButtonLayout;
  Spacing, Margin: Integer; FGlyph: TBitmap; FNumGlyphs: Integer;
  const Caption: string; var TextBounds: TRect; var GlyphPos: TPoint);
var
  TextPos: TPoint;
  ClientSize, GlyphSize, TextSize: TPoint;
  TotalSize: TPoint;
begin
  // calculate the item sizes
  ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top);

  if FGlyph <> nil then
    GlyphSize := Point(FGlyph.Width div FNumGlyphs, FGlyph.Height)
  else
    GlyphSize := Point(0, 0);

  if Length(Caption) > 0 then
    begin
      TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
      DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CALCRECT or DT_SINGLELINE);
      TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom - TextBounds.Top);
    end
  else
    begin
      TextBounds := Rect(0, 0, 0, 0);
      TextSize := Point(0, 0);
    end;

  // If the layout has the glyph on the right or the left, then both the
  // text and the glyph are centered vertically.  If the glyph is on the top
  // or the bottom, then both the text and the glyph are centered horizontally.
  if Layout in [blGlyphLeft, blGlyphRight] then
  begin
    GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
    TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
  end
  else
  begin
    GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;
    TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
  end;

  // if there is no text or no bitmap, then Spacing is irrelevant
  if (TextSize.X = 0) or (GlyphSize.X = 0) then
    Spacing := 0;

  // adjust Margin and Spacing
  if Margin = -1 then
  begin
    if Spacing = -1 then
    begin
      TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
      if Layout in [blGlyphLeft, blGlyphRight] then
        Margin := (ClientSize.X - TotalSize.X) div 3
      else
        Margin := (ClientSize.Y - TotalSize.Y) div 3;
      Spacing := Margin;
    end
    else
    begin
      TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y + Spacing + TextSize.Y);
      if Layout in [blGlyphLeft, blGlyphRight] then
        Margin := (ClientSize.X - TotalSize.X + 1) div 2
      else
        Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
    end;
  end
  else
  begin
    if Spacing = -1 then
    begin
      TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y - (Margin + GlyphSize.Y));
      if Layout in [blGlyphLeft, blGlyphRight] then
        Spacing := (TotalSize.X - TextSize.X) div 2
      else
        Spacing := (TotalSize.Y - TextSize.Y) div 2;
    end;
  end;

  case Layout of
    blGlyphLeft:
    begin
      GlyphPos.X := Margin;
      TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
    end;
    blGlyphRight:
    begin
      GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;
      TextPos.X := GlyphPos.X - Spacing - TextSize.X;
    end;
    blGlyphTop:
    begin
      GlyphPos.Y := Margin;
      TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
    end;
    blGlyphBottom:
    begin
      GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
      TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
    end;
  end;

  // fixup the result variables
  with GlyphPos do
  begin
    Inc(X, Client.Left + Offset.X);
    Inc(Y, Client.Top + Offset.Y);
  end;
  OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X, TextPos.Y + Client.Top + Offset.X);
end;

function Min(val1, val2: Word): Word;
begin
  Result := val1;
  if val1 > val2 then
    Result := val2;
end;

function GetFontMetrics(Font: TFont): TTextMetric;
var
  DC: HDC;
  SaveFont: HFont;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Result);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
end;

function GetFontHeight(Font: TFont): Integer;
begin
  with GetFontMetrics(Font) do
    Result := Round(tmHeight + tmHeight / 8);
end;

function RectInRect(R1, R2: TRect): Boolean;
begin
  Result := IntersectRect(R1, R1, R2);
end;

end.