ListViewのヘッダに色を付けるには？
解決Delphi5では、ListViewのヘッダ項目に色を付けるコード(某掲示板で見つけた）を下記方法で実現できていたのですが、Delphi2007では色が付きません。Delphi2007でListViewのヘッダ項目に色を付ける方法をご存知の方、教えてください。宜しくお願いいたします。
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls;
type
TForm1 = class(TForm)
ListView1: TListView;
procedure FormCreate(Sender: TObject);
private
{ Private 宣言 }
public
{ Public 宣言 }
OriginalWndProc:TWndMethod;
procedure SubclassProc(var Msg:TMessage);
procedure HeaderDrawItem(Msg:TWMDrawItem);
procedure MakeOwnerDraw(Section:integer);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses Commctrl;
//ヘッダーのセクションの描画
procedure TForm1.HeaderDrawItem(Msg: TWMDrawItem);
var
DIS:TDrawItemStruct;
r:TRect;
s:string;
hBr: HBRUSH;
begin
DIS := Msg.DrawItemStruct^;
if DIs.CtlType <> ODT_HEADER then exit;
hBr := 0;
case DIS.itemID of
0:hBr := CreateSolidBrush(ColorToRGB(clYellow));
1:hBr := CreateSolidBrush(ColorToRGB(clLime));
end;
r := DIS.rcItem;
Windows.FillRect(DIS.hDC,r,hBr);
DeleteObject(hBr);
s := ListView1.Columns[DIS.itemID].Caption;
SetBkMode(DIS.hDC,TRANSPARENT);
Windows.TextOut(DIS.hDC,r.Left+5,r.Top+2,PChar(s),Length(s));
end;
//サブクラスプローシージャ
procedure TForm1.SubclassProc(var Msg: TMessage);
var
pNMH:PNMHdr;
begin
OriginalWndProc(Msg);
case Msg.Msg of
WM_DRAWITEM:HeaderDrawItem(TWMDrawItem(Msg));
WM_NOTIFY:begin
pNMH := PNMHdr(Msg.LParam);
if pNMH.code = HDN_ENDTRACK then begin
MakeOwnerDraw(0);
MakeOwnerDraw(1);
end;
end;
end;
end;
//ヘッダーの各セクションのオーナードローの設定
procedure TForm1.MakeOwnerDraw(Section: integer);
var
hHeader:HWND;
Item:THDItem;
begin
hHeader := GetWindow(ListView1.Handle,GW_CHILD);
if hHeader = 0 then exit;
Item.Mask := HDI_FORMAT;
Item.fmt := HDF_OWNERDRAW;
Header_SetItem(hHeader,Section,Item);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
OriginalWndProc := ListView1.WindowProc;
ListView1.WindowProc := SubclassProc;
MakeOwnerDraw(0);
MakeOwnerDraw(1);
end;
解決にはなりませんがランタイムテーマが関係しています。
Delphi2007で新規作成した場合、ランタイムテーマが有効（ボタンなどが角丸表示）になります。
上記コードの場合、ランタイムテーマは無効にすればヘッダ行の色が変わります。
遅くなりまして、申し訳ございません。
めじな様、レスありがとうございました。
ランタイムテーマが関係していたのですね。
ランタイムテーマを有効のまま、ヘッダの色は変更できないのでしょうか？
できれば、ランタイムテーマは有効のままにしたいです。
上記コード以外の方法があるのでしたら教えてください。
よろしくお願いします。
探したらそのものズバリなのがありました。
XPManに関係なく色変わりますね、これだと。
これを元に更にクリック時の描画なんか入れるといい感じになるのではないでしょうか。
http://hiderin.air-nifty.com/delphi/2007/08/index.html#entry-20144643
めじな様、ありがとうございます。
ヘッダの色はあきらめて、代わりにTImageListのアイコンを
表示しようと思ってました。
でもわざわざ探していただいて感謝します。
早速、試してみます。
めじな様、教えていただたいたURL大変参考になりました。
XPテーマが有効でも問題なく色をつけることができました。
ありがとうございました。
教えていただいたDelphi-fanのページもチェックしていましたが、
どうもあまかったようです。(^^;
色をつけることができても、ヘッダのカラムの境界をダブルクリック、またはドラッグした場合に表示がおかしくならないかな？
だけど様、私の環境ではドラッグは試していませんが、
カラム境界のダブルクリックは正常に描画され色残り等もなく
問題ありませんでした。
<環境>
Windows Vista Home Premium
Delphi2007
Vistaでは、カラムの境界をダブルクリックしてカラム幅が変わった時でもその右側の独自描画しているカラム表示が変にならないの？
(※色を独自描画しているカラムが左端１個だけの場合ならば変になることはないけど、紹介されたDelphiFanのサンプルでは変になる)
また、Drag中にリアルタイムで横幅が変る設定で、境界をDragして横幅を変えている最中にもカラム表示が変にならない？
XPではどちらの場合もその時点でおかしくなってしまう。(※Drag終了時、または変になったカラムにポインタ移動すれば直るけど)
それから、もし、クリック時にカラムを凹ませることも出来たのなら、そのコードを紹介して欲しいな。
３列にして左からclYellow、clLime、clSkyBlue で描画しましたが特に変にはなりませんでした。
確かにドラッグして幅を広げた時にカラム境界の縦線が１本残りますが、これはオリジナルの
ListView自体に存在する問題ですよね？
何か他に条件があるのかもしれませんが。
Delphiのバージョンで異なるのでしょうか。
＜環境＞
WindowsXP Pro SP3
Delphi2007
どうも、「おかしな現象」についての認識に食い違いがあるようで、めじなさんが見ているのは、
◆「Drag中にリアルタイムではカラム幅が変らない」場合の現象
この設定状態でカラム境界のドラッグを開始すると、ポインタ付近に縦線がXORモードで描かれて、
ドラッグ中はその縦線だけが左右に動いても、その右側のヘッダやリスト部分の位置は固定されたまま。
ドラッグ終了時に、それらが新しい位置で描画される。
この場合には、こちらでもドラッグ中に縦線がヘッダ部分に残る現象が起きる。
「おかしな現象」というのは、そうではなくて、
◆「Drag中にリアルタイムでカラム幅が変る」場合に起きる現象
この設定状態でカラム境界のドラッグを開始すると、独自描画無しなら、その右側のヘッダやリスト部分が
ポインタの移動に合せて左右に動く。でも、すべてのカラムヘッダに独自描画していると、ドラッグの最中、
右側のリスト部分はポインタの移動に合せて左右に動いても、ヘッダ部だけは固定されたまま動かない。
ダブルクリック時のおかしな現象は、微妙なものなので良く注意して見ないと分からないかも。
(独自描画されたカラム境界が正常位置に比べて、わずかにずれている。５列以上でないと分からない)
※「Drag中にリアルタイムでカラム幅が変る」ようにするには、
「画面のプロパティ」の「デザイン」タブの中の「効果」ボタンをクリックして、その「効果」画面中の
□「ドラッグ中にウィンドウの内容を表示する」
にチェックを付けて、ＯＫボタンでそれらの画面を閉じる。
XPでは、その設定変更が起動中のアプリにも反映されるはずだけど、一応、変更後にアプリを再起動。
そういう事ですか。
確かにＯＳ自体の視覚スタイルや効果は軽くするためにいじっていました。
設定をデフォルトにすると戻すのが面倒なので私の環境では確認しませんが
そういう現象が出る、と言う事は認識しました。
真琴：「こう変えれば良くなるンじゃない？」
広海：「ン？ マコト、こんなのオマエが一人で？」
真琴：「そぅ、アタシだって、やればこれくらいのコトは…」
広海：「なぁんて、冗談は顔だけ…、前にカイトから教えてもらったンだろぅ？」
真琴：「なによ、バァ〜ッカ、…でもぉ、ジツはそうナンだけど^^;;」
type
TGradientDirection = (gdHorizontal, gdVertical);
TListView = class(ComCtrls.TListView)
private
procedure CreateWnd; override;
procedure WmPaint(var Msg: TWMPaint); message WM_PAINT;
procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;
procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY;
procedure WMEraseBkgnd(var Msg: TWMEraseBkGnd); message WM_ERASEBKGND;
public
CanvasDC: HDC;
Header_Handle: HWND;
procedure DrawColumns;
end;
type
TForm1 = class(TForm)
ListView1: TListView;
.....
var
Form1: TForm1;
ButtonPosX: Integer;
HeaderChanging: Boolean;
FOldHeaderWndProc: TFNWndProc;
function NewHeaderWndProc(hW: HWND; Msg: UINT; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall;
implementation
type
TTriVertex = packed record
x: Longint;
y: Longint;
Red: WORD;
Green: WORD;
Blue: WORD;
Alpha: WORD;
end;
function GradientFill(DC: HDC; Tvx: Pointer; NumTvx: DWORD;
Meshes: Pointer; NumMeshes: DWORD; Mode: DWORD): DWORD; stdcall;
external 'MSImg32.dll' name 'GradientFill';
procedure DrawAlfaGradient(Canvas: TCanvas; CBgn, CEnd: TColor; aRect: TRect; GrDirection: TGradientDirection);
var
cr: Cardinal;
Tvx: array[0..1] of TTriVertex;
GradientRect: TGradientRect;
begin
Tvx[0].x := aRect.Left;
Tvx[0].y := aRect.Top;
cr := CBgn;
Tvx[0].Red := (cr and $FF) shl 8;
Tvx[0].Green := (cr and $FF00);
Tvx[0].Blue := (cr and $FF0000) shr 8;
Tvx[0].Alpha := 0;
Tvx[1].x := aRect.Right;
Tvx[1].y := aRect.Bottom;
cr := CEnd;
Tvx[1].Red := (cr and $FF) shl 8;
Tvx[1].Green := (cr and $FF00);
Tvx[1].Blue := (cr and $FF0000) shr 8;
Tvx[1].Alpha := 0;
GradientRect.UpperLeft := 0;
GradientRect.LowerRight := 1;
GradientFill(Canvas.Handle, @Tvx[0], 2, @GradientRect, 1, DWORD(GrDirection));
end;
procedure TListView.DrawColumns;
var
Header_Rect, Column_Rect, OutofColumns_Rect: TRect;
i, X, W1, W2, CW: Integer;
aCanvas: TCanvas;
Column: TListColumn;
dwFormat: DWORD;
begin
if Header_Handle = 0 then Exit;
Windows.GetClientRect(Header_Handle, Header_Rect);
W1 := GetSystemMetrics(SM_CXBORDER);
W2 := GetSystemMetrics(SM_CXFIXEDFRAME) - W1;
aCanvas := TCanvas.Create;
try
aCanvas.Handle := GetDC(Header_Handle);
X := 0;
for i:=0 to Columns.Count-1 do begin
Column := Columns[i];
CW := Columns[i].Width;
if CW < 5 then begin inc(X, CW); Continue; end;
Column_Rect := Rect(X+W1, W1, X+CW-W2, Header_Rect.Bottom-W2);
if (ButtonPosX > X)and(ButtonPosX < X+CW-W2) then OffsetRect(Column_Rect, 1, 1);
DrawAlfaGradient(aCanvas, $AAFFEE, $55CC88, Column_Rect, gdVertical);
SetBkMode(aCanvas.Handle, TRANSPARENT);
OffsetRect(Column_Rect, 1, 1);
aCanvas.Font.Color := clBlack;
dwFormat := DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS;
case Column.Alignment of
taLeftJustify : dwFormat := dwFormat or DT_LEFT;
taRightJustify: dwFormat := dwFormat or DT_RIGHT;
taCenter : dwFormat := dwFormat or DT_CENTER;
end;
InflateRect(Column_Rect, -4, 0);
DrawText(aCanvas.Handle, PChar(Column.Caption), -1, Column_Rect, dwFormat);
inc(X, CW);
end;
OutofColumns_Rect := Rect(X+W1, W1, Header_Rect.Right, Header_Rect.Bottom-W2);
DrawAlfaGradient(aCanvas, clWhite, $CCBBAA, OutofColumns_Rect, gdVertical);
finally
ReleaseDC(Header_Handle, aCanvas.Handle);
aCanvas.Free;
end;
end;
procedure TListView.CreateWnd;
begin
Inherited;
Header_Handle := ListView_GetHeader(Handle);
FOldHeaderWndProc := TFNWndProc(SetWindowLong(Header_Handle, GWL_WNDPROC, Longint(@NewHeaderWndProc)));
HeaderChanging := False;
CanvasDC := GetDC(Handle);
end;
function NewHeaderWndProc(hWnd: HWND; Msg: UINT; WParam: WPARAM; LParam: LPARAM): LRESULT;
begin
Result := CallWindowProc(FOldHeaderWndProc, hWnd, Msg, WParam, LParam);
case Msg of
WM_PAINT: Form1.ListView1.DrawColumns;
WM_LBUTTONDOWN: ButtonPosX := LOWORD(LParam);
WM_LBUTTONUP: ButtonPosX := -1;
end;
end;
procedure TListView.WMNotify(var Msg: TWMNotify);
var
pHDN: PHDNOTIFY;
begin
inherited;
pHDN := PHDNOTIFY(Msg.NMHdr);
case PNMHdr(Msg.NMHdr)^.Code of
HDN_ITEMCHANGING:
begin
Columns[pHDN^.Item].Width := pHDN^.PItem.cxy;
ButtonPosX := -1;
end;
HDN_BEGINTRACK, HDN_BEGINTRACKW: HeaderChanging := True;
HDN_ENDTRACK, HDN_ENDTRACKW: begin HeaderChanging := False; Invalidate; end;
end;
end;
procedure TListView.WMEraseBkgnd(var Msg: TWMEraseBkGnd);
begin
if HeaderChanging then exit;
inherited;
end;
procedure TListView.CNNotify(var Msg: TWMNotify);
var
DefaultDraw: Boolean;
begin
DefaultDraw := True;
if (Msg.NMHdr^.Code = NM_CUSTOMDRAW) then begin
with PNMCustomDraw(Msg.NMHdr)^ do begin
Msg.Result := CDRF_DODEFAULT;
if dwDrawStage = CDDS_PREPAINT then begin
Msg.Result := Msg.Result or CDRF_NOTIFYITEMDRAW;
exit;
end else
if (dwDrawStage and CDDS_ITEMPREPAINT) <> 0 then begin
with PNMLVCustomDraw(Msg.NMHdr)^ do begin
Canvas.Handle := CanvasDC;
SelectObject(hdc, Canvas.Font.Handle);
Canvas.Handle := 0;
end;
if (Items[dwItemSpec].Selected) then begin
DefaultDraw := False;
if (dwDrawStage and CDDS_SUBITEM) <> 0 then begin
Msg.Result := Msg.Result or CDRF_SKIPDEFAULT;
end else begin
Msg.Result := Msg.Result or CDRF_SKIPDEFAULT;
end;
end;
end;
end;
end;
if DefaultDraw then inherited;
end;
procedure TListView.WMPaint(var Msg: TWMPaint);
var
R: TRect;
Item: TListItem;
i: Integer;
BgnCol, EndCol: TColor;
dwFormat: DWORD;
function GetFormat(Column: TListColumn): DWORD;
begin
result := DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS;
case Column.Alignment of
taLeftJustify : begin result := result or DT_LEFT; inc(R.Left, 6); end;
taRightJustify: begin result := result or DT_RIGHT; InflateRect(R, -6, 0); end;
taCenter : result := result or DT_CENTER;
end;
end;
begin
inherited;
if (Selected = nil) then exit;
if Focused then begin
BgnCol := $FF7755;
EndCol := $BB3311;
Canvas.Font.Color := $66FFFF;
end else begin
BgnCol := $EEBBFF;
EndCol := $BB66CC;
Canvas.Font.Color := $DD3322;
end;
Canvas.Handle := CanvasDC;
Item := Selected;
repeat
ListView_GetItemRect(Handle, Item.Index, R, LVIR_LABEL);
if R.Top < 7 then begin
Item := GetNextItem(Item, sdAll, [isSelected]);
continue;
end;
DrawAlfaGradient(Canvas, BgnCol, EndCol, R, gdVertical);
SetBkMode(CanvasDC, TRANSPARENT);
OffsetRect(R, -2, 0);
DrawText(CanvasDC, PChar(Item.Caption), -1, R, GetFormat(Columns[0]));
for i:=0 to Item.SubItems.Count-1 do begin
ListView_GetSubItemRect(Handle, Item.Index, i+1, LVIR_BOUNDS, @R);
DrawAlfaGradient(Canvas, BgnCol, EndCol, R, gdVertical);
DrawText(CanvasDC, PChar(Item.SubItems[i]), -1, R, GetFormat(Columns[i+1]));
end;
R.Left := R.Right; R.Right := Width;
Canvas.FillRect(R);
Item := GetNextItem(Item, sdAll, [isSelected]);
until Item = nil;
end;
procedure TForm1.〜
begin
........
広海：「しっかし、ナンだ？ このヘッダと選択行の色は」
真琴：「カワイイでしょ？ アタシの趣味に合わせたグラデーション」
広海：「あっそ、ま、ヘッダも凹む…ドラッグもＯＫ、…わりとヨク出来てるじゃん」
真琴：「あ、雨も風もスゴク強くなってきた…、ハルコさん遅いよね、なんか心配…」
広海：「きっと…、いや、ぅう〜ん、こんなに遅くなるはずないか…」
真琴：「ね、もしもハルコさんにまでナニかあったらどうしよう、皆…アタシの傍から居なくなっちゃう」
広海：「マコト、お前この頃チョット弱気過ぎるんじゃないの〜？」
真琴：「でもぉ…」
勝爺：「…大丈夫だよ、オレだってココに居るじゃないか、マコト」
真琴：「エッ！！？その声は…、おじいちゃん？！」
広海：「まさか、あの…、社長の幽霊？ でも出るのは時期的にまだ早かったりして…」
勝爺：「バカやろう、ダレが幽霊だ、…ホラ、足だってコノ通りあるだろう」
広海：「マジ〜？ …あっ、イテッ！」
真琴：「痛かったら、これって夢じゃないよネ…」
広海：「ツネルなら自分のほっぺたにしろよ、マコト、…もう手加減もナシで〜」
勝爺：「ほっぺたくらい貸してやれ、じゃ、オレはチョット行ってくるからな」
真琴：「え？ おじいちゃん、ドコへ？」
勝爺：「この格好観りゃ分かるだろぅ、サーフィンだよ」
真琴：「あの、おじいちゃん、外は雨、それに風もスゴイし…」
勝爺：「風で大波が来るからイイんだよ、サーフィンするには」
真琴：「でも、でも、去年、台風の時サーフィンして、それで死んじゃったのよね？」
勝爺：「人間死ぬのは一度だけ、…だろ？だから、もうナニやってもダイジョウＶ」
広海：「あ、そりゃそうだＹ、なんちゃって」
真琴：「ないよ、そんな理屈って…、おじいちゃん、やめて…、おじいちゃん！…」
春子：「マコト、 …マ・コ・ト、もう起きなきゃ学校遅れるよ」
真琴：「…ン？ …あれっ？ あ〜…夢だったのかぁ〜」
勝爺：「珍しく朝寝坊だな、マコト、さっさと顔洗って、アサメシ食べろ」
真琴：「あ、おじいちゃん、オハヨウ、…エッ！？ …アタシ、まだ夢みてるの？」
| ツイート |  |