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

Updated on 2019.06.18: Code corrected to support properties like PARENTx, performance improved.

Updated on 2019.06.14: Code corrected to support proper case for short ID.

Updated on 2019.06.13: Late binding to work on EPM or AO.

Decided to share simple code to get list of dimension members having some property value. The standard EPM API function is missing for this task. The code can be easily changed to support multiple properties for selection

The following references are required in Tools -> References:

Parameters are described in the code:

Option Explicit

'References to Microsoft Scripting Runtime required

Public Function GetMembersByProperty(strConn As String, _
    strDim As String, strProperty As String, _
    strPropValue As String, blnFullMember As Boolean) As String()
'Parameters: strConn - Connection string, strDim - Dimension name,
'strProperty - Property name, strPropValue - Property value,
'blnFullMember - True: result as full name [DIMNAME].[PARENTHx].[MEMBERID]
'False: result as MEMBERID
'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 strProps() As String
    Dim blnExistFlag As Boolean
    Dim blnPARENTH As Boolean
    Dim lngDimHierPref As Long
    Dim strDimHierPref As String
    Dim strMem() As String
    Dim strMemID As String
    Dim dctMembers As New Scripting.Dictionary
    Dim varPropVal As Variant
    Dim varMemFull As Variant
    Dim lngTemp As Long
    Dim lngTemp1 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 strMem(0 To 1)
        strMem(0) = ""
        strMem(1) = "NO_EPM"
        GetMembersByProperty = strMem
        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 strMem(0 To 1)
        strMem(0) = ""
        strMem(1) = "NO_DIMENSION"
        GetMembersByProperty = strMem
        Exit Function
    End If
    
    'Check if Property strProperty exists for Dimension strDim
    blnExistFlag = False
    strProps = epm.GetPropertyList(strConn, strDim)
    For lngTemp = 0 To UBound(strProps)
        If strProps(lngTemp) = strProperty Then
            blnExistFlag = True
        End If
    Next lngTemp
    
    Erase strProps
    
    If Not blnExistFlag Then
        ReDim strMem(0 To 1)
        strMem(0) = ""
        strMem(1) = "NO_PROPERTY"
        GetMembersByProperty = strMem
        Exit Function
    End If
    
    'Test for Properties like PARENTHx
    If strProperty Like "PARENTH*" Then
        blnPARENTH = True
        lngDimHierPref = Len(strDim) + Len(strProperty) + 5 'Len of "[DIMNAME].[PARENTHx]"
        strDimHierPref = "[" & strDim & "].[" & strProperty 'String like "[DIMNAME].[PARENTHx"
    End If

    'Get full list of dimension members with duplicates due to possible multiple hierarchies
    strMem = epm.GetHierarchyMembers(strConn, "", strDim)
    For lngTemp = 0 To UBound(strMem)
        lngTemp1 = InStrRev(strMem(lngTemp), "[")
        strMemID = Mid(strMem(lngTemp), lngTemp1 + 1, Len(strMem(lngTemp)) - lngTemp1 - 1)
        'Add only unique member ID's (ID in upper case!)
        If Not dctMembers.Exists(strMemID) Then
            dctMembers.Add strMemID, strMem(lngTemp)
        End If
    Next lngTemp
    
    'Loop dictionary with unique member list and read Property value
    lngTemp = 0
    For Each varMemFull In dctMembers.Items
        'Check member proprty value
        'Corrected based on Evgeniy Samardak comment!
        'Application.Run("EPMMemberProperty" instead of epm.GetPropertyValue(
        If blnPARENTH Then
            'For PARENTx properties
            strMemID = strDimHierPref & Mid(varMemFull, lngDimHierPref)
            varPropVal = Application.Run("EPMMemberProperty", "", strMemID, strProperty)
            If varPropVal = "The member requested does not exist in the specified hierarchy." Or _
                varPropVal = 0 Then
                    varPropVal = ""
            End If
        Else
            'For other properties
            varPropVal = Application.Run("EPMMemberProperty", "", CStr(varMemFull), strProperty)
        End If
        If varPropVal = strPropValue Then
            If blnFullMember Then
                strMem(lngTemp) = CStr(varMemFull)
            Else
                'Get ID in proper case
                strMem(lngTemp) = CStr(Application.Run("EPMMemberProperty", "", CStr(varMemFull), "ID"))
            End If
            lngTemp = lngTemp + 1
        End If
    Next varMemFull
    
    Set dctMembers = Nothing
    
    If lngTemp = 0 Then
        ReDim strMem(0 To 1)
        strMem(0) = ""
        strMem(1) = "NO_MATCH"
    Else
        ReDim Preserve strMem(0 To lngTemp - 1)
    End If
    
    GetMembersByProperty = strMem
    Exit Function
Err:
    ReDim strMem(0 To 1)
    strMem(0) = ""
    If Err.Number = -1073479167 Then
        strMem(1) = "NO_CONNECTION"
    Else
        strMem(1) = "OTHER_ERROR"
    End If
    GetMembersByProperty = strMem

End Function

Procedure to test GetMembersByProperty function:

