VBA Subclass of control

Home

(2)TreeView

（1）Subclass Listview

マイクロソフトのリストビューは、パソコンの環境によって利用出来ないか、
配布が出来ない状態があります。
そこで、環境に依存しないサブクラスでリストビュー作成の紹介です。
環境ＯＳはwindowsです。

-----------------------------------------------------------

これからの内容はmougモーグのExcelＶＢＡに於いて
投稿者: たっく氏, 回答者: Abyss氏　のお二人のやり取りから
公開された内容を一部加筆したものです。
貴重な情報に感謝いたします。

mouglink1 mouglink2 mouglink3 mouglink4
------------------------------------------------------------

下記のソースコードはReport表示形式（Item＋subItem）となります。
又ダウンロードファイルを2種類用意しましたので、
動作確認は、そちらのファイルで確認願います。
Userformは、モーダルのみ動作のみ対応となります。

公開に当たり利用者の知識向上の手助けとなれば幸いです。

※ダウンロードファイル   ListView(Report).zip  ListView(List).zip

Option Explicit

Public Const WS_CHILD = &H40000000
Public Const WS_VISIBLE = &H10000000
Public Const WS_CLIPSIBLINGS = &H4000000
Public Const WS_EX_CLIENTEDGE = &H200&
Public Const WM_SETFOCUS = 7&
Public Const WM_NOTIFY = &H4E&
Public Const WM_MOUSEACTIVATE = &H21&
Public Const WM_NCDESTROY = &H82&
Public Const WM_SETFONT = &H30
Public Const MA_NOACTIVATE = 3&
Public Const LVS_REPORT = 1&
Public Const LVS_SHOWSELALWAYS = 8&
Public Const LVS_EX_FULLROWSELECT = &H20&
Public Const LVS_EX_GRIDLINES = 1&
Public Const LVS_EX_CHECKBOXES = 4&
Public Const LVM_SETEXTENDEDLISTVIEWSTYLE = &H1036
Public Const LVM_SETITEM = &H1000& + 76
Public Const LVM_INSERTITEM = &H1000& + 77
Public Const LVM_INSERTCOLUMN = &H1000& + 97
Public Const LVM_GETITEMTEXT = &H1000& + 115
Public Const LVN_ITEMCHANGED = -100& - 1
Public Const LVCF_WIDTH = 2&
Public Const LVCF_TEXT = 4&
Public Const LVCF_SUBITEM = 8&
Public Const LVIF_TEXT = 1&
Public Const LVM_FIRST = &H1000
' テキストの背景色を設定
Public Const LVM_SETTEXTBKCOLOR = (LVM_FIRST + 38) 
' 背景色の設定
Public Const LVM_SETBKCOLOR = (LVM_FIRST + 1) 
' テキストの文字色を設定     
Public Const LVM_SETTEXTCOLOR = (LVM_FIRST + 36)   
Public Const NM_CLICK = -2&
Public Const NM_DBLCLK = -3&

Declare Function InitCommonControlsEx& Lib "comctl32" _
    (ByVal lpInitCtrls&)
Declare Function SetWindowSubclass& Lib "comctl32" _
    (ByVal hwnd&, _
     ByVal pfnSubclass&, _
     ByVal uIdSubclass&, _
     ByVal dwRefData&)
Declare Function DefSubclassProc& Lib "comctl32" _
    (ByVal hwnd&, _
     ByVal uMsg&, _
     ByVal wParam&, _
     ByVal lParam&)
Declare Function RemoveWindowSubclass& Lib "comctl32" _
    (ByVal hwnd&, _
     ByVal pfnSubclass&, _
     ByVal uIdSubclass&)
Declare Function CreateWindowExW& Lib "user32" _
    (ByVal dwExStyle&, _
     ByVal lpClassName&, _
     ByVal lpWindowName&, _
     ByVal dwStyle&, _
     ByVal X&, ByVal Y&, ByVal nWidth&, ByVal nHeight&, _
     ByVal HwndParent&, _
     ByVal HMENU&, _
     ByVal hInstance&, _
     ByVal lpParam&)
