Count # of members subscribed to a topic?

Alright here's my addition for the time being.   I cleaned it up a bit to make sense to me, which may not make sense to everyone - however, here's my variant.

New Addition: 

Changes

• Small reorg of Functions code
• Changed Subscriber sheet name to BoardSubCounts
• Added sheet BoardSubscribers.  Columns:
  • Column: Category ID
  • Column: Board ID
  • Column: Board Name
  • Column: Subscriber User
  • Range: A2 = SubReportStart
  • Button Text: Get Subscribers
  • Button Macro: BoardSubscribersReport.xlsm!Main_Prog.GetSubscribers

Gotcha:  I've only tested this on Staging, and expect it to take quite a while to print on even our small production environment.   This inspires a future deviation (stay tuned), but I'm sharing this code because it demonstrates the simplicity of extending what allensmith81  has given us.  (I added a new sheet & created 1 new method "Sub GetSubscribers()")

VBA for Modules / Functions: (contains cleaned-up methods)

Dim msXML As XMLHTTP60

Sub CheckAndUpdateSessionKey()
    Dim keyAge As Long
    keyAge = DateDiff("n", ThisWorkbook.Sheets("Settings").Range("SessionKey").Offset(0, 1).Value, Now())
    If keyAge > 30 Or ThisWorkbook.Sheets("Settings").Range("SessionKey").Value = "" Or _
       ThisWorkbook.Sheets("Settings").Range("SessionKey").Value = "Invalid session key." Then
        UpdateSessionKey
    End If
End Sub

Sub UpdateSessionKey()
    Dim strUname As String, strUpass As String, strURL As String, strCall As String, strResponse As String
    Dim XDoc As Object, root As Object
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False: XDoc.validateOnParse = False
    strUname = ThisWorkbook.Sheets("Settings").Range("Username").Value
    strUpass = URLEncode(ThisWorkbook.Sheets("Settings").Range("Password").Value)
    strURL = ThisWorkbook.Sheets("Settings").Range("CommunityUrl").Value

    strCall = strURL & "/restapi/vc/authentication/sessions/login?user.login=" & strUname & "&user.password=" & strUpass
    strResponse = vbaCURL(strCall, "POST")
    XDoc.LoadXML (strResponse)
    Set root = XDoc.DocumentElement
    ThisWorkbook.Sheets("Settings").Range("SessionKey").Value = root.FirstChild.Text
    ThisWorkbook.Sheets("Settings").Range("SessionKey").Offset(0, 1).Value = Now()
End Sub

Public Function URLEncode(ByVal StringVal As String, Optional SpaceAsPlus As Boolean = False) As String
    Dim bytes() As Byte, b As Byte, i As Integer, space As String

  If SpaceAsPlus Then space = "+" Else space = "%20"

  If Len(StringVal) > 0 Then
    With New ADODB.Stream
      .Mode = adModeReadWrite
      .Type = adTypeText
      .Charset = "UTF-8"
      .Open
      .WriteText StringVal
      .Position = 0
      .Type = adTypeBinary
      .Position = 3 ' skip BOM
      bytes = .Read
    End With

    ReDim result(UBound(bytes)) As String

    For i = UBound(bytes) To 0 Step -1
      b = bytes(i)
      Select Case b
        Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
          result(i) = Chr(b)
        Case 32
          result(i) = space
        Case 0 To 15
          result(i) = "%0" & Hex(b)
        Case Else
          result(i) = "%" & Hex(b)
      End Select
    Next i

    URLEncode = Join(result, "")
  End If
End Function

Public Function vbaCURL(ByVal strURL As String, ByVal strCallType As String, Optional strSessionKey As String) As String
    Dim strclientid As String
    strclientid = ThisWorkbook.Sheets("Settings").Range("clientid").Value
    If msXML Is Nothing Then Set msXML = New XMLHTTP60
    With msXML
        .Open strCallType, strURL, False:
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "client-id", strclientid
        If strSessionKey <> "" Then .setRequestHeader "Li-Api-Session-Key", strSessionKey
        .send
        vbaCURL = StrConv(.responseBody, vbUnicode)
    End With
