Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 adb4167de94b70f3…

MALICIOUS

Office (OOXML)

920.0 KB Created: 2021-02-16 18:15:00 UTC Authoring application: Microsoft Office Word 16.0000 First seen: 2021-04-10
MD5: 137d9e34d22a32830f5e7d0e00b748dd SHA-1: 419053af95c268bcccf014ae7647f7ad47225469 SHA-256: adb4167de94b70f3bb8de3c3f339a63eb73adc579c2cec2ff92a0f3cbed1e61c
326 Risk Score

Heuristics 11

  • VBA project inside OOXML medium 8 related findings OOXML_VBA
    Document contains a VBA project — VBA macros present
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
      m_varAppID = Shell("NOTEPAD.EXE " & m_strFileName, vbNormalFocus)
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
      Set oWS = CreateObject("WScript.Shell")
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
                 "CreateField|CreateGroup|CreateIndex|CreateObject|CreateProperty|CreateRelation|CreateTableDef|CreateUser|CreateWorkspace|CURRENCY|" & _
  • GetObject call high OLE_VBA_GETOBJ
    GetObject call
    Matched line in script
                 "EXISTS|Exit|FALSE|Field|Fields|FillCache|FLOAT|FLOAT4|FLOAT8|FOREIGN|Form|Forms|FROM|Full|FUNCTION|GENERAL|GetObject|GetOption|" & _
  • CallByName call high OLE_VBA_CALLBYNAME
    CallByName call
    Matched line in script
      CallByName fcnParentForm(oEventCtrl), ValidationProcedure, VbMethod, oEventCtrl
  • VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXEC
    Triggers on the COMBINATION of two tokens co-occurring in the same compiled VBA/cache stream: an auto-execution entry point (Auto_Open / AutoOpen / Document_Open / Workbook_Open / Auto_Close / AutoClose) AND a shell/download/object-execution token (Shell, CreateObject, GetObject, PowerShell, cmd.exe, URLDownloadToFile, WinHttp, XMLHTTP, ADODB.Stream, ShellExecute, ExecuteExcel4Macro). Neither token alone fires it — it is the pairing that flags p-code-only or source-extraction-failure macro documents where the visible VBA source is unavailable. The matched tokens are named in the detail line below.
  • AutoOpen macro low OLE_VBA_AUTOOPEN
    AutoOpen macro
    Matched line in script
    Sub AutoOpen()
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
      Kill Environ("TEMP") & "\XMLMapping.txt"
  • External hyperlinks (1) low OOXML_EXTERNAL_HYPERLINKS
    Document contains 1 external hyperlink — clickable URLs are stored as external relationships. First target: http://gregmaxey.mvps.org/word_tip_pages/installing_employing_macros.html
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://www.jkp-ads.com In document text (OOXML body / shared strings)
    • http://Greg_Maxey/CC_Mapping_PartIn document text (OOXML body / shared strings)
    • http://www.gmayor.com/Address_Book.htmIn document text (OOXML body / shared strings)
    • http://NameSpace1In document text (OOXML body / shared strings)
    • http://NameSpace2In document text (OOXML body / shared strings)
    • http://gregmaxey.comIn document text (OOXML body / shared strings)
    • http://gregmaxey.com/word_tips.htmlIn document text (OOXML body / shared strings)
    • https://www.gmayor.com/replace_using_wildcards.htmIn document text (OOXML body / shared strings)
    • http://www.wordarticles.com/Articles/Colors/2007.php#SettingColorsIn document text (OOXML body / shared strings)
    • https://www.gmayor.com/replace_using_wildcards.htm9In document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingCanvasIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2014/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2015/9/8/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2015/10/21/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/5/9/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/5/10/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/5/11/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/5/12/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/5/13/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/5/14/chartexIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/markup-compatibility/2006In document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/inkIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2017/model3dIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/officeDocument/2006/relationshipsIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/officeDocument/2006/mathIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingDrawingIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawingIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/wordprocessingml/2006/mainIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordmlIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2012/wordmlIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2018/wordml/cexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2016/wordml/cidIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2018/wordmlIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2015/wordml/symexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingGroupIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingInkIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2006/wordmlIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingShapeIn document text (OOXML body / shared strings)
    • http://gregmaxey.mvps.org/word_tip_pages/installing_employing_macros.htmlDocument hyperlink
    • http://schemas.microsoft.com/office/2009/07/customuiIn document text (OOXML body / shared strings)
    • http://gregmaxey.mvps.org/word_tip_pages/content_control_tools.htmlIn document text (OOXML body / shared strings)
    • https://www.paypal.com/cgi-bin/webscr?cmd=_s-xclick&hosted_button_id=HMGYMYSGL4WD4In document text (OOXML body / shared strings)
    • https://www.paypal.com/cgi-bin/webscr?cmd=_s-xclick&hosted_button_id=776KL2DPCD4JNIn document text (OOXML body / shared strings)
    • https://www.paypal.com/cgi-bin/webscr?cmd=_s-xclick&hosted_button_id=Z9Y7VQAJ7WNC8In document text (OOXML body / shared strings)
    • http://gregmaxey.mvps.org/word_tip_pages/content_control_fillin_form.htmlIn document text (OOXML body / shared strings)
    • http://strugglingtoexcel.wordpress.com/In document text (OOXML body / shared strings)
    • https://sysmod.wordpress.com/2011/11/24/dictionary-vba-class-update/In document text (OOXML body / shared strings)

