VBNet - Форум - Ошибка при раскраске ListView

Вопрос: Ошибка при раскраске ListView Добавлено: 12.11.10 16:53

Автор вопроса: Mc.WOLF

'module
Option Explicit

Public Const GWL_EXSTYLE = -20
Public Const GWL_HINSTANCE = -6
Public Const GWL_HWNDPARENT = -8
Public Const GWL_ID = -12
Public Const GWL_STYLE = -16
Public Const GWL_USERDATA = -21
Public Const GWL_WNDPROC = -4
Public Const DWL_DLGPROC = 4
Public Const DWL_MSGRESULT = 0
Public Const DWL_USER = 8

Public Const NM_CUSTOMDRAW = (-12&)
Public Const WM_NOTIFY As Long = &H4E&
Public Const CDDS_PREPAINT As Long = &H1&
Public Const CDRF_NOTIFYITEMDRAW As Long = &H20&
Public Const CDDS_ITEM As Long = &H10000
Public Const CDDS_ITEMPREPAINT As Long = CDDS_ITEM Or CDDS_PREPAINT
Public Const CDRF_NEWFONT As Long = &H2&
Public Const CDDS_SUBITEM  As Long = &H20000
Public Const CDRF_NOTIFYSUBITEMDRAW As Long = &H20&

Public Type NMHDR
    hWndFrom As Long   ' Window handle of control sending message
    idFrom As Long        ' Identifier of control sending message
    code  As Long          ' Specifies the notification code
End Type

' sub struct of the NMCUSTOMDRAW struct
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

' generic customdraw struct
Public Type NMCUSTOMDRAW
    hdr As NMHDR
    dwDrawStage As Long
    hDC As Long
    rc As RECT
    dwItemSpec As Long
    uItemState As Long
    lItemlParam As Long
End Type

' listview specific customdraw struct
Public Type NMLVCUSTOMDRAW
    nmcd As NMCUSTOMDRAW
    clrText As Long
    clrTextBk As Long
    ' if IE >= 4.0 this member of the struct can be used
    iSubItem As Integer
End Type

Public g_addProcOld As Long
Public g_MaxItems As Long
Public g_MaxColumns As Long
Public clr() As Long

Public Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Function WindowProc(ByVal hWnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Select Case iMsg
    Case WM_NOTIFY
        Dim udtNMHDR As NMHDR
        CopyMemory udtNMHDR, ByVal lParam, 12&

        With udtNMHDR
            If .code = NM_CUSTOMDRAW Then
                Dim udtNMLVCUSTOMDRAW As NMLVCUSTOMDRAW
                CopyMemory udtNMLVCUSTOMDRAW, ByVal lParam, Len(udtNMLVCUSTOMDRAW)
                With udtNMLVCUSTOMDRAW.nmcd
                    Select Case .dwDrawStage
                    Case CDDS_PREPAINT
                        WindowProc = CDRF_NOTIFYITEMDRAW
                        Exit Function
                    Case CDDS_ITEMPREPAINT
                        WindowProc = CDRF_NOTIFYSUBITEMDRAW
                        Exit Function
                    Case CDDS_ITEMPREPAINT Or CDDS_SUBITEM
                        If clr(.dwItemSpec, udtNMLVCUSTOMDRAW.iSubItem) <> 0 Then
                            ' a color has been specified, then write row, column
                            udtNMLVCUSTOMDRAW.clrTextBk = clr(.dwItemSpec, udtNMLVCUSTOMDRAW.iSubItem)
                        Else
                            'there is no color, then revert to white background
                            udtNMLVCUSTOMDRAW.clrTextBk = RGB(255, 255, 255)
                        End If
                        CopyMemory ByVal lParam, udtNMLVCUSTOMDRAW, Len(udtNMLVCUSTOMDRAW)
                        WindowProc = CDRF_NEWFONT
                        Exit Function
                    End Select
                End With
            End If
        End With
    End Select
    WindowProc = CallWindowProc(g_addProcOld, hWnd, iMsg, wParam, lParam)
End Function

Public Sub SetLIBackColor(lv As ListView, Row As Integer, Col As Integer, BkColor As Long)
    ' the first column cannot be changed yet
    If Col <= 1 Then Col = 2
    clr(Row - 2, Col - 1) = BkColor
    ' a refresh will repaint the listview thus trapping the events
    lv.Refresh
End Sub

'in form

Private Sub Command1_Click()
    ' set back colors for the specified rows and columns
    SetLIBackColor ListView1, 4, 4, vbCyan      ' row 4 column 4
    SetLIBackColor ListView1, 2, 2, vbMagenta   ' row 2 column 2

End Sub

Private Sub Form_Load()
    ' subclass the listview using the handle of the form
    ' if you are using the listview in a user control, pass the handle of the usercontrol in the
    ' user control initialize sub
    g_addProcOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)

    ' add a few listitems for practise
    Dim lstItm As MSComctlLib.ListItem

    Set lstItm = ListView1.ListItems.Add(, , "Item 1")
    lstItm.SubItems(1) = "Item 1"
    lstItm.SubItems(2) = "Item 1"
    lstItm.SubItems(3) = "Item 1"

    Set lstItm = ListView1.ListItems.Add(, , "Item 2")
    lstItm.SubItems(1) = "Item 2"
    lstItm.SubItems(2) = "Item 2"
    lstItm.SubItems(3) = "Item 2"

    Set lstItm = ListView1.ListItems.Add(, , "Item 3")
    lstItm.SubItems(1) = "Item 3"
    lstItm.SubItems(2) = "Item 3"
    lstItm.SubItems(3) = "Item 3"

    Set lstItm = ListView1.ListItems.Add(, , "Item 4")
    lstItm.SubItems(1) = "Item 4"
    lstItm.SubItems(2) = "Item 4"
    lstItm.SubItems(3) = "Item 4"

    ReDim Preserve clr(ListView1.ListItems.Count, ListView1.ColumnHeaders.Count)
    'Initialise the subclassing
    g_MaxItems = ListView1.ListItems.Count - 1
    g_MaxColumns = ListView1.ColumnHeaders.Count
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ' unsubclass the listview
    ' if the listview is inside a usercontrol, put this in a terminate event
    SetWindowLong hWnd, GWL_WNDPROC, g_addProcOld

