TM1 Forum

Code: Select all

'******************************************
'Look down the hierarchy and create a PDF
'report for every N-level TM1 element
'******************************************
Public Function gbCreatePDFs(Optional ByVal bSelected As Boolean) As Boolean

    Const sSource As String = "gbCreatePDFs()"
    Dim bReturn As Boolean
    Dim rngCell As Range, lCalculation As Long
    Dim iPDFCount As Integer, iPDFCounter As Integer
    Dim frmPDF As FPDF

    On Error GoTo ErrorHandler
    bReturn = True

    lCalculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    'Test whether TM1 add-in is loaded
    Application.Run "TM1RECALC1"
    Application.ScreenUpdating = False

    'If selected reports only, (passed boolean optionally),
    'show a form for user to select reports to create.
    'For each one selected, produce a new report.
    'Otherwise loop all elements.
    Set frmPDF = New FPDF
    With frmPDF

        'Populate the form list with elements to select from
        If Not .gbPopulateList() Then Err.Raise glHANDLED_ERROR
        .Show

        If .UserCancel Then
            Err.Raise glUSER_CANCEL
        Else

            'Grab the selections into a local array
            'arrSelectedReports = .Selections
            Set mrngCellsToTest = .SelectionRange
        End If
    End With

    wksMaster.Activate

    'Add a backslash to the output folder string if necessary.
    msOutputFolderPDF = wksControl.Range("PDFOutputFolder").Value
    msOutputFolderExcel = wksControl.Range("ExcelOutputFolder").Value

    If Right(msOutputFolderPDF, 1) <> "\" Then
        wksControl.Range("PDFOutputFolder").Value = msOutputFolderPDF & "\"
    End If

    'Get the number of PDFs so we can show progress to the user.
    iPDFCount = mrngCellsToTest.Rows.Count

    'Loop through cells and create pdfs where indicated.
    For Each rngCell In mrngCellsToTest.Cells
        iPDFCounter = iPDFCounter + 1
        Application.StatusBar = "Creating " & rngCell.Value & _
                              " PDF, " & iPDFCounter & " of " & iPDFCount & "..."

        'Select the CC item in the pick list.
        If Not mbCreatePDF(rngCell.Value) Then Err.Raise glHANDLED_ERROR

    Next rngCell

    'Report finished.
    MsgBox "Finished creating PDF reports.", vbInformation + vbOKOnly

ProcExit:
    gbCreatePDFs = bReturn
    'Restore environment.
    Application.Calculation = lCalculation
    Application.ScreenUpdating = True
    Application.StatusBar = ""
    Application.DisplayAlerts = True
    Exit Function

ErrorHandler:
    bReturn = False
    If Err.Number = 1004 Then
        MsgBox "Please check that you are logged in to TM1", vbExclamation + vbOKOnly, "TM1 Load Error"
    End If
    If gbCentralErrorHandler(msMODULE, sSource) Then
        Stop
        Resume
    Else
        Resume ProcExit
    End If

End Function

'***********************************************
'CREATE A PDF REPORT FOR THE PASSED COST CENTRE
'***********************************************
Private Function mbCreatePDF(ByVal sCostCentre As String) As Boolean
    Const sSource As String = "mbCreatePDF()"
    Dim bReturn As Boolean, wkbNew As Workbook, rngStart As Range

    On Error GoTo ErrorHandler
    bReturn = True

    Application.ScreenUpdating = False

    'Enter the Cost Centre and recalculate.
    wksMaster.Activate
    wksMaster.Range("Expense_Cost_Centre").Value = sCostCentre
    Application.Run "tm1recalc1"

    'Only produce a report where there are some numbers.
    If Not mbAllCellsAreZero Then

        UnhideZeroRows
        Application.ScreenUpdating = False

        'Copy the result to a new workbook, value copy everything,
        'then hide rows and export as PDF
        Set rngStart = wksMaster.Range("HideRowStart")

        'Create a new workbook
        wksMaster.UsedRange.Copy
        Set wkbNew = Workbooks.Add

        'Copy the whole of master
        With ActiveSheet
            'Copy the whole of master
            wksMaster.UsedRange.Copy

            .Paste

            'PasteSpecial to copy column widths
            wksMaster.UsedRange.Copy
            .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks _
                                                                                   :=False, Transpose:=False
            'PasteSpecial to remove formulas
            .UsedRange.Copy
            .Range("A1").PasteSpecial Paste:=xlPasteValues

            'Copy the hiderow start range
            rngStart.Copy _
                    Destination:=.Range(Mid(rngStart.Name.RefersTo, 9, 10))

            .Range(Mid(rngStart.Name.RefersTo, 9, 10)).Name = "HideRowStart"

            'Hide the check total row
            .Rows(gs_ROW_CHECKTOTAL).Hidden = True

            'Delete the TM1 header area.
            .Rows(gs_ROWS_HEADER).Delete Shift:=xlUp

            'Hide blank/zero rows
            If Not gbHideZeroRows(False) Then Err.Raise glHANDLED_ERROR

            'Set the print parameters.
            With .PageSetup
                .CenterFooter = "Page &P of &N"
                .Orientation = xlLandscape
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 20
                .PrintTitleRows = gs_ROWS_PRINT_TITLES
            End With

            'Produce PDF
            .ExportAsFixedFormat _
                    Type:=xlTypePDF, _
                    Filename:=wksControl.Range("PDFOutputFolder").Value & Replace(sCostCentre, "/", "-") & ".pdf"

        End With
        Application.DisplayAlerts = False
        wkbNew.Saved = True
        wkbNew.Close SaveChanges:=False

    End If

ProcExit:
    Set wkbNew = Nothing
    mbCreatePDF = bReturn
    Exit Function

ErrorHandler:
    bReturn = False

    If gbCentralErrorHandler(msMODULE, sSource) Then
        Stop
        Resume
    Else
        Resume ProcExit
    End If

End Function