End Function

Function liqlQuery(strLiql As String, strCallType As String) As String
    Dim strURL As String, strPath As String
    strURL = ThisWorkbook.Sheets("Settings").Range("CommunityURL").Value
    strPath = "/api/2.0/search?q=" & URLEncode(strLiql) & "&format=xml"
    liqlQuery = vbaCURL(strURL & strPath, strCallType, ThisWorkbook.Sheets("Settings").Range("SessionKey").Value)
End Function

Function GetSubscriptionsCount(strBoardid As String) As String
    Dim strQuery As String, strResponse As String, XDoc As Object, root As Object
    strQuery = ThisWorkbook.Sheets("Settings").Range("CommunityURL").Value & "/restapi/vc/boards/id/" & strBoardid & "/subscribers/email/board/count"
    strResponse = vbaCURL(strQuery, "GET", ThisWorkbook.Sheets("Settings").Range("SessionKey").Value)
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False: XDoc.validateOnParse = False
    XDoc.LoadXML (strResponse)
    Set root = XDoc.DocumentElement
    GetSubscriptionsCount = root.FirstChild.Text
End Function

Function GetCatName(strBoardid As String) As String
    Dim strResponse As String, strLiql As String, XDoc As Object, root As Object
    strLiql = "Select parent_category.title from boards where id='" & strBoardid & "'"
    strResponse = liqlQuery(strLiql, "GET")
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False: XDoc.validateOnParse = False
    XDoc.LoadXML (strResponse)
    Set root = XDoc.DocumentElement
    GetCatName = XDoc.SelectSingleNode("//items/item/parent_category/title").Text
End Function

VBA for Modules / Main_Prog (contains new method)

Option Explicit

Sub GetSubscriptions()
    Dim xmlDoc As Object, root As Object
    Dim xmlCatID As Object, xmlCatTitle As Object
    Dim xmlBoardID As Object, xmlBoardTitle As Object
    Dim intCat As Long, intBoard As Long
    Dim strLiql As String, strLiql2 As String
    Dim strResponse As String, strResponse2 As String
    Dim dbloffset As Long
    
    Call CheckAndUpdateSessionKey
    
    strLiql = "Select id,title from categories ORDER BY position DESC limit 1000"
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.async = False: xmlDoc.validateOnParse = False
    Debug.Print strLiql
    strResponse = liqlQuery(strLiql, "GET")
    xmlDoc.LoadXML (strResponse)
    Set root = xmlDoc.DocumentElement
    Set xmlCatID = xmlDoc.getElementsByTagName("id")
    Set xmlCatTitle = xmlDoc.getElementsByTagName("title")
    
    With ThisWorkbook.Sheets("BoardSubCounts")
        For intCat = 0 To xmlCatID.Length - 1
            strLiql2 = "select id, title from boards where ancestor_categories.id = '" & xmlCatID(intCat).Text & "' ORDER BY position DESC limit 1000"
            Set xmlDoc = CreateObject("MSXML2.DOMDocument")
            xmlDoc.async = False: xmlDoc.validateOnParse = False
            strResponse2 = liqlQuery(strLiql2, "GET")
            xmlDoc.LoadXML (strResponse2)
            Set root = xmlDoc.DocumentElement
            Set xmlBoardID = xmlDoc.getElementsByTagName("id")
            Set xmlBoardTitle = xmlDoc.getElementsByTagName("title")
            
            For intBoard = 0 To xmlBoardID.Length - 1
                .Range("ReportStart").Offset(intBoard + dbloffset, 0).Value = xmlCatTitle(intCat).Text
                .Range("ReportStart").Offset(intBoard + dbloffset, 1).Value = xmlBoardTitle(intBoard).Text
                .Range("ReportStart").Offset(intBoard + dbloffset, 2).Value = GetSubscriptionsCount(xmlBoardID(intBoard).Text)
                DoEvents
            Next
            
            dbloffset = dbloffset + xmlBoardID.Length
        Next
    End With
