PowerPoint中Microsoft Purview敏感度标签的VBA技术咨询

问题1：捕获用户手动选择敏感度标签的触发事件 #

PowerPoint原生没有事件响应用户手动从功能区选择敏感度标签的操作，这里用轮询+应用级事件优化的方案实现实时触发：

步骤1：创建应用级事件监听类 #

新建类模块，命名为clsPPTAppEvents，粘贴以下代码：

Option Explicit
Private WithEvents PPTApp As Application
Private LastLabelGUID As String
Private PollTimer As Double

Private Sub Class_Initialize()
    Set PPTApp = Application
    PollTimer = Now + TimeValue("00:00:00.5") ' 500ms间隔检查
    Application.OnTime PollTimer, "CheckLabelChange"
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    Application.OnTime PollTimer, "CheckLabelChange", , False
    Set PPTApp = Nothing
End Sub

Private Sub PPTApp_WindowActivate(ByVal Pres As Presentation, ByVal Wn As DocumentWindow)
    If Pres.SensitivityLabel.Id <> "" Then
        LastLabelGUID = Pres.SensitivityLabel.Id
    End If
    PollTimer = Now + TimeValue("00:00:00.5")
    Application.OnTime PollTimer, "CheckLabelChange"
End Sub

Private Sub PPTApp_WindowDeactivate(ByVal Pres As Presentation, ByVal Wn As DocumentWindow)
    On Error Resume Next
    Application.OnTime PollTimer, "CheckLabelChange", , False
End Sub

步骤2：实现检查逻辑与触发更新 #

新建标准模块，命名为modLabelHandler，粘贴以下代码：

Option Explicit
Public PPTAppEvents As clsPPTAppEvents

Sub Auto_Open()
    Set PPTAppEvents = New clsPPTAppEvents
End Sub

Sub CheckLabelChange()
    Dim ActivePres As Presentation
    Set ActivePres = ActivePresentation
    
    If ActivePres Is Nothing Then Exit Sub
    
    Dim CurrentLabelGUID As String
    CurrentLabelGUID = ActivePres.SensitivityLabel.Id
    
    If CurrentLabelGUID <> PPTAppEvents.LastLabelGUID Then
        PPTAppEvents.LastLabelGUID = CurrentLabelGUID
        UpdateBrandedFooter CurrentLabelGUID ' 替换为你已实现的页脚更新代码
    End If
    
    PPTAppEvents.PollTimer = Now + TimeValue("00:00:00.5")
    Application.OnTime PPTAppEvents.PollTimer, "CheckLabelChange"
End Sub

该方案通过500ms轮询检测标签GUID变化，同时在窗口失活时停止轮询，平衡实时性与性能消耗，延迟基本可忽略。

问题2：通过GUID获取标签文本（避免硬编码） #

提供两种实现方案，根据场景选择：

方案1：调用Microsoft Graph API（云端同步，准确） #

通过Graph API获取组织全量敏感度标签，根据GUID匹配名称：

Function GetLabelTextByGUID(labelGUID As String) As String
    Dim objHTTP As Object
    Set objHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
    
    Dim token As String
    token = GetGraphAccessToken() ' 需自行实现Graph令牌获取逻辑（OAuth2或预取令牌）
    
    objHTTP.Open "GET", "https://graph.microsoft.com/v1.0/informationProtection/labels", False
    objHTTP.SetRequestHeader "Authorization", "Bearer " & token
    objHTTP.Send
    
    If objHTTP.Status = 200 Then
        Dim jsonResponse As Object
        Set jsonResponse = JsonConverter.ParseJson(objHTTP.ResponseText) ' 需引入VBA-JSON库
        
        Dim label As Object
        For Each label In jsonResponse("value")
            If label("id") = labelGUID Then
                GetLabelTextByGUID = label("name")
                Exit Function
            End If
        Next label
    End If
    
    GetLabelTextByGUID = "Unknown Label"
End Function

注意：需引入VBA-JSON库处理JSON响应，账号需拥有InformationProtectionPolicy.Read.All权限。

方案2：读取本地注册表（离线可用，依赖本地同步） #

敏感度标签会同步到本地注册表，直接读取对应GUID的显示名称：

Function GetLabelTextFromRegistry(labelGUID As String) As String
    Dim regPath As String
    regPath = "Software\Microsoft\Office\16.0\Common\Security\Labels\" & labelGUID
    
    Dim objShell As Object
    Set objShell = CreateObject("WScript.Shell")
    
    On Error Resume Next
    GetLabelTextFromRegistry = objShell.RegRead("HKCU\" & regPath & "\DisplayName")
    On Error GoTo 0
    
    If GetLabelTextFromRegistry = "" Then
        GetLabelTextFromRegistry = "Unknown Label"
    End If
End Function

注意：仅适用于已同步到本地客户端的标签，若标签未同步会返回默认值。

整合流程 #

1. 启动PowerPoint时，Auto_Open自动初始化事件监听。
2. 用户在功能区选择敏感度标签后，轮询检测到GUID变化。
3. 通过上述任一函数获取标签文本，传入你的页脚更新代码。
4. 实时生成符合品牌规范的页脚标签。

内容的提问来源于stack exchange，提问作者Rogue