Declare Function SendMessageW& Lib "user32" _
    (ByVal hwnd&, _
     ByVal uMsg&, _
     ByVal wParam&, _
     ByVal lParam&)
Declare Function GetFocus& Lib "user32" ()
Declare Function SetFocus& Lib "user32" (ByVal hwnd&)
Declare Sub MoveMemory Lib "Kernel32" Alias "RtlMoveMemory" _
    (pDest As Any, _
     pSrc As Any, _
     ByVal cbLen&)
Declare Function SysAllocString& Lib "Oleaut32" (ByVal ptr&)
Declare Function GetSysColor Lib "user32" _ 
    (ByVal nIndex As Long) As Long
Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" _
    (ByVal H As Long, _
     ByVal W As Long, _
     ByVal E As Long, _
     ByVal o As Long, _
     ByVal W As Long, _
     ByVal i As Long, _
     ByVal u As Long, _
     ByVal S As Long, _
     ByVal C As Long, _
     ByVal OP As Long, _
     ByVal CP As Long, _
     ByVal Q As Long, _
     ByVal PAF As Long, _
     ByVal F As String) As Long

Type LVCOLUMN
    mask        As Long
    fmt         As Long
    cx          As Long
    pszText     As Long
    cchTextMax  As Long
    iSubItem    As Long
    iImage      As Long
    buf(3)      As Long
End Type
Type LVITEM
    mask        As Long
    iItem       As Long
    iSubItem    As Long
    state       As Long
    stateMask   As Long
    pszText     As Long
    cchTextMax  As Long
    buf(7)      As Long
End Type
Type NMITEMACTIVATE
    hdr(2)      As Long
    iItem       As Long
    iSubItem    As Long
    buf(6)      As Long
End Type
Type NMLISTVIEW
    hrd(2)      As Long
    iItem       As Long
    iSubItem    As Long
    buf(4)      As Long
End Type
Type TT
    hParent As Long
    hChild As Long
    pfn As Long
End Type

Public TT As TT, acc As IAccessible
Public Function Redirect&(ByVal hwnd&, _ 
                          ByVal uMsg&, _ 
                          ByVal wParam&, _
                          ByVal lParam&, _ 
                          ByVal id&, _ 
                          ByVal lv As ListView)
    Redirect = lv.WndProc(hwnd, uMsg, wParam, lParam)
End Function
      

Dim fr As IControl

Event ItemSelected(ByVal iItem&, ByVal iSubItem&)
Event ItemClick(ByVal iItem&, ByVal iSubItem&)
'Event ItemDClick(ByVal iItem&, ByVal iSubItem&)

Public Sub Init(ByVal Ctl As IOptionFrame)
    Dim p&, i&, j&, mWS&
    Dim ii&(1)
    Dim wd&, ht&
    Dim flbkColor As Long
    Dim fnt As Long
    Dim buf As Long
    
    If TT.hParent Then Exit Sub
    Set fr = Ctl
    TT.hParent = fr.[_GethWnd]
    If TT.hParent = 0 Then
        Err.Raise 91
    End If
    
    Set acc = fr
    acc.accLocation 0, 0, wd, ht
    
    ii(0) = 8
    ii(1) = 1   'ICC_LISTVIEW_CLASSES
    InitCommonControlsEx VarPtr(ii(0))
    
    With TT
        .pfn = GetPtr(AddressOf Redirect)
        SetWindowSubclass .hParent, .pfn, .hParent, ObjPtr(Me)
        
        'コモンコントロールのウィンドウスタイル
        mWS = WS_CHILD Or WS_VISIBLE Or WS_CLIPSIBLINGS
        mWS = mWS Or &O1 Or LVS_SHOWSELALWAYS
        'LVS_REPORT→&01　LVS_LIST→&03
       
        .hChild = CreateWindowExW(WS_EX_CLIENTEDGE, _
                            StrPtr("SysListView32"), 0, mWS, _
                            0, 0, wd, ht, .hParent, 0, 0, 0)
        SetWindowSubclass .hChild, .pfn, .hChild, ObjPtr(Me)
                                    
        '拡張スタイル
        mWS = LVS_EX_GRIDLINES Or LVS_EX_CHECKBOXES Or _ 
              LVS_EX_FULLROWSELECT