End Sub


Sub GetSubscribers()
    Dim xmlDoc As Object, root As Object
    Dim xmlCatID As Object, xmlCatTitle As Object
    Dim xmlBoardID As Object, xmlBoardTitle As Object
    Dim xmlSubUsers As Object, xmlSubEmails As Object
    Dim intCat As Long, intBoard As Long, intSub As Long
    Dim strLiql As String, strLiql2 As String
    Dim sheetName As String
    Dim strResponse As String, strResponse2 As String
    Dim dbloffset As Long
    
    Call CheckAndUpdateSessionKey
    
    strLiql = "Select id,title from categories ORDER BY position DESC limit 1000"
    sheetName = "BoardSubscribers"
    
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.async = False: xmlDoc.validateOnParse = False
    Debug.Print strLiql
    strResponse = liqlQuery(strLiql, "GET")
    xmlDoc.LoadXML (strResponse)
    Set root = xmlDoc.DocumentElement
    Set xmlCatID = xmlDoc.getElementsByTagName("id")
    Set xmlCatTitle = xmlDoc.getElementsByTagName("title")
    
    With ThisWorkbook.Sheets(sheetName)
        For intCat = 0 To xmlCatID.Length - 1
            strLiql2 = "select id, title from boards where ancestor_categories.id = '" & xmlCatID(intCat).Text & "' ORDER BY position DESC limit 1000"
            Set xmlDoc = CreateObject("MSXML2.DOMDocument")
            xmlDoc.async = False: xmlDoc.validateOnParse = False
            strResponse2 = liqlQuery(strLiql2, "GET")
            xmlDoc.LoadXML (strResponse2)
            Set root = xmlDoc.DocumentElement
            Set xmlBoardID = xmlDoc.getElementsByTagName("id")
            Set xmlBoardTitle = xmlDoc.getElementsByTagName("title")
            
            For intBoard = 0 To xmlBoardID.Length - 1
            
                Dim strQuery As String, strResponse3 As String, XDocSub As Object, rootSub As Object
                strQuery = ThisWorkbook.Sheets("Settings").Range("CommunityURL").Value & "/restapi/vc/boards/id/" & xmlBoardID(intBoard).Text & "/subscribers/email/board"
                strResponse3 = vbaCURL(strQuery, "GET", ThisWorkbook.Sheets("Settings").Range("SessionKey").Value)
                Set XDocSub = CreateObject("MSXML2.DOMDocument")
                XDocSub.async = False: XDocSub.validateOnParse = False
                XDocSub.LoadXML (strResponse3)
                Set rootSub = XDocSub.DocumentElement
                Set xmlSubUsers = XDocSub.getElementsByTagName("login")
                
                For intSub = 0 To xmlSubUsers.Length - 1
                
                    .Range("SubReportStart").Offset(intSub + dbloffset, 0).Value = xmlCatTitle(intCat).Text
                    .Range("SubReportStart").Offset(intSub + dbloffset, 1).Value = xmlBoardID(intBoard).Text
                    .Range("SubReportStart").Offset(intSub + dbloffset, 2).Value = xmlBoardTitle(intBoard).Text
                    .Range("SubReportStart").Offset(intSub + dbloffset, 3).Value = xmlSubUsers(intSub).Text                    
                    
                    DoEvents
                Next
                          
                dbloffset = dbloffset + xmlSubUsers.Length
            Next            
        Next
    End With
End Sub

We need a GitHub repo.  This absolutelly triggers me to continue building some Tabular Components based on this same concept, to do this work server-side for larger lists such as Subscriber reports, message lists, etc.  Stay tuned & keep innovating.