Public Sub Test()
    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 = GetMembersByProperty(epm.GetActiveConnection(ThisWorkbook.Worksheets("Sheet1")), _
        "SOMEDIMNAME", "SOMEPROPERTYNAME", "SOMEPROPERTYVALUE", False)
    If strMem(0) = "" Then
        Debug.Print strMem(1)
    Else
        For lngTemp = 0 To UBound(strMem)
            Debug.Print strMem(lngTemp)
        Next lngTemp
    End If
End Sub

The results of this function can be used for different checks, for DM package answer prompt generation (Simple VBA procedure to pass parameters to DM packages)  etc. You can even create your own member selector using VBA listbox as a replacement of OpenFilteredMemberSelector API.

Sample of Member Selector:

Create User Form frmSelectMembers with 3 elements:

lbxMembers – ListBox

cmbOK – CommandButton

cmbCancel – CommandButton

Add code to the frmSelectMembers code:

Option Explicit

Private blnOKPressed As Boolean

Private Sub cmbCancel_Click()
    Unload Me
End Sub

Private Sub cmbOK_Click()
    Dim lngTemp As Long
    Dim lngTemp1 As Long
    
    blnOKPressed = True
    'Read selected items
    For lngTemp = 0 To Me.lbxMembers.ListCount - 1
        If Me.lbxMembers.Selected(lngTemp) Then
            strMembs(lngTemp1) = Me.lbxMembers.List(lngTemp)
            lngTemp1 = lngTemp1 + 1
        End If
    Next lngTemp
    If lngTemp1 = 0 Then
        ReDim strMembs(0 To 0)
        strMembs(0) = ""
    Else
        ReDim Preserve strMembs(0 To lngTemp1 - 1)
    End If
    
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    Dim lngTemp As Long
    
    Me.Caption = "Select Members for " & strDimName & " Dimension"
    With Me.lbxMembers
        .ColumnCount = 1
        .ColumnWidths = "100"
        .Font.Size = 10
        .MultiSelect = fmMultiSelectMulti
        For lngTemp = 0 To UBound(strMembs)
            .AddItem
            .List(lngTemp, 0) = strMembs(lngTemp)
        Next lngTemp
    End With
End Sub

Private Sub UserForm_Terminate()
    If Not blnOKPressed Then
        ReDim strMembs(0 To 0)
        strMembs(0) = ""
    End If
End Sub

Add the code to some module to launch Member Selector function SelectMembersFilt:

Option Explicit

'Globals to pass data to and from form
Public strMembs() As String
Public strDimName As String

Public Function SelectMembersFilt(strConn As String, strDim As String, strProperty As String, _
    strPropValue As String) As String()
    
    Dim lngTemp As Long
    
    'Set global variables: strDimName and strMembs
    strDimName = strDim
    strMembs = GetMembersByProperty(strConn, strDimName, strProperty, strPropValue, False)
    
    'Load form if member list is not empty
    If strMembs(0) = "" Then
        Debug.Print strMembs(1)
    Else
        frmSelectMembers.Show vbModal
    End If
    
    SelectMembersFilt = strMembs

End Function

Public Sub SelectMembersTest()
    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 = SelectMembersFilt(epm.GetActiveConnection(ThisWorkbook.Worksheets("Sheet1")), _
    "SOMEDIMNAME", "SOMEPROPERTYNAME", "SOMEPROPERTYVALUE")
    
    'List selected members
    If strMem(0) = "" Then
        Debug.Print "Nothing Selected"
    Else
        For lngTemp = 0 To UBound(strMem)
            Debug.Print strMem(lngTemp)
        Next lngTemp
    End If
    
End Sub

If you run SelectMembersTest you will have something like:

Result in the Immediate window will be:

PC_PL00-00011
PC_PL01-00000
PC_PL01-00001

The standard API function OpenFilteredMemberSelector can be used with the code:

Public Sub SelectMembers()

    Dim objAddIn As COMAddIn
    Dim epm As Object
    Dim AOComAdd As Object
    Dim blnEPMInstalled As Boolean

    Dim strMembers As String
    Dim strMem() As String
    Dim lngTemp As Long
    Dim lngTemp1 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

    strMembers = epm.OpenFilteredMemberSelector( _
        epm.GetActiveConnection(ThisWorkbook.Worksheets("Sheet1")), _
        "SOMEDIMNAME", "", "SOMEPROPERTYNAME=SOMEPROPERTYVALUE", True)
    If strMembers <> "" Then
        strMembers = Left(strMembers, Len(strMembers) - 1)
        strMem = Split(strMembers, ";")
        For lngTemp = 0 To UBound(strMem)
            lngTemp1 = InStrRev(strMem(lngTemp), "[")
            strMem(lngTemp) = Mid(strMem(lngTemp), lngTemp1 + 1, _
                Len(strMem(lngTemp)) - lngTemp1 - 1)
            Debug.Print strMem(lngTemp)
        Next lngTemp
    Else
        Debug.Print "Nothing selected"
    End If

End Sub

With the form presented to user:

Extra button has to be clicked to perform selection.

GetMembersByProperty can be slow for dimensions with a huge member list (all members of dimension are read inside this code).

Vadim

P.S. epm.GetPropertyValue function was replaced by Application.Run(“EPMMemberProperty”… to improve performance based on Evgeniy Samardak comment!

References:

BPC NW 10: VBA to get dimension members list and properties