[ 786_TListView のカラムヘッダのカスタム描画 ]

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.StdCtrls,
  Vcl.ExtCtrls, Vcl.Themes;

type
  TForm1 = class(TForm)
    ListView1: TListView;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

  function LVHeaderWndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM;
    lParam: LPARAM): LRESULT; stdcall;
  procedure DrawHeaderText(AHDC: HDC; const AText: string; ARect: TRect;
    ATextFlags: Cardinal; const AFontSize: Integer; const ATextColor: TColor;
    ADetail: TThemedElementDetails; AElement: TThemedHeader);

var
  Form1: TForm1;

implementation

uses
  Winapi.CommCtrl,
  System.Types,
  Winapi.Dwmapi,
  Winapi.UxTheme;

{$R *.dfm}

var
  FLVHOriginProc : Pointer;
  FhLVHeader     : THandle;

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LCol   : TListColumn;
  LItem  : TListItem;
  LColNo : Integer;
  LRowNo : Integer;
begin
  ListView1.ViewStyle := vsReport;

  ListView1.Items.BeginUpdate;

  for LColNo := 0 to 2 do begin
    LCol := ListView1.Columns.Add;
    LCol.Caption := 'Col ' + IntToStr(LColNo + 1);
    LCol.Width   := 100;
  end;

  // テスト表示用のデータ
  for LColNo := 0 to 1 do begin
    for LRowNo := 0 to 49 do begin
      LItem :=  ListView1.Items.Add;
      LItem.Caption := Format('    %.6d',[LRowNo + 1]);
      ListView1.Items[LRowNo].SubItems.Add(Format('    %.5d',[LRowNo + 1]));
    end;
  end;

  ListView1.Items.EndUpdate;


  // カラムヘッダのコントロールのウィンドウハンドルを取得
  FhLVHeader := ListView_GetHeader(ListView1.Handle);
  // カラムヘッダコントロールの WndProc を退避し，新しく WndProc を設定
  FLVHOriginProc := Pointer(SetWindowLong(FhLVHeader,
                           GWL_WNDPROC,
                           NativeInt(@LVHeaderWndProc)));
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  SetWindowLong(FhLVHeader, GWL_WNDPROC, NativeInt(FLVHOriginProc));
end;

//-----------------------------------------------------------------------------^
//  SetWindowLong 関数のコールバック関数
//  TListView のカラムヘッダコントロールのサブクラス化処理
//-----------------------------------------------------------------------------^
function LVHeaderwndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM;
  lParam: LPARAM): LRESULT; stdcall;
  {$WRITEABLECONST ON}
const
  FIsPessed : Boolean = False;
{$WRITEABLECONST OFF}
var
  LListView : TListView;
  LHDLyaout : PHDLayout;
  LHeaderDC : HDC;
  LCurPos   : TPoint;
  LRect     : TRect;
  LDetails  : TThemedElementDetails;
  LElement  : TThemedHeader;
  LTextFlag : Cardinal;
  LCaption  : string;
  LIndex    : Integer;
begin
  // 操作対象の TListview
  LListView := Form1.ListView1;

  Result := CallWindowProc(FLVHOriginProc, hWnd, Msg, wParam, lParam);

  // カラムヘッダの高さを設定
  if Msg = HDM_LAYOUT then begin
    LHDLyaout := PHDLayout(lParam);
    LHDLyaout.WindowPos.cy := 40;
    LHDLyaout.Rect.Top := LHDLyaout.WindowPos.cy + 2;
  end;

  case Msg of
    WM_LBUTTONDOWN : FIsPessed := True;
    WM_LBUTTONUP   : FIsPessed := False;
    WM_MOUSEMOVE   :
    begin
      // 左のカラムに移動した時に WM_PAINT が発生しない現象の回避策
      LVHeaderwndProc(FhLVHeader, WM_PAINT, 0, 0);
    end;
  end;

  if Msg = WM_PAINT then begin
    LHeaderDC := GetDC(FhLVHeader); 

    for LIndex := 0 to LListView.Columns.Count -1 do begin
      Header_GetItemRect(FhLVHeader, LIndex, @LRect);

      GetCursorPos(LCurPos);
      ScreenToClient(FhLVHeader, LCurPos);

      // マウスカーソル下のカラムの判定
      if PtInRect(LRect, LCurPos) then begin
        if FIsPessed then begin
          LElement := thHeaderItemPressed;
        end else begin
          LElement := thHeaderItemHot;
        end;
      end else begin
        LElement := thHeaderItemNormal;
      end;

