ListViewのカスタム描画で選択色を変更するには？

解決

ウリエ 2005-03-08 07:26:25 No: 88735

VB6のListViewコントロールの選択色をカスタム描画で変更する方法を試行しています。現状は、http://www.codeguru.com/Cpp/controls/listview/article.php/c1035
を参考に、１行全体の選択色を変更できる様にはなりました。
しかし、選択範囲を１行全体ではなく、デフォルトと同じ様に、アイテムのラベル範囲にしたいのですが、思うようにいきません。

カスタム描画で実現するためのヒントを戴ければ助かります。
宜しくお願いします。以下に、現状のテストコードを載せます。

'// Form1.frm
Option Explicit

Private Sub Form_Load()
    Dim i As Long
    With ListView1
        .View = lvwReport
        .ColumnHeaders.Add , , "Item"
        .ColumnHeaders.Add , , "SubItem"
        For i = 1 To 5
            .ListItems.Add , , "Item " & i
            .ListItems(i).SubItems(1) = "SubItem " & i
        Next i
    End With
    Call SubClass(Me.hWnd)
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Call UnSubClass(Me.hWnd)
End Sub

'// Module1.bas
Option Explicit

Private Type NMHDR
    hwndFrom As Long
    idFrom As Long
    code As Long
End Type

Private Const NM_FIRST As Long = 0
Private Const NM_CUSTOMDRAW As Long = (NM_FIRST - 12)

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type NMCUSTOMDRAWINFO
    hdr As NMHDR
    dwDrawStage As Long
    hdc As Long
    rc As RECT
    dwItemSpec As Long
    iItemState As Long
    lItemlParam As Long
End Type

Private Type NMLVCUSTOMDRAW
    nmcd As NMCUSTOMDRAWINFO
    clrText As Long
    clrTextBk As Long
    iSubItem As Integer
End Type

Private Const CDDS_PREPAINT As Long = &H1
Private Const CDDS_POSTPAINT As Long = &H2
Private Const CDDS_ITEM As Long = &H10000
' Private Const CDDS_SUBITEM As Long = &H20000
Private Const CDDS_ITEMPREPAINT As Long = CDDS_ITEM Or CDDS_PREPAINT
Private Const CDDS_ITEMPOSTPAINT As Long = CDDS_ITEM Or CDDS_POSTPAINT

Private Const CDRF_DODEFAULT As Long = &H0
Private Const CDRF_NOTIFYPOSTPAINT As Long = &H10
Private Const CDRF_NOTIFYITEMDRAW As Long = &H20
Private Const CDRF_NOTIFYSUBITEMDRAW As Long = &H20

Private Type LVITEM
    mask As Long
    iItem As Long
    iSubItem As Long
    State As Long
    stateMask As Long
    pszText As Long
    cchTextMax As Long
    iImage As Long
    lParam As Long
    iIndent As Long
End Type

Private Const LVIF_STATE As Long = &H8

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long

Private Const WM_NOTIFY As Long = &H4E&