'        LVS_EX_FULLROWSELECT→1行選択
'        LVS_EX_GRIDLINES→グリッドライン
'        LVS_EX_CHECKBOXES →ChekBox付き

        SendMessageW .hChild, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, mWS
       '------/text color/----------
'       flbkColor = GetSysColor(vbButtonFace And &HFF)
'       SendMessageW .hChild, LVM_SETTEXTBKCOLOR, 0, flbkColor
'       SendMessageW .hChild, LVM_SETBKCOLOR, 0, flbkColor
'       SendMessageW .hChild, LVM_SETTEXTCOLOR, 0, RGB(255, 0, 0)
       '------/text font/----------
       fnt = CreateFont(16, _
                         FW_NORMAL, _
                         0, _
                         0, _
                         0, _
                         False, _
                         False, _
                         False, _
                         DEFAULT_CHARSET, _
                         OUT_DEFAULT_PRECIS, _
                         CLIP_DEFAULT_PRECIS, _
                         DEFAULT_QUALITY, _
                         DEFAULT_PITCH, _
                         "MS UI Gothic")

'            int nHeight,               '// フォントの高さ
'            int nWidth,                '// 平均文字幅
'            int nEscapement,           '// 文字送り方向の角度
'            int nOrientation,          '// ベースラインの角度
'            int fnWeight,              '// フォントの太さ
'            DWORD fdwItalic,           '// 斜体にするかどうか
'            DWORD fdwUnderline,        '// 下線を付けるかどうか
'            DWORD fdwStrikeOut,        '// 取り消し線を付けるかどうか
'            DWORD fdwCharSet,          '// 文字セットの識別子
'            DWORD fdwOutputPrecision,  '// 出力精度
'            DWORD fdwClipPrecision,    '// クリッピング精度
'            DWORD fdwQuality,          '// 出力品質
'            DWORD fdwPitchAndFamily,   '// ピッチとファミリ
'            LPCTSTR lpszFace           '// フォント名
        SendMessageW .hChild, WM_SETFONT, fnt, ByVal 1&
    End With
End Sub

Public Function InsertColumn&(Title As String, ByVal iCol&, _ 
                              ByVal Width&)
    Dim lvc As LVCOLUMN
    With lvc
        .mask = LVCF_TEXT Or LVCF_WIDTH Or LVCF_SUBITEM
        .cx = Width
        .pszText = StrPtr(Title)
    End With
    With TT
        If .hChild = 0 Then Exit Function
        InsertColumn = SendMessageW(.hChild, LVM_INSERTCOLUMN, iCol, _ 
                       VarPtr(lvc))
    End With
End Function

Public Function InsertItem&(sItem As String, ByVal iItem&)
    Dim lvi As LVITEM
    With lvi
        .mask = LVIF_TEXT
        .iItem = iItem
        .pszText = StrPtr(sItem)
    End With
    With TT
        If .hChild = 0 Then Exit Function
        InsertItem = SendMessageW(.hChild, LVM_INSERTITEM, 0, _ 
                                  VarPtr(lvi))
    End With
End Function

Public Function SetItem(sItem As String, ByVal iItem&, ByVal iSubItem&)
    Dim lvi As LVITEM
    With lvi
        .mask = LVIF_TEXT
        .iItem = iItem
        .iSubItem = iSubItem
        .pszText = StrPtr(sItem)
    End With
    With TT
        If .hChild = 0 Then Exit Function
        SetItem = SendMessageW(.hChild, LVM_SETITEM, 0, VarPtr(lvi))
    End With
End Function

Public Function DeleteAllItems()
    DeleteAllItems = SendMessageW(TT.hChild, &H1009, 0, 0)
End Function

Public Function GetItemCount()
'    Dim Cnt As Integer
'    Cnt = SendMessageW(TT.hChild, &H1004, 0, 0)
    GetItemCount = SendMessageW(TT.hChild, &H1004, 0, 0)
End Function

