BPC NW 10: VBA function to get BAS(SomeParent) dimension members list

Decided to share simple code to get base member list under some parent member. The standard EPM API function is missing for this task.

The following references are required in Tools -> References:

No special references required, EPM is assigned using late binding.

Parameters are described in the code:

Option Explicit

Public Function GetBAS(strConn As String, _
    strDim As String, strParentMember As String) As String()
'Parameters: strConn - Connection string, strDim - Dimension name,
'strParentMember - Parent member ID (case sensitive)
'if strParentMember is base member then it will be returned itself
'Result: Array of strings. If first element is "" then nothing found
'and second element - error reason

    Dim objAddIn As COMAddIn
    Dim epm As Object
    Dim AOComAdd As Object
    Dim blnEPMInstalled As Boolean
    
    Dim strDims() As String
    Dim blnExistFlag As Boolean
    Dim strProps() As String
    Dim blnFormulaExistFlag As Boolean
    Dim blnIsNotFormulaFlag As Boolean
    Dim blnIsCalcFlag As Boolean
    Dim strCalcProp As String
    Dim strParentMemberDim As String
    Dim strParentHierarchy As String
    Dim strMem() As String
    Dim strMemIDParent() As String
    Dim strMemBAS() As String
    Dim lngTemp As Long
    Dim lngBASCount As Long
    
On Error GoTo Err
    'Universal code to get FPMXLClient for standalone EPM or AO
    For Each objAddIn In Application.COMAddIns
        If objAddIn.progID = "FPMXLClient.Connect" Then
            Set epm = objAddIn.Object
            blnEPMInstalled = True
            Exit For
        ElseIf objAddIn.progID = "SapExcelAddIn" Then
            Set AOComAdd = objAddIn.Object
            Set epm = AOComAdd.GetPlugin("com.sap.epm.FPMXLClient")
            blnEPMInstalled = True
            Exit For
        End If
    Next objAddIn
    
    If Not blnEPMInstalled Then
        ReDim strMemBAS(0 To 1)
        strMemBAS(0) = ""
        strMemBAS(1) = "NO_EPM"
        GetBAS = strMemBAS
        Exit Function
    End If
    
    'Check if Dimension strDim exists
    strDims = epm.GetDimensionList(strConn)
    For lngTemp = 0 To UBound(strDims)
        If strDims(lngTemp) = strDim Then
            blnExistFlag = True
        End If
    Next lngTemp
    
    Erase strDims
    
    If Not blnExistFlag Then
        ReDim strMemBAS(0 To 1)
        strMemBAS(0) = ""
        strMemBAS(1) = "NO_DIMENSION"
        GetBAS = strMemBAS
        Exit Function
    End If
    
    'Check if Dimension strDim has one or more hierarchies and contain FORMULA property
    blnExistFlag = False
    strProps = epm.GetPropertyList(strConn, strDim)
    For lngTemp = 0 To UBound(strProps)
        If strProps(lngTemp) Like "PARENTH*" Then
            blnExistFlag = True
        ElseIf strProps(lngTemp) = "FORMULA" Then
            blnFormulaExistFlag = True
        End If
    Next lngTemp
    
    Erase strProps
    
    If Not blnExistFlag Then
        'No hierarchy
        'Check that member exists in dimension
        strMem = epm.GetHierarchyMembers(strConn, "", strDim)
        For lngTemp = 0 To UBound(strMem)
            If Application.Run("EPMMemberProperty", "", strMem(lngTemp), "ID") = strParentMember _
                Then GoTo MEMBER_ITSELF
        Next lngTemp
        GoTo NO_MEMBER
    End If
    
    strParentMemberDim = strDim & ":" & strParentMember
    
    'Get CALC property of strParentMember
    strCalcProp = Application.Run("EPMMemberProperty", "", strParentMemberDim, "CALC")
    If strCalcProp = "Y" Then
        blnIsCalcFlag = True
    ElseIf strCalcProp Like "[#]Error - Invalid Member Name:*" Then GoTo NO_MEMBER
    End If
    
    
    'If we have dimension member formulas - check for formula of strParentMember
    blnIsNotFormulaFlag = True
    If blnFormulaExistFlag Then
        If Application.Run("EPMMemberProperty", "", strParentMemberDim, "FORMULA") <> "" Then
            blnIsNotFormulaFlag = False
        End If
    End If

    If blnIsCalcFlag And blnIsNotFormulaFlag Then
        strParentHierarchy = epm.GetMemberHierarchy(strConn, strParentMemberDim)
        strMem = epm.GetHierarchyMembers(strConn, strParentHierarchy, strDim)
        ReDim strMemIDParent(0 To 1, 0 To UBound(strMem))
        ReDim strMemBAS(0 To UBound(strMem))
        blnExistFlag = False
        For lngTemp = 0 To UBound(strMem)
            strMemIDParent(0, lngTemp) = Application.Run("EPMMemberProperty", "", strMem(lngTemp), "ID")
            strMemIDParent(1, lngTemp) = Application.Run("EPMMemberProperty", "", strMem(lngTemp), strParentHierarchy)
            If strMemIDParent(0, lngTemp) = strParentMember Then
                blnExistFlag = True
            End If
        Next lngTemp
        If Not blnExistFlag Then GoTo NO_MEMBER
        GetChildren strParentMember, strMemIDParent, strMemBAS, lngBASCount
        ReDim Preserve strMemBAS(0 To lngBASCount - 1)
        GetBAS = strMemBAS
    Else
        'Check that member exists in dimension
        strMem = epm.GetHierarchyMembers(strConn, "", strDim)
        For lngTemp = 0 To UBound(strMem)
            If Application.Run("EPMMemberProperty", "", strMem(lngTemp), "ID") = strParentMember _
                Then GoTo MEMBER_ITSELF
        Next lngTemp
        GoTo NO_MEMBER
    End If
    Exit Function