Extracted artifacts 2

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source from OOXML) 671417 bytes
SHA-256: 28533ab34340368982482ff3e47565f7c1329763e23cf3c53cf2a6083fc1f563
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "0{00020906-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "clsNode"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
'Build 024
'***************************************************************************
'
' Authors:  JKP Application Development Services, info@jkp-ads.com, http://www.jkp-ads.com
'           Peter Thornton, pmbthornton@gmail.com
'
' (c)2013, all rights reserved to the authors
'
' You are free to use and adapt the code in these modules for
' your own purposes and to distribute as part of your overall project.
' However all headers and copyright notices should remain intact
'
' You may not publish the code in these modules, for example on a web site,
' without the explicit consent of the authors
'***************************************************************************

'-------------------------------------------------------------------------
' Module    : clsNode
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (www.jkp-ads.com)
' Created   : 15-01-2013
' Purpose   : Holds all information of a node of the tree
'-------------------------------------------------------------------------
Option Explicit

Private mbExpanded As Boolean

Private mcolChildNodes As Collection

Private moParentNode As clsNode
Private moLastActiveNode As clsNode
Private moTree As clsTreeView

Private msKey As String
Private mvCaption

Private mlChecked As Long        ' PT checkbox tristate boolean 0/-1 or 1 for null
'Private mbVisible As Boolean        ' PT determines if the node can be displayed
Private mnIndex As Long             ' PT order added to Treeview's mcolNodes, won't change
Private mlVisIndex As Long          ' PT the visible order in the current view, changes with expand/collapse
Private mvIconMainKey               ' PT string name or numeric index as icon Key for the Image collection
Private mvIconExpandedKey           ' PT ditto for expanded icon
Private mlIconCnt As Long           ' PT number of icons availabel for this node 0, 1 or 2
Private msngTextWidth As Single     ' PT autosized text width before the node is widened beyond the frame
Private mlBackColor As Long         ' PT
Private mbBold As Boolean           ' PT
Private mlForeColor As Long         ' PT
Private mvTag

Public WithEvents mctlControl As MSForms.Label 'Private WithEvents mctlControl As MSForms.label
Attribute mctlControl.VB_VarHelpID = -1
Private WithEvents mctlExpander As MSForms.Label
Attribute mctlExpander.VB_VarHelpID = -1
Private WithEvents moEditBox As MSForms.TextBox     ' PT editbox
Attribute moEditBox.VB_VarHelpID = -1
Private WithEvents mctlCheckBox As MSForms.Label    ' PT checkbox
Attribute mctlCheckBox.VB_VarHelpID = -1

Private mctlExpanderBox As MSForms.Label
Private mctlVLine As MSForms.Label  ' PT vertical line, only the first child node with children will have a vertical line
Private mctlHLine As MSForms.Label  ' PT horizontal line
Private mctlIcon As MSForms.image   ' PT separate icon image control

Public Enum ndSortOrder
    ndAscending = 1
    ndDescending = 2
End Enum
Public Enum ndCompareMethod
    ndBinaryCompare = 0
    ndTextCompare = 1
End Enum
Public Enum ndMouse
    ndDown = 1
    ndUp = 2
    ndMove = 3
    ndBeforeDragOver = 4
    ndBeforeDropOrPaste = 5
