XPスタイルで色設定 (ID:37428)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

裕子：「こんにちは〜、マコト居る？」
真琴：「えっ？ あ、ユウコかぁ、…遊びにきたの？」
裕子：「ナニよ、誰か待ってたの？ …ねぇマコト、この前のアレ、ユウスケに教えてあげたら、"3色だけじゃつまらない、それに試したら色も違うし、エラーも出る"だって」
真琴：「え？ そう？ 何のエラー？ 使ってるDelphiのバージョンは？」
裕子：「バージョン？ ユウスケが使ってるのは、たしか…D6のPersonalとか」
真琴：「あぁ〜、ソレねぇ、Windows.pasのTTriVertexの定義に間違いがあるの」
裕子：「間違い？ どんな？」
真琴：「メンバーのRed,Greenなどの型がナゼかShortInt、ホントはWORDじゃないと…」

COLOR16 = Shortint;  // ShortIntは間違いで、WORDが正しい

_TRIVERTEX = packed record
    x: Longint;
    y: Longint;
    Red: COLOR16;
    Green: COLOR16;
    Blue: COLOR16;
    Alpha: COLOR16;
  end;
  TTriVertex = _TRIVERTEX;

真琴：「だから、TriVertex[0].Red:=$7800;とか書くと"定数値が範囲外"のエラーも」
裕子：「じゃあ、Windows.pasの間違い部分を書き換えないとダメなの？」
真琴：「うん、そうしてもイイけど、自分のユニットで正しく定義し直してもＯＫ」
裕子：「あ、そう、…あと、ボタンの色は3種類じゃなくて、もっと増やせないの？」
真琴：「色は TColorで指定するように変更したから自由な色が使えるようになったよ」

http://makoto.me.land.to/img/snapshot2.png

【Delphi7以前で、ThemeManagerとマニフェストファイルを使う場合】

uses ..., ThemeMgr, ThemeSrv;

type
  TButton = class(StdCtrls.TButton)
  private
    FButton: TThemedButton;
    FBtnColor: TColor;
    FBgnColor: TColor;
    FEndColor: TColor;
    procedure WndProc(var Msg: TMessage); override;
    procedure SetBtnColor(Value: TColor);
    procedure DrawButton;
  published
    property BtnColor: TColor read FBtnColor write SetBtnColor;
  public
    constructor Create(AOwner: TComponent); override;
  end;
type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    .............

implementation

type
 TGradientDirection = (gdHorizontal, gdVertical);

type
  PTriVertex = ^TTriVertex;
  TTriVertex = packed record
    X, Y: LongInt;
    Red, Green, Blue, Alpha: WORD;
  end;
  TRIVERTEX = TTriVertex;
  _TRIVERTEX = TTriVertex;