Private Const LVM_FIRST As Long = &H1000
Private Const LVM_SETITEMSTATE As Long = (LVM_FIRST + 43)
Private Const LVM_GETITEMSTATE As Long = (LVM_FIRST + 44)
Private Const LVIS_FOCUSED As Long = &H1
Private Const LVIS_SELECTED As Long = &H2

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetFocus Lib "user32" () As Long

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
        (ByVal hWnd As Long, ByVal nIndex As Long, _
        ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
        (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_WNDPROC As Long = (-4)
Private Declare Function CallWindowProc Lib "user32" _
        Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
        ByVal hWnd As Long, ByVal Msg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long

Private m_lpOldWndProc As Long

Public Sub SubClass(ByVal hWnd As Long)
m_lpOldWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub UnSubClass(ByVal hWnd As Long)
Call SetWindowLong(hWnd, GWL_WNDPROC, m_lpOldWndProc)
End Sub

Private Function WindowProc(ByVal hWnd As Long, _
                            ByVal uMsg As Long, _
                            ByVal wParam As Long, _
                            ByVal lParam As Long) As Long
    Select Case uMsg
    Case WM_NOTIFY
        Static bHighlighted As Boolean
        Dim iRow As Long
        Dim p As NMHDR
        Call MoveMemory(p, ByVal lParam, Len(p))

        Select Case (p.code)
        Case NM_CUSTOMDRAW
            Dim lvcd As NMLVCUSTOMDRAW
            Call MoveMemory(lvcd, ByVal lParam, Len(lvcd))

            Select Case (lvcd.nmcd.dwDrawStage)
            Case CDDS_PREPAINT
                WindowProc = CDRF_NOTIFYITEMDRAW
                Exit Function
            Case CDDS_ITEMPREPAINT
                iRow = lvcd.nmcd.dwItemSpec
                bHighlighted = IsRowHighlighted(p.hwndFrom, iRow)
                If (bHighlighted) Then
                    lvcd.clrText = vbWhite
                    lvcd.clrTextBk = vbRed
                    Call MoveMemory(ByVal lParam, lvcd, Len(lvcd))
                    Call EnableHighlighting(p.hwndFrom, iRow, False)
                End If
                WindowProc = CDRF_DODEFAULT Or CDRF_NOTIFYPOSTPAINT
                Exit Function
            Case CDDS_ITEMPOSTPAINT
                If (bHighlighted) Then
                    iRow = lvcd.nmcd.dwItemSpec
                    Call EnableHighlighting(p.hwndFrom, iRow, True)
                End If
                WindowProc = CDRF_DODEFAULT
                Exit Function
            Case Else
                WindowProc = CDRF_DODEFAULT
                Exit Function
            End Select
        End Select
    End Select
    WindowProc = CallWindowProc(m_lpOldWndProc, hWnd, uMsg, wParam, lParam)
End Function

Private Sub EnableHighlighting(ByVal hWnd As Long, _
                               ByVal row As Long, _
                               ByVal bHighlight As Boolean)
    Dim lvi As LVITEM
    lvi.mask = LVIF_STATE
    lvi.State = bHighlight
    lvi.stateMask = LVIS_FOCUSED Or LVIS_SELECTED
    Call SendMessage(hWnd, LVM_SETITEMSTATE, row, lvi)
End Sub

Private Function IsRowSelected(ByVal hWnd As Long, _
ByVal row As Long) As Boolean
IsRowSelected = (SendMessage(hWnd, LVM_GETITEMSTATE, row, ByVal LVIS_SELECTED) <> 0)
End Function

Private Function IsRowHighlighted(ByVal hWnd As Long, _
ByVal row As Long) As Boolean
IsRowHighlighted = IsRowSelected(hWnd, row) And (GetFocus = hWnd)
End Function

ひろ 2005-03-09 00:38:28 No: 88736

Grid系のコントロールを使う方が楽かもしれませんよ。

ウリエ 2005-03-09 07:23:23 No: 88737

ひろさんアドバイスありがとう。次の機会に検討したいと思います。

で、選択範囲をアイテムのラベル範囲にできませんでしたが、アイテム矩形の範囲にはできました。今回は、これで妥協したいと思います。
以下が、その追加・修正コードです。

Private Const CDDS_SUBITEM As Long = &H20000
Private Declare Function OleTranslateColor Lib "oleaut32" _
(ByVal clr As Long, ByVal hpal As Long, pcolorref As Long) As Long

Private Function WindowProc(ByVal hWnd As Long, _
                            ByVal uMsg As Long, _
                            ByVal wParam As Long, _
                            ByVal lParam As Long) As Long
    Select Case uMsg
    Case WM_NOTIFY
        Static bHighlighted As Boolean
        Static iRow As Long
        Dim p As NMHDR
        Call MoveMemory(p, ByVal lParam, Len(p))

        Select Case (p.code)
        Case NM_CUSTOMDRAW
            Dim lvcd As NMLVCUSTOMDRAW
            Call MoveMemory(lvcd, ByVal lParam, Len(lvcd))

            Select Case (lvcd.nmcd.dwDrawStage)
            Case CDDS_PREPAINT
                WindowProc = CDRF_NOTIFYITEMDRAW
                Exit Function
            Case CDDS_ITEMPREPAINT
                iRow = lvcd.nmcd.dwItemSpec
                bHighlighted = IsRowHighlighted(p.hwndFrom, iRow)
                If (bHighlighted) Then
                    Call EnableHighlighting(p.hwndFrom, iRow, False)
                End If
                WindowProc = CDRF_NOTIFYSUBITEMDRAW
                Exit Function
            Case (CDDS_ITEMPREPAINT Or CDDS_SUBITEM)
                If (bHighlighted) And (lvcd.iSubItem = 0) Then
                    lvcd.clrText = vbWhite
                    lvcd.clrTextBk = vbRed
                    Call EnableHighlighting(p.hwndFrom, iRow, True)
                Else
                    lvcd.clrText = ToCOLOEREF(vbWindowText)
                    lvcd.clrTextBk = ToCOLOEREF(vbWindowBackground)
                End If
                Call MoveMemory(ByVal lParam, lvcd, Len(lvcd))
                WindowProc = CDRF_DODEFAULT
                Exit Function
            Case Else
                WindowProc = CDRF_DODEFAULT
                Exit Function
            End Select
        End Select
    End Select
    WindowProc = CallWindowProc(m_lpOldWndProc, hWnd, uMsg, wParam, lParam)
End Function

Private Function ToCOLOEREF(ByVal clr As OLE_COLOR) As Long
Call OleTranslateColor(clr, 0, ToCOLOEREF)
End Function