End Enum

#If Mac Then
    Const mcFullWidth As Long = 800
#Else
    Const mcFullWidth As Long = 600
#End If


'*********************
'* Public Properties *
'*********************

Public Property Get BackColor() As Long

    BackColor = mlBackColor ' if zero the treecaller will apply the frame container's backcolor

End Property

Public Property Let BackColor(lColor As Long)
'PT if lColor is written as 0/black, change it to 1 as 0 means default
    mlBackColor = lColor
    If mlBackColor = 0 Then mlBackColor = 1
    If Not mctlControl Is Nothing Then
        mctlControl.BackColor = lColor
    End If
End Property

Public Property Get Bold() As Boolean
    Bold = mbBold
End Property

Public Property Let Bold(bBold As Boolean)
    mbBold = bBold
    If Not mctlControl Is Nothing Then
        mctlControl.Font.Bold = mbBold
    End If
End Property

Public Property Get Caption()
    Caption = mvCaption
End Property

Public Property Let Caption(ByVal vCaption)
    mvCaption = vCaption
    If Not mctlControl Is Nothing Then
        mctlControl.Caption = CStr(vCaption)
    End If
End Property

Public Property Get Child() As clsNode
' PT Returns a reference to the first Child node, if any
    On Error Resume Next
    Set Child = mcolChildNodes(1)
End Property

Public Property Get Checked()    ' PT
     ' Checked values are -1 true, 0 false, +1 mixed
     ' If TriState is enabled be careful not to return a potential +1 to a boolean or it'll coerce to True
    Checked = mlChecked
End Property

Public Property Let Checked(vChecked)  ' PT
    Dim bFlag As Boolean, bTriState As Boolean
    Dim lChecked As Long
    Dim cChild As clsNode

    ' Checked values are -1 true, 0 false, +1 mixed
    ' if vChecked is a boolean Checked will coerce to -1 or 0
    ' if vChecked is Null Checked is set as +1

    If VarType(vChecked) = vbBoolean Then
        lChecked = vChecked
    ElseIf IsNull(vChecked) Then
        lChecked = 1
    ElseIf vChecked >= -1 And vChecked <= 1 Then
        lChecked = vChecked
    End If

    bFlag = lChecked <> mlChecked
    mlChecked = lChecked

    If Not mctlCheckBox Is Nothing And bFlag Then
        moTree.Changed = True
        UpdateCheckbox
    End If
    
    If Not moTree Is Nothing Then    ' eg during clone
        bFlag = moTree.CheckBoxes(bTriState)
        If bTriState Then
            If ParentNode.Caption <> "RootHolder" Then
                ParentNode.CheckTriStateParent
            End If
            
            If Not ChildNodes Is Nothing Then
                For Each cChild In ChildNodes
                    cChild.CheckTriStateChildren mlChecked
                Next
            End If
        End If
    End If
    
End Property

Public Property Get ChildNodes() As Collection
    Set ChildNodes = mcolChildNodes
End Property

Public Property Set ChildNodes(colChildNodes As Collection)
    Set mcolChildNodes = colChildNodes
End Property

Public Property Get Expanded() As Boolean
    Expanded = mbExpanded
End Property

Public Property Let Expanded(ByVal bExpanded As Boolean)
    mbExpanded = bExpanded
    If Not Me.Expander Is Nothing Then
        UpdateExpanded bControlOnly:=False
    ElseIf Not Me.Control Is Nothing Then
        UpdateExpanded bControlOnly:=True
    End If
End Property

Public Property Get ForeColor() As Long
    ForeColor = mlForeColor
End Property

Public Property Let ForeColor(lColor As Long)
'PT if lColor is written as 0/black, change it to 1 as 0 means default
    mlForeColor = lColor
    If mlForeColor = 0 Then mlForeColor = 1
    If Not mctlControl Is Nothing Then
        mctlControl.ForeColor = lColor
    End If
End Property

Public Property Get FirstSibling() As clsNode
    If Not moParentNode Is Nothing Then    ' PT Root has no parent
        Set FirstSibling = moParentNode.GetChild(1)
    End If
End Property

Public Property Get LastSibling() As clsNode
    If Not moParentNode Is Nothing Then    ' PT Root has no parent
        Set LastSibling = moParentNode.GetChild(-1)    ' -1 flags GetChild to return the last Child
    End If