Public Function LabelText(ByVal iItem&, ByVal iSubItem&) As String
    Dim lv As LVITEM
    Dim buf(255) As Integer
    
    With lv
        .cchTextMax = 256
        .iSubItem = iSubItem
        .pszText = VarPtr(buf(0))
    End With
    SendMessageW TT.hChild, LVM_GETITEMTEXT, iItem, VarPtr(lv)
    With lv
        If .pszText = 0 Then Exit Function
        MoveMemory ByVal VarPtr(LabelText), SysAllocString(.pszText), 4
    End With
End Function

Public Function GetCheckState(ByVal ii As Long) As Boolean
    ' チェック状態を取得（ii = インデックス）...
    ' LVM_GETITEMSTATE...
    ii = SendMessageW(TT.hChild, &H102C, ii, &H1000&)
    GetCheckState = ii  '= 0
End Function

Public Function SetCheckState(ByVal ii As Long, ByVal F As Boolean)
    ' チェック状態をセット（ii = インデックス)
    ' iiが「-1」の時は全ての項目が対象
    Dim buf As LVITEM
    With buf
        .stateMask = &HF000&    'LVIS_STATEIMAGEMASK
        .state = &H1000&
        If F Then .state = &H2000&
    End With
    ' LVM_SETITEMSTATE
    SendMessageW TT.hChild, &H102B, ii, VarPtr(buf)
End Function

Friend Function WndProc&(ByVal hwnd&, _ 
                         ByVal uMsg&, _ 
                         ByVal wParam&, _ 
                         ByVal lParam&)
    Dim iCode As Long
    Dim lvi As LVITEM
    Dim nlv As NMLISTVIEW
    Dim nia As NMITEMACTIVATE  ' ←追加

    If hwnd = TT.hParent Then
        Select Case uMsg
        
        Case WM_SETFOCUS
            SetFocus TT.hChild
            Exit Function

        Case WM_NOTIFY
            MoveMemory iCode, ByVal lParam + 8, 4
            Select Case iCode
                    
            Case LVN_ITEMCHANGED 'ItemSelected
                MoveMemory nlv, ByVal lParam, LenB(nlv)
                RaiseEvent ItemSelected(nlv.iItem, nlv.iSubItem)
                Exit Function
                
            Case NM_CLICK 'ItemClick
                MoveMemory nia, ByVal lParam, LenB(nia)
                RaiseEvent ItemClick(nia.iItem, nia.iSubItem)
                Exit Function
'
'            Case NM_DBLCLK
'                MoveMemory nia, ByVal lParam, LenB(nia)
'                RaiseEvent ItemClick(nia.iItem, nia.iSubItem)
'                Exit Function
            
            'Case いろいろ...
            '      :
            '      :
            End Select
        End Select
    Else
        Select Case uMsg

        Case WM_MOUSEACTIVATE
            If GetFocus() <> hwnd Then
                acc.accSelect 1&
                WndProc = MA_NOACTIVATE
                Exit Function
            End If

        Case WM_NCDESTROY
            RemoveSubClass
            Exit Function
       '----------------------------
        Case WM_KEYDOWN
            Select Case wParam
                Case VK_RETURN
                   Exit Function
                Case VK_UP, VK_DOWN
                   WndProc = DefSubclassProc(hwnd, uMsg, wParam, lParam)
                   Exit Function
            End Select
            Exit Function
       '-----------------------------
        End Select
    End If
    WndProc = DefSubclassProc(hwnd, uMsg, wParam, lParam)
End Function

Private Function GetPtr&(ByVal ptr&)
    GetPtr = ptr
End Function

Private Sub RemoveSubClass()
    With TT
        If .hChild Then
            RemoveWindowSubclass .hChild, .pfn, .hChild
            .hChild = 0
        End If
        
        If .hParent Then
            RemoveWindowSubclass .hParent, .pfn, .hParent
            .hParent = 0
        End If
    End With
End Sub

Private Sub Class_Terminate()
    RemoveSubClass
End Sub
      

Option Explicit
Private WithEvents LView As ListView

