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

[former_member186338]

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