End Property

Public Property Get ImageExpanded()
' PT string name or numeric index for the main icon key
    ImageExpanded = mvIconExpandedKey
End Property

Public Property Let ImageExpanded(vImageExpanded)
' PT string name or numeric index for an expanded icon key
    On Error GoTo errExit
    If Not IsMissing(vImageExpanded) Then
        If Not IsEmpty(vImageExpanded) Then
            If Len(mvIconMainKey) = 0 Then
                mvIconMainKey = vImageExpanded
            End If
            mvIconExpandedKey = vImageExpanded
            mlIconCnt = 2
        End If
    End If
errExit:
End Property

Public Property Get ImageMain()
' PT string name or numeric index for the main icon key
    ImageMain = mvIconMainKey
End Property

Public Property Let ImageMain(vImageMain)
' PT string name or numeric index for the main icon key
    On Error GoTo errExit
    If Not IsMissing(vImageMain) Then
        If Not IsEmpty(vImageMain) Then
            mvIconMainKey = vImageMain
            If mlIconCnt = 0 Then mlIconCnt = 1
        End If
    End If
errExit:
End Property

Public Property Get Key() As String
    Key = msKey
End Property

Public Property Let Key(ByVal sKey As String)
    Dim bIsInMainCol As Boolean
    Dim i As Long
    Dim cTmp As clsNode

    On Error GoTo ErrH

    If Tree Is Nothing Then
        msKey = sKey
        Exit Property
    ElseIf msKey = sKey Or Len(sKey) = 0 Then
        Exit Property
    End If

    On Error Resume Next
    Set cTmp = Tree.Nodes.Item(sKey)
    On Error GoTo ErrH

    If Not cTmp Is Nothing Then
        Err.Raise 457    ' standard duplicate key error
    End If

    ' to change the Key, remove Me and add Me back where it was with the new key
    For Each cTmp In Tree.Nodes
        i = i + 1
        If cTmp Is Me Then
            bIsInMainCol = True
            Exit For
        End If
    Next

    If bIsInMainCol Then
        With Tree.Nodes
            .Remove i
            If .Count Then
                .add Me, sKey, i
            Else
                .add Me
            End If
        End With
    Else
        ' Let Key  called by via move/copy
    End If

    msKey = sKey

    Exit Property
ErrH:
    Err.Raise Err.Number, "Let Key", Err.Description
End Property

Public Property Get Level() As Long
    Dim lLevel As Long
    Dim cNode As clsNode

    On Error GoTo ErrH
    lLevel = -1
    Set cNode = Me.ParentNode
    While Not cNode Is Nothing
        lLevel = lLevel + 1
        Set cNode = cNode.ParentNode
    Wend
    Level = lLevel
    Exit Property
ErrH:
    #If DebugMode = 1 Then
        Stop
        Resume
    #End If
End Property

Public Property Get NextNode() As clsNode    ' can't name this proc 'Next' in VBA
' PT return the next sibling if there is one
    Dim i As Long
    Dim cNode As clsNode

    With Me.ParentNode
        For Each cNode In .ChildNodes
            i = i + 1
            If cNode Is Me Then
                Exit For
            End If
        Next
        If .ChildNodes.Count > i Then
            Set NextNode = .ChildNodes(i + 1)
        End If
    End With
End Property

Public Property Get ParentNode() As clsNode
    Set ParentNode = moParentNode
End Property

Public Property Set ParentNode(oParentNode As clsNode)
    Set moParentNode = oParentNode
End Property

Public Property Get Previous() As clsNode
' PT return the previous sibling if there is one
    Dim i As Long
    Dim cNode As clsNode

    With Me.ParentNode
        For Each cNode In Me.ParentNode.ChildNodes
            i = i + 1
            If cNode Is Me Then
                Exit For
            End If
        Next
        If i > 1 Then
            Set NextNode = .ChildNodes(i - 1)
        End If
    End With
End Property

Public Property Get Root() As clsNode
    Dim cTmp As clsNode
    Set cTmp = Me
    Do While Not cTmp.ParentNode.ParentNode Is Nothing
        Set cTmp = cTmp.ParentNode
    Loop
    Set Root = cTmp
End Property

Public Property Get Tag()
  Tag = mvTag
End Property

Public Property Let Tag(vTag)
    mvTag = vTag