Private Sub UserForm_Initialize()
    Dim i As Long
    Dim Item1 As String
    Dim Item2 As String
    Dim Item3 As String
    '-------------------
    Frame1.Height = 170
    Frame1.Width = 225
    '-------------------

    Set LView = New ListView
    LView.Init Frame1
    SendMessageW TT.hChild, LVM_SETTEXTCOLOR, 0, RGB(0, 0, 0)    '[黒]
'    SendMessageW TT.hChild, LVM_SETTEXTCOLOR, 0, RGB(0, 0, 255)  '[青]

    With LView
        'Hheader
        .InsertColumn "Item", 0, 70
        .InsertColumn "subItem1", 1, 110
        .InsertColumn "subItem2", 2, 110
        'Item
        For i = 0 To 10
            Item1 = "Item" & i
            Item2 = "subItem1-" & i
            Item3 = "subItem2-" & i
            
            .InsertItem Item1, i
            .SetItem Item2, i, 1
            .SetItem Item3, i, 2
            'アイテムにチェックを入れる
           .SetCheckState i, 1
        Next
    End With
End Sub

Private Sub LView_ItemClick(ByVal iItem&, ByVal iSubItem&)  
    TextBox1.Text = iItem
    TextBox2.Text = LView.LabelText(iItem, 2) 'iSubItem or 1 ~2

    If iItem <> -1 Then
        If LView.GetCheckState(iItem) Then
            LView.SetCheckState iItem, 1
        Else
            LView.SetCheckState iItem, 0
        End If
    End If
End Sub

Private Sub LView_ItemSelected(ByVal iItem&, ByVal iSubItem&)
    TextBox1.Text = iItem
    TextBox2.Text = LView.LabelText(iItem, 2) 'iSubItem or 1 ~2
End Sub

Private Sub CommandButton1_Click()
    Dim i As Long
    Dim Item1 As String
    Dim Item2 As String
    Dim Item3 As String
    
    With LView
        'Item
        For i = 0 To 10
            Item1 = "Item" & i
            Item2 = "subItem1-" & i
            Item3 = "subItem2-" & i
            
            .InsertItem Item1, i
            .SetItem Item2, i, 1
            .SetItem Item3, i, 2
            'アイテムにチェックを入れる
            .SetCheckState i, 1
        Next
    End With
End Sub

Private Sub CommandButton2_Click()
    LView.DeleteAllItems
End Sub

Private Sub CommandButton3_Click()
    MsgBox LView.GetItemCount
End Sub

Private Sub CommandButton4_Click()
    UserForm1.Hide
    Unload Me
End Sub

Private Sub CommandButton5_Click()
    Dim i As Long
    Dim cnt As Long
    cnt = LView.GetItemCount
    With LView
        For i = 0 To cnt
           If LView.GetCheckState(i) = False Then
               Debug.Print LView.LabelText(i, 0)
           End If
        Next
    End With
End Sub
      

（2）Subclass Treeview

ツリービューのコードは、私の知識では不可能なので、ネット検索したものを紹介します。
動作確認をしましたが、動作的には宜しいかと思います。

ただフォームに多くのチェックボタンが有り、実用に組み込むには、
そのプロパティ設定をそぎ落とし、ソースコードに盛り込んでの利用がベターと思います。
どなたか、加工してみては如何でしょうか。
又その結果をお知らせ頂ければ、この場で公開したいと思います。

JKP An MSForms (all VBA) treeview

※ダウンロードファイル:Download the treeview sample Excel workbook (including documentation)

---

その後の情報ですが、
ツリービューのコードを自分なりに加工してみました。
元々表示する事が目的でしたが、元コードには
貴重なツールが有り十分に活用する事が出来ます。
これも作成者ＪＫＰ氏に深く感謝致します。

この加工編集ブックが著作権に侵害しないとの認識の上で、
ブックを公開致します。（Form画像参照）
利用者のサポートツールになれば幸いです。

※ダウンロードファイル   TreeView.zip TreeView(64bit).zip

私事ですが、ＪＫＰ氏のコードで発見したこと
・条件付きコンパイル
・エラー発生時の行番号を表示

© 2014-2015 shin2.