تغییر رنگ فونت سطر در ListVeiw

با سلام

چه جوری میشه خاصیت ForeColor یک سطر در ListVeiw رو وقتیکه موس بر روی اون سطر قرار داره رو تغییر داد که با بقیه سطور فرق داشته باشه؟

خودم پیداش کردم

Option Explicit

Private m_lngPreviousRow As Long

Private Const LVM_FIRST As Long = &H1000

Private Const LVM_HITTEST As Long = (LVM_FIRST + 18)

Private Type POINTAPI

    x As Long

    Y As Long

End Type

Private Type LVHITTESTINFO

    pt As POINTAPI

    flags As Long

    iItem As Long

    iSubItem As Long

End Type

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

    'this public sub would probably be in a .bas module

Public Sub ColorListviewRow(lv As ListView, RowNbr As Long, RowColor As OLE_COLOR)

    '*************************************************  **************************

    'Purpose: Color a ListView Row

    'Inputs : lv - The ListView

    '         RowNbr - The index of the row to be colored

    '         RowColor - The color to color it

    'Outputs:

    '*************************************************  **************************

       Dim itmX As ListItem

       Dim lvSI As ListSubItem

       Dim intIndex As Integer

       On Error GoTo ErrorRoutine

       Set itmX = lv.ListItems(RowNbr)

       itmX.ForeColor = RowColor

       For intIndex = 1 To lv.ColumnHeaders.Count - 1

           Set lvSI = itmX.ListSubItems(intIndex)

           lvSI.ForeColor = RowColor

       Next

       Set itmX = Nothing

       Set lvSI = Nothing

       Exit Sub

    ErrorRoutine:

       MsgBox Err.Description

End Sub

Private Sub lvwTOC_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)

       Dim lvhti As LVHITTESTINFO

       Dim lngCurrentRow As Long

       lvhti.pt.x = x / Screen.TwipsPerPixelX

       lvhti.pt.Y = Y / Screen.TwipsPerPixelY

       lngCurrentRow = SendMessage(lvwTOC.hwnd, LVM_HITTEST, 0, lvhti) + 1

       'check to see if the MouseMove has changed which row is under the mouse:

       If lngCurrentRow <> m_lngPreviousRow Then 'row has changed

           If ((m_lngPreviousRow > 0) And (m_lngPreviousRow <= lvwTOC.ListItems.Count)) Then

               'so, we need to reset the old row's ForeColor:

               ColorListviewRow lvwTOC, m_lngPreviousRow, &HFFFFC0 'light blue

               If ((lngCurrentRow > 0) And (lngCurrentRow <= lvwTOC.ListItems.Count)) Then

                   'and set the current row's ForeColor:

                   ColorListviewRow lvwTOC, lngCurrentRow, &H8080FF 'light red

               End If

           Else 'first time through (m_lngPreviousRow = -1 in FormLoad)

               If ((lngCurrentRow > 0) And (lngCurrentRow <= lvwTOC.ListItems.Count)) Then

                   ColorListviewRow lvwTOC, lngCurrentRow, &H8080FF 'light red

               End If

           End If

           'and update he module level variable to indicate that the current row is now the old row:

           m_lngPreviousRow = lngCurrentRow

       End If

End Sub

لطفا جوابتون رو اول در یک TXT کپی کنید بعد از اونجا کپی کنید داخل سایت که استایلهاش حذف بشه

نقل قول:

---

نوشته شده توسط romina2006

خودم پیداش کردم

Option Explicit

Private m_lngPreviousRow As Long

Private Const LVM_FIRST As Long = &H1000

Private Const LVM_HITTEST As Long = (LVM_FIRST + 18)

Private Type POINTAPI

    x As Long

    Y As Long

End Type

Private Type LVHITTESTINFO

    pt As POINTAPI

    flags As Long

    iItem As Long

    iSubItem As Long

End Type

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

    'this public sub would probably be in a .bas module

