TimoSoft-Software.de

Code: Select all

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


  Private subItemToEdit As ListViewSubItem
  Private oldCaretItem As Long


  Private Declare Function DrawText Lib "user32.dll" Alias "DrawTextW" (ByVal hDC As Long, ByVal lpStr As Long, ByVal nCount As Long, ByRef lpRect As RECT, ByVal wFormat As Long) As Long
  Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
  Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
  Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hDC As Long) As Long
  Private Declare Function SendMessageAsLong Lib "user32.dll" Alias "SendMessageW" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long


Private Sub ListView1_AfterScroll(ByVal dx As Long, ByVal dy As Long)
  If Text1.Visible Then
    ' abort
    Text1.Visible = False
    Set subItemToEdit = Nothing
    ListView1.Refresh
  End If
End Sub

Private Sub ListView1_Click(ByVal listItem As ExLVwLibUCtl.IListViewItem, ByVal listSubItem As ExLVwLibUCtl.IListViewSubItem, ByVal button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single, ByVal hitTestDetails As ExLVwLibUCtl.HitTestConstants)
  If Not (listItem Is Nothing) Then
    If listItem.Caret And (oldCaretItem = listItem.Index) Then
      ' the caret item was clicked (and it already was the caret before)
      If Not (listSubItem Is Nothing) Then
        ' enter sub-item edit mode
        Set subItemToEdit = listSubItem
      End If
    End If
  End If
End Sub

Private Sub ListView1_CustomDraw(ByVal listItem As ExLVwLibUCtl.IListViewItem, ByVal listSubItem As ExLVwLibUCtl.IListViewSubItem, textColor As stdole.OLE_COLOR, TextBackColor As stdole.OLE_COLOR, ByVal drawStage As ExLVwLibUCtl.CustomDrawStageConstants, ByVal itemState As ExLVwLibUCtl.CustomDrawItemStateConstants, ByVal hDC As Long, drawingRectangle As ExLVwLibUCtl.RECTANGLE, furtherProcessing As ExLVwLibUCtl.CustomDrawReturnValuesConstants)
  If Not (subItemToEdit Is Nothing) Then
    Select Case drawStage
      Case CustomDrawStageConstants.cdsPrePaint
        furtherProcessing = CustomDrawReturnValuesConstants.cdrvNotifyItemDraw
      Case CustomDrawStageConstants.cdsItemPrePaint
        If listItem.Index = subItemToEdit.ParentItem.Index Then
          furtherProcessing = CustomDrawReturnValuesConstants.cdrvNotifySubItemDraw
        End If
      Case CustomDrawStageConstants.cdsSubItemPrePaint
        If listSubItem.Index = subItemToEdit.Index Then
          furtherProcessing = CustomDrawReturnValuesConstants.cdrvSkipDefault
        End If
    End Select
  End If
End Sub

Private Sub ListView1_MouseDown(ByVal listItem As ExLVwLibUCtl.IListViewItem, ByVal listSubItem As ExLVwLibUCtl.IListViewSubItem, ByVal button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single, ByVal hitTestDetails As ExLVwLibUCtl.HitTestConstants)
  If Not (ListView1.CaretItem Is Nothing) Then
    oldCaretItem = ListView1.CaretItem.Index
  Else
    oldCaretItem = -1
  End If
End Sub

Private Sub ListView1_StartingLabelEditing(ByVal listItem As ExLVwLibUCtl.IListViewItem, cancelEditing As Boolean)
  Const SM_CXEDGE = 45
  Const SM_CYEDGE = 46
  Const WM_GETFONT = &H31
  Const WM_SETFONT = &H30
  Dim hFont As Long
  Dim cx As Long
  Dim cy As Long
  Dim x As Long
  Dim y As Long

  If Not (subItemToEdit Is Nothing) Then
    cancelEditing = True

    x = 3 * GetSystemMetrics(SM_CXEDGE) + subItemToEdit.Left(ItemRectangleTypeConstants.irtLabelOnly)
    y = subItemToEdit.Top(ItemRectangleTypeConstants.irtLabelOnly)
    cy = subItemToEdit.Height(ItemRectangleTypeConstants.irtLabelOnly) + 2 * GetSystemMetrics(SM_CYEDGE)
    Text1.Move ListView1.Left + x, ListView1.Top + y, Text1.Width, cy

    Text1.Text = subItemToEdit.Text
    Text1.SelStart = 0
    Text1.SelLength = Len(Text1.Text)

    ' ensure, that Text1 and ListView1 use the same font
    hFont = SendMessageAsLong(ListView1.hWnd, WM_GETFONT, 0, 0)
    SendMessageAsLong Text1.hWnd, WM_SETFONT, hFont, 0

    Text1.Visible = True
    Text1.SetFocus
  End If
End Sub

Private Sub Text1_Change()
  Const DT_CALCRECT = &H400
  Const DT_CENTER = &H1
  Const DT_EDITCONTROL = &H2000
  Const DT_NOPREFIX = &H800
  Const DT_SINGLELINE = &H20
  Dim cx As Long
  Dim hDC As Long
  Dim rc As RECT
  Dim str As String

  hDC = GetDC(ListView1.hWnd)
  str = Text1.Text
  DrawText hDC, StrPtr(str), Len(str), rc, DT_CALCRECT Or DT_CENTER Or DT_EDITCONTROL Or DT_NOPREFIX Or DT_SINGLELINE
  ReleaseDC ListView1.hWnd, hDC

  cx = rc.Right - rc.Left
  If cx < 50 Then
    cx = 50
  End If
  If Text1.Left - ListView1.Left + cx > ListView1.Width Then
    cx = ListView1.Width - Text1.Left + ListView1.Left
  End If

  Text1.Width = cx
End Sub

Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = KeyCodeConstants.vbKeyEscape Then
    ' abort
    Text1.Visible = False
    Set subItemToEdit = Nothing
  ElseIf KeyCode = KeyCodeConstants.vbKeyReturn Then
    ' apply text
    subItemToEdit.Text = Text1.Text
    Text1.Visible = False
    Set subItemToEdit = Nothing
  End If
End Sub

Private Sub Text1_LostFocus()
  ' abort
  Text1.Visible = False
  Set subItemToEdit = Nothing
  ListView1.Refresh
End Sub