　　  LCaption  := LListView.Column[LIndex].Caption;
      LTextFlag := DT_SINGLELINE or DT_CENTER or DT_VCENTER;

      LDetails := TStyleManager.SystemStyle.GetElementDetails(LElement);
      DrawHeaderText(LHeaderDC, LCaption, LRect, LTextFlag, 15, clBlue,
                     LDetails, LElement);
    end;
  end;
end;

//-----------------------------------------------------------------------------^
//  実際のカラムヘッダの描画ルーチン
//
//  フォントのサイズと文字列の描画位置を変更するので背景を塗り潰す
//  背景を塗り潰さないと元の文字列が描画される
//-----------------------------------------------------------------------------^
procedure DrawHeaderText(AHDC: HDC; const AText: string; ARect: TRect;
  ATextFlags: Cardinal; const AFontSize: Integer; const ATextColor: TColor;
  ADetail: TThemedElementDetails; AElement: TThemedHeader);
var
  LdttOpts  : TDTTOpts;
  LFont     : TFont;
  LhOldFont : HFONT;
  LCanvas   : TCanvas;
begin
  DrawThemeBackground(TStyleManager.SystemStyle.Theme[ADetail.Element],
                          AHDC, ADetail.Part, ADetail.State, ARect, nil);


  // フォント関係の設定
  if AElement = thHeaderItemPressed then begin
    ARect.Left := ARect.Left + 2;
    ARect.Top  := ARect.Top + 2;
  end;

  LFont := TFont.Create;
  try
    LFont.Size := AFontSize;
    LFont.Style := [fsBold];
    LhOldFont   := SelectObject(AHDC, LFont.Handle);

    FillChar(LdttOpts, SizeOf(TDTTOpts), $0 );
    LdttOpts.dwSize   := SizeOf(TDTTOpts);
    LdttOpts.crText   := ColorToRGB(ATextColor);
    LdttOpts.dwFlags  := DTT_TEXTCOLOR;
    LdttOpts.iStateId := ADetail.State;

    DrawThemeTextEx(TStyleManager.SystemStyle.Theme[ADetail.Element],
                    AHDC,
                    ADetail.Part,
                    ADetail.State,
                    AText,
                    Length(AText),
                    ATextFlags,
                    ARect,
                    LdttOpts);

    // 元のフォントに戻しておく
    SelectObject(AHDC, LhOldFont);
  finally
    FreeAndNil(LFont);
  end;
end;

end.

//-----------------------------------------------------------------------------^
//  実際のカラムヘッダの描画ルーチン
//
//  フォントのサイズと文字列の描画位置を変更するので背景を塗り潰す
//  背景を塗り潰さないと元の文字列が描画される
//-----------------------------------------------------------------------------^
procedure DrawHeaderText(AHDC: HDC; const AText: string; ARect: TRect;
  ATextFlags: Cardinal; const AFontSize: Integer; const ATextColor: TColor;
  ADetail: TThemedElementDetails; AElement: TThemedHeader);
var
  LdttOpts  : TDTTOpts;
  LFont     : TFont;
  LhOldFont : HFONT;
  LCanvas   : TCanvas;
begin
  // マウスカーソル下にないカラムの背景色を変更
  if AElement = thHeaderItemNormal then begin
    LCanvas := TCanvas.Create;
    try
      LCanvas.Handle := AHDC;
      LCanvas.Brush.Color := $00C8DAEA;
      LCanvas.FillRect(ARect);
    finally
      FreeAndNil(LCanvas);
    end;
  end else begin
    DrawThemeBackground(TStyleManager.SystemStyle.Theme[ADetail.Element],
                          AHDC, ADetail.Part, ADetail.State, ARect, nil);
  end;


  // フォント関係の設定
  if AElement = thHeaderItemPressed then begin
    ARect.Left := ARect.Left + 2;
    ARect.Top  := ARect.Top + 2;
  end;

  LFont := TFont.Create;
  try
    LFont.Size := AFontSize;
    LFont.Style := [fsBold];
    LhOldFont   := SelectObject(AHDC, LFont.Handle);

    FillChar(LdttOpts, SizeOf(TDTTOpts), $0 );
    LdttOpts.dwSize   := SizeOf(TDTTOpts);
    LdttOpts.crText   := ColorToRGB(ATextColor);
    LdttOpts.dwFlags  := DTT_TEXTCOLOR;
    LdttOpts.iStateId := ADetail.State;

    DrawThemeTextEx(TStyleManager.SystemStyle.Theme[ADetail.Element],
                    AHDC,
                    ADetail.Part,
                    ADetail.State,
                    AText,
                    Length(AText),
                    ATextFlags,
                    ARect,
                    LdttOpts);

    // 元のフォントに戻しておく
    SelectObject(AHDC, LhOldFont);
  finally
    FreeAndNil(LFont);
  end;
end;