Public Sub ColorListviewRow(lv As ListView, RowNbr As Long, RowColor As OLE_COLOR)

    '*************************************************  **************************

    'Purpose: Color a ListView Row

    'Inputs : lv - The ListView

    '         RowNbr - The index of the row to be colored

    '         RowColor - The color to color it

    'Outputs:

    '*************************************************  **************************

       Dim itmX As ListItem

       Dim lvSI As ListSubItem

       Dim intIndex As Integer

       On Error GoTo ErrorRoutine

       Set itmX = lv.ListItems(RowNbr)

       itmX.ForeColor = RowColor

       For intIndex = 1 To lv.ColumnHeaders.Count - 1

           Set lvSI = itmX.ListSubItems(intIndex)

           lvSI.ForeColor = RowColor

       Next

       Set itmX = Nothing

       Set lvSI = Nothing

       Exit Sub

    ErrorRoutine:

       MsgBox Err.Description

End Sub

Private Sub lvwTOC_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)

       Dim lvhti As LVHITTESTINFO

       Dim lngCurrentRow As Long

       lvhti.pt.x = x / Screen.TwipsPerPixelX

       lvhti.pt.Y = Y / Screen.TwipsPerPixelY

       lngCurrentRow = SendMessage(lvwTOC.hwnd, LVM_HITTEST, 0, lvhti) + 1

       'check to see if the MouseMove has changed which row is under the mouse:

       If lngCurrentRow <> m_lngPreviousRow Then 'row has changed

           If ((m_lngPreviousRow > 0) And (m_lngPreviousRow <= lvwTOC.ListItems.Count)) Then

               'so, we need to reset the old row's ForeColor:

               ColorListviewRow lvwTOC, m_lngPreviousRow, &HFFFFC0 'light blue

               If ((lngCurrentRow > 0) And (lngCurrentRow <= lvwTOC.ListItems.Count)) Then

                   'and set the current row's ForeColor:

                   ColorListviewRow lvwTOC, lngCurrentRow, &H8080FF 'light red

               End If

           Else 'first time through (m_lngPreviousRow = -1 in FormLoad)

               If ((lngCurrentRow > 0) And (lngCurrentRow <= lvwTOC.ListItems.Count)) Then

                   ColorListviewRow lvwTOC, lngCurrentRow, &H8080FF 'light red

               End If

           End If

           'and update he module level variable to indicate that the current row is now the old row:

           m_lngPreviousRow = lngCurrentRow

       End If

End Sub

---

اینهمه کد برای یک کار ساده ارزش نداره اونم با تابع SendMessage
توصیه میکنم حتما از vsFlexGrid استفاده کنید

برای vsFlexGrid این کد رو نوشتم کار میکنه ولی وقتیکه روی سطر آخر کلیک میکنم خطا Invalid property array index رو میده.چیکار باید کرد ؟

If VSFlexGrid1.MouseRow = 0 Or VSFlexGrid1.MouseRow = -1 Then Exit Sub

VSFlexGrid1.Cell(flexcpBackColor, VSFlexGrid1.MouseRow, 1, VSFlexGrid1.MouseRow, VSFlexGrid1.Cols - 1) = &H80C0FF

For I = 1 To VSFlexGrid1.Row

If I = VSFlexGrid1.MouseRow Then I = I + 1

VSFlexGrid1.Cell(flexcpBackColor, I, 1, I, VSFlexGrid1.Cols - 1) = &HC0FFFF

Next I

یک دونه null اضافی به انتهای لیست اضافه کن

کدش رو تصحیح کردم :

If VSFlexGrid1.MouseRow = 0 Or VSFlexGrid1.MouseRow = -1 Then Exit Sub

VSFlexGrid1.Cell(flexcpBackColor, VSFlexGrid1.MouseRow, 1, VSFlexGrid1.MouseRow, VSFlexGrid1.Cols - 1) = &H80C0FF

For I = 1 To VSFlexGrid1.Rows - 2

If I = VSFlexGrid1.MouseRow Then I = I + 1

VSFlexGrid1.Cell(flexcpBackColor, I, 1, I, VSFlexGrid1.Cols - 1) = &HC0FFFF

Next I