End Property


'*****************************
'* Public subs and functions *
'*****************************

Public Function Sort(Optional ByVal ndOrder As ndSortOrder = ndAscending, _
                     Optional ByVal ndCompare As ndCompareMethod = ndTextCompare) As Boolean
' PT Sorts the child nodes,
'    returns True if the order has changed to flag Refresh should be called
    Dim sCaptions() As String
    Dim lStart As Long, lLast As Long, i As Long
    Dim colNodes As New Collection
    Dim bIsUnSorted As Boolean

    On Error GoTo errExit
    lStart = 1
    lLast = ChildNodes.Count    ' error if no childnodes to sort

    If lLast = 1 Then
        ' nothing to sort
        Exit Function
    End If

    ReDim idx(lStart To lLast) As Long
    ReDim sCaptions(lStart To lLast) As String
    For i = lStart To lLast
        idx(i) = i
        sCaptions(i) = ChildNodes.Item(i).Caption
    Next

    If ndOrder <> ndAscending Then ndOrder = -1    ' descending
    If ndCompare <> ndTextCompare Then ndCompare = ndBinaryCompare

    Call BinarySortIndexText(sCaptions(), lStart, lLast, idx, ndOrder, ndCompare)

    For i = lStart To lLast - 1
        If idx(i) <> idx(i + 1) - 1 Then
            bIsUnSorted = True
            Exit For
        End If
    Next

    If bIsUnSorted Then
        For i = lStart To lLast
            colNodes.add ChildNodes(idx(i))
        Next
        Set ChildNodes = colNodes
        Sort = True
    End If

errExit:
'   Probably(?) any error was because there were no childnodes, no need to raise an error
End Function

Public Function AddChild(Optional sKey As String, _
                         Optional vCaption, _
                         Optional sTag, _
                         Optional vImageMain, _
                         Optional vImageExpanded) As clsNode
    Dim cChild As clsNode

    On Error GoTo ErrH
    Set cChild = New clsNode
    With moTree.Nodes
        If Len(sKey) Then
100         .add cChild ', sKey GKM-Can't use key for an XMLPart mapping.
101
            cChild.Key = sKey
        Else
            .add cChild
        End If

        cChild.Index = .Count
    End With

    If mcolChildNodes Is Nothing Then
        Set mcolChildNodes = New Collection
    End If

    mcolChildNodes.add cChild

    With cChild
        If Not IsMissing(vImageMain) Then
            If Len(vImageMain) Then
                .ImageMain = vImageMain
            End If
        End If

        If Not IsMissing(vImageExpanded) Then
            If Len(vImageExpanded) Then
                .ImageExpanded = vImageExpanded
            End If
        End If

        .Caption = vCaption
        .Tag = sTag
        Set .Tree = moTree
        Set .ParentNode = Me
    End With

    Set AddChild = cChild

    Exit Function
ErrH:
    #If DebugMode = 1 Then
        Stop
        Resume
    #End If

    If Erl = 100 And Err.Number = 457 Then
        Err.Raise vbObjectError + 1, "clsNode.AddChild", "Duplicate key: '" & sKey & "'"
    Else
        Err.Raise Err.Number, "clsNode.AddChild", Err.Description
    End If
End Function

Public Function ChildIndex(sKey As String) As Long
'-------------------------------------------------------------------------
' Procedure : ChildIndex
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (www.jkp-ads.com)
' Created   : 15-01-2013
' Purpose   : Returns the index of a childnode using its key
'-------------------------------------------------------------------------
    Dim cNode As clsNode
    Dim lCt As Long
    For Each cNode In mcolChildNodes
        lCt = lCt + 1
        If sKey = cNode.Key Then
            ChildIndex = lCt
            Set cNode = Nothing
            Exit Function
        End If
    Next
    Set cNode = Nothing
End Function

Public Function FullPath() As String
' PT, get all the grand/parent keys
' assumes use of key

    Dim S As String
    Dim cNode As clsNode

    On Error GoTo errDone
    S = Me.Key
    Set cNode = Me

    While Err.Number = 0
        Set cNode = cNode.ParentNode
        S = cNode.Key & "\" & S
    Wend

errDone:
    FullPath = S
End Function

