Count # of members subscribed to a topic?

Good catch! I thought I had removed everything that was specific to our community.

Also please you didn't find anything scummy 🙂

Allen Smith

Technical & Compliance Lead

Microsoft Tech Community

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.

Thanks this sheet I have put here is only a small subsample of functions in a big sheet I have that does everything from manage labels, extract blog authors, editors, publishers to find users by email address enmass (but still quicker than pulling out entire user database from admin).

Infact here is what the full sheet can do, let me know if anyone needs functions for this:

• Move Posts
• Get a count of how many members have a role (part of another sequence of functions / subs)
• Get a topic count (used repeatedly in another call to produce a list of topics for every board in the community)
• Get MessageID from URL
• Get repliy count for a given message id
• Get a users rank
• Delete messages
• Get all the labels on a a given message id
• Get all the tags on a given message id
• Clean the date given by the API into an actual date for excel
• Delete a Tag
• Delete a Label
• Create a Tag
• Create a label
• Find out the conversation style for a board id
• Get all the roles a given user has
• get the role id for a give blog role
• Get the RSVPs for an event
• get user id by email address
• Get a unique list of labels for a given board (up to 1000)
• List some of the meta data for a given collection of messages in a spreadsheet
• Post a message from excel to the community
• get all message ids for every topic in a board
• Get the name of the board a message id is in
• List all users who have not full completed registration
• List all categories in a given category

I also have a whole suite of tools that do stuff in Python as well.

Happy to share, keep in mind I may not always be able to reply right away.

I'm on a similar track to build out little helper utilities, but so far only using Python and PowerQuery / M.

keithkelly Yeah PowerQuery could be really powerful, I wrote my VBA before PowerQuery was a thing.

Of course I am kinda at the point now where I am clearing my decks ready to build utilities using the new API for Aurora.. that should be a game changer from what is documented.

Can you imagine being able to label a post in real time as "hot" or "trending" because of realtime pageview counts....

Community Mecca.