MEMBER_ITSELF:
    'Member found
    ReDim strMemBAS(0 To 0)
    strMemBAS(0) = strParentMember
    GetBAS = strMemBAS
    Exit Function

NO_MEMBER:
    'Member not found
    ReDim strMemBAS(0 To 1)
    strMemBAS(0) = ""
    strMemBAS(1) = "NO_MEMBER"
    GetBAS = strMemBAS
    Exit Function

Err:
    ReDim strMemBAS(0 To 1)
    strMemBAS(0) = ""
    If Err.Number = -1073479167 Then
        strMemBAS(1) = "NO_CONNECTION"
    Else
        strMemBAS(1) = "OTHER_ERROR"
    End If
    GetBAS = strMem

End Function

Public Sub GetChildren(strParent As String, ByRef strMemIDParent() As String, _
    ByRef strMemBAS() As String, ByRef lngBASCount As Long)
    
    Dim lngTemp As Long
    Dim blnParent As Boolean
    
    For lngTemp = 0 To UBound(strMemIDParent, 2)
        If strMemIDParent(1, lngTemp) = strParent Then
            blnParent = True
            GetChildren strMemIDParent(0, lngTemp), strMemIDParent, strMemBAS, lngBASCount
        End If
    Next lngTemp
    If Not blnParent Then
        strMemBAS(lngBASCount) = strParent
        lngBASCount = lngBASCount + 1
    End If
End Sub

GetChidren is used recursively!

Procedure to test GetBAS function:

Public Sub TestBas()

    Dim objAddIn As COMAddIn
    Dim epm As Object
    Dim AOComAdd As Object
    Dim blnEPMInstalled As Boolean
    
    Dim strMem() As String
    Dim lngTemp As Long
    
    'Universal code to get FPMXLClient for standalone EPM or AO
    For Each objAddIn In Application.COMAddIns
        If objAddIn.progID = "FPMXLClient.Connect" Then
            Set epm = objAddIn.Object
            blnEPMInstalled = True
            Exit For
        ElseIf objAddIn.progID = "SapExcelAddIn" Then
            Set AOComAdd = objAddIn.Object
            Set epm = AOComAdd.GetPlugin("com.sap.epm.FPMXLClient")
            blnEPMInstalled = True
            Exit For
        End If
    Next objAddIn
    
    If Not blnEPMInstalled Then
        MsgBox "EPM is not installed!"
        Exit Sub
    End If
    
    strMem = GetBAS(epm.GetActiveConnection(ThisWorkbook.Worksheets("Sheet1")), _
    "SOMEDIMNAME", "SOME_PARENT")
    
    'List selected members
    If strMem(0) = "" And UBound(strMem) = 1 Then
        Debug.Print strMem(1)
    Else
        For lngTemp = 0 To UBound(strMem)
            Debug.Print strMem(lngTemp)
        Next lngTemp
    End If
    
End Sub

References:

BPC NW 10: VBA function to get dimension members list by Property value