End Sub

Private Sub ListView1_Click()
    ' when a user clicks a listview item
    ' on the selected row, change column 2 and column 3 to be green and red
    Dim lstItm As MSComctlLib.ListItem
    Set lstItm = ListView1.SelectedItem

    If TypeName(lstItm) = "Nothing" Then Exit Sub
    SetLIBackColor ListView1, ListView1.SelectedItem.Index, 2, vbGreen
    SetLIBackColor ListView1, ListView1.SelectedItem.Index, 3, vbRed
End Sub

Private Sub Timer1_Timer()
Dim i As Integer
i = 1
Do Until i = ListView1.ListItems.Count + 1
    If ListView1.ListItems(i).SubItems(2) = "Item 3" Then
        SetLIBackColor ListView1, i, 2, vbMagenta
    End If

i = i + 1
Loop
End Sub

Выбивает "subscript out of range" clr(Row - 2, Col - 1) = BkColor как это поправить?
Ответить

Ответы Всего ответов: 6

Номер ответа: 1 Автор ответа: AgentFire ICQ: 192496851 Вопросов: 75 Ответов: 3178	Профиль \| \| #1	Добавлено: 12.11.10 17:17
	не указывать выходящие на рамки значения Ответить

Номер ответа: 2 Автор ответа: Mc.WOLF Вопросов: 26 Ответов: 84	Профиль \| \| #2	Добавлено: 12.11.10 17:34
	не совсем понял Ответить

Номер ответа: 3 Автор ответа: AgentFire ICQ: 192496851 Вопросов: 75 Ответов: 3178	Профиль \| \| #3	Добавлено: 12.11.10 18:43
	ты указываешь какие то значиния, а ошибка вылезает, что ты мол, указал что то вне допустимых рамок. Ответить

Номер ответа: 4 Автор ответа: Winand Вопросов: 87 Ответов: 2795	Web-сайт: winandfx.narod.ru Профиль \| \| #4	Добавлено: 12.11.10 21:30
	логично, что при row равном 1 или 0 будет ошибка Ответить

Номер ответа: 5 Автор ответа: Mc.WOLF Вопросов: 26 Ответов: 84	Профиль \| \| #5	Добавлено: 13.11.10 19:29
	так как это исправить? Помогите пожалуйста... Ответить

Номер ответа: 6 Автор ответа: Mc.WOLF Вопросов: 26 Ответов: 84	Профиль \| \| #6	Добавлено: 15.11.10 10:55
	Так как кто нибудь поможет или как? Ответить

Страница: 1 |