ListView_TinyMind

ListView基本用法大全

//增加项或列(字段)
ListView1.Clear;
ListView1.Columns.Clear;
ListView1.Columns.Add;
ListView1.Columns.Add;
ListView1.Columns.Add;
ListView1.Columns.Items[0].Caption:='id';
ListView1.Columns.Items[1].Caption:='type';
ListView1.Columns.Items[2].Caption:='title';
ListView1.Columns.Items[2].Width:=300;
Listview1.ViewStyle:=vsreport;
Listview1.GridLines:=true;               //注:此处代码也可以直接在可视化编辑器中完成,
也可写成以下这样
begin
with listview1 do
begin
Columns.Add;
Columns.Add;
Columns.Add;
ViewStyle:=vsreport;
GridLines:=true;
columns.items[0].caption:='进程名';
columns.items[1].caption:='进程ID';
columns.items[2].caption:='进程文件路径';
Columns.Items[0].Width:=100;
Columns.Items[1].Width:=100;
Columns.Items[2].Width:=150;
end
end;
//增加记录
with listview1.items.add do 
begin 
caption:='1212'; 
subitems.add('hh1'); 
subitems.add('hh2'); 
end;
//删除 
listview1.items.delete(0);
//从数据库表里读取数据写入Listview
var
Titem:Tlistitem;       //此处一定要预定义临时记录存储变量.
begin
ListView1.Items.Clear;
with adoquery1 do
begin
close;
sql.Clear;
sql.Add('select spmc,jg,sl from kcxs');
Open;
ListView1.Items.Clear;
while not eof do
begin
Titem:=ListView1.Items.add;
Titem.Caption:=FieldByName('spmc').Value;
Titem.SubItems.Add(FieldByName('sl').Value);
Titem.SubItems.Add(FieldByName('jg').Value);
next;
end;
//删除 
ListView1.DeleteSelected;
//如何取得ListView中选中行的某一列的值
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage(ListView1.Selected.SubItems.Strings[1]); //返回选中行第三列中的值
end;
showMessage(listView1.Selected.Caption);   //返回选中行第一列的值.
第1列的值： -->>> ListView1.Selected.Caption   
第i列的值(i>1):-->>> ListView1.Selected.SubItems.Strings[i]
ListView1.Items.Item[1].SubItems.GetText); //取得listview某行某列的值
Edit2.Text := listview1.Items[i].SubItems.strings[0];   //读第i行第2列
返回选中行所有子列值.是以回车符分开的，你还要从中剥离出来你要的子列的值。
showMessage(ListView1.Selected.SubItems.GetText);  
ListView 简单排序的实现
ListView 排序

怎样实现单击一下按升序,再单击一下按降序。
function CustomSortProc(Item1, Item2: TListItem; ColumnIndex: integer): integer; stdcall;
begin
if ColumnIndex = 0 then
Result := CompareText(Item1.Caption,Item2.Caption)
else
Result := CompareText(Item1.SubItems[ColumnIndex-1],Item2.SubItems[ColumnIndex-1])
end;
procedure TFrmSrvrMain.ListView1ColumnClick(Sender: TObject;
Column: TListColumn);
begin
ListView1.CustomSort(@CustomSortProc,Column.Index);
end;

===============================================================
//增加 
i := ListView1.Items.Count; 
with ListView1 do 
begin 
ListItem:=Items.Add; 
ListItem.Caption:= IntToStr(i); 
ListItem.SubItems.Add('第 '+IntToStr(i)+' 行'); 
ListItem.SubItems.Add('第三列内容'); 
end;
//按标题删除 
for i:=ListView1.Items.Count-1 downto 0 Do 
if ListView1.Items[i].Caption = Edit1.Text then 
begin 
ListView1.Items.Item[i].Delete(); //删除当前选中行 
end;
//选中一行 
if ListView1.Selected <> nil then 
Edit1.Text := ListView1.Selected.Caption;

// listview1.Items[Listview1.Items.Count -1].Selected := True; 
// listview1.Items[Listview1.Items.Count -1].MakeVisible(True); 
procedure TForm1.Button2Click(Sender: TObject); // 选择第一条 
begin 
listview1.SetFocus; 
listview1.Items[0].Selected := True; 
end;
procedure TForm1.Button1Click(Sender: TObject); // 选择最后一条 
begin 
listview1.SetFocus; 
listview1.Items[Listview1.Items.Count -1].Selected := True; 
end;
//这是个通用的过程 
procedure ListViewItemMoveUpDown(lv : TListView; Item : TListItem; MoveUp, SetFocus : Boolean); 
var 
DestItem : TListItem; 
begin 
if (Item = nil) or 
((Item.Index - 1 < 0) and MoveUp) or 
((Item.Index + 1 >= lv.Items.Count) and (not MoveUp)) 
then Exit; 
lv.Items.BeginUpdate; 
try 
if MoveUp then 
DestItem := lv.Items.Insert(Item.Index - 1) 
else 
DestItem := lv.Items.Insert(Item.Index + 2); 
DestItem.Assign(Item); 
lv.Selected := DestItem; 
Item.Free; 
finally 
lv.Items.EndUpdate; 
end; 
if SetFocus then lv.SetFocus; 
DestItem.MakeVisible(False); 
end;
//此为调用过程，可以任意指定要移动的Item，下面是当前(Selected)Item 
ListViewItemMoveUpDown(ListView1, ListView1.Selected, True, True);//上移 
ListViewItemMoveUpDown(ListView1, ListView1.Selected, False, True);//下移

TListView组件使用方法
引用CommCtrl单元
procedure TForm1.Button1Click(Sender: TObject); 
begin 
ListView_DeleteColumn(MyListView.Handle, i);//i是要删除的列的序号，从0开始
end;
用LISTVIEW显示表中的信息： 
procedure viewchange(listv:tlistview;table:tcustomadodataset;var i:integer); 
begin 
tlistview(listv).Items.BeginUpdate; {listv:listview名} 
try 
tlistview(listv).Items.Clear; 
with table do {table or query名} 
begin 
active:=true; 
first; 
while not eof do 
begin 
listitem:=tlistview(listv).Items.add; 
listitem.Caption:=trim(table.fields[i].asstring); 
// listitem.ImageIndex:=8; 
next; 
end; 
end; 
finally 
tlistview(listv).Items.EndUpdate; 
end; 
end;
 
ListView使用中的一些要点。以下以一个两列的ListView为例。 
→增加一行： 
with ListView1 do 
begin 
ListItem:=Items.Add; 
ListItem.Caption:='第一列内容'; 
ListItem.SubItems.Add('第二列内容'); 
end; 
→清空ListView1： 
ListView1.Items.Clear; 
→得到当前被选中行的行的行号以及删除当前行： 
For i:=0 to ListView1.Items.Count-1 Do 
If ListView1.Items[i].Selected then //i=ListView1.Selected.index 
begin 
ListView1.Items.Delete(i); //删除当前选中行 
end; 
当然，ListView有OnSelectItem事件,可以判断选择了哪行,用个全局变量把它赋值出来。 
→读某行某列的操作： 
Edit1.Text := listview1.Items[i].Caption; //读第i行第1列 
Edit2.Text := listview1.Items[i].SubItems.strings[0]; //读第i行第2列 
Edit3.Text := listview1.Items[i].SubItems.strings[1]; //读第i行第3列 
以次类推，可以用循环读出整列。 
→将焦点上移一行： 
For i:=0 to ListView1.Items.Count-1 Do 
If (ListView1.Items[i].Selected) and (i>0) then 
begin 
ListView1.SetFocus; 
ListView1.Items.Item[i-1].Selected := True; 
end; 
不过在Delphi6中，ListView多了一个ItemIndex属性，所以只要 
ListView1.SetFocus; 
ListView1.ItemIndex:=3; 
就能设定焦点了。

Delphi的listview能实现交替颜色么？ 
procedure TForm1.ListView1CustomDrawItem( 
Sender: TCustomListView; Item: TListItem; State: TCustomDrawState; 
var DefaultDraw: Boolean); 
var 
i: integer; 
begin 
i:= (Sender as TListView).Items.IndexOf(Item); 
if odd(i) then sender.Canvas.Brush.Color:= $02E0F0D7 
else sender.Canvas.Brush.Color:= $02F0EED7; 
Sender.Canvas.FillRect(Item.DisplayRect(drIcon)); 
end;
 

要想随时更改ListView 中某一行的字体颜色，要在ListView的 OnCustomDrawItem 的事件中书写相关的代码。例如 我想更改选中的某行字体的颜色，则需要在事件中写入下的代码：
if item.Index = strtoint(edit1.Text) then //该条件是用于判断是否符合更改字体颜色的行的条件。
   Sender.Canvas.Font.Color := clred;

View Code

//增加记录
with listview1.items.add do 
begin 
caption:='1212'; 
subitems.add('hh1'); 
subitems.add('hh2'); 
end;


listview1.items.delete(0);

//从数据库表里读取数据写入Listview

var
Titem:Tlistitem;       //此处一定要预定义临时记录存储变量.
begin
ListView1.Items.Clear;
with adoquery1 do
begin
close;
sql.Clear;
sql.Add('select spmc,jg,sl from kcxs');
Open;
ListView1.Items.Clear;
while not eof do
begin
Titem:=ListView1.Items.add;
Titem.Caption:=FieldByName('spmc').Value;
Titem.SubItems.Add(FieldByName('sl').Value);
Titem.SubItems.Add(FieldByName('jg').Value);
next;
end;


//删除 
ListView1.DeleteSelected;

View Code

ListView列宽自适应

使用TListView列表显示内容，如果列内容过长，就会显示成‘XXX…’形式，此时如果双击列标题，列宽将变为自适应。用代码设置如下：

1、设置ListView.Column[0].Width := -1;//列宽根据列内容自适应，此时保证列内容都可见。

2、设置ListView.Column[0].Width := -2;//列宽根据列标题自适应，此时保证列标题可见。

改变Listview标题栏颜色

var
  F_FARPROC: FARPROC;
  F_Color: TColor;
procedure SetListHeadColor(hListView: HWND; Color: TColor);
  function NewHeadProc(hwnd: HWND; uMsg: UINT;
    wParam: WPARAM; lParam: LPARAM): Longint; stdcall;
  var
    Rect: TRect;
    Canvas: TCanvas;
    Bmp: TBitmap;
  begin
    Result := Windows.CallWindowProc(F_FARPROC, hwnd, uMsg, wParam, lParam);
    if uMsg = WM_PAINT then
    begin
      Windows.GetClientRect(hwnd, Rect);
      Rect.Top := Rect.Top - 2;
      Rect.Left := Rect.Left - 2;
      Rect.Right := Rect.Right + 2;
      Canvas := TCanvas.Create;
      try
        Canvas.Handle := GetDC(hwnd);
        Bmp := TBitmap.Create;
        try
          Bmp.Width := Rect.Right;
          Bmp.Height := Rect.Bottom;
          Bmp.Canvas.CopyRect(Rect, Canvas, Rect);
          Bmp.Transparent := true;
          Bmp.TransparentColor := clBtnFace;
          Canvas.Brush.Color := F_Color;
          Canvas.Rectangle(Rect);
          Canvas.Draw(0, 0, Bmp);
        finally
          Bmp.Free;
        end;
      finally
        ReleaseDC(hwnd, Canvas.Handle);
        Canvas.Free;
      end;
    end;
  end;
var
  FHeaderHandle: HWND;
begin
  FHeaderHandle := FindWindowEx(hListView, 0, 'SysHeader32', nil);
  F_FARPROC := FARPROC(SetWindowLong(FHeaderHandle, GWL_WNDPROC, LongInt(@NewHeadProc)));
  InvalidateRect(FHeaderHandle, nil, FALSE);
  F_Color := Color;
end;

View Code

绘制TListView背景

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListView1: TListView;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure DrawParentBackground(Control: TControl; DC: HDC; R: PRect = nil;
  bDrawErasebkgnd: Boolean = False);
var
  SaveIndex: Integer;
  MemDC: HDC;
  MemBmp: HBITMAP;
begin
  if R <> nil then
  begin
    MemDC := CreateCompatibleDC(DC);
    MemBmp := CreateCompatibleBitmap(DC, Control.Width, Control.Height);
    SelectObject(MemDC, MemBmp);
    try
      with Control.BoundsRect.TopLeft do
        SetWindowOrgEx(MemDC, X, Y, nil);
      if bDrawErasebkgnd then
        Control.Parent.Perform(WM_ERASEBKGND, Integer(MemDC), Integer(MemDC));
      Control.Parent.Perform(WM_PAINT, Integer(MemDC), Integer(MemDC));
      with Control.BoundsRect.TopLeft do
        BitBlt(DC, R^.Left, R^.Top, R^.Right - R^.Left, R^.Bottom - R^.Top,
          MemDC, X + R^.Left, Y + R^.Top, SRCCOPY);
    finally
      DeleteObject(MemBmp);
      DeleteDC(MemDC);
    end;
    Exit;
  end;
  SaveIndex := SaveDC(DC);
  try
    with Control.BoundsRect.TopLeft do
      SetWindowOrgEx(DC, X, Y, nil);
    if bDrawErasebkgnd then
      Control.Parent.Perform(WM_ERASEBKGND, Integer(DC), Integer(DC));
    Control.Parent.Perform(WM_PAINT, Integer(DC), Integer(DC));
  finally
    RestoreDC(DC, SaveIndex);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
DC: HDC;
begin
DrawParentBackground(listview1,DC);
end;

end.

View Code

如何在同一个listview中拖动item以调整原来的顺序

procedure TForm1.FormCreate(Sender: TObject);
const
  Names: array[0..5, 0..1] of string = (
    ('Rubble', 'Barney'),
    ('Michael', 'Johnson'),
    ('Bunny', 'Bugs'),
    ('Silver', 'HiHo'),
    ('Simpson', 'Bart'),
    ('Squirrel', 'Rocky')
    );

var
  I: Integer;
  NewColumn: TListColumn;
  ListItem: TListItem;
begin
  with ListView do
  begin
    Align := alClient;
    RowSelect := True;
    ViewStyle := vsReport;
    DragMode := dmAutomatic;

    NewColumn := Columns.Add;
    NewColumn.Caption := 'Last';
    NewColumn := Columns.Add;
    NewColumn.Caption := 'First';

    for I := Low(Names) to High(Names) do
    begin
      ListItem := Items.Add;
      ListItem.Caption := Names[I][0];
      ListItem.SubItems.Add(Names[I][1]);
    end;
  end;
end;

procedure TForm1.ListViewDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
var
  TargetItem, SourceItem: TListItem;
begin
  TargetItem := ListView.GetItemAt(X, Y);
  if (Source = Sender) and (TargetItem <> nil) then
  begin
    Accept := True;

    SourceItem := ListView.Selected;
    if SourceItem = TargetItem then
      Accept := False;
  end
  else
    Accept := False;
end;


procedure TForm1.ListViewDragDrop(Sender, Source: TObject; X, Y: Integer);
var
  TargetItem, SourceItem, TempItem: TListItem;
begin
  TargetItem := ListView.GetItemAt(X, Y);
  if TargetItem <> nil then
  begin
    TempItem := TListItem.Create(ListView.Items);

    SourceItem := ListView.Selected;
    TempItem.Assign(SourceItem);
    SourceItem.Assign(TargetItem);
    TargetItem.Assign(TempItem);
    TargetItem.Selected := True;

    FreeAndNil(TempItem);
  end;
