TM1 Forum

Code: Select all

-----MODULE1--------------
Function bCommandBarExists(sCmdBarName As String) As Boolean
'test if a given menu exists

    Dim bCbExists As Boolean
        
    Dim cb As CommandBar

    bCbExists = False
    For Each cb In Application.CommandBars
        If cb.name = sCmdBarName Then
            bCbExists = True
            Exit For
        End If
    Next

    bCommandBarExists = bCbExists

End Function

Sub addMenu()
'add "freeze values" entry in TM1 menu

  Dim cmdbar As CommandBar
  Dim toolsMenu As CommandBarControl
  Dim myMenu As CommandBarPopup
  Dim subMenu As CommandBarControl
  
' Point to the Worksheet Menu Bar
  Set cmdbar = Application.CommandBars("Worksheet Menu Bar")

' Point to the Tools menu on the menu bar
  Set toolsMenu = cmdbar.Controls("TM1")
  
' Create the sub Menu(s)
  Set subMenu = toolsMenu.Controls.Add
  

    With subMenu
      .Caption = "Freeze values"
      .BeginGroup = True
      .OnAction = "'" & ThisWorkbook.name & "'!DeleteTM1Formulas" ' Assign Macro to Menu Item
    End With


End Sub
Sub BuildCustomToolbar()
'build a new TM1 toolbar for "freeze values"

Dim oCmdBar As CommandBar
On Error Resume Next

'point to custom toolbar
Set oCmdBar = CommandBars("TM1 Freeze")

'if it doesn't exist create it
If Err <> 0 Then
Set oCmdBar = CommandBars.Add("TM1 Freeze")
Err = 0
With oCmdBar
'now add a control
With .Controls.Add(msoControlButton)
.Caption = "Freeze Values"
.OnAction = "!DeleteTM1Formulas"
.Tag = .Caption
'set the button icon
.FaceId = 107
End With
End With
End If

'make it visible
oCmdBar.Visible = True
'on top
Application.CommandBars("TM1 Freeze").Position = msoBarTop
End Sub

Sub DeleteTM1Formulas()
'replace TM1 formulas with their current values

Dim ws As Worksheet, AWS As String, ConfirmReplace As Boolean
Dim i As Integer, OK As Boolean
    If ActiveWorkbook Is Nothing Then Exit Sub
    i = MsgBox("Replace all TM1 formulas with their current values?", _
    vbQuestion + vbYesNo)
    ConfirmReplace = False
    If i = vbNo Then Exit Sub
    ConfirmReplace = False
    AWS = ActiveSheet.name
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        OK = DeleteLinksInWS(ConfirmReplace, ws)
        If Not OK Then Exit For
    Next ws
    Set ws = Nothing
    Sheets(AWS).Select
    Application.ScreenUpdating = True
End Sub

Private Function DeleteLinksInWS(ConfirmReplace As Boolean, _
    ws As Worksheet) As Boolean
'replace formulas with their values

Dim cl As Range, cFormula As String, i As Integer
    DeleteLinksInWS = True
    If ws Is Nothing Then Exit Function
    Application.StatusBar = "Deleting external formula references in " & _
        ws.name & "..."
    ws.Activate
    For Each cl In ws.UsedRange
        cFormula = cl.Formula
        If Len(cFormula) > 0 Then
            If Left$(cFormula, 5) = "=SUBN" Or Left$(cFormula, 3) = "=DB" Or Left$(cFormula, 5) = "=VIEW" Then
                    If Not ConfirmReplace Then
                        cl.Formula = cl.Value
                    Else
                        Application.ScreenUpdating = True
                        cl.Select
                        i = MsgBox("Replace the formula with the value?", _
                            vbQuestion + vbYesNoCancel, _
                            "Replace external formula reference in " & _
                             cl.Address(False, False, xlA1) & _
                             " with the cell value?")
                        Application.ScreenUpdating = False
                        If i = vbCancel Then
                            DeleteLinksInWS = False
                            Exit Function
                        End If
                        If i = vbYes Then
                            On Error Resume Next
                            ' in case the worksheet is protected
                            cl.Formula = cl.Value
                            On Error GoTo 0
                        End If
                    End If
            End If
        End If
    Next cl
    Set cl = Nothing
    Application.StatusBar = False
End Function