Public Function GetChild(vKey As Variant) As clsNode
'-------------------------------------------------------------------------
' Procedure : GetChild
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (www.jkp-ads.com)
' Created   : 15-01-2013
' Purpose   : Returns a childnode using its key
'-------------------------------------------------------------------------
    Dim cNode As clsNode
    Dim lIdx As Long

    If VarType(vKey) = vbString Then

        For Each cNode In mcolChildNodes
            If vKey = cNode.Key Then
                Set GetChild = cNode
                Set cNode = Nothing
                Exit Function
            End If
        Next

    ElseIf Not mcolChildNodes Is Nothing Then
        lIdx = vKey
        If lIdx = -1 Then
            lIdx = mcolChildNodes.Count
        End If
        If lIdx > 0 Then
            Set GetChild = mcolChildNodes(lIdx)
        Else: Set mcolChildNodes = Nothing
        End If
    End If

    Set cNode = Nothing
End Function


'*************************************************************************
'*    Friend Properties, Subs & Funtions                                 *
'*    ** these procedures are visible throughout the project but should  *
'*    ** only be used to communicate with the TreeView, ie clsTreeView   *
'*************************************************************************



'' PT new properties in 006PT2:
'' Created, CreatedButton, Checked, CheckBoxName, Index, VisIndex
''

Friend Property Get Control() As MSForms.Label
    Set Control = mctlControl
End Property

Friend Property Set Control(ctlControl As MSForms.Label)
    Set mctlControl = ctlControl
    If Not mctlControl Is Nothing Then
        If Not moTree Is Nothing Then
            Set mctlControl.Font = moTree.TreeControl.Font
        Else
            Stop
        End If
    End If
End Property

Friend Property Get Index() As Long    ' PT
    Index = mnIndex
End Property

Friend Property Let Index(idx As Long)
' PT Index: the order this node was added to Treeview's collection mcolNodes
'    Index will never increase but may decrement if previously added nodes are removed
    mnIndex = idx
End Property

Friend Property Let VisIndex(lVisIndex As Long)
    mlVisIndex = lVisIndex
End Property

Friend Property Get VisIndex() As Long    ' PT
    VisIndex = mlVisIndex
End Property

Friend Property Get Tree() As clsTreeView
    Set Tree = moTree
End Property

Friend Property Set Tree(oTree As clsTreeView)
    Set moTree = oTree
End Property

Friend Property Get Checkbox() As MSForms.Control
    Set Checkbox = mctlCheckBox
End Property

Friend Property Set Checkbox(oCtl As MSForms.Control)
    Set mctlCheckBox = oCtl
End Property

Friend Property Get Expander() As MSForms.Label
    Set Expander = mctlExpander
End Property

Friend Property Set Expander(ctlExpander As MSForms.Label)
    Set mctlExpander = ctlExpander
End Property

Friend Property Get ExpanderBox() As MSForms.Label
    Set ExpanderBox = mctlExpanderBox
End Property

Friend Property Set ExpanderBox(ctlExpanderBox As MSForms.Label)
    Set mctlExpanderBox = ctlExpanderBox
End Property

Friend Property Set HLine(ctlHLine As MSForms.Label)
    Set mctlHLine = ctlHLine
End Property

Friend Property Get HLine() As MSForms.Label
    Set HLine = mctlHLine
End Property

Friend Property Set Icon(ctlIcon As MSForms.image)
    Set mctlIcon = ctlIcon
End Property

Friend Property Get Icon() As MSForms.image
    Set Icon = mctlIcon
End Property

Friend Property Get TextWidth() As Single
    TextWidth = msngTextWidth
End Property

Friend Property Let TextWidth(sngTextWidth As Single)
    msngTextWidth = sngTextWidth
End Property

Friend Property Get VLine() As MSForms.Label
    Set VLine = mctlVLine
End Property

Friend Property Set VLine(ctlVLine As MSForms.Label)
    Set mctlVLine = ctlVLine
End Property

Friend Sub CheckTriStateParent()
' PT set triState value of parent according to its childnodes' values
    Dim alChecked(-1 To 1) As Long
    Dim cChild As clsNode

    If Not ChildNodes Is Nothing Then
        For Each cChild In ChildNodes
            alChecked(cChild.Checked) = alChecked(cChild.Checked) + 1
        Next
        If alChecked(1) Then
            alChecked(1) = 1
        ElseIf alChecked(-1) = ChildNodes.Count Then
            alChecked(1) = -1
        ElseIf alChecked(0) = ChildNodes.Count Then
            alChecked(1) = 0
        Else
            alChecked(1) = 1
        End If
        
        If Checked <> alChecked(1) Then
            mlChecked = alChecked(1)
            UpdateCheckbox
        End If

    End If
    
    If Not Me.Caption = "RootHolder" Then
        If Not ParentNode.ParentNode Is Nothing Then
            ParentNode.CheckTriStateParent
        End If
    End If