function GradientFill(DC: HDC; var Vertex: TTriVertex; NumVertex: ULONG; Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall;
external 'GDI32.DLL' name 'GdiGradientFill';

function ColorRGBToHLS(clrRGB: TColorRef; var Hue, Luminance, Saturation: Word): BOOL; stdcall;
external 'SHLWAPI.DLL' name 'ColorRGBToHLS';

//function ColorHLSToRGB(Hue, Luminance, Saturation: Word): TColorRef; stdcall;
//external 'SHLWAPI.DLL' name 'ColorHLSToRGB';

threadvar
  CachedRGBToHLSclrRGB: TColorRef;
  CachedRGBToHLSHue: WORD;
  CachedRGBToHLSLum: WORD;
  CachedRGBToHLSSat: WORD;

const
  HLSMAX = 240;
  RGBMAX = 255;
  HLSUndefined = (HLSMAX*2/3);

function HueToRGB(Lum, Sat, Hue: Double): Integer;
var
  ResultEx: Double;
begin
  if (hue < 0) then hue := hue + HLSMAX;
  if (hue > HLSMAX) then hue := hue - HLSMAX;
  if (hue < (HLSMAX/6)) then
   ResultEx := Lum + (((Sat-Lum)*hue+(HLSMAX/12))/(HLSMAX/6))
  else if (hue < (HLSMAX/2)) then
   ResultEx := Sat
  else if (hue < ((HLSMAX*2)/3)) then
   ResultEx := Lum + (((Sat-Lum)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6))
  else
   ResultEx := Lum;
  result := Round(ResultEx);
end;

function ColorHLSToRGB(Hue, Luminance, Saturation: Word): TColorRef;
  function RoundColor(Value: Double): Integer;
  begin
   if Value > 255 then result := 255 else result := Round(Value);
  end;
var
  R,G,B: Double;
  Magic1,Magic2: Double;
begin
  if (Saturation = 0) then begin
   R := (Luminance * RGBMAX) / HLSMAX;
   G := R;
   B := R;
   if (Hue <> HLSUndefined) then ; // ERROR
  end else begin
   if (Luminance <= (HLSMAX/2)) then
    Magic2 := (Luminance * (HLSMAX + Saturation) + (HLSMAX/2)) / HLSMAX
   else
    Magic2 := Luminance + Saturation - ((Luminance * Saturation) + (HLSMAX/2)) / HLSMAX;
   Magic1 := 2 * Luminance - Magic2;
   R := (HueToRGB(Magic1,Magic2,Hue+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX;
   G := (HueToRGB(Magic1,Magic2,Hue)*RGBMAX + (HLSMAX/2)) / HLSMAX;
   B := (HueToRGB(Magic1,Magic2,Hue-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX;
  end;
  result := RGB(RoundColor(R), RoundColor(G), RoundColor(B));
end;

procedure GradientFillCanvas(Canvas: TCanvas; StartColor, EndColor: TColor;
  const ARect: TRect; Direction: TGradientDirection);
const
  cGradientDirections: array[TGradientDirection] of Cardinal =
  (GRADIENT_FILL_RECT_H, GRADIENT_FILL_RECT_V);
var
  Vertexes: array[0..1] of TTriVertex;
  GradientRect: TGradientRect;
begin
  Vertexes[0].x := aRect.Left;
  Vertexes[0].y := aRect.Top;
  Vertexes[0].Red   := (StartColor and $FF) shl 8;
  Vertexes[0].Green := (StartColor and $FF00);
  Vertexes[0].Blue  := (StartColor and $FF0000) shr 8;
  Vertexes[0].Alpha := 0;

Vertexes[1].x := aRect.Right;
  Vertexes[1].y := aRect.Bottom;
  Vertexes[1].Red   := (EndColor and $FF) shl 8;
  Vertexes[1].Green := (EndColor and $FF00);
  Vertexes[1].Blue  := (EndColor and $FF0000) shr 8;
  Vertexes[1].Alpha := 0;

GradientRect.UpperLeft:=0;
  GradientRect.LowerRight:=1;

GradientFill(Canvas.Handle, Vertexes[0], 2, @GradientRect, 1, cGradientDirections[Direction]);
end;

constructor TButton.Create(AOwner: TComponent);
begin
  inherited;
  FButton := tbPushButtonNormal;
  FBtnColor := $ffddff;
  SetBtnColor(FBtnColor);
end;

procedure TButton.WndProc(var Msg: TMessage);
begin
  inherited;
  case Msg.Msg of
   WM_PAINT: DrawButton;
   WM_MOUSEMOVE: FButton := tbPushButtonHot;
   WM_LBUTTONDOWN: FButton := tbPushButtonPressed;
   WM_LBUTTONUP: FButton := tbPushButtonHot;
   WM_MOUSELEAVE: FButton := tbPushButtonNormal;
  end;
end;

procedure TButton.SetBtnColor(Value: TColor);
var
  H, L, S: WORD;
begin
  ColorRGBToHLS(Value, H, L, S);
  FBgnColor := ColorHLSToRGB(H, L+45, S);
  FEndColor := ColorHLSToRGB(H, L-45, S);
end;

procedure TButton.DrawButton;
var
  R: TRect;
  Detail: TThemedElementDetails;
  c3, c4: TColor;
  DC: HDC;
  aCanvas: TCanvas;
  H, L, S: WORD;
begin
  if not(ThemeServices.ThemesEnabled) then exit;

ColorRGBToHLS(FBgnColor, H, L, S);
  c3 := ColorHLSToRGB(H, L+12, S);
  ColorRGBToHLS(FEndColor, H, L, S);
  c4 := ColorHLSToRGB(H, L+12, S);

DC := GetDC(Self.Handle);
  aCanvas := TCanvas.Create;
  aCanvas.Handle := DC;
  aCanvas.Font.Assign(Self.Font);
  R := ClientRect;
  if not Enabled then FButton := tbPushButtonDisabled;
  Detail := ThemeServices.GetElementDetails(FButton);
//  InflateRect(R, -3, -3);
  R := ThemeServices.ContentRect(aCanvas.Handle, Detail, R);
  if Focused or (FButton = tbPushButtonHot) then InflateRect(R, -1, -1);
  case FButton of
   // 通常のボタン状態
   tbPushButtonNormal   : GradientFillCanvas(aCanvas, FBgnColor, FEndColor, R, gdVertical);
   // マウスがボタン上にある
   tbPushButtonHot      : GradientFillCanvas(aCanvas, c3, c4, R, gdVertical);
   // ボタンが押されている
   tbPushButtonPressed  : GradientFillCanvas(aCanvas, FEndColor, FBgnColor, R, gdVertical);
   // ボタンが無効状態
   tbPushButtonDisabled : GradientFillCanvas(aCanvas, $eeeeee, $cccccc, R, gdVertical);
   // デフォルトのボタン
   tbPushButtonDefaulted: GradientFillCanvas(aCanvas, FBgnColor, FEndColor, R, gdVertical);
  end;
  ThemeServices.DrawText(DC, Detail, Caption, R, DT_SINGLELINE or DT_CENTER or DT_VCENTER, 0);
  ReleaseDC(Self.Handle, DC);
  aCanvas.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Button1.BtnColor := $ff88ff;
  Button2.BtnColor := $ffff66;
  Button3.BtnColor := $55ffff;
  Button4.BtnColor := $55ff55;
  Button5.BtnColor := $F5F0FF;// clWebLavenderBlush;
  Button6.BtnColor := $DDA0DD;// clWebPlum;
  Button7.BtnColor := $B469FF;// clWebHotPink;
  Button8.BtnColor := $4763FF;// clWebTomato;
  Button9.FBgnColor := $55ffff;  Button9.FEndColor := $ff55ff;
  Button10.BtnColor := $FFFFE0;// clWebLightCyan;
  Button11.BtnColor := $D4FF7F;// clWebAquamarine;
  Button12.BtnColor := $FFF8F0;// clWebAliceBlue;
  Button13.BtnColor := $FAE6E6;// clWebLavender;
  Button14.FBgnColor := $55ffff;  Button14.FEndColor := $ffdd00;
  Button15.BtnColor := $B5E4FF;// clWebMoccasin;
  Button16.BtnColor := $87B8DE;// clWebBurlywood;
  Button17.BtnColor := $00D7FF;// clWebGold;
  Button18.BtnColor := $60A4F4;// clWebSandyBrown;
  Button19.FBgnColor := $ff99ff;  Button19.FEndColor := $ffcc00;
  Button20.BtnColor := $F0FFF0;// clWebHoneydew;
  Button21.BtnColor := $90EE90;// clWebLightGreen;
  Button22.BtnColor := $2FFFAD;// clWebGreenYellow;
  Button23.BtnColor := $00FF00;// clWebLime;
  Button24.FBgnColor := $00eeff;  Button24.FEndColor := $00cc00;
end;

-------------------------------------------------------------------
【Delphi8以降で、XPMan,Themes,GraphUtilを使う場合】

uses  ...,  XPMan, Themes, GraphUtil;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    ...........

constructor TButton.Create(AOwner: TComponent);
begin
  inherited;
  FButton := tbPushButtonNormal;
  FBtnColor := $ffddff;
  FBtnColor := clWebFloralWhite;
  SetBtnColor(FBtnColor);
end;

procedure TButton.SetBtnColor(Value: TColor);
var
  H, L, S: WORD;
begin
  ColorRGBToHLS(Value, H, L, S);
  FBgnColor := ColorHLSToRGB(H, L+45, S);
  FEndColor := ColorHLSToRGB(H, L-45, S);
end;

procedure TButton.DrawButton;
var
  R: TRect;
  Detail: TThemedElementDetails;
  c3, c4: TColor;
  DC: HDC;
  aCanvas: TCanvas;
  H, L, S: WORD;
begin
  if not(ThemeServices.ThemesEnabled) then exit;

ColorRGBToHLS(FBgnColor, H, L, S);
  c3 := ColorHLSToRGB(H, L+12, S);
  ColorRGBToHLS(FEndColor, H, L, S);
  c4 := ColorHLSToRGB(H, L+12, S);

DC := GetDC(Self.Handle);
  aCanvas := TCanvas.Create;
  aCanvas.Handle := DC;
  aCanvas.Font.Assign(Self.Font);
  R := ClientRect;
  if not Enabled then FButton := tbPushButtonDisabled;
  Detail := ThemeServices.GetElementDetails(FButton);
//  InflateRect(R, -3, -3);
  R := ThemeServices.ContentRect(aCanvas.Handle, Detail, R);
  if Focused or (FButton = tbPushButtonHot) then InflateRect(R, -1, -1);
  case FButton of
   tbPushButtonNormal   : GradientFillCanvas(aCanvas, FBgnColor, FEndColor, R, gdVertical);
   tbPushButtonHot      : GradientFillCanvas(aCanvas, c3, c4, R, gdVertical);
   tbPushButtonPressed  : GradientFillCanvas(aCanvas, FEndColor, FBgnColor, R, gdVertical);
   tbPushButtonDisabled : GradientFillCanvas(aCanvas, $eeeeee, $cccccc, R, gdVertical);
   tbPushButtonDefaulted: GradientFillCanvas(aCanvas, FBgnColor, FEndColor, R, gdVertical);
  end;
  ThemeServices.DrawText(DC, Detail, Caption, R, DT_SINGLELINE or DT_CENTER or DT_VCENTER, 0);
  ReleaseDC(Self.Handle, DC);
  aCanvas.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Button1.BtnColor := $ff88ff;
  Button2.BtnColor := $ffff66;
  Button3.BtnColor := $55ffff;
  Button4.BtnColor := $55ff55;
  Button5.BtnColor := clWebLavenderBlush;
  Button6.BtnColor := clWebPlum;
  Button7.BtnColor := clWebHotPink;
  Button8.BtnColor := clWebTomato;
  Button9.FBgnColor := $55ffff;  Button9.FEndColor := $ff55ff;
  Button10.BtnColor := clWebLightCyan;
  Button11.BtnColor := clWebAquamarine;
  Button12.BtnColor := clWebAliceBlue;
  Button13.BtnColor := clWebLavender;
  Button14.FBgnColor := $55ffff;  Button14.FEndColor := $ffdd00;
  Button15.BtnColor := clWebMoccasin;
  Button16.BtnColor := clWebBurlywood;
  Button17.BtnColor := clWebGold;
  Button18.BtnColor := clWebSandyBrown;
  Button19.FBgnColor := $ff99ff;  Button19.FEndColor := $ffcc00;
  Button20.BtnColor := clWebHoneydew;
  Button21.BtnColor := clWebLightGreen;
  Button22.BtnColor := clWebGreenYellow;
  Button23.BtnColor := clWebLime;
  Button24.FBgnColor := $00eeff;  Button24.FEndColor := $00cc00;
end;

裕子：「じゃぁ、これをユウスケに教えてあげよう、…ところで、右側のカレンダーみたいなものナニ？」
真琴：「あ、コレはスケジュールとか日記とかを書き込めるカレンダーコンポ、今作ってる途中」
裕子：「こんなの、マコト 一人で？ スゴイじゃん」
真琴：「アタシが全部作ったんじゃないの、カイトさんのコンポを改造してるだけよ」
裕子：「カイトさんってダレ？ あ〜、もしかして、マコトの彼氏とか」
真琴：「そんなんじゃないよ、でも、アッチの宇宙では民宿に来なかったから、コッチの宇宙でも別の人生歩んでるか、存在すらしてないかも…」
裕子：「ナニそれ、SF小説も書いてるの？ マコト、面白そう、ねぇもっと聞かせて〜」
真琴：「また、今度ね^^;、それより、ハルコさんの声真似して入ってこないでよ」
裕子：「そういえば、ハルコさんはドコか旅行でも行ってるの？ 最近、見ないけど」
真琴：「うん、まぁ、そう…、旅行といっても間違いじゃないような…^^;」

←解決時は質問者本人がここをチェックしてください。

戻る