end;

View Code

为了释放TreeView中每个节点的Data占用的内存

为了释放TreeView中每个节点的Data占用的内存，需遍历整个TreeView，于是上网搜索一番，参考各位高手的代码，编写如下：
tv: TTreeView;
procedure OverTreeView(node: TTreenode);
......
procedure Form1.FormDestroy(Sender: TObject);
var
  node: TTreenode;
begin
  if tv <> nil then  
  begin
    node := tv.Items.GetFirstNode;
    if (node <> nil) then
    begin
      if (node.Data <> nil) then Dispose(node.Data);
      OverTreeView(node);
    end;
  end;
end;
 
......
 
procedure Form1.OverTreeView(node: TTreenode);
//释放data占用的内存
begin
  while node <> nil do
  begin
    if node.HasChildren then
    begin
      node := node.getFirstChild;
      if node.Data <> nil then Dispose(node.Data);
      Overtreeview(node);
      node := node.Parent;
    end;
    if node.getNextSibling <> nil then
    begin
      node := node.getNextSibling;
      if node.Data <> nil then Dispose(node.Data);
    end else exit;
  end;
end;

View Code

將listview顯示的縮圖加入到listview2

下面的function可以將listview的縮圖加到listview2但是全都顯示listview1第一張的圖片，但是檔名是確定的，只是顯示的圖片都是第一張。

function MoveLvItem(lvOrig,lvdest:TlistView;checked:boolean=false):string;

var i,j:integer;

    itemlist:TObjectlist;

    listitem,newlistitem:TListItem;

begin

  ItemList:=TObjectList.Create(false);

  if not checked then

  begin

    for i:=lvOrig.Selected.Index to lvOrig.Items.Count -1 do

    begin

    if lvorig.Items[i].Selected then ItemList.Add(lvorig.Items[i]);

    end;

  end

  else

  begin

      for i:=0 to lvorig.Items.Count -1 do

      begin

      if lvorig.Items[i].Checked then itemlist.Add(lvorig.Items[i]);

      end;

  end;

    for i:=0 to itemlist.Count -1 do

    begin

      listitem:=itemList[i] as TlistItem;

      newlistitem:= lvdest.Items.Add;

      newlistitem.Caption:=listitem.Caption;

    for j:= 0 to listitem.SubItems.Count -1 do

    begin

      newlistitem.SubItems.Add(listitem.SubItems[j]);

    end;

    end;

    result:=(itemList[0] as TListItem).Caption;

    (ItemList[0] as TlistItem).Delete;

    for i:= 1 to ItemList.Count -1 do

    begin

       result:=Result +','+(Itemlist[-1] as TListItem).Caption;

      (ItemList[1] as TListItem).Delete;

    end;

      ItemList.Free;

    end;

View Code

listview-to-listview2

function MoveLvItem(lvOrig,lvdest:TlistView;checked:boolean=false):string;
var i,j:integer;
    itemlist:TObjectlist;
    listitem,newlistitem:TListItem;
begin
  ItemList:=TObjectList.Create(false);
  if not checked then
  begin
    for i:=lvOrig.Selected.Index to lvOrig.Items.Count -1 do
    begin
    if lvorig.Items[i].Selected then ItemList.Add(lvorig.Items[i]);
    end;
  end
  else
  begin
      for i:=0 to lvorig.Items.Count -1 do
      begin
      if lvorig.Items[i].Checked then itemlist.Add(lvorig.Items[i]);
      end;
  end;
    for i:=0 to itemlist.Count -1 do
    begin
      listitem:=itemList[i] as TlistItem;
      newlistitem:= lvdest.Items.Add;
      newlistitem.Caption:=listitem.Caption;
    for j:= 0 to listitem.SubItems.Count -1 do
    begin
      newlistitem.SubItems.Add(listitem.SubItems[j]);
    end;
    end;
    result:=(itemList[0] as TListItem).Caption;
    (ItemList[0] as TlistItem).Delete;
    for i:= 1 to ItemList.Count -1 do
    begin
       result:=Result +','+(Itemlist[-1] as TListItem).Caption;
      (ItemList[1] as TListItem).Delete;
    end;
      ItemList.Free;
    end;

View Code

自绘LISTVIEW的滚动条

因项目需要准备对LISTVIEW的滚动条进行自绘。于是在网上搜了一下，问题没解决，却搜出一篇令人不愉快的帖子。确实，那时候实力是不够的，但现在应该是没问题了，为这个目的才不断磨练自己的。

LISTVIEW控件的滚动条是系统自带的，它不创建窗口。对LISTVIEW窗口本身进行子类化后，要处理一些跟滚动条有关的消息。

首先是要骗过WM_NCPAINT消息。这个十分容易。WM_NCPAINT消息的wParam是一个区域的句柄。当它不为1时，从它里面CLIP 掉滚动条的区域，再传给原窗口过程即可。当它为1时，创建一个包含控件全客户区域的Region，再从中CLIP掉滚动条的区域，传给原窗口过程。

然后是WM_HSCROLL和WM_VSCROLL消息。在调用原窗口过程之前需要去掉窗口的WS_HSCROLL和WS_VSCROLL样式，否则窗口过程就会在消息中绘制滚动条。调用后需要恢复。同时为避免窗口在WM_STYLECHANGING和WM_STYLECHANGED消息中重绘，也需要截获这两个消息。

WM_NCCALCSIZE消息也是必须截获的。如果是在处理WM_HSCROLL和WM_VSCROLL消息的过程中响应WM_NCCALCSIZE，则必须去掉WS_HSCROLL和WS_VSCROLL样式。

然后是WM_ERASEBACKGROUND,WM_MOUSEWHELL消息。在这消息后需要重绘滚动条。

最重要的莫过于WM_NCHITTEST消息了。因为是自绘，所以滚动条的按下和拖动都必须在这里处理。

在自己写的滚动条Track函数中，最头疼的莫过于ThumbTrack了。当你计算好滚动到的绝对位置后，用SendMessage(hWnd, WM_XSCROLL, MAKEWPARAM(SB_THUMBTRACK, Pos), 0)发给窗口时，它居然没有反应。这是因为窗口过程不会从消息中取得TrackPos，而是会调用GetScrollInfo的API取得 TrackPos（因为前者只有16位）。但是使用SetScrollInfo是没办法设置TrackPos的。虽然你可以用SIF_POS标志让它同时设置Pos和TrackPos，但当Pos等于TrackPos时，窗口过程不会做任何响应。从windows源代码中我们可以了解到，TrackPos 并不会为每个窗口保存一份，实际上，在任一时刻最多只有一个滚动条在做ThumbTrack的操作，因此系统只需要用一个全局变量来保存就可以了。

解决这个问题的办法是HookAPI。在GetScrollInfo中返回我们自己的TrackPos。要注意的是要Hook的不是本模块的 API，而是ComCtl32.dll中的GetScrollInfo。因此简单的如往@GetScrollInfo地址写几句跳转的方法是行不通的。必须遍历ComCtl32.dll的pe头。这种技术在很多文章中都有描述。

不多说了，以下是Delphi代码，要点在前面已有描述，源码中没有做特殊说明。

使用说明：

资源中是一张横条的192*16的位图，从左到右依次是：左箭头、右箭头、上箭头、下箭头、左箭头按下、右箭头按下、上箭头按下、下箭头按下、横Thumb条、纵Thumb条、横背景条、纵背景条。

初始化时，调用GetSkinSB.InitSkinSB(ListView1.Handle);即可。窗口销毁前调用GetSkinSB.UninitSkinSB(ListView1.Handle)。

虽然也可针对EDIT(TMemo)和其它使用系统滚动条的控件使用此模块，但效果各有差异，需要分别做特殊处理。

unit SkinSB;
 
interface
 
uses
  SysUtils, Classes, Windows, Messages, Graphics;
 
const
  SKINSB_PROP = '{8BC6661E-5880-4353-878D-C3B3784CFC5F}';
 
