XPスタイルで色設定
TBUTTONから派生したコンポーネントを作成して
Paint変更して、ThemeServices.DrawElement
でボタンをXPスタイルに対応したのですが、
ボタンの色の変え方がわかりませんる
ColorToRGBメソッドを使うのでしょうか？
ご存知の方よろしくお願いします。
真琴：「はい、おじいちゃん、シャツのボタン付けたよ」
勝爺：「おぅ、そうか、ごくろうさん、同じ白い色のボタンあったのか？」
真琴：「それが、白のボタンがなくて…、だから、この色でもいいよね？」
勝爺：「ん？なんだ？ この色しかなかったのか？」
真琴：「明るいピンクだから見たカンジＯＫでしょ、うん大丈夫、カワイイし…^^」
http://makoto.me.land.to/img/snapshot.png
uses ..., GraphUtil, XPMan, Themes;
type
TButtonColor = (bcNONE, bcRED, bcGREEN, bcBLUE);
TButton = class(StdCtrls.TButton)
private
FButton: TThemedButton;
ButtonColor: TButtonColor;
procedure WndProc(var Msg: TMessage); override;
procedure DrawButton;
public
constructor Create(AOwner: TComponent); override;
end;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
........................
constructor TButton.Create(AOwner: TComponent);
begin
inherited;
FButton := tbPushButtonNormal;
ButtonColor := bcRED;
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.DrawButton;
var
R: TRect;
Detail: TThemedElementDetails;
c1, c2, c3, c4: TColor;
DC: HDC;
aCanvas: TCanvas;
begin
if not(ThemeServices.ThemesEnabled) then exit;
case ButtonColor of
bcNONE : exit;
bcRED : begin c1 := $ffddff; c2 := $ff66ff; c3 := $ffeeff; c4 := $ff77ff; end;
bcGREEN: begin c1 := $ddffdd; c2 := $77ff77; c3 := $eeffee; c4 := $88ff88; end;
bcBLUE : begin c1 := $ffffcc; c2 := $ffdd66; c3 := $ffffdd; c4 := $ffff77; end;
end;
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);
if Focused or (FButton = tbPushButtonHot) then InflateRect(R, -1, -1);
case FButton of
// 通常のボタン状態
tbPushButtonNormal : GradientFillCanvas(aCanvas, c1, c2, R, gdVertical);
// カーソルがボタン上にある
tbPushButtonHot : GradientFillCanvas(aCanvas, c3, c4, R, gdVertical);
// ボタンが押されている
tbPushButtonPressed : GradientFillCanvas(aCanvas, c2, c1, R, gdVertical);
// ボタンが無効状態
tbPushButtonDisabled : GradientFillCanvas(aCanvas, $eeeeee, $cccccc, R, gdVertical);
// デフォルトのボタン
tbPushButtonDefaulted: GradientFillCanvas(aCanvas, c1, c2, 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.ButtonColor := bcRED;
Button2.ButtonColor := bcBLUE;
Button3.ButtonColor := bcGREEN;
end;
勝爺：「なに、カワイイだと？ …まぁいいか、…じゃチョット出かけてくるからな」
真琴：「夕方までには戻ってくるでしょ？ 晩ごはんの仕度しておくね？」
勝爺：「そうだな、じゃ、そうしてくれ、一人でも大丈夫か？」
真琴：「うん、いってらっしゃ〜い、…あれ？ 今ハルコさんの声が聞こえたような…」
ピンクのボタンさんありがとうがおざいます。
試してみましたが、当方の環境がDelphi7のため
GradientFillCanvasが使えません。
Webで調べた所、代用になりそうな物を見つけましたが
（下のコードです。）
今度は、 arTVX[0].Red := $7800;
の所で定数式が範囲を超えましたのエラーがでます。
なぜでしょうか。
よろしくお願いします。
type
TGradientDirection = (gdHorizontal, gdVertical);
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);
type
TTriVertex = packed record
X,Y :LongInt;
Red,Green,Blue,Alpha: Word;
end;
var
Vertexes: array[0..1] of TTriVertex;
GradientRect: TGradientRect;
begin
StartColor:=ColorToRGB(StartColor);
EndColor:=ColorToRGB(EndColor);
Vertexes[0].X:=ARect.Left;
Vertexes[0].Y:=ARect.Top;
Vertexes[0].Red:=GetRValue(StartColor) shl 8;
Vertexes[0].Blue:=GetBValue(StartColor) shl 8;
Vertexes[0].Green:=GetGValue(StartColor) shl 8;
Vertexes[0].Alpha:=0;
Vertexes[1].X:=ARect.Right;
Vertexes[1].Y:=ARect.Bottom;
Vertexes[1].Red:=GetRValue(EndColor) shl 8;
Vertexes[1].Blue:=GetBValue(EndColor) shl 8;
Vertexes[1].Green:=GetGValue(EndColor) shl 8;
Vertexes[1].Alpha:=0;
GradientRect.UpperLeft:=0;
GradientRect.LowerRight:=1;
GradientFill(Canvas.Handle, Windows.PTriVertex(@Vertexes[0])^, 2,
@GradientRect, 1, cGradientDirections[Direction]);
end;
procedure TForm1.FormPaint(Sender: TObject);
var
arTVX : array[0..1] of TRIVERTEX;
GradRect: GRADIENT_RECT;
begin
arTVX[0].X := 0;
arTVX[0].Y := 0;
arTVX[0].Red := $7800;
arTVX[0].Green := $B900;
arTVX[0].Blue := $D900;
arTVX[0].Alpha := $0000;
arTVX[1].X := Width;
arTVX[1].Y := Height;
arTVX[1].Red := $FF00;
arTVX[1].Green := $FF00;
arTVX[1].Blue := $FF00;
arTVX[1].Alpha := $0000;
GradRect.UpperLeft := 0;
GradRect.LowerRight := 1;
GradientFill(Canvas.Handle, @arTVX, 2, @GradRect, 1, GRADIENT_FILL_RECT_H);
end;
裕子：「こんにちは〜、マコト居る？」
真琴：「えっ？ あ、ユウコかぁ、…遊びにきたの？」
裕子：「ナニよ、誰か待ってたの？ …ねぇマコト、この前のアレ、ユウスケに教えてあげたら、"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
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;
...........
constructor TButton.Create(AOwner: TComponent);
begin
inherited;
FButton := tbPushButtonNormal;
FBtnColor := $ffddff;
FBtnColor := clWebFloralWhite;
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 := 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小説も書いてるの？ マコト、面白そう、ねぇもっと聞かせて〜」
真琴：「また、今度ね^^;、それより、ハルコさんの声真似して入ってこないでよ」
裕子：「そういえば、ハルコさんはドコか旅行でも行ってるの？ 最近、見ないけど」
真琴：「うん、まぁ、そう…、旅行といっても間違いじゃないような…^^;」
あいかわらず凄いですね、カイトさんのカレンダーコンポーネント
楽しみですね。
| ツイート |  |