End Sub

Friend Sub CheckTriStateChildren(lChecked As Long)
' PT, make checked values of children same as parent's
'     only called if triState is enabled
Dim cChild As clsNode

    mlChecked = lChecked
    UpdateCheckbox

    If Not ChildNodes Is Nothing Then
        For Each cChild In ChildNodes
            cChild.CheckTriStateChildren lChecked
        Next
    End If
End Sub

Friend Function hasIcon(vKey) As Boolean
' PT get the appropriate icon key/index, if any
    If mlIconCnt = 2 And mbExpanded Then
        vKey = mvIconExpandedKey
        hasIcon = True    'Not IsEmpty(vKey) '(True
    ElseIf mlIconCnt Then
        vKey = mvIconMainKey
        hasIcon = True    'Not IsEmpty(vKey)
    End If
End Function

Friend Sub EditBox(bEnterEdit As Boolean)    '  PT new in 006PT2 ,,move to clsTreView
'-------------------------------------------------------------------------
' Procedure : moCtl_Click
' Author    : Peter Thornton
' Created   : 20-01-2013
' Purpose   : Enter/exit Editmode, show/hide the edit textbox
'-------------------------------------------------------------------------
    On Error Resume Next
    Set moEditBox = moTree.TreeControl.Controls("EditBox")
    On Error GoTo 0

    If bEnterEdit Then
    
        If moEditBox Is Nothing Then
            Set moEditBox = moTree.TreeControl.Controls.add("forms.textbox.1", False)
            moEditBox.Name = "EditBox"
        End If

        With moEditBox
            .Left = Control.Left - 3
            .Top = Control.Top - 1.5
            .AutoSize = True
            .BorderStyle = fmBorderStyleSingle
            .Text = Caption
            Control.Visible = False    ' hide the node label while editing
            .ZOrder 0
            .Visible = True
            .SelStart = 0
            .SelLength = Len(.Text)
            .SetFocus
        End With

    ElseIf Not moEditBox Is Nothing Then
        ' exit editmode
        If Not moEditBox Is Nothing Then
            ' error if moEditBox has already been removed
            On Error Resume Next
            moEditBox.Visible = False
            moEditBox.Text = ""
            Set moEditBox = Nothing
        End If
        Control.Visible = True

    End If
End Sub

Friend Function RemoveChild(cNode As clsNode) As Boolean
'PT remove a node from the collection,
'   note, this is only one part of the process of removing a node

    Dim lCt As Long
    Dim cTmp As clsNode
    On Error GoTo ErrH

    For Each cTmp In mcolChildNodes
        lCt = lCt + 1
        If cTmp Is cNode Then
            mcolChildNodes.Remove lCt
            RemoveChild = True
            Exit For
        End If
    Next

    If mcolChildNodes.Count = 0 Then
        Set mcolChildNodes = Nothing
        Me.Expanded = False
    End If

    Exit Function
ErrH:
    Err.Raise vbObjectError, "RemoveChild", Err.Description
End Function

Friend Sub RemoveNodeControls()
    Dim cChild As clsNode
    If Not ChildNodes Is Nothing Then
        For Each cChild In ChildNodes
            cChild.RemoveNodeControls
        Next
    End If
    DeleteNodeControls False
End Sub

Friend Sub TerminateNode(Optional bDeleteNodeControls As Boolean)
'-------------------------------------------------------------------------
' Procedure : TerminateNode
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (www.jkp-ads.com)
' Created   : 15-01-2013
' Purpose   : Terminates the class instance
'-------------------------------------------------------------------------
    Dim cChild As clsNode
    'Instead of the Terminate event of the class we use this public
    'method so it can be explicitly called by parent classes.
    'This is done because to break the two way or circular references
    'between the parent child classes.
    
    'The most important call in this routine is to destroy the reference
    'between this node class and the parent treeview class -
    '    < Set moTree = Nothing >
    'Once all the moTree references to have been destroyed everything else will
    ' 'tear down' normally

    If Not ChildNodes Is Nothing Then
        For Each cChild In ChildNodes
            ' recursively drill down to all child nodes in this branch
            cChild.TerminateNode bDeleteNodeControls
        Next
    End If

    ' If deleting individual nodes while the treeview is running we also want to
    ' remove all associated controls as well as removing references
    
    If bDeleteNodeControls Then
        DeleteNodeControls True
        If bDeleteNodeControls Then
            Index = -1
        End If
    End If

    Set mcolChildNodes = Nothing
    Set moTree = Nothing
End Sub


'******************************
'* Private subs and functions *
'******************************

Private Sub BinarySortIndexText(sCaptions() As String, ByVal lStart As Long, ByVal lEnd As Long, ByRef idx() As Long, ndOrder As Long, ndCompare As ndCompareMethod)
' PT sorts the index array based on the string array
    Dim lSmall As Long, lLarge As Long, sMid As String, lTmp As Long

    lSmall = lStart
    lLarge = lEnd
    sMid = sCaptions(idx((lSmall + lLarge) / 2))

    Do While lSmall <= lLarge
        Do While (StrComp(sCaptions(idx(lSmall)), sMid, ndCompare) = -ndOrder And lSmall < lEnd)
            lSmall = lSmall + 1
        Loop
        Do While (StrComp(sCaptions(idx(lLarge)), sMid, ndCompare) = ndOrder And lLarge > lStart)
            lLarge = lLarge - 1
        Loop
        If lSmall <= lLarge Then
            lTmp = idx(lSmall)
            idx(lSmall) = idx(lLarge)
            idx(lLarge) = lTmp
            lSmall = lSmall + 1
            lLarge = lLarge - 1
        End If
    Loop

    If lStart <= lLarge Then
        Call BinarySortIndexText(sCaptions(), lStart, lLarge, idx, ndOrder, ndCompare)
    End If
    If lSmall <= lEnd Then
        Call BinarySortIndexText(sCaptions(), lSmall, lEnd, idx, ndOrder, ndCompare)
    End If
End Sub

Private Sub DeleteNodeControls(bClearIndex As Boolean)
'PT Delete all controls linked to this node

    On Error GoTo ErrH

    With moTree.TreeControl.Controls
        If Not mctlControl Is Nothing Then
            .Remove mctlControl.Name
            Set mctlControl = Nothing
            If Not mctlHLine Is Nothing Then
                .Remove mctlHLine.Name
                Set mctlHLine = Nothing
            End If
            If Not mctlIcon Is Nothing Then
                .Remove mctlIcon.Name
                Set mctlIcon = Nothing
            End If
            If Not mctlIcon Is Nothing Then
                .Remove mctlIcon.Name
                Set mctlIcon = Nothing
            End If
        End If

        If Not mctlExpander Is Nothing Then
            .Remove mctlExpander.Name
            Set mctlExpander = Nothing
        End If
        If Not mctlExpanderBox Is Nothing Then
            .Remove mctlExpanderBox.Name
            Set mctlExpanderBox = Nothing
        End If
        If Not mctlVLine Is Nothing Then
            .Remove mctlVLine.Name
            Set mctlVLine = Nothing
        End If


        If Not moEditBox Is Nothing Then
            .Remove moEditBox.Name
            Set moEditBox = Nothing
        End If
        If Not mctlCheckBox Is Nothing Then
            .Remove mctlCheckBox.Name
            Set mctlCheckBox = Nothing
        End If

        If Not Me.ParentNode Is Nothing Then
            ' if Me is the last child delete parent's expander and VLine (if it has one)
            If FirstSibling Is LastSibling Then

                If Not Me.ParentNode.VLine Is Nothing Then
                    .Remove Me.ParentNode.VLine.Name
                    Set Me.ParentNode.VLine = Nothing
                End If
                
                If Not Me.ParentNode.ExpanderBox Is Nothing Then
                    .Remove Me.ParentNode.ExpanderBox.Name
                    Set Me.ParentNode.ExpanderBox = Nothing
                End If

…
vbaProject_00.bin vba-project OOXML VBA project: word/vbaProject.bin 2185216 bytes
SHA-256: f190b9080265cd0649b5ceed3b96717e33e081e319b7a20be51c2df6bae0e646