type
 
  TBarPosCode = ( bpcNone,
                  bpcHArrowL, bpcHArrowR, bpcHPageL, bpcHPageR, bpcHThumb,
                  bpcVArrowU, bpcVArrowD, bpcVPageU, bpcVPageD, bpcVThumb,
                  bpcCross );
 
  TWindowProc = function (hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
 
  PSkinSBInfo = ^TSkinSBInfo;
  TSkinSBInfo = packed record
    OldWndProc: TWindowProc;
    Prevent: Boolean; // prevent style change message
    Scrolling: Boolean;
    Style: Cardinal; // real style
    ThumbTrack: Boolean;
    ThumbPos: Integer;
    Tracking: Boolean; // tracking: click arrow or track thumb
  end;
 
  TSkinSB = class
  protected
    FBitmap: TBitmap;
    constructor CreateInstance;
  public
    constructor Create;
    destructor Destroy; override;
    procedure InitSkinSB(H: HWND);
    procedure UnInitSkinSB(H: HWND);
    procedure DrawElem(H: HWND; Code: TBarPosCode; R: TRect; Down: Boolean);
  end;
 
function GetSkinSB: TSkinSB;
 
function SkinSBWndProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
function GetSkinSBInfo(hWnd: HWND): PSkinSBInfo;
 
implementation
 
uses
  CommCtrl;
 
{$R *.res}
 
var
  l_SkinSB: TSkinSB;
  l_SkinSB_Prop: TATOM;
 
type
  PImageImportDescriptor = ^TImageImportDescriptor;
  TImageImportDescriptor = packed record
    OriginalFirstThunk: DWORD;  // or Characteristics: DWORD
    TimeDateStamp: DWORD;
    ForwarderChain: DWORD;
    Name: DWORD;
    FirstThunk: DWORD;
  end;
  PImageChunkData = ^TImageChunkData;
  TImageChunkData = packed record
    case Integer of
      0: ( ForwarderString: DWORD );
      1: ( Func: DWORD );
      2: ( Ordinal: DWORD );
      3: ( AddressOfData: DWORD );
  end;
  PImageImportByName = ^TImageImportByName;
  TImageImportByName = packed record
    Hint: Word;
    Name: array[0..0] of Byte;
  end;
 
type
  PHookRec = ^THookRec;
  THookRec = packed record
    OldFunc: Pointer;
    NewFunc: Pointer;
  end;
 
var
  _HookGetScrollInfo: THookRec;
 
procedure HookApiInMod(ImageBase: Cardinal; ApiName: PChar; PHook: PHookRec);
var
  pidh: PImageDosHeader;
  pinh: PImageNtHeaders;
  pSymbolTable: PIMAGEDATADIRECTORY;
  piid: PIMAGEIMPORTDESCRIPTOR;
  pitd_org, pitd_1st: PImageChunkData;
  piibn: PImageImportByName;
  pAPIFunction: Pointer;
  written, oldAccess: DWORD;
begin
  if ImageBase = 0 then Exit;
  pidh := PImageDosHeader(ImageBase);
  pinh := PImageNtHeaders(DWORD(ImageBase) + Cardinal(pidh^._lfanew));
  pSymbolTable := @pinh^.OptionalHeader.DataDirectory[1];
  piid := PImageImportDescriptor(DWORD(ImageBase) + pSymbolTable^.VirtualAddress);
  repeat
    pitd_org := PImageChunkData(DWORD(ImageBase) + piid^.OriginalFirstThunk);
    pitd_1st := PImageChunkData(DWORD(ImageBase) + piid^.FirstThunk);
    repeat
      piibn := PImageImportByName(DWORD(ImageBase) + LPDWORD(pitd_org)^);
      pAPIFunction := Pointer(pitd_1st^.Func);
      if StrComp(ApiName, @piibn^.Name) = 0 then
      begin
        PHook^.OldFunc := pAPIFunction;
        VirtualProtect(@(pitd_1st^.Func), SizeOf(DWORD), PAGE_WRITECOPY, oldAccess);
        WriteProcessMemory(GetCurrentProcess(), @(pitd_1st^.Func), @PHook^.NewFunc, SizeOf(DWORD), written);
        VirtualProtect(@(pitd_1st^.Func), SizeOf(DWORD), oldAccess, oldAccess);
      end;
      Inc(pitd_org);
      Inc(pitd_1st);
    until pitd_1st^.Func = 0;
    Inc(piid);
  until piid^.FirstThunk + piid^.OriginalFirstThunk + piid^.ForwarderChain + piid^.Name = 0;
end;
 
function GetSkinSBInfo(hWnd: HWND): PSkinSBInfo;
begin
  Result := PSkinSBInfo( GetProp(hWnd, MAKEINTATOM(l_SkinSB_Prop)) );
end;
 
function GetSkinSB: TSkinSB;
begin
  if l_SkinSB = nil then l_SkinSB := TSkinSB.CreateInstance;
  Result := l_SkinSB;
end;
 
function CalcScrollBarRect(H: HWND; nBarCode: Cardinal): TRect;
var
  Style, ExStyle: Cardinal;
begin
  SetRect(Result, 0, 0, 0, 0);
  Style := GetWindowLong(H, GWL_STYLE);
  ExStyle := GetWindowLong(H, GWL_EXSTYLE);
  if (nBarCode = SB_HORZ) and ((Style and WS_HSCROLL) = 0) then Exit;
  if (nBarCode = SB_VERT) and ((Style and WS_VSCROLL) = 0) then Exit;
  GetWindowRect(H, Result);
  OffsetRect(Result, -Result.Left, -Result.Top);
  if ((ExStyle and WS_EX_DLGMODALFRAME) <> 0)
    or ((ExStyle and WS_EX_CLIENTEDGE) <> 0) then
  begin
    InflateRect(Result, -GetSystemMetrics(SM_CXEDGE), -GetSystemMetrics(SM_CYEDGE));
  end;
  // special: returns the cross
  if nBarCode = SB_BOTH then
  begin
    if ((Style and WS_HSCROLL) = 0) or ((Style and WS_VSCROLL) = 0) then
    begin
      SetRect(Result, 0, 0, 0, 0);
      Exit;
    end;
    Result.Top := Result.Bottom - GetSystemMetrics(SM_CYVSCROLL);
    if (ExStyle and WS_EX_LEFTSCROLLBAR) <> 0 then Result.Right := Result.Left + GetSystemMetrics(SM_CXHSCROLL)
    else Result.Left := Result.Right - GetSystemMetrics(SM_CXHSCROLL);
    Exit;
  end;
  if nBarCode = SB_HORZ then
  begin
  //    if (ExStyle and WS_EX_TOPSCROLLBAR) <> 0 then Result.Bottom := Result.Top + GetSystemMetrics(SM_CYVSCROLL)
    Result.Top := Result.Bottom - GetSystemMetrics(SM_CYVSCROLL);
    if ((Style and WS_VSCROLL) <> 0) then Dec(Result.Right, GetSystemMetrics(SM_CYVSCROLL));
  end;
  if nBarCode = SB_VERT then
  begin
    if (ExStyle and WS_EX_LEFTSCROLLBAR) <> 0 then Result.Right := Result.Left + GetSystemMetrics(SM_CXHSCROLL)
    else Result.Left := Result.Right - GetSystemMetrics(SM_CXHSCROLL);
    if ((Style and WS_HSCROLL) <> 0) then Dec(Result.Bottom, GetSystemMetrics(SM_CXHSCROLL));
  end;
end;
 
type
  TBarElem = (beArrow1, beBG, beThumb, beArrow2);
  TBarElemRects = array[TBarElem] of TRect;
 
function CalcBarElemRects(hWnd: HWND; nBarCode: Integer): TBarElemRects;
var
  R: TRect;
  SI: TScrollInfo;
  ThumbSize: Integer;
  X, L, H, BlockH, BlockV: Integer;
begin
  R := CalcScrollBarRect(hWnd, nBarCode);
  SI.cbSize := SizeOf(SI);
  SI.fMask := SIF_ALL;
  GetScrollInfo(hWnd, nBarCode, SI);
  Result[beArrow1] := R;
  Result[beArrow2] := R;
  Result[beBG] := R;
  Result[beThumb] := R;
  if nBarCode = SB_VERT then
  begin
    BlockV := GetSystemMetrics(SM_CYVSCROLL);
    L := Result[beArrow1].Top + BlockV;
    H := Result[beArrow2].Bottom - BlockV;
    Result[beArrow1].Bottom := L;
    Result[beArrow2].Top := H;
//    Inc(L);
//    Dec(H);
    Result[beBG].Top := L;
    Result[beBG].Bottom := H;
  end
  else
  begin
    BlockH := GetSystemMetrics(SM_CXHSCROLL);
    L := Result[beArrow1].Left + BlockH;
    H := Result[beArrow2].Right - BlockH;
    Result[beArrow1].Right := L;
    Result[beArrow2].Left := H;
//    Inc(L);
//    Dec(H);
    Result[beBG].Left := L;
    Result[beBG].Right := H;
  end;
  if SI.nMax - SI.nMin - Integer(SI.nPage) + 1 <= 0 then
  begin
    // max thumb, no thumb
    if nBarCode = SB_VERT then
    begin
      Result[beThumb].Top := L;
      Result[beThumb].Bottom := H;
    end
    else
    begin
      Result[beThumb].Left := L;
      Result[beThumb].Right := H;
    end;
    Exit;
  end;
  ThumbSize := MulDiv(H - L, SI.nPage, SI.nMax - SI.nMin + 1);
  X := L + MulDiv(SI.nTrackPos, H - ThumbSize - L, SI.nMax - Integer(SI.nPage) - SI.nMin + 1);
  if nBarCode = SB_VERT then
  begin
    Result[beThumb].Top := X;
    Result[beThumb].Bottom := X + ThumbSize;
  end
  else
  begin
    Result[beThumb].Left := X;
    Result[beThumb].Right := X + ThumbSize;
  end;
end;
 
function GetPtBarPos(H: HWND; Pt: TPoint): TBarPosCode;
var
  R: TRect;
  BR: TBarElemRects;
begin
  Result := bpcNone;
  R := CalcScrollBarRect(H, SB_HORZ);
  InflateRect(R, GetSystemMetrics(SM_CXEDGE), GetSystemMetrics(SM_CYEDGE));
  if PtInRect(R, Pt) then
  begin
    BR := CalcBarElemRects(H, SB_HORZ);
    if PtInRect(BR[beArrow1], Pt) then Result := bpcHArrowL
    else if PtInRect(BR[beThumb], Pt) then Result := bpcHThumb
    else if PtInRect(BR[beArrow2], Pt) then Result := bpcHArrowR
    else if Pt.X < BR[beThumb].Left then Result := bpcHPageL
    else Result := bpcHPageR;
    Exit;
  end;
  R := CalcScrollBarRect(H, SB_VERT);
  InflateRect(R, GetSystemMetrics(SM_CXEDGE), GetSystemMetrics(SM_CYEDGE));
  if PtInRect(R, Pt) then
  begin
    BR := CalcBarElemRects(H, SB_VERT);
    if PtInRect(BR[beArrow1], Pt) then Result := bpcVArrowU
    else if PtInRect(BR[beThumb], Pt) then Result := bpcVThumb
    else if PtInRect(BR[beArrow2], Pt) then Result := bpcVArrowD
    else if Pt.Y < BR[beThumb].Top then Result := bpcVPageU
    else Result := bpcVPageD;
    Exit;
  end;
end;
 
type
  TGetScrollInfoFunc = function (H: HWND; Code: Integer; var SI: TScrollInfo): Boolean; stdcall;
 
function _SkinSB_GetScrollInfo(H: HWND; Code: Integer; var SI: TScrollInfo): Boolean; stdcall;
var
  P: PSkinSBInfo;
begin
  Result := TGetScrollInfoFunc(_HookGetScrollInfo.OldFunc)(H, Code, SI);
  P := GetSkinSBInfo(H);
  if (P <> nil) and P^.ThumbTrack and ((SI.fMask and SIF_TRACKPOS) <> 0) then
  begin
    SI.nTrackPos := P^.ThumbPos;
  end;
end;
 
{ TSkinSB }
 
constructor TSkinSB.Create;
begin
  raise Exception.Create('use GetSkinSB.');
end;
 
constructor TSkinSB.CreateInstance;
begin
  inherited;
  _HookGetScrollInfo.OldFunc := nil;
  _HookGetScrollInfo.NewFunc := @_SkinSB_GetScrollInfo;
  HookApiInMod( GetModuleHandle('comctl32.dll'), 'GetScrollInfo', @_HookGetScrollInfo );
  FBitmap := TBitmap.Create;
  FBitmap.LoadFromResourceName(hInstance, 'scrollbar');
end;
 
destructor TSkinSB.Destroy;
begin
  FreeAndNil(FBitmap);
  inherited;
end;
 
procedure TSkinSB.DrawElem(H: HWND; Code: TBarPosCode; R: TRect;
  Down: Boolean);
var
  Canvas: TCanvas;
begin
  Canvas := TCanvas.Create;
  try
    Canvas.Handle := GetWindowDC(H);
    try
      case Code of
        bpcHArrowL:
        begin
          if Down then BitBlt(Canvas.Handle, R.Left, R.Top, 16, 16, FBitmap.Canvas.Handle, 64, 0, SRCCOPY)
          else BitBlt(Canvas.Handle, R.Left, R.Top, 16, 16, FBitmap.Canvas.Handle, 0, 0, SRCCOPY);
          Exit;
        end;
        bpcHArrowR:
        begin
          if Down then BitBlt(Canvas.Handle, R.Left, R.Top, 16, 16, FBitmap.Canvas.Handle, 80, 0, SRCCOPY)
          else BitBlt(Canvas.Handle, R.Left, R.Top, 16, 16, FBitmap.Canvas.Handle, 16, 0, SRCCOPY);
          Exit;
        end;
        bpcHThumb:
        begin
          BitBlt(Canvas.Handle, R.Left, R.Top, 2, 16, FBitmap.Canvas.Handle, 128, 0, SRCCOPY);
          BitBlt(Canvas.Handle, R.Right - 2, R.Top, 2, 16, FBitmap.Canvas.Handle, 142, 0, SRCCOPY);
          StretchBlt(Canvas.Handle, R.Left + 2, R.Top, R.Right - R.Left - 4, 16, FBitmap.Canvas.Handle,
            130, 0, 12, 16, SRCCOPY);
          Exit;
        end;
        bpcHPageL, bpcHPageR:
        begin
          if R.Right - R.Left < 4 then
          begin
            StretchBlt(Canvas.Handle, R.Left, R.Top, R.Right - R.Left, 16, FBitmap.Canvas.Handle,
              160, 0, 16, 16, SRCCOPY);
          end
          else
          begin
            BitBlt(Canvas.Handle, R.Left, R.Top, 2, 16, FBitmap.Canvas.Handle, 160, 0, SRCCOPY);
            BitBlt(Canvas.Handle, R.Right - 2, R.Top, 2, 16, FBitmap.Canvas.Handle, 174, 0, SRCCOPY);
            StretchBlt(Canvas.Handle, R.Left + 2, R.Top, R.Right - R.Left - 4, 16, FBitmap.Canvas.Handle,
              162, 0, 12, 16, SRCCOPY);
          end;
          Exit;
        end;
        bpcVArrowU:
        begin
          if Down then BitBlt(Canvas.Handle, R.Left, R.Top, 16, 16, FBitmap.Canvas.Handle, 96, 0, SRCCOPY)
          else BitBlt(Canvas.Handle, R.Left, R.Top, 16, 16, FBitmap.Canvas.Handle, 32, 0, SRCCOPY);
          Exit;
        end;
        bpcVArrowD:
        begin
          if Down then BitBlt(Canvas.Handle, R.Left, R.Top, 16, 16, FBitmap.Canvas.Handle, 112, 0, SRCCOPY)
          else BitBlt(Canvas.Handle, R.Left, R.Top, 16, 16, FBitmap.Canvas.Handle, 48, 0, SRCCOPY);
          Exit;
        end;
        bpcVThumb:
        begin
          BitBlt(Canvas.Handle, R.Left, R.Top, 16, 2, FBitmap.Canvas.Handle, 144, 0, SRCCOPY);
          BitBlt(Canvas.Handle, R.Left, R.Bottom - 2, 16, 2, FBitmap.Canvas.Handle, 144, 14, SRCCOPY);
          StretchBlt(Canvas.Handle, R.Left, R.Top + 2, 16, R.Bottom - R.Top - 4, FBitmap.Canvas.Handle,
            144, 2, 16, 12, SRCCOPY);
          Exit;
        end;
        bpcVPageU, bpcVPageD:
        begin
          if R.Bottom - R.Top < 4 then
          begin
            StretchBlt(Canvas.Handle, R.Left, R.Top, 16, R.Bottom - R.Top, FBitmap.Canvas.Handle,
              176, 0, 16, 16, SRCCOPY);
          end
          else
          begin
            BitBlt(Canvas.Handle, R.Left, R.Top, 16, 2, FBitmap.Canvas.Handle, 176, 0, SRCCOPY);
            BitBlt(Canvas.Handle, R.Left, R.Bottom - 2, 16, 2, FBitmap.Canvas.Handle, 176, 14, SRCCOPY);
            StretchBlt(Canvas.Handle, R.Left, R.Top + 2, 16, R.Bottom - R.Top - 4, FBitmap.Canvas.Handle,
              176, 2, 16, 12, SRCCOPY);
          end;
          Exit;
        end;
      end;
      Canvas.Pen.Color := clBlack;
      Canvas.Brush.Color := clWhite;
      Canvas.Rectangle(R);
    finally
      ReleaseDC(H, Canvas.Handle);
    end;
  finally
    Canvas.Handle := 0;
    FreeAndNil(Canvas);
  end;
end;
 
procedure TSkinSB.InitSkinSB(H: HWND);
var
  PInfo: PSkinSBInfo;
begin
  PInfo := GetSkinSBInfo(H);
  if PInfo <> nil then Exit; // already inited
  New(PInfo);
  PInfo^.OldWndProc := TWindowProc(GetWindowLong(H, GWL_WNDPROC));
  PInfo^.Style := GetWindowLong(H, GWL_STYLE);
  PInfo^.Prevent := False;
  PInfo^.Scrolling := False;
  PInfo^.ThumbTrack := False;
  SetWindowLong(H, GWL_WNDPROC, Cardinal(@SkinSBWndProc));
  SetProp(H, MAKEINTATOM(l_SkinSB_Prop), Cardinal(PInfo));
end;
 
procedure TSkinSB.UnInitSkinSB(H: HWND);
var
  PInfo: PSkinSBInfo;
begin
  PInfo := GetSkinSBInfo(H);
  if PInfo = nil then Exit; // not inited
  RemoveProp(H, MAKEINTATOM(l_SkinSB_Prop));
  SetWindowLong(H, GWL_WNDPROC, Cardinal(@PInfo^.OldWndProc));
  Dispose(PInfo);
end;
 
const
  WM_REPEAT_CLICK = WM_USER + $6478;
 
procedure OnRepeatClickTimer(hWnd: HWND; uMsg: UINT; idEvent: UINT; dwTime: DWORD); stdcall;
begin
  KillTimer(0, idEvent);
  PostThreadMessage(MainThreadID, WM_REPEAT_CLICK, 0, 0);
end;
 
procedure RedrawScrollBars(hWnd: HWND);
var
  RHBar, RVBar, RCross: TRect;
  BR: TBarElemRects;
begin
  RHBar := CalcScrollBarRect(hWnd, SB_HORZ);
  if not IsRectEmpty(RHBar) then
  begin
    BR := CalcBarElemRects(hWnd, SB_HORZ);
    GetSkinSB.DrawElem(hWnd, bpcHPageL, Rect(BR[beBG].Left, BR[beBG].Top, BR[beThumb].Left, BR[beBG].Bottom), False);
    GetSkinSB.DrawElem(hWnd, bpcHPageR, Rect(BR[beThumb].Right, BR[beBG].Top, BR[beBG].Right, BR[beBG].Bottom), False);
    GetSkinSB.DrawElem(hWnd, bpcHThumb, BR[beThumb], False);
    GetSkinSB.DrawElem(hWnd, bpcHArrowL, BR[beArrow1], False);
    GetSkinSB.DrawElem(hWnd, bpcHArrowR, BR[beArrow2], False);
  end;
  RVBar := CalcScrollBarRect(hWnd, SB_VERT);
  if not IsRectEmpty(RVBar) then
  begin
    BR := CalcBarElemRects(hWnd, SB_VERT);
    GetSkinSB.DrawElem(hWnd, bpcVPageU, Rect(BR[beBG].Left, BR[beBG].Top, BR[beBG].Right, BR[beThumb].Top), False);
    GetSkinSB.DrawElem(hWnd, bpcVPageD, Rect(BR[beBG].Left, BR[beThumb].Bottom, BR[beBG].Right, BR[beBG].Bottom), False);
    GetSkinSB.DrawElem(hWnd, bpcVThumb, BR[beThumb], False);
    GetSkinSB.DrawElem(hWnd, bpcVArrowU, BR[beArrow1], False);
    GetSkinSB.DrawElem(hWnd, bpcVArrowD, BR[beArrow2], False);
  end;
  RCross := CalcScrollBarRect(hWnd, SB_BOTH);
  if not IsRectEmpty(RCross) then
  begin
    GetSkinSB.DrawElem(hWnd, bpcCross, RCross, False);
  end;
end;
 
procedure TrackBar(hWnd: HWND; nBarCode: Integer; PosCode: TBarPosCode; BarElem: TBarElem; MsgCode: Integer);
var
  BR: TBarElemRects;
  Msg: tagMSG;
  Pt: TPoint;
  R: TRect;
  ScrollMsg: Cardinal;
  RepeatClick: Boolean;
  idEvent: UINT;
  SI: TScrollInfo;
 
  procedure RefreshRect;
  begin
    BR := CalcBarElemRects(hWnd, nBarCode);
    R := BR[BarElem];
  end;
 
begin
  RepeatClick := False;
  BR := CalcBarElemRects(hWnd, nBarCode);
  R := BR[BarElem];
  GetScrollInfo(hWnd, nBarCode, SI);
  if nBarCode = SB_HORZ then ScrollMsg := WM_HSCROLL
  else ScrollMsg := WM_VSCROLL;
  if BarElem = beBG then
  begin
    if PosCode = bpcHPageL then R.Right := BR[beThumb].Left
    else if PosCode = bpcHPageR then R.Left := BR[beThumb].Right
    else if PosCode = bpcVPageU then R.Bottom := BR[beThumb].Top
    else if PosCode = bpcVPageD then R.Top := BR[beThumb].Bottom;
  end;
  GetSkinSB.DrawElem(hWnd, PosCode, R, True);
  GetSkinSBInfo(hWnd)^.Tracking := True;
  idEvent := 0;
  try
    SetCapture(hWnd);
    idEvent := SetTimer(0, 0, 1000, @OnRepeatClickTimer);
    while GetCapture = hWnd do
    begin
      if not GetMessage(Msg, 0, 0, 0) then Break;
      if (Msg.hwnd = 0) and (Msg.message = WM_REPEAT_CLICK) then
      begin
        GetCursorPos(Pt);
        ScreenToClient(hWnd, Pt);
        if PtInRect(R, Pt) then
        begin
          RepeatClick := True;
          SendMessage(hWnd, ScrollMsg, MsgCode, 0);
          SendMessage(hWnd, ScrollMsg, SB_ENDSCROLL, 0);
          RefreshRect;
          GetSkinSB.DrawElem(hWnd, PosCode, R, True);
//          if MsgCode = SB_LINEDOWN then SetScrollPos(hWnd, nBarCode, GetScrollPos(hWnd, nBarCode) + 1, False);
          if MsgCode = SB_PAGEDOWN then SetScrollPos(hWnd, nBarCode, GetScrollPos(hWnd, nBarCode) + Integer(SI.nPage), False);
//          if MsgCode = SB_LINEUP then SetScrollPos(hWnd, nBarCode, GetScrollPos(hWnd, nBarCode) - 1, False);
          if MsgCode = SB_PAGEUP then SetScrollPos(hWnd, nBarCode, GetScrollPos(hWnd, nBarCode) - Integer(SI.nPage), False);
          RedrawScrollBars(hWnd);
          SetTimer(0, 0, 80, @OnRepeatClickTimer);
        end;
      end
      else if Msg.hwnd = hWnd then
      begin
        case Msg.message of
          WM_LBUTTONUP:
          begin
            if RepeatClick then Break;
            GetCursorPos(Pt);
            ScreenToClient(hWnd, Pt);
            if PtInRect(R, Pt) then
            begin
              SendMessage(hWnd, ScrollMsg, MsgCode, 0);
              SendMessage(hWnd, ScrollMsg, SB_ENDSCROLL, 0);
              RefreshRect;
//              if MsgCode = SB_LINEDOWN then SetScrollPos(hWnd, nBarCode, GetScrollPos(hWnd, nBarCode) + 1, False);
              if MsgCode = SB_PAGEDOWN then SetScrollPos(hWnd, nBarCode, GetScrollPos(hWnd, nBarCode) + Integer(SI.nPage), False);
//              if MsgCode = SB_LINEUP then SetScrollPos(hWnd, nBarCode, GetScrollPos(hWnd, nBarCode) - 1, False);
              if MsgCode = SB_PAGEUP then SetScrollPos(hWnd, nBarCode, GetScrollPos(hWnd, nBarCode) - Integer(SI.nPage), False);
            end;
            Break;
          end;
        end;
      end;
      DispatchMessage(Msg);
    end;
  finally
    if idEvent <> 0 then KillTimer(0, idEvent);
    if IsWindow(hWnd) then
    begin
      if GetCapture = hWnd then ReleaseCapture;
      GetSkinSB.DrawElem(hWnd, PosCode, R, False);
      GetSkinSBInfo(hWnd)^.Tracking := False;
    end;
  end;
end;
 
procedure TrackThumb(hWnd: HWND; nBarCode: Integer; PosCode: TBarPosCode; BarElem: TBarElem);
var
  BR: TBarElemRects;
  Msg: tagMSG;
  Pt: TPoint;
  DragX: Integer;
  R: TRect;
  ScrollMsg: Cardinal;
  SI, SI2: TScrollInfo;
  Pos: Integer;
  H, L, ThumbSize, X: Integer;
  Pushed: Boolean;
 
  function ValidDragArea(ARect: TRect; APt: TPoint): Boolean;
  begin
    if nBarCode = SB_HORZ then Result := Abs((ARect.Bottom + ARect.Top) div 2 - APt.Y) < 150
    else Result := Abs((ARect.Left + ARect.Right) div 2 - APt.X) < 150;
  end;
 
  function CalcPos(ARect: TRect; APt: TPoint; ADragX: Integer): Integer;
  var
    NewX: Integer;
  begin
    if nBarCode = SB_HORZ then NewX := APt.X - ADragX
    else NewX := APt.Y - ADragX;
    Result := SI.nMin + MulDiv(NewX - L, SI.nMax - Integer(SI.nPage) - SI.nMin + 1, H - L - ThumbSize);
    if Result < SI.nMin then Result := SI.nMin;
    if Result > SI.nMax - Integer(SI.nPage) + 1 then
      Result := SI.nMax - Integer(SI.nPage) + 1;
  end;
 
  procedure UpdateDragBar(ADown: Boolean; APos: Integer = -10000);
  var
    W: Integer;
  begin
    BR := CalcBarElemRects(hWnd, nBarCode);
    R := BR[BarElem];
    if nBarCode = SB_HORZ then
    begin
      if APos <> -10000 then
      begin
        W := R.Right - R.Left;
        if APos < BR[beArrow1].Right then APos := BR[beArrow1].Right;
        if APos + W > BR[beArrow2].Left then APos := BR[beArrow2].Left - W;
        R.Left := APos;
        R.Right := APos + W;
      end;
      GetSkinSB.DrawElem(hWnd, bpcHPageL, Rect(BR[beBG].Left, BR[beBG].Top, R.Left, BR[beBG].Bottom), False);
      GetSkinSB.DrawElem(hWnd, bpcHPageR, Rect(R.Right, BR[beBG].Top, BR[beBG].Right, BR[beBG].Bottom), False);
    end
    else
    begin
      if APos <> -10000 then
      begin
        W := R.Bottom - R.Top;
        if APos < BR[beArrow1].Bottom then APos := BR[beArrow1].Bottom;
        if APos + W >= BR[beArrow2].Top then APos := BR[beArrow2].Top - W - 1;
        R.Top := APos;
        R.Bottom := APos + W;
      end;
      GetSkinSB.DrawElem(hWnd, bpcVPageU, Rect(BR[beBG].Left, BR[beBG].Top, BR[beBG].Right, R.Top), False);
      GetSkinSB.DrawElem(hWnd, bpcVPageD, Rect(BR[beBG].Left, R.Bottom, BR[beBG].Right, BR[beBG].Bottom), False);
    end;
    GetSkinSB.DrawElem(hWnd, PosCode, R, ADown);
    OutputDebugString(PChar(Format('R=(%d,%d,%d,%d)', [R.Left, R.Top, R.Right, R.Bottom])));
  end;
 
begin
  BR := CalcBarElemRects(hWnd, nBarCode);
  R := BR[BarElem];
  if nBarCode = SB_HORZ then ScrollMsg := WM_HSCROLL
  else ScrollMsg := WM_VSCROLL;
  SI.cbSize := SizeOf(SI);
  SI.fMask := SIF_ALL;
  GetScrollInfo(hWnd, nBarCode, SI);
  GetCursorPos(Pt);
  ScreenToClient(hWnd, Pt);
  if nBarCode = SB_HORZ then
  begin
    DragX := Pt.X - BR[beThumb].Left;
    ThumbSize := BR[beThumb].Right - BR[beThumb].Left;
    L := BR[beArrow1].Right;
    H := BR[beArrow2].Left;
  end
  else
  begin
    DragX := Pt.Y - BR[beThumb].Top;
    ThumbSize := BR[beThumb].Bottom - BR[beThumb].Top;
    L := BR[beArrow1].Bottom;
    H := BR[beArrow2].Top;
  end;
{  if nBarCode = SB_HORZ then SendMessage(hWnd, WM_SYSCOMMAND, SC_HSCROLL, MAKELPARAM(Pt.X, Pt.Y))
  else SendMessage(hWnd, WM_SYSCOMMAND, SC_VSCROLL, MAKELPARAM(Pt.X, Pt.Y)); }
  GetSkinSBInfo(hWnd)^.Tracking := True;
  UpdateDragBar(True);
  try
    SetCapture(hWnd);
    while GetCapture = hWnd do
    begin
      if not GetMessage(Msg, 0, 0, 0) then Break;
      if Msg.hwnd = hWnd then
      begin
        case Msg.message of
          WM_MOUSEMOVE:
          begin
            Pushed := ValidDragArea(R, Pt);
            GetCursorPos(Pt);
            ScreenToClient(hWnd, Pt);
            if ValidDragArea(R, Pt) then
            begin
              Pos := CalcPos(R, Pt, DragX);
              if nBarCode = SB_HORZ then X := Pt.X - DragX
              else X := Pt.Y - DragX;
            end
            else
            begin
              Pos := SI.nPos;
              X := DragX;
            end;
            GetSkinSBInfo(hWnd)^.ThumbPos := Pos;
            GetSkinSBInfo(hWnd)^.ThumbTrack := True;
            SendMessage(hWnd, ScrollMsg, MAKEWPARAM(SB_THUMBTRACK, Pos), 0);
            GetSkinSBInfo(hWnd)^.ThumbTrack := False;
            UpdateDragBar(Pushed, X);
          end;
          WM_LBUTTONUP:
          begin
            GetCursorPos(Pt);
            ScreenToClient(hWnd, Pt);
            if ValidDragArea(R, Pt) then
            begin
              Pos := CalcPos(R, Pt, DragX);
              SI2.cbSize := SizeOf(SI2);
              SI2.fMask := SIF_ALL;
              GetScrollInfo(hWnd, nBarCode, SI2);
              SI2.nPos := Pos;
              SI2.nTrackPos := Pos;
              SetScrollInfo(hWnd, nBarCode, SI2, False);
              SI2.nTrackPos := 0;
              SI2.nPos := 0;
              GetScrollInfo(hWnd, nBarCode, SI2);
              SendMessage(hWnd, ScrollMsg, MAKEWPARAM(SB_THUMBPOSITION, Pos), 0);
              SendMessage(hWnd, ScrollMsg, SB_ENDSCROLL, 0);
            end;
            Break;
          end;
        end;
      end;
      DispatchMessage(Msg);
    end;
  finally
    if IsWindow(hWnd) then
    begin
      if GetCapture = hWnd then ReleaseCapture;
      GetSkinSBInfo(hWnd)^.Tracking := False;
    end;
    UpdateDragBar(False);
  end;
end;
 
function SkinSBWndProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
var
  PInfo: PSkinSBInfo;
  Style, ExStyle: Cardinal;
  R, RHBar, RVBar, RCross: TRect;
  Pt: TPoint;
  Rgn, Rgn2: HRGN;
  PR: PRect;
  BR: TBarElemRects;
  XBar, YBar: Integer;
begin
  PInfo := GetSkinSBInfo(hWnd);
  if PInfo = nil then Result := DefWindowProc(hWnd, uMsg, wParam, lParam) //// error!!!
  else
  begin
    case uMsg of
      WM_NCHITTEST:
      begin
        GetCursorPos(Pt);
        ScreenToClient(hWnd, Pt);
        case GetPtBarPos(hWnd, Pt) of
          bpcHArrowL:
          begin
            if (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
            begin
              if GetCapture <> hWnd then
                TrackBar(hWnd, SB_HORZ, bpcHArrowL, beArrow1, SB_LINELEFT);
            end;
            Result := HTNOWHERE;
            Exit;
          end;
          bpcHArrowR:
          begin
            if (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
            begin
              if GetCapture <> hWnd then
                TrackBar(hWnd, SB_HORZ, bpcHArrowR, beArrow2, SB_LINERIGHT);
            end;
            Result := HTNOWHERE;
            Exit;
          end;
          bpcHPageL:
          begin
            if (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
            begin
              if GetCapture <> hWnd then
              begin
                TrackBar(hWnd, SB_HORZ, bpcHPageL, beBG, SB_PAGELEFT);
                RedrawScrollBars(hWnd);
              end;
            end;
            Result := HTNOWHERE;
            Exit;
          end;
          bpcHPageR:
          begin
            if (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
            begin
              if GetCapture <> hWnd then
              begin
                TrackBar(hWnd, SB_HORZ, bpcHPageR, beBG, SB_PAGERIGHT);
                RedrawScrollBars(hWnd);
              end;
            end;
            Result := HTNOWHERE;
            Exit;
          end;
          bpcHThumb:
          begin
            if (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
            begin
              if GetCapture <> hWnd then
                TrackThumb(hWnd, SB_HORZ, bpcHThumb, beThumb);
            end;
            Result := HTNOWHERE;
            Exit;
          end;
 
          bpcVArrowU:
          begin
            if (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
            begin
              if GetCapture <> hWnd then
                TrackBar(hWnd, SB_VERT, bpcVArrowU, beArrow1, SB_LINELEFT);
            end;
            Result := HTNOWHERE;
            Exit;
          end;
          bpcVArrowD:
          begin
            if (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
            begin
              if GetCapture <> hWnd then
                TrackBar(hWnd, SB_VERT, bpcVArrowD, beArrow2, SB_LINERIGHT);
            end;
            Result := HTNOWHERE;
            Exit;
          end;
          bpcVPageU:
          begin
            if (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
            begin
              if GetCapture <> hWnd then
              begin
                TrackBar(hWnd, SB_VERT, bpcVPageU, beBG, SB_PAGELEFT);
                RedrawScrollBars(hWnd);
              end;
            end;
            Result := HTNOWHERE;
            Exit;
          end;
          bpcVPageD:
          begin
            if (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
            begin
              if GetCapture <> hWnd then
              begin
                TrackBar(hWnd, SB_VERT, bpcVPageD, beBG, SB_PAGERIGHT);
                RedrawScrollBars(hWnd);
              end;
            end;
            Result := HTNOWHERE;
            Exit;
          end;
          bpcVThumb:
          begin
            if (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
            begin
              if GetCapture <> hWnd then
                TrackThumb(hWnd, SB_VERT, bpcVThumb, beThumb);
            end;
            Result := HTNOWHERE;
            Exit;
          end;
        end;
      end;
      WM_HSCROLL:
      begin
        PInfo^.Scrolling := True;
        Style := GetWindowLong(hWnd, GWL_STYLE);
        PInfo^.Style := Style;
        PInfo^.Prevent := True;
        try
          SetWindowLong(hWnd, GWL_STYLE, Style and (not (WS_VSCROLL or WS_HSCROLL)));
        finally
          PInfo^.Prevent := False;
        end;
        Result := CallWindowProc(@PInfo^.OldWndProc, hWnd, uMsg, wParam, lParam);
        RedrawScrollBars(hWnd);
        PInfo^.Prevent := True;
        try
          SetWindowLong(hWnd, GWL_STYLE, Style);
        finally
          PInfo^.Prevent := False;
        end;
        PInfo^.Scrolling := False;
        Exit;
      end;
 
      WM_VSCROLL:
      begin
        PInfo^.Scrolling := True;
        Style := GetWindowLong(hWnd, GWL_STYLE);
        PInfo^.Style := Style;
        PInfo^.Prevent := True;
        try
          SetWindowLong(hWnd, GWL_STYLE, Style and (not (WS_VSCROLL or WS_HSCROLL)));
        finally
          PInfo^.Prevent := False;
        end;
        Result := CallWindowProc(@PInfo^.OldWndProc, hWnd, uMsg, wParam, lParam);
        PInfo^.Prevent := True;
        try
          SetWindowLong(hWnd, GWL_STYLE, Style);
        finally
          PInfo^.Prevent := False;
        end;
        PInfo^.Scrolling := False;
        Exit;
      end;
      WM_STYLECHANGED:
      begin
        if wParam = GWL_STYLE then
        begin
          if PInfo^.Prevent then
          begin
            Result := 0;
            Exit;
          end
          else
          begin
            PInfo^.Style := GetWindowLong(hWnd, GWL_STYLE);
          end;
        end;
      end;
      WM_NCCALCSIZE:
      begin
        Style := GetWindowLong(hWnd, GWL_STYLE);
        ExStyle := GetWindowLong(hWnd, GWL_EXSTYLE);
        XBar := GetSystemMetrics(SM_CXVSCROLL);
        YBar := GetSystemMetrics(SM_CYHSCROLL);
        if PInfo^.Scrolling then
        begin
          PInfo^.Prevent := True;
          try
            SetWindowLong(hWnd, GWL_STYLE, Style and (not (WS_HSCROLL or WS_VSCROLL)));  // real style
          finally
            PInfo^.Prevent := False;
          end;
        end;
        Result := CallWindowProc(@PInfo^.OldWndProc, hWnd, uMsg, wParam, lParam);
        if PInfo^.Scrolling then
        begin
          PR := PRect(lParam);
          if (PInfo^.Style and WS_VSCROLL) <> 0 then
          begin
            if (ExStyle and WS_EX_LEFTSCROLLBAR) <> 0 then Inc(PR^.Left, XBar)
            else Dec(PR^.Right, XBar);
          end;
          if (PInfo^.Style and WS_HSCROLL) <> 0 then
          begin
            Dec(PR^.Bottom, YBar);
          end;
        end;
        if PInfo^.Scrolling then
        begin
          PInfo^.Prevent := True;
          try
            SetWindowLong(hWnd, GWL_STYLE, Style);  // old style
          finally
            PInfo^.Prevent := False;
          end;
        end;
        Exit;
      end;
      WM_NCPAINT:
      begin
        GetWindowRect(hWnd, R);
        Pt := R.TopLeft;
        if wParam = 1 then
        begin
          Rgn := CreateRectRgn(Pt.X, Pt.Y, Pt.X + R.Right, Pt.Y + R.Bottom);
        end else Rgn := wParam;
        RHBar := CalcScrollBarRect(hWnd, SB_HORZ);
        OffsetRect(RHBar, Pt.X, PT.Y);
        if not IsRectEmpty(RHBar) then
        begin
          BR := CalcBarElemRects(hWnd, SB_HORZ);
          GetSkinSB.DrawElem(hWnd, bpcHPageL, Rect(BR[beBG].Left, BR[beBG].Top, BR[beThumb].Left, BR[beBG].Bottom), False);
          GetSkinSB.DrawElem(hWnd, bpcHPageR, Rect(BR[beThumb].Right, BR[beBG].Top, BR[beBG].Right, BR[beBG].Bottom), False);
          GetSkinSB.DrawElem(hWnd, bpcHThumb, BR[beThumb], False);
          GetSkinSB.DrawElem(hWnd, bpcHArrowL, BR[beArrow1], False);
          GetSkinSB.DrawElem(hWnd, bpcHArrowR, BR[beArrow2], False);
        end;
        Rgn2 := CreateRectRgn(RHBar.Left, RHBar.Top, RHBar.Right, RHBar.Bottom);
        CombineRgn(Rgn, Rgn, Rgn2, RGN_DIFF);
        DeleteObject(Rgn2);
        RVBar := CalcScrollBarRect(hWnd, SB_VERT);
        if not IsRectEmpty(RVBar) then
        begin
          BR := CalcBarElemRects(hWnd, SB_VERT);
          GetSkinSB.DrawElem(hWnd, bpcVPageU, Rect(BR[beBG].Left, BR[beBG].Top, BR[beBG].Right, BR[beThumb].Top), False);
          GetSkinSB.DrawElem(hWnd, bpcVPageD, Rect(BR[beBG].Left, BR[beThumb].Bottom, BR[beBG].Right, BR[beBG].Bottom), False);
          GetSkinSB.DrawElem(hWnd, bpcVThumb, BR[beThumb], False);
          GetSkinSB.DrawElem(hWnd, bpcVArrowU, BR[beArrow1], False);
          GetSkinSB.DrawElem(hWnd, bpcVArrowD, BR[beArrow2], False);
        end;
        OffsetRect(RVBar, Pt.X, PT.Y);
        Rgn2 := CreateRectRgn(RVBar.Left, RVBar.Top, RVBar.Right, RVBar.Bottom);
        CombineRgn(Rgn, Rgn, Rgn2, RGN_DIFF);
        DeleteObject(Rgn2);
        RCross := CalcScrollBarRect(hWnd, SB_BOTH);
        if not IsRectEmpty(RCross) then
        begin
          GetSkinSB.DrawElem(hWnd, bpcCross, RCross, False);
        end;
        OffsetRect(RCross, Pt.X, PT.Y);
        Rgn2 := CreateRectRgn(RCross.Left, RCross.Top, RCross.Right, RCross.Bottom);
        CombineRgn(Rgn, Rgn, Rgn2, RGN_DIFF);
        DeleteObject(Rgn2);
        Result := CallWindowProc(@PInfo^.OldWndProc, hWnd, uMsg, Rgn, lParam);
        if wParam = 1 then DeleteObject(Rgn);
        Exit;
      end;
      WM_ERASEBKGND:
      begin
        Style := GetWindowLong(hWnd, GWL_STYLE);
        PInfo^.Prevent := True;
        try
          SetWindowLong(hWnd, GWL_STYLE, Style and (not (WS_VSCROLL or WS_HSCROLL)));
        finally
          PInfo^.Prevent := False;
        end;
 
        Result := CallWindowProc(@PInfo^.OldWndProc, hWnd, uMsg, wParam, lParam);
        PInfo^.Prevent := True;
        try
          SetWindowLong(hWnd, GWL_STYLE, Style);  // old style
        finally
          PInfo^.Prevent := False;
        end;
        Exit;
      end;
      WM_MOUSEWHEEL, WM_MOUSEMOVE:
      begin
        Result := CallWindowProc(@PInfo^.OldWndProc, hWnd, uMsg, wParam, lParam);
        if PInfo^.Tracking then Exit;
        if (uMsg = WM_MOUSEMOVE) and ((wParam and MK_LBUTTON) = 0) then Exit;
        RedrawScrollBars(hWnd);
        Exit;
      end;
    end;
    Result := CallWindowProc(@PInfo^.OldWndProc, hWnd, uMsg, wParam, lParam);
  end;
end;
 
initialization
 
  l_SkinSB := nil;
  l_SkinSB_Prop := GlobalAddAtom(SKINSB_PROP);
 
finalization
 
  if Assigned(l_SkinSB) then FreeAndNil(l_SkinSB);
 
end.

View Code

补充：使用此方法后，在调用SetScrollInfo后也必须调用RedrawScrollBars重绘滚动条。Hook本模块的SetScrollInfo API是个好方法。在这里就不给出代码了。

透明listview

给你段透明的代码,自己去改吧  
Delphi(Pascal) code
procedure DrawParentBackground(Control: TControl; DC: HDC; R: PRect = nil; bDrawErasebkgnd: Boolean = False);
var
  SaveIndex: Integer;
  MemDC: HDC;
  MemBmp: HBITMAP;
begin
  if R <> nil then
  begin
    MemDC := CreateCompatibleDC(DC);
    MemBmp := CreateCompatibleBitmap(DC, Control.Width, Control.Height);
    SelectObject(MemDC, MemBmp);
    try
      with Control.BoundsRect.TopLeft do
        SetWindowOrgEx(MemDC, X, Y, nil);
      if bDrawErasebkgnd then
        Control.Parent.Perform(WM_ERASEBKGND, Integer(MemDC), Integer(MemDC));
      Control.Parent.Perform(WM_PAINT, Integer(MemDC), Integer(MemDC));
      with Control.BoundsRect.TopLeft do
        BitBlt(DC, R^.Left, R^.Top, R^.Right - R^.Left, R^.Bottom - R^.Top, MemDC, X + R^.Left, Y + R^.Top, SRCCOPY);
    finally
      DeleteObject(MemBmp);
      DeleteDC(MemDC);
    end;
    Exit;
  end;
  SaveIndex := SaveDC(DC);
  try
    with Control.BoundsRect.TopLeft do
      SetWindowOrgEx(DC, X, Y, nil);
    if bDrawErasebkgnd then
      Control.Parent.Perform(WM_ERASEBKGND, Integer(DC), Integer(DC));
    Control.Parent.Perform(WM_PAINT, Integer(DC), Integer(DC));
  finally
    RestoreDC(DC, SaveIndex);
  end;
end;
------解决方案--------------------
用winapi嘛。

函数功能：设置窗口透明颜色
格式：BOOL SetLayeredWindowAttributes(
            HWND hwnd,         //窗口手柄
            COLORREF crKey,    //指定颜色值
            BYTE bAlpha,        //混合函数值
            DWORD dwFlags     //动作
            );


------解决方案--------------------
{API声明}
type
 TSetLayeredWindowAttributes
   = function(wnd: HWND; crKey: DWORD;
     bAlpha: BYTE; dwFlag: DWORD): Boolean; stdcall;

const
 WS_EX_LAYERED = ＄80000;
 LWA_ALPHA = 2;

var
 hLibUser32: THandle;
 MySetLayeredWindowAttributes:
     TSetLayeredWindowAttributes;

implementation

{＄R ＊.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
 p: Pointer;
begin
 hLibUser32 := LoadLibraryA(‘user32.dll');
 MySetLayeredWindowAttributes := nil;
 if hLibUser32 <> 0 then begin
  p:=GetProcAddress(hLibUser32,  
   ‘SetLayeredWindowAttributes');
   if p = nil then begin
     FreeLibrary(hLibUser32);
     hLibUser32 := 0;
   end else begin
     MySetLayeredWindowAttributes :=  
    TSetLayeredWindowAttributes(p);
   end;
 end;
 if hLibUser32 <> 0 then begin
   SetWindowLong(Handle, GWL_EXSTYLE,
     GetWindowLong(Handle, GWL_EXSTYLE)
      or WS_EX_LAYERED);
   ScrollBar1.Position := ScrollBar1.Max;
   ScrollBar1Change(Self);
 end else begin
   ShowMessage(‘该操作系统不支持！');
Application.Terminate;
end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
if hLibUser32 <> 0 then begin
FreeLibrary(hLibUser32);
hLibUser32 := 0;
end;
end;

procedure TForm1.ScrollBar1Change(Sender: TObject);
var
alpha: Integer;
begin
if hLibUser32 <> 0 then begin
alpha := ScrollBar1.Position;
alpha := alpha ＊ 255 div  
 (ScrollBar1.Max － ScrollBar1.Min);
if alpha < 8 then alpha := 8;
if alpha > 255 then alpha := 255;
MySetLayeredWindowAttributes
(Handle, 0, Byte(alpha), LWA_ALPHA);
end;
end;

----程序在Delphi5.0、Wndows2000操作系统下调试成功。
Delphi(Pascal) code
  Test = class(TListView)
  public
     function IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean; override;
  public
     IsTrantp: Boolean;
     constructor Create(AOwner: TComponent); override;
  end;

constructor Test.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  IsTrantp := True;
end;

function Test.IsCustomDrawn(Target: TCustomDrawTarget;
  Stage: TCustomDrawStage): Boolean;
var
  R1: TRect;
begin
  R1 := Self.ClientRect;
  DrawParentBackground(Self, Canvas.Handle, @R1, IsTrantp);
end;

// 测试
procedure TForm1.Button2Click(Sender: TObject);
var
  T1: Test;
begin
  T1 := Test.Create(self);
  T1.Parent := Self;
end;

------解决方案--------------------
持续关注三行代码。

------解决方案--------------------
等待楼主发出代码。

------解决方案--------------------
关注NEW人三行代码！

------解决方案--------------------
三行似乎不可能。除了下面必须的三行设置属性的代码：
SetWindowLong(Form.Handle, GWL_STYLE, GetWindowLong(Form.Handle, GWL_STYLE) and not WS_CLIPCHILDREN);
SetWindowLong(Listview.Handle, GWL_STYLE, GetWindowLong(Listview.Handle, GWL_STYLE) and not WS_CLIPSIBLING);
SetWindowLong(Listview.Handle, GWL_EX_STYLE, GetWindowLong(Listview.Handle, GWL_STYLE) or WS_EX_TRANSPARENT);
还需要截取listview的WM_ERASEBKGND消息

View Code

控制listview的每行的颜色

我们可以设定一个字段的值,用以判断用什么颜色显示listview的颜色,例子如下

procedure TMainForm.ListView2CustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
  if item.SubItems.Strings[7] = Edit11.Text then
    begin
    item.listview.Canvas.Brush.Color:=clwhite;
    item.ListView.Canvas.Font.Color:=clblack;
    end
  else
    begin
    item.ListView.Canvas.Brush.Color:=clred;
    item.ListView.Canvas.Font.Color:=clwhite;
    end;
end;

View Code

delphi取得文件图标并在TListView中显示

{delphi取得文件图标并在TListView中显示
技术要点：
　　一、使用SHGetFileInfo函数获取指定扩展名的文件图标。需要引用ShellAPI单元。
　　二、使用TStringList来保存扩展名与其图标的索引号。当添加一个文件名至TListView后，
我们已经取得了其图标，再次添加同样扩展名的文件时，不需再次获取其图标，只要从该TStringList中取得其图标索引号即可}

uses
  ShellAPI;

var
  IconList:TStringList;

{　实现获取图标及将图标添加到TImageList中的过程 }
procedure ListView_SetItemImageIndex(Item: TListItem);
var
  nIndex:Integer;
  Icon:TIcon;
  fileName:string;
  extName:string;
  sinfo:SHFILEINFO;
begin
  if TListView(Item.ListView).SmallImages<>nil then
  begin
    fileName:=Item.Caption;
    extName:=ExtractFileExt(fileName);
    nIndex:=IconList.IndexOf(extName);
    if nIndex>-1 then
    begin
      nIndex:=Integer(IconList.Objects[nIndex]);
      Item.ImageIndex:=nIndex;
    end else
    begin
      FillChar(sinfo, SizeOf(sinfo),0);
      SHGetFileInfo(PChar(extName),FILE_ATTRIBUTE_NORMAL,sinfo,SizeOf(sInfo),
                    SHGFI_USEFILEATTRIBUTES or SHGFI_ICON or SHGFI_SMALLICON);
      if sinfo.hIcon>0 then
      begin
        Icon:=TIcon.Create;
        Icon.Handle:=sinfo.hIcon;
        nIndex:=TListView(Item.ListView).SmallImages.AddIcon(Icon);
        Icon.Free;
        Item.ImageIndex:=nIndex;
        IconList.AddObject(extName,TObject(nIndex));
      end;
    end;
  end;
end;

{　测试过程 }
procedure TForm1.Button1Click(Sender: TObject);
var
  Item:TListItem;
begin
  Item:=ListView1.Items.Add;
  Item.Caption:=‘c:\test.jpg‘;
  ListView_SetItemImageIndex(Item);
end;

{ 对IconList进行初始化及释放 }
initialization
  IconList:=TStringList.Create;
finalization
  IconList.Free;
end.

View Code

listview自绘制

{
欢迎转载，http://www.freedelphitips.com
}
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, ExtCtrls, ImgList, CommCtrl, StdCtrls, shellapi;

  //定义一个记录用来存放listview的内容
type
  Plistdata = ^Tlistdata;
  Tlistdata = record
    Caption: string; //caption内容
    second: string; //第二列内容
    three: string; //第三列内容
    picon: TIcon; //图标
  end;
type
  TForm1 = class(TForm)
    ListView1: TListView;
    ImageList1: TImageList;
    Panel1: TPanel;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure ListView1AdvancedCustomDrawItem(Sender: TCustomListView;
      Item: TListItem; State: TCustomDrawState; Stage: TCustomDrawStage;
      var DefaultDraw: Boolean);
    procedure Label1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  ListViewData: TList;
implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  imglist: TImageList;
  i: integer;
  listdata: Plistdata;
begin
  //设定一个imagelist,来扩充listview的item的高度
  imgList := timagelist.Create(nil);
  imgList.Width := 1;
  imglist.Height := 50; //listview的item的设度设置
  listview1.SmallImages := imgList; //这里设置listView的SmallImageList ,用imgList将其撑大

  //初使化listview的数据到tlist中
  ListViewData := tlist.Create;
  for i := 0 to 5 do
  begin
    New(listdata);
    listdata^.Caption := '第' + inttostr(i) + '行第一列数据';
    listdata^.second := '第' + inttostr(i) + '行第二列数据';
    listdata^.three := '第' + inttostr(i) + '行第三列数据';
    listdata^.picon := TIcon.Create;
    ImageList1.GetIcon(i, listdata^.picon);
    ListViewData.Add(listdata);
  end;
  //插入空内容到listview
  for i := 0 to 5 do
    ListView1.Items.Add;
end;

procedure TForm1.ListView1AdvancedCustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; Stage: TCustomDrawStage;
  var DefaultDraw: Boolean);
var
  listdata: Plistdata;
  i: integer;
  rect, BoundRect: TRect;
begin
  //取每行的数据
  listdata := ListViewData.Items[Item.index];
  //得到每行的rect
  BoundRect := Item.DisplayRect(drBounds);

 // 设定背景色
  if cdsFocused in State then
  begin
    Sender.Canvas.Brush.Color := $00C5F1FF;
  end
  else
  begin
    Sender.Canvas.Brush.Color := clWhite;
  end;

  ListView1.Canvas.FillRect(BoundRect); //填充颜色

  for i := 0 to ListView1.Columns.Count - 1 do
  begin
    //获取每一列item的Rect
    ListView_GetSubItemRect(Sender.Handle, Item.Index, i, LVIR_LABEL, @Rect);
    case i of
      0: //画Caption 及图标
        begin

          //画图标
          ListView1.Canvas.Draw(Rect.Left + 7, Rect.top + (Rect.Bottom - rect.Top - ImageList1.Height) div 2, listdata.Picon);

          InflateRect(rect, -45, 0); //向后移45个像素,避免被后面画字时覆盖
         // Sender.Canvas.Font.Color := clBlue;

          DrawText(
            ListView1.Canvas.Handle,
            PCHAR(Trim(listdata.Caption)),
            -1,
            rect,
            DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS or 0);
        end;
      1:
        begin

          //画第二列内容
          DrawText(
            ListView1.Canvas.Handle,
            PCHAR(Trim(listdata.second)),
            -1,
            rect,
            DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS or 0);
        end;
      2:
        begin

          //画第三列内容
          DrawText(
            ListView1.Canvas.Handle,
            PCHAR(Trim(listdata.three)),
            -1,
            rect,
            DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS or 0);
        end;
    end;
        //画个线分开
    ListView1.Canvas.Pen.Color := clblue;
    ListView1.Canvas.MoveTo(BoundRect.Left, BoundRect.Bottom - 1);
    ListView1.Canvas.LineTo(BoundRect.right, BoundRect.Bottom - 1);
  end;

  //防止闪屏
  Sender.DoubleBuffered := true;

end;

procedure TForm1.Label1Click(Sender: TObject);
begin
  ShellExecute(Application.Handle, 'open', PChar('http://www.FreeDelphiTips.com'), nil, nil, SW_ShowNormal);
end;

end.

View Code

delphi listview自绘图形

自画TlistView带进度条的Item

TListView的Item条一般是由系统自画的，但电驴就实现了自画，使之看起来很漂亮，我们用DELPHI也可以实现！

首先要引用CommCtrl单元，这是TListView底层控制单元：
uses
 CommCtrl;
 
//画状态条
procedure DrawSubItem(LV: TListView; Item: TListItem; SubItem: Integer;
 Prosition: Single; Max, Style: Integer; IsShowProgress: Boolean;
 DrawColor: TColor = $00005B00;
 FrameColor: TColor = $00002F00);
//获取SubItem的区域
 function GetItemRect(LV_Handle, iItem, iSubItem: Integer): TRect;
 var
    Rect: TRect;
 begin
    ListView_GetSubItemRect(LV_Handle, iItem, iSubItem, LVIR_LABEL, @Rect);
    Result := Rect;
 end;
var
 PaintRect, r: TRect;
 i, iWidth, x, y: integer;
 S: string;
begin
 try
 
    with lv do
    begin
      //LockPaint := True;
      PaintRect := GetItemRect(LV.Handle, Item.Index, SubItem);
     r := PaintRect;
//      if SubItem = DrawSubItem then
      Begin
        //这一段是算出百分比
        if Prosition >= Max then
          Prosition := 100
        else
          if Prosition <= 0 then
            Prosition := 0
          else
            Prosition := Round((Prosition / Max) * 100);
 
        if (Prosition = 0) and (not IsShowProgress) then
        begin 
        //如果是百分比是0，就直接显示空白
          Canvas.FillRect(r);
 
        end
        else
        begin
        //先直充背景色
          Canvas.FillRect(r);
          Canvas.Brush.Color := Color;
//          Canvas.FillRect(r);
 
        //画一个外框
          InflateRect(r, -2, -2);
          Canvas.Brush.Color := FrameColor; //$00002F00;
          Canvas.FrameRect(R);
 
          Canvas.Brush.Color := Color;
          InflateRect(r, -1, -1);
//          Canvas.FillRect(r);
 
          InflateRect(r, -1, -1);
        //根据百分比算出要画的进度条内容宽度
          iWidth := R.Right - Round((R.Right - r.Left) * ((100 - Prosition) /
            100));
          case Style of
            0: //进度条类型，实心填充
              begin
                Canvas.Brush.Color := DrawColor;
                r.Right := iWidth;
                Canvas.FillRect(r);
              end;
            1: //进度条类型，竖线填充
              begin
                i := r.Left;
                while i < iWidth do
                begin
                  Canvas.Pen.Color := Color;
                  Canvas.MoveTo(i, r.Top);
                  Canvas.Pen.Color := DrawColor;
                  canvas.LineTo(i, r.Bottom);
                  Inc(i, 3);
                end;
              end;
          end;
//画好了进度条后，现在要做的就是显示进度数字了
          Canvas.Brush.Style := bsClear;
          if Prosition = Round(Prosition) then
            S := Format('%d%%', [Round(Prosition)])
          else
            S := FormatFloat('#0.0', Prosition);
 
          with PaintRect do
          begin
            x := Left + (Right - Left + 1 - Canvas.TextWidth(S)) div 2;
            y := Top + (Bottom - Top + 1 - Canvas.TextHeight(S)) div 2;
          end;
          SetBkMode(Canvas.handle, TRANSPARENT);
          Canvas.TextRect(PaintRect, x, y, S);
 
        end;
//进度条全部画完，把颜色设置成默认色了
        Canvas.Brush.Color := Color;
 
      end
    end;
 except
 end;
end;
 
 
上面是画进度条的，现在要给TlistView处理Item重绘的消息，事件是OnCustomDrawItem，需要说明的是，如果想要随心所欲的自画Item，那么就要全部自己来完成，不再需要系统来处理：
procedure TForm1.ListView1CustomDrawItem(
 Sender: TCustomListView; Item: TListItem; State: TCustomDrawState;
 var DefaultDraw: Boolean);
var
 BoundRect, Rect: TRect;
 i: integer;
 TextFormat: Word;
 LV: TListView;
 
//这个子过程是用来画CheckBox和ImageList的
 procedure Draw_CheckBox_ImageList(r: TRect; aCanvas: TCanvas; Checked: Boolean);
 var
    R1: TRect;
    i: integer;
 begin
    if Sender.Checkboxes then
    begin
      aCanvas.Pen.Color := clBlack;
      aCanvas.Pen.Width := 2;
      //画CheckBox外框
      aCanvas.Rectangle(r.Left + 2, r.Top + 2, r.Left + 14, r.Bottom - 2);
      if Checked then
      begin //画CheckBox的勾
        aCanvas.MoveTo(r.Left + 4, r.Top + 6);
        aCanvas.LineTo(r.Left + 6, r.Top + 11);
        aCanvas.LineTo(r.Left + 11, r.Top + 5);
      end;
      aCanvas.Pen.Width := 1;
    end;
    //开始画图标
    i := PDownLoadListItem(Item.Data)^.StatsImageIndex;
    if i > -1 then
    begin
    //获取图标的RECT
      if Boolean(ListView_GetSubItemRect(sender.Handle, item.Index, 0, LVIR_ICON, @R1)) then
      begin
        ImageList_Stats.Draw(LV.Canvas, R1.Left, R1.Top, i);
        if item.ImageIndex > -1 then
          LV.SmallImages.Draw(LV.Canvas, R1.Right + 2, R1.Top, item.ImageIndex);
      end;
 
    end;
 end;
begin
 LV := ListView1;
 BoundRect := Item.DisplayRect(drBounds);
 InflateRect(BoundRect, -1, 0);
 
//这个地方你可以根据自己的要求设置成想要的颜色，实现突出显示
 LV.Canvas.Font.Color := clBtnText;
 
//查看是否是被选中
 if Item.Selected then
 begin
    if cdsFocused in State then
    begin
      LV.Canvas.Brush.Color := $00ECCCB9; // //clHighlight;
    end
    else
    begin
      LV.Canvas.Brush.Color := $00F8ECE5; //clSilver;
    end;
 end
 else
 begin
    if (Item.Index mod 2) = 0 then
      LV.Canvas.Brush.Color := clWhite
    else
      LV.Canvas.Brush.Color := $00F2F2F2;
 end;
 
 LV.Canvas.FillRect(BoundRect); //初始化背景
 
 for i := 0 to LV.Columns.Count - 1 do
 begin
 //获取SubItem的Rect
    ListView_GetSubItemRect(LV.Handle, Item.Index, i, LVIR_LABEL, @Rect);
    case LV.Columns[i].Alignment of
      taLeftJustify:
        TextFormat := 0;
      taRightJustify:
        TextFormat := DT_RIGHT;
      taCenter:
        TextFormat := DT_CENTER;
    end;
    case i of
      0: //画Caption，0就是表示Caption，这不是Subitems[0]
        begin
//先画选择框与图标
          Draw_CheckBox_ImageList(BoundRect, LV.Canvas, Item.Checked);
//再画Caption的文字
          InflateRect(Rect, -(5 + ImageList_Stats.Width), 0); //向后移3个像素,避免被后面画线框时覆盖
          DrawText(
            LV.Canvas.Handle,
            PCHAR(Item.Caption),
            Length(Item.Caption),
            Rect,
            DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS or TextFormat);
        end;
      1..MaxInt: //画Subitems[i]
        begin
          if i - 1 = 2 then //显示状态条
          begin
//开始处理进度条了，这个示例是第3栏显示进度条，可以自己随便定义
            DrawSubItem(TListView(Sender),
              item,
              i,
              StrToFloatDef(Item.SubItems[i - 1], 0),
              100,
              0,
              True,
 //这里用了一个Lable来选颜色，你自己可以使用一个变量来代替
             LableProgressColor.Color, //进度条外框颜色
              LableProgressColor.Color //进度条颜色
);
 
          end
          else
//画SubItem的文字
            if i - 1 <= Item.SubItems.Count - 1 then
              DrawText(
                LV.Canvas.Handle,
                PCHAR(Item.SubItems[i - 1]),
                Length(Item.SubItems[i - 1]),
                Rect,
                DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS or TextFormat);
 
 
 
        end;
    end;
 
 end;
 
 
 LV.Canvas.Brush.Color := clWhite;
 
 if Item.Selected then //画选中条外框
 begin
    if cdsFocused in State then//控件是否处于激活状态
      LV.Canvas.Brush.Color := $00DAA07A // $00E2B598; //clHighlight;
    else
      LV.Canvas.Brush.Color := $00E2B598; //$00DAA07A // clHighlight;
    LV.Canvas.FrameRect(BoundRect); // 
 end;
 
 DefaultDraw := False; //不让系统画了
 
 with Sender.Canvas do
    if Assigned(Font.OnChange) then Font.OnChange(Font);
 
 
 
end;
function ReDrawItem(HwndLV: HWND; ItemIndex: integer): boolean;
begin
  Result := ListView_RedrawItems(HwndLV, ItemIndex, ItemIndex);
end;
//使用：
item:=ListView1.Selected;
item.subitems[1]:='30';//设置为30%
//然后刷新这个item
ReDrawItem(ListView1.handle,Item.index);

View Code

listview数据保存为txt

一段简单的跟1一样的代码，listview所见即所得写如txt文件

procedure TForm1.Button2Click(Sender: TObject);
const
  FormatStr = '%:-20s|';
var
  StrList: TStringList;
  Str: string;
  Line: string;
  i, j: integer;
begin
  StrList := TStringList.Create;
  try
    Str := '';
    Line := '';
    for i := 0 to ListView1.Columns.Count - 1 do
    begin
      Str := Str + Format(FormatStr, [ListView1.Columns[i].Caption]);
      Line := Line + '--------------------+';
    end;
    StrList.Add(Str);
    Strlist.Add(Line);
    for j := 0 to ListView1.Items.Count - 1 do
    begin
      Str := Format(FormatStr, [ListView1.Items[j].Caption]);
      for i := 1 to ListView1.Columns.Count - 1 do
        Str := Str + Format(FormatStr, [ListView1.Items[j].SubItems[i - 1]]);
      StrList.Add(Str);
    end;
    Strlist.SaveToFile('c:\temp.txt');
  finally
    StrList.Free;
  end;
end;

View Code

TListView的ListItem完全自绘

因工作需要完全自绘ListItem，模仿成电驴的样式，查找了N久相关的资料，发现很少有这方面的，最后用ListView_GetSubItemRect关键词在一个小日本的网站上找到一点相关的代码，修改后解决该问题。

至于是否存在BUG，偶用了几天还木有发现，如果有什么问题，请大家回复一下，谢谢

注意：代码只支持ViewStyle=vsReport

uses
  CommCtrl;
procedure LVDrawItem(Sender: TListView; Item: TListItem; State: TCustomDrawState;
  var DefaultDraw: Boolean);
var
  BoundRect, Rect: TRect;
  i: integer;
  TextFormat: Word;
  LV: TListView;
  procedure Draw_CheckBox_ImageList(r: TRect; aCanvas: TCanvas; Checked: Boolean);
  var
    R1: TRect;
  begin
    if Sender.Checkboxes then
    begin
      aCanvas.Pen.Color := clBlack;
      aCanvas.Pen.Width := 2;
      //画CheckBox外框，也可以修改成你想要的图标显示
      aCanvas.Rectangle(r.Left + 2, r.Top + 2, r.Left + 14, r.Bottom - 2);
      if Checked then
      begin //画CheckBox的勾
        aCanvas.MoveTo(r.Left + 4, r.Top + 6);
        aCanvas.LineTo(r.Left + 6, r.Top + 11);
        aCanvas.LineTo(r.Left + 11, r.Top + 5);
      end;
      aCanvas.Pen.Width := 1;
    end;
    //开始画图标
    if (Item.ImageIndex > -1)and(LV.SmallImages <>nil) then
    begin
    //获取图标的RECT
      if Boolean(ListView_GetSubItemRect(sender.Handle, item.Index, 0, LVIR_ICON, @R1)) then
      begin
        LV.SmallImages.Draw(LV.Canvas, R1.Left, R1.Top, Item.ImageIndex);
      end;
    end;
  end;
begin
  LV := Sender;
  BoundRect := Item.DisplayRect(drBounds);
  InflateRect(BoundRect, -1, 0);
  if Item.Selected then
  begin
    if cdsFocused in State then
    begin
      LV.Canvas.Brush.Color := $00ECCCB9; //  //clHighlight;
//      LV.Canvas.Font.Color := clBtnText; //clHighlightText;
    end
    else
    begin
      LV.Canvas.Brush.Color := $00F8ECE5; //clSilver;
//      LV.Canvas.Font.Color := clBtnText;
    end;
  end
  else
  begin
//    LV.Canvas.Brush.Color := clWindow;
//    LV.Canvas.Font.Color := clWindowText;
  end;
 
  LV.Canvas.FillRect(BoundRect); //初始化背景
 
  for i := 0 to LV.Columns.Count - 1 do
  begin
  //获取SubItem的Rect
    ListView_GetSubItemRect(LV.Handle, Item.Index, i, LVIR_LABEL, @Rect);
    case LV.Columns[i].Alignment of
      taLeftJustify:
        TextFormat := 0;
      taRightJustify:
        TextFormat := DT_RIGHT;
      taCenter:
        TextFormat := DT_CENTER;
    end;
    case i of
      0: //画Caption
        begin
          Draw_CheckBox_ImageList(BoundRect, LV.Canvas, Item.Checked);
 
          InflateRect(Rect, -3, 0); //向后移3个像素,避免被后面画线框时覆盖
          DrawText(
            LV.Canvas.Handle,
            PCHAR(Item.Caption),
            Length(Item.Caption),
            Rect,
            DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS or TextFormat);
        end;
      1..MaxInt: //画Subitems[i]
        begin
          if i - 1 <= Item.SubItems.Count - 1 then
            DrawText(
              LV.Canvas.Handle,
              PCHAR(Item.SubItems[i - 1]),
              Length(Item.SubItems[i - 1]),
              Rect,
              DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS or TextFormat);
        end;
    end;
 
  end;
 
 
  LV.Canvas.Brush.Color := clWhite;
 
  if Item.Selected then //画选中条外框
  begin
    if cdsFocused in State then
      LV.Canvas.Brush.Color := $00DAA07A // $00E2B598; //clHighlight;
    else
      LV.Canvas.Brush.Color := $00E2B598; //$00DAA07A // clHighlight;
    LV.Canvas.FrameRect(BoundRect); // DrawFocusRect(Item.DisplayRect(drBounds)); //
  end;
 
  DefaultDraw := False; //True;//cdsSelected in State;
 
  with Sender.Canvas do
    if Assigned(Font.OnChange) then Font.OnChange(Font);
 
end;
 
//使用技巧
 
procedure TFormDownLoad.LV_ResourceListCustomDrawItem(
  Sender: TCustomListView; Item: TListItem; State: TCustomDrawState;
  var DefaultDraw: Boolean);
begin
  if (Item.Index mod 2) = 0 then
    Sender.Canvas.Brush.Color := clWhite
  else
    Sender.Canvas.Brush.Color := $00EBEBEB;
 
  LVDrawItem(LV_ResourceList, Item, State, DefaultDraw);
 
end;

View Code

Delphi中使用TListView显示数据库的内容

本例教你在TListView组件中显示数据库的内容。

首先创建一个新的项目，然后向窗体上添加一个TQuery组件和一个TListView组件。添加组件后的窗体。

设置TQuery组件的DatabaseName属性设置为DBDEMOS，SQL属性设置为select * from country，Active属性设置为True。然后添加程序初始化代码如下：

procedure TForm1.FormCreate(Sender: TObject);

var

　i:Integer;

　TempColumn:TListColumn;

　TempItem:TListItem;

begin

　ListView1.ViewStyle:=vsReport;

　for i:=0 to Query1.FieldCount-1 do

　begin

　　TempColumn:=self.ListView1.Columns.Add;

　　TempColumn.Caption:=Query1.Fields[i].FieldName;

　end;

　Query1.First;

　while not Query1.Eof do

　begin

　　TempItem:=self.ListView1.Items.Add;

　　TempItem.Caption:=Query1.Fields[0].AsString;

　　for i:=1 to Query1.FieldCount-1 do

　　begin

　　　TempItem.SubItems.Add(Query1.Fields[i].AsString);

　　end;

　　Query1.Next;

　end;

end;

View Code

程序首先通过ListView1.ViewStyle:=vsReport语句设置TListView组件的ViewStyle属性值为vsReport。然后通过第1个循环中的TempColumn:=self.ListView1.Columns.Add和TempColumn.Caption:=Query1.Fields[i].FieldName语句在TListView组件的标题行中显示数据库中字段的名称。最后通过一个循环逐行输出数据库的所有数据。

程序代码如下：

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, DB, ADODB, Grids, DBGrids, ComCtrls, DBTables;

type

　TForm1 = class(TForm)

　Query1: TQuery;

　ListView1: TListView;

　procedure FormCreate(Sender: TObject);

private

　{ Private declarations }

public

　{ Public declarations }

end;

var

　Form1: TForm1;

　implementation

　{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);

// www.bianceng.cn 

var

　i:Integer;

　TempColumn:TListColumn;

　TempItem:TListItem;

begin

　ListView1.ViewStyle:=vsReport;

　for i:=0 to Query1.FieldCount-1 do

　begin

　　TempColumn:=self.ListView1.Columns.Add;

　　TempColumn.Caption:=Query1.Fields[i].FieldName;

　end;

　Query1.First;

　while not Query1.Eof do

　begin

　　TempItem:=self.ListView1.Items.Add;

　　TempItem.Caption:=Query1.Fields[0].AsString;

　　for i:=1 to Query1.FieldCount-1 do

　　begin

　　　TempItem.SubItems.Add(Query1.Fields[i].AsString);

　　end;

　　Query1.Next;

　end;

end;

end.

View Code

保存文件，然后按F9键运行程序，程序运行结果

Delphi实现下载进程的动态显示

许多知名的下载软件中都有下载管理器，用一个TListView来显示下载的进程，你可以清楚的看到已经下载了多少，还有多少内容仍需下载，这样的控件，Delphi自身并未提供，但我们可以在TListView的基础之上加入进度条控件（TProgressBar)来实现这一功能，这样就能既能满足我们的实际需求，又不用“牺牲”口袋里白花花的银子，还能增加我们对控件嵌套的认识，一箭三雕，何乐而不为呢？
 
　　到底该怎么做呢？让我想想……好了让我们先从TListView的ViewStyle属性开始吧，这个属性我们常用，把TListView做为一个表格来显示各种数据时，我们常常把这个属性设置成vsReport，设置之后，最左边的列（Column)包含一个小的图标和数据，从第二列开始就是显示一个个字段的数据，这是我们最常见的TListView的样子，每天一打开Windows的资源管理器，我们就能看到它。（如图一）
 
Delphi实现下载进程的动态显示
图一

 
　　打开Delphi，新建一个工程，在自动生成的Form上，放置一个TListView控件，在它的Columns属性中定义两列，第一列放置数据项（Item)，第二列用来存放Progress.（如图二）
 
Delphi实现下载进程的动态显示
图二

 
　　在Form上加入一个按钮（Button)，在按钮的Click事件中加入如下代码，用于在按下按钮时，可以在TListView的第二列显示TProgress。
 
　　添加Item的代码如下：
 
procedure TForm1.AddItemButtonClick(Sender: TObject);
const
　pbColumnIndex = 1;
　pbMax = 100;
var
　li : TListItem;
　lv : TListView;
　pb : TProgressBar;
　pbRect : TRect;
begin
　lv := ListViewEx1;
　//建立一个新的ListItem
　li := lv.Items.Add;
　li.Caption := ’Item ’ + IntToStr(lv.Items.Count);
 
　//建立一个ProgressBar，置入TListView的第二列中
　pb := TProgressBar.Create(nil);
　pb.Parent := lv;
　li.Data := pb;
　pbRect := li.DisplayRect(drBounds);
　pbRect.Left := pbRect.Left +
　lv.Columns[-1 + pbColumnIndex].Width;
　pbRect.Right := pbRect.Left +
　lv.Columns[pbColumnIndex].Width;
　pb.BoundsRect := pbRect;
end; //添加ItemButton事件
 
　　上面的代码可以实现这样的功能：按下按钮之后，一个Progressbar被建立，一个对Progressbar的引用被加进ListItem的Data属性，最后，Progressbar被放置在由pbColumnIndex属性指定的列中。
 
　　当想要将一个项（Item）从TListView中删除，你必须先判断添加进去的Progressbar的内存占用是否已经被释放，如果已经完成，就继续。
 
　　删除Item的代码如下：
 
procedure TForm1.RemoveItemButtonClick(Sender: TObject);
var
　lv : TListView;
　li : TListItem;
　i, idx : integer;
　pb : TProgressBar;
begin
　lv := ListViewEx1;
 
　li := lv.Selected;
 
　if li <> nil then
　begin
　　idx := li.Index;
　　TProgressBar(li.Data).Free;//先释放TProgressBar
　　lv.Items.Delete(idx);
 
　　//把行向上移动
　　for i := idx to -1 + lv.Items.Count do
　　begin
　　　li := lv.Items.Item[i];
　　　pb := TProgressBar(li.Data);
　　　pb.Top := pb.Top - (pb.BoundsRect.Bottom - pb.BoundsRect.Top);
　　end;
　end;
end; //删除ItemButton事件
 
　　完成之后，我们来测试一下，我们拖一个TTimer控件，然后在它的OnTime事件中填入下面的代码，模拟一下在一个真实的环境下，这个被我们美化过的TListView控件会有如何精彩表现，也让大伙一起体会一把写程序的小小成就感吧。（如图三）
 
Delphi实现下载进程的动态显示
图三

 
　　代码如下：
 
procedure TForm1.Timer1Timer(Sender: TObject);
var
　idx : integer;
　pb: TProgressbar;
　lv : TListView;
begin
　lv := ListViewEx1;
 
　if lv.Items.Count = 0 then Exit;
 
　//随机生成一个数据项
　//根据生成的数据来控制TProgressBar的长度
　idx := Random(lv.Items.Count);
　pb := TProgressBar(lv.Items[idx].Data);
　if pb.Position < pb.Max then
　　pb.StepIt
　else
　　pb.Position := 0;
end;//Timer事件
 
　　就是这样的简单，任何有名的软件都是由这样的一个个小知识点构成，只要细心体会知名软件的优势与长处，模仿然后改进说不定你能做出比它们都棒的软件！
 
　　开发环境： WindowsXP SP2+Delphi7

View Code

Delphi 2010的TListView扩展了一些功能，其中就有项分组功能，在XP和Vista以上系统有效。但是扩展的更多一些功能只对Vista系统有效。下面在XP SP3下实现TListView的分组效果：

1.新建一个应用程序，拖动一个TListView到窗体上；

2.在窗体创建函数，写入以下代码：

procedure TForm1.FormCreate(Sender: TObject); 
begin 
  with lv1 do 
  begin 
    AllocBy := 0;                                //设置总共的项数量，省去每次添加开辟内存空间 
    Checkboxes := False;                         //项左边出现复选框，vsList or vsReport有效 
    Color := clWindow;                           //背景颜色 
    ColumnClick := True;                         //列头能否点击 
    with Columns.Add do                          //增加列 
    begin 
      Alignment := taLeftJustify;                //左对齐 
      Caption := '列一'; 
      ImageIndex := -1; 
      Width := 100; 
    end; 
    with Columns.Add do                          //增加列 
    begin 
      Caption := '列二'; 
      ImageIndex := -1; 
      Width := 50; 
    end; 
    Ctl3D := True; 
    DoubleBuffered := False;                     //双缓冲 
    Enabled := True; 
    FlatScrollBars := False;                     //平滑滚动条 
    FullDrag := False;                           //允许拖动列头 
    GridLines := False;                          //表格线 
    GroupHeaderImages := nil;                    //分组头关联图像列表 
    with Groups.Add do                           //增加分组 
    begin 
      BottomDescription := '底部的说明文字'; 
      ExtendedImage := -1;                       //关联 GroupHeaderImages图像列表，only on Windows Vista 
      Footer := '页脚文本'; 
      FooterAlign := taLeftJustify;              //页脚文本对齐 
      GroupID := 0;                              //组ID号 
      Header := '页首文本'; 
      HeaderAlign := taLeftJustify; 
      State := [                                 //分组状态，一些状态只应用于VISTA系统 
                lgsNormal,                       //所有分组展开 
                lgsHidden,                       //分组隐藏 
                lgsCollapsed,                    //分组折叠 Windows Vista only. 
                lgsNoHeader,                     //页首不可见 Windows Vista only. 
                lgsCollapsible,                  //分组可折叠 Windows Vista only. 
                lgsFocused,                      //分组有键盘焦点 Windows Vista only. 
                lgsSelected,                     //分组被选择 Windows Vista only. 
                lgsSubseted,                     //只有分组的一个子集显示出来 Windows Vista only. 
                lgsSubSetLinkFocused             //分组的子集有键盘焦点  Windows Vista only. 
               ]; 
       SubsetTitle := '子集标题'; 
       Subtitle := '子标题'; 
       TitleImage := -1;                         //关联 GroupHeaderImages图像列表，only on Windows Vista 
       TopDescription := '顶部的说明文字'; 
    end; 
    with Groups.Add do 
    begin 
      GroupID := 1; 
      Header := '分组标题'; 
    end; 
    GroupView := True;                            //打开或关闭分组视图 
    HideSelection := True;                        //失去焦点时，项不再保持被选择状态 
    HotTrack := False;                            //指定是否鼠标移过项进行高亮 
    HotTrackStyles := [ 
                   //  htHandPoint,               //手势 
                   //  htUnderlineCold,           //非热点下划线 
                   //  htUnderlineHot             //下划线热点 
                      ]; 
    HoverTime := -1;                              //鼠标在项上暂停时间，除非HotTrack为True 
    with IconOptions do                           //确定如何排列图标，vsIcon or vsSmallIcons 有效 
    begin 
      Arrangement := iaTop;                       //项在顶部从左到右对齐，iaLeft在左部从上到下对齐 
      AutoArrange := False;                       //图标自动重新排列 
      WrapText := True;                           //图标标题是否折行 
    end; 
    with Items.Add do                             //增加项 
    begin 
      Caption := '行一列一'; 
      ImageIndex := -1;                           //关联 LargeImages or SmallImages图像列表 
      StateIndex := -1;                           //关联StateImages图像列表 
      GroupID := 0;                               //关联分组ID号 
      SubItems.Add('行一列二');                   //添加第二列 
    end; 
    with Items.Add do 
    begin 
      Caption := '行二列一'; 
      GroupID := 1; 
      SubItems.Add('行二列二'); 
    end; 
    LargeImages := nil;                            //大图标图像列表 
    MultiSelect := False;                          //多选 
    OwnerData := False;                            //指定列表视图控件是否是虚拟的 
    OwnerDraw := False;                            //自绘项 
    ParentColor := False;                          //继承父控件颜色 
    ReadOnly := False;                             //只读 
    RowSelect := False;                            //整行选择 
    ShowColumnHeaders := True;                     //显示列头，vsReport有效 
    ShowWorkAreas := False;                        //显示工作区，vsIcon or vsSmallIcon有效，不支持 OwnerData 
    SmallImages := nil;                            //小图标图像列表 
    SortType := stNone;                            //确定列表项如何自动排序 
    StateImages := nil;                            //状态图像列表 
    ViewStyle := vsReport;                         //视图风格，vsIcon、vsSmallIcon、vsList、vsReport 
  end; 
end;

View Code

拖动一个TImageList到窗体上，添加一些图标到TImageList上，使TListView所有可以关联图像列表的都关联到此TImageList上，然后分别设置图像索引的不同

在ListView中添加一个进度条

看CxGrid资料的时候,看见了一个为兄弟的文章,我就转一下了.
 
//需要Use CommCtrl
Function GetSubItemRect( handle, ItemsIndex, SubIndex: Integer ): TRect ;
Begin
ListView_GetSubItemRect( Handle, ItemsIndex, SubIndex, 0, @Result ) ;
End ;
Procedure TFormMain.lvw_listCustomDrawSubItem( Sender: TCustomListView ;
Item: TListItem ;SubItem: Integer ;State: TCustomDrawState ;
Var DefaultDraw: Boolean ) ;
Var
l_Rect: TRect ;
l_intPercent: Integer ;
Begin
If SubItem = 3 Then
Begin
If Item.Data = Nil Then
Exit ;
l_intPercent := PListData( Item.Data ).Percent ;
//获取ListView子项的Rect
l_Rect := GetSubItemRect( Item.Handle, Item.Index, SubItem ) ;
//画一条外边框
InflateRect( l_Rect, -1, -1 ) ;
Sender.Canvas.Brush.Color := clBlack ;
Sender.Canvas.FrameRect( l_Rect ) ;
//先填充底色
InflateRect( l_Rect, -1, -1 ) ;
Sender.Canvas.Brush.Color := lvw_list.Color ;
Sender.Canvas.FillRect( l_Rect ) ;
//再根据进度画出完成区域
If l_intPercent = 100 Then
Sender.Canvas.Brush.Color := clGreen
Else
Sender.Canvas.Brush.Color := clPurple ;
l_Rect.Right := l_Rect.Left + Floor( ( l_Rect.Right - l_Rect.Left ) * l_intPercent / 100 ) ;
Sender.Canvas.FillRect( l_Rect ) ;
//恢复笔刷
Sender.Canvas.Brush.Color := lvw_list.Color ;
//关键的一句，屏蔽系统自绘过程
DefaultDraw := False ;
End ;
End ;
相关定义
Type
TListData = Record
FileName: String ;
Percent: Integer ;
End ;
PListData = ^TListData ;

View Code

listview导出到excel

uses  
   ExcelXP, strutils, QDialogs, Variants;

 
 function  get_listviewTOexcel(listview:TListView;strTitle:string;strTerm :string):Boolean;
var
  //------------------------------------
  ExcelApplication1: TExcelApplication;
  ExcelWorksheet1: TExcelWorksheet;
  ExcelWorkbook1: TExcelWorkbook;
  //------------------------------------
  SaveDialog_EXCEL : TSaveDialog;//文件保存控件
  //------------------------------------
  filename :string; //文件名
  next_i   :Boolean;//是否可以继续运行
  //------------------------------------
  cyc_i    :Integer;
  cyc_j    :Integer;
  cyc_k    :Integer;
  //------------------------------------
begin
  //保存文件对话框
  SaveDialog_EXCEL := TSaveDialog.Create(nil);
  SaveDialog_EXCEL.Filter:= 'EXCEL电子表格|*.xls';
  SaveDialog_EXCEL.Title := '保存到';
  //检查Excel是否安装
  try
    ExcelApplication1 := (TExcelApplication.Create(Application));
    ExcelWorksheet1   := TExcelWorksheet.Create(Application);
    ExcelWorkbook1    := TExcelWorkbook.Create(Application);
    ExcelApplication1.Connect;
    next_i := True;
  except
    Application.Messagebox('没有安装 Excel。', '错误', MB_OK + MB_ICONINFORMATION);
    Abort;
    next_i := False;
  end;
  //调用Excel----------------------
  if next_i then
    begin
      try
        ExcelApplication1.Workbooks.Add(EmptyParam, 0);
        ExcelWorkbook1.ConnectTo(ExcelApplication1.Workbooks[1]);
        ExcelWorksheet1.ConnectTo(ExcelWorkbook1.Worksheets[1] as _worksheet);
      except
        Application.Messagebox('调用Excel失败，Excel不可用。', '错误', MB_OK + MB_ICONINFORMATION);
        next_i := False;
      end;
    end;
  //选择保存到什么位置-------------
  if next_i then
    begin
      if SaveDialog_EXCEL.Execute =  True then
        begin
          if rightstr(SaveDialog_EXCEL.FileName,4) <> '.xls' then
          SaveDialog_EXCEL.FileName := SaveDialog_EXCEL.FileName + '.xls';
          filename := SaveDialog_EXCEL.FileName;
        end
      else
        begin
          next_i := False;
        end;
    end;
  //写字段名------------------------
  if next_i then
    begin
    for cyc_i:=0 to listview.Columns.Count-1 do//  DBG_WriteExcel.Columns.Count-1 do
      begin
        ExcelWorksheet1.Cells.Item[5, cyc_i + 1]:= listview.Columns[cyc_i].Caption; //DBG_WriteExcel.Columns.Items[j].Title.Caption;
        ExcelWorksheet1.Cells.item[5, cyc_i + 1].font.size := '10';
      end;
    end;
  //写数据------------------------
  if next_i then
    begin
      try
        for cyc_j := 6 to listview.Items.Count + 5 do  //行
          begin
            for cyc_i:=0 to listview.Columns.Count-1 do//列
              begin
                //列值也有可能是Caption
                if cyc_i= 0 then
                  begin
                    ExcelWorksheet1.Cells.item[cyc_j, cyc_i + 1].NumberFormatLocal:='@';
                    ExcelWorksheet1.Cells.item[cyc_j, cyc_i + 1].font.size := '10';
                    //ShowMessage( listview.Columns[cyc_i].Caption +'  '+ listview.Items[cyc_j-4].Caption );
                    ExcelWorksheet1.Cells.item[cyc_j, cyc_i + 1].Value  := listview.Items[cyc_j-6].Caption;
                  end
                else
                  begin
                    if listview.Columns[cyc_i].MaxWidth<>1 then
                      begin
                        ExcelWorksheet1.Cells.item[cyc_j, cyc_i + 1].NumberFormatLocal:='@';
                        ExcelWorksheet1.Cells.item[cyc_j, cyc_i + 1].font.size := '10';
                        //ShowMessage( listview.Columns[cyc_i].Caption +'  '+ listview.Items[cyc_j-4].SubItems[cyc_i-1] );
                        ExcelWorksheet1.Cells.item[cyc_j, cyc_i + 1].Value  := listview.Items[cyc_j-6].SubItems[cyc_i-1];
                      end
                    else
                      begin
                        ExcelWorksheet1.Cells.item[cyc_j, cyc_i + 1].NumberFormatLocal:='@';
                        ExcelWorksheet1.Cells.item[cyc_j, cyc_i + 1].font.size := '10';
                        ExcelWorksheet1.Cells.item[cyc_j, cyc_i + 1].Value  := '';
                      end
                  end;
              end;
          end;
      except
        next_i:= False;
        Application.Messagebox(pchar('网络连接失败，数据为能全部导出'), '提示',MB_OK + MB_ICONINFORMATION);
      end;
    end;
  //保存信息-----------------------
  if next_i then
    begin
      try
        ExcelWorksheet1.Columns.AutoFit;
        //表头
        with ExcelWorkSheet1 do            //将第一行的标题合并居中
          begin
            Columns.AutoFit;
            Cells.item[1, 1] := strTitle;
            Cells.Item[1, 1].font.size := '14';
            Cells.Item[1, 1].Font.Bold := True;
            Range[Cells.Item[1,1], Cells.Item[1,listview.Columns.Count]].HorizontalAlignment:=xlCenter; //水平居中
            Range[Cells.Item[1,1], Cells.Item[1,listview.Columns.Count]].VerticalAlignment  :=xlCenter;      //垂直居中
            Range[Cells.Item[1,1], Cells.Item[1,listview.Columns.Count]].Select;
            Range[Cells.Item[1,1], Cells.Item[1,listview.Columns.Count]].Merge(Cells.Item[1,listview.Columns.Count]);     //合并单元格
          end;

//with   ExcelWorkSheet1   do            //将第一行的标题合并居中
// begin
//      Columns.AutoFit;
//      Cells.Item[1,1]:='标题';
//      Range[Cells.Item[1,1],Cells.Item[1,8]].HorizontalAlignment:=xlCenter;    //水平居中
//    Range[Cells.Item[1,1],Cells.Item[1,8]].VerticalAlignment:=xlCenter;      //垂直居中
//    Range[Cells.Item[1,1],Cells.Item[1,8]].Select;
//      Range[Cells.Item[1,1],Cells.Item[1,8]].Merge(Cells.Item[1,k]);     //合并单元格
//   Cells.Item[1,8].Font.Size:='20';
//end;

        //生成日期
        ExcelWorksheet1.Cells.item[2, 1] := '生成时间:'+ FormatDateTime('yyyy年MM月dd日  hh:mm:ss',Now);
        ExcelWorksheet1.Cells.Item[2, 1].font.size := '14';
        //查询条件
        ExcelWorksheet1.Cells.item[3, 1] := strTerm;
        ExcelWorksheet1.Cells.Item[3, 1].font.size := '14';
        //保存信息到文件
        ExcelWorksheet1.SaveAs(filename);
        Application.Messagebox(pchar('数据已成功导出至：' + UpperCase(filename) ), '提示', MB_OK + MB_ICONINFORMATION);
      except
        next_i:= False;
        Application.Messagebox(pchar('数据导出失败：' + UpperCase(filename) ), '提示', MB_OK + MB_ICONINFORMATION);
      end;
    end;

  //资源释放
  try
    ExcelApplication1.Disconnect;
    ExcelApplication1.Quit;
    ExcelApplication1.Free;
    ExcelWorksheet1.Free;
    ExcelWorkbook1.Free;
  except

  end;

  Result := next_i;
end;
 
调用：  get_listviewTOexcel(lvCLLB,'','');

View Code

插入、载入

procedure TMainFrm_U.TSavaClick(Sender: TObject);
{保存rxrichedit编辑后的内容}
var
  stringstream1: TStringStream;
begin
  stringstream1 := TStringStream.create('');
  rxRichEdit1.Lines.SaveToStream(stringstream1);//需要对这个流文件进行压缩
  if rxRichEdit1.Modified then   //当已打开的文件被修改了以后
  begin
  UniQuery1.SQL.Text :='UPDATE Rich SET F_Con = :F_Con WHERE Type_id = :Type_id' ;
  UniQuery1.ParamByName('Type_id').AsString := PMyData(TreeView1.Selected.Data)^.ID;
  UniQuery1.ParamByName('F_Con').LoadFromStream(stringstream1, DB.ftBlob);
  UniQuery1.Execute;
  end;

end;


procedure TMainFrm_U.TreeView1Click(Sender: TObject);
{查询文本内容}
var
  Titem: Tlistitem;
  query: TUniQuery;
  mStream: TStringStream;
  ms: TMemoryStream;
   T: DWORD;
begin
  if TreeView1.Selected <> nil then
  begin
    if TreeView1.Selected.Data <> nil then
    begin
    T := GetTickCount;
      StatusBar1.Panels[1].Text := TreeView1.Selected.Text;
      query := TUniQuery.create(nil);
      query.Connection := UniConnection1;
      query.SQL.Clear;
      query.SQL.Add('Select Type_id,F_Con from Rich where Type_id=:Type_id');
      query.ParamByName('Type_id').AsString := PMyData(TreeView1.Selected.Data)^.ID;
      // UniQuery1.ParamByName('a6').LoadFromFile(OpenDialog1.FileName,DB.ftBlob);
      query.Open;
      ListView1.Clear;
      if query.RecordCount>0 then
      begin
     // if query. then

      while not query.Eof do
      begin
        Titem := ListView1.Items.Add;
        //ms := TMemoryStream.create;
        //mStream := TStringStream.create('');
         Titem.Caption := Query.FieldByName('Type_id').AsString;
         Label1.Caption:=Treeview1.Selected.Text;
         //Titem.SubItems.Add(query.FieldByName('Type_id').AsString);
         //Titem.Data:='';
        // stringstream1 := TStream.Create;
        // (Query.FieldByName('Type_id') as TBlobField).SaveToStream(stringstream1);
        //TBlobField(query.FieldByName('F_Con')).SaveToStream(mStream);
        // ms.SaveToStream(mStream);
       // RichEdit1.Lines.LoadFromStream(mStream);
        //TBlobField(query.FieldByName('F_Con')).Assign(RichEdit1.Lines);
         rxRichEdit1.Lines.Assign(query.FieldByName('F_Con'));
        //query.Post;
        query.next;
      end;
      StatusBar1.Panels[1].Text := Format('用时: %d ms', [GetTickCount - T]);
       end
       else
       begin
         rxRichEdit1.Clear;
       end;
      UniQuery1.close;
    end;
    { PMyData(TreeView1.Selected.Data)
      ^.idName + PMyData(TreeView1.Selected.Data)^.LName; }
  end;
end;

View Code

优质内容筛选与推荐>>
1、python的格式化输出
2、pubwin
3、ubuntu安装Android Studio开发环境
4、Java之创建对象>5.Avoid creating unnecessary objects
5、【webpack构建优化】热更新

0 │ 收藏 │ 举报

朋友将在看一看看到

分享想法到看一看