TM1 Forum

Code: Select all

Sub TM1_Indent_Elements(control As IRibbonControl)

    Const iNrOfSpacesPerLevel As Integer = 4

    Dim iLevel                As Integer
    Dim r                     As Range
    Dim sDim                  As String
    Dim Server_Dimension      As String
    Dim lTypeOfOutput         As Long
    Dim lMsgboxAddElementType As VbMsgBoxResult
    Dim sElementType_TM1      As String
    Dim sElementType_Excel    As String
    Dim sServer               As String

    On Error Resume Next

    Server_Dimension = InputBox("Please enter the dimension name" & vbNewLine & vbNewLine & _
                                "If you enter the server name : dimension name string, this server name is used", "(Server:)Dimension name", "")
    sServer = Split(Server_Dimension, ":")(0)
    sDim = Split(Server_Dimension, ":")(1)

    If Run("DIMIX", sServer & ":" & "}Dimensions", sDim) = 0 Then
        MsgBox "Please choose a valid value for server:dimension name"
        GoTo einde
    End If

    Server_Dimension = sServer & ":" & sDim

    Application.ScreenUpdating = False

    lTypeOfOutput = Application.InputBox("Do you want to:" & vbNewLine & vbNewLine & _
                                         "(1) indent cells, in the same column" & vbNewLine & _
                                         "(2) use spaces, in the same column" & vbNewLine & _
                                         "(3) distribute elements over columns" & vbNewLine & vbNewLine, "Indenting elements", 1, , , , , 1)

    If lTypeOfOutput < 1 Or lTypeOfOutput > 3 Then
        GoTo einde
    End If

    If lTypeOfOutput <> 3 Then
        lMsgboxAddElementType = MsgBox("Do you want to add the element type (like Greek Sigma and small n/s (choose: Yes) or not (choose: No) ?", vbYesNoCancel, "Element")
    Else
        lMsgboxAddElementType = vbNo
    End If

    For Each r In Selection.Cells

        If Run("DIMIX", Server_Dimension, r.text) > 0 Then

            iLevel = Run("DNLEV", Server_Dimension) - Run("ELLEV", Server_Dimension, r.text) - 1

            Select Case lMsgboxAddElementType

            Case vbcancel: GoTo einde

            Case vbYes

                sElementType_TM1 = Run("DTYPE", Server_Dimension, r.text)
                sElementType_Excel = IIf(sElementType_TM1 = "C", "S", IIf(sElementType_TM1 = "N", "#", "ab"))

                Select Case lTypeOfOutput

                Case 1

                    r.InsertIndent iLevel
                    If r.HasFormula Then
                        r.formula = "=""" & sElementType_Excel & " " & """ & " & Mid(r.formula, 2)
                    Else
                        r.value = "'" & sElementType_Excel & " " & r.text
                    End If

                Case 2

                    If r.HasFormula Then
                        r.formula = "=""" & Space(1 + iLevel * iNrOfSpacesPerLevel) & sElementType_Excel & " "" & " & Mid(r.formula, 2)
                    Else
                        r.value = "'" & Space(1 + iLevel * iNrOfSpacesPerLevel) & sElementType_Excel & " " & r.text
                    End If

                End Select

                If Not r.HasFormula Then
                    'font type change
                    With r.Characters(start:=InStr(r.text, sElementType_Excel), length:=IIf(sElementType_TM1 = "S", 2, 1)).Font
                        .name = IIf(sElementType_TM1 = "C", "Symbol", "Courier")
                        .FontStyle = "Bold"

                        .ThemeColor = IIf(sElementType_TM1 = "C", xlThemeColorAccent2, xlThemeColorAccent5)
                        .TintAndShade = -0.249977111117893
                        .ThemeFont = xlThemeFontNone

                    End With
                End If

            Case vbNo

                Select Case lTypeOfOutput

                Case 1

                    r.InsertIndent iLevel

                Case 2

                    If r.HasFormula Then
                        r.formula = "=""" & Space(1 + iLevel * iNrOfSpacesPerLevel) & """ & " & Mid(r.formula, 2)
                    Else
                        r.value = "'" & Space(1 + iLevel * iNrOfSpacesPerLevel) & r.text
                    End If

                Case 3

                    If iLevel > 0 Then
                        If r.HasFormula Then
                            r.Offset(, iLevel).formula = r.formula
                        Else
                            r.Offset(, iLevel).value = "'" & r.text
                        End If
                        r.ClearContents
                    End If

                End Select

            End Select

        End If

    Next

    Selection.Columns.AutoFit

    On Error GoTo 0

einde:

    Application.ScreenUpdating = True

End Sub