Option Explicit

Sub Get_Power_BI_Usage_Metrics()
'Script by Hans Peter Pfister, www.powerbi-pro.com
'Get data from usage metric reports in PowerBI (It doesn't work on other datasets....)
'You need full access rights to do so!
'Use this script on your own liability and responsibility!
'you need to define 3 tables in sheet "Parameters" (or define all in the script and adapt the script)
'1. Target, 1 column ("Target folder for data"), 1 row with folder path (e.g. C:\User\xxxx\Desktop)
'2. Location, 1 column ("Location Datacenter"), 1 row with the location of the Azure DC which hosts your Power BI Data (e.g. north-europe)
'3. Datasets, 2 columns ("Report Name", "Dataset"), 1 row per dataset (e.g. "mydataset", dataset value)
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

    'Define variables
    Dim wbTarget As Workbook
    Dim lo_tbl As ListObject
    Dim arr_Datasets As Variant
    Dim arr_Write As Variant
    Dim x, i, k As Integer
    Dim str_Dataset_ID, str_dc_loc, Str_connection, str_Command, str_Dataset_Name, str_query(100), str_file, str_record     As String
    Dim str_openingParen, str_closingParen As String
    Dim obj_rs As Object
    Dim int_TableCount, int_i As Integer
     
    'Suppress alerts and screen updates
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    'Bind to active workbook
    Set wbTarget = ActiveWorkbook

    'Error Handler
    Err.Clear
    On Error GoTo ErrHandler
    
    'Create Array List with all datasets from table "Datasets"
    Set lo_tbl = Sheets("Parameters").ListObjects("Datasets")
    'Set lo_tbl = ActiveSheet.ListObjects("Datasets")
    arr_Datasets = lo_tbl.DataBodyRange
    
    'Loop through all datasets
    For x = LBound(arr_Datasets) To UBound(arr_Datasets)
    
        'Define Connection String
        str_Dataset_ID = arr_Datasets(x, 2)
        
        'Define Location of Azure Datacenter from table "Location"
        str_dc_loc = Range("Location[Location Datacenter]").Value
              
        'Define connection string
        Str_connection = "Provider=MSOLAP.7;Integrated Security=SSPI;Data Source=https://analysis.windows.net/powerbi/api;;" & _
            "Initial Catalog=" & str_Dataset_ID & _
            ";Location=https://wabi-" & str_dc_loc & "-redirect.analysis.windows.net/xmla?vs=sobe_wowvirtualserver&" & _
            "db=" & str_Dataset_ID & _
            ";MDX Compatibility= 1; MDX Missing Member Mode= Error; Safety Options= 2; Update Isolation Level= 2"
  
        'Get all tables from model in Power BI Service
        str_Command = "SELECT TABLE_NAME FROM $System.DBSchema_Tables WHERE TABLE_TYPE = 'Table'"
        str_Dataset_Name = arr_Datasets(x, 1)
        
        Set obj_rs = CreateObject("ADODB.Recordset")
        obj_rs.Open str_Command, Str_connection
   
        'Write tables in an array
        arr_Write = obj_rs.GetRows(obj_rs.RecordCount)
        int_TableCount = obj_rs.RecordCount
      
        For int_i = 0 To int_TableCount - 1
            str_query(int_i) = Right(arr_Write(0, int_i), Len(arr_Write(0, int_i)) - 1)
        Next int_i
     
        obj_rs.Close
    
        'Loop through all tables
        For i = LBound(str_query) To int_TableCount - 1
            str_Command = "EVALUATE '" & str_query(i) & "'"

            'Define the target for the files from table "Target"
            str_file = Range("Target[Target folder for data]").Value & "\" & str_query(i) & "_" & str_Dataset_Name & ".csv"
        
            Set obj_rs = CreateObject("ADODB.Recordset")
            obj_rs.Open str_Command, Str_connection
                
            'Loop through all fields and get field name
            For k = 0 To obj_rs.Fields.Count - 1
                    str_closingParen = InStr(obj_rs.Fields(k).Name, "]")
                    str_openingParen = InStr(obj_rs.Fields(k).Name, "[")
                If k = 0 Then
                    str_record = Mid(obj_rs.Fields(k).Name, str_openingParen + 1, str_closingParen - str_openingParen - 1)
                Else: str_record = str_record & ";" & Mid(obj_rs.Fields(k).Name, str_openingParen + 1, str_closingParen - str_openingParen - 1)
                End If
            Next k
                
            str_record = Mid(str_record, 1) & vbNewLine

            If obj_rs.RecordCount > 0 Then
                str_record = str_record & """" & obj_rs.GetString(adClipString, , """;""", """" & vbNewLine & """")
                str_record = Left(str_record, Len(str_record))
            
                'Write to file
                Open str_file For Output Lock Write As #1
                Print #1, str_record
                
            Else
                'Write "no data"
                Open str_file For Output Lock Write As #1
                Print #1, "no data"
            
            End If
            
            str_record = ""
            Close #1
            obj_rs.Close
        Next i
    Next x
    
    MsgBox "Done"
    
ExitPoint:
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
    Set obj_rs = Nothing
    'Set obj_conn = Nothing
    Str_connection = vbNullString
    Set lo_tbl = Nothing
    Set arr_Write = Nothing
    Exit Sub

ErrHandler:
    If Err.LastDllError = 0 _
    Then
        MsgBox "No data - " & str_file & " - the file can not be created! " & vbCr & Err.Description, vbOKOnly
        Open str_file For Binary Access Write As #1
        Put #1, , "no data"
        
        Close #1
    Else
    MsgBox "An error occured - " & Err.LastDllError, vbOKOnly
    End If
    Resume ExitPoint
        
End Sub