Hi Thomas, 我之前帮公司内部做过类似的自动化需求，用Excel VBA结合Microsoft Graph API完全能实现你要的功能——检查指定聊天是否存在，不存在就创建新聊天、发送初始消息并添加指定用户。下面是我整理的可直接复用的方案，包含代码示例和关键注意事项：

一、前置准备 #

在开始写代码前，你需要完成这两项基础准备：

1. 导入VBA-JSON库：Graph API返回的是JSON格式数据，VBA原生解析效率极低，我当时用的是VBA-JSON（直接把库代码复制到你的VBA模块里即可，无需额外安装）
2. 配置Graph API权限：你需要在Azure AD中注册一个应用（个人测试也可以用交互式权限），至少要开通Chat.ReadWrite、User.Read.All、ChatMember.ReadWrite这三个权限，同时记录下你的租户ID、客户端ID，用于获取访问Token

二、核心代码实现 #

1. 通用工具函数：获取Graph API访问Token #

我当时用的是设备码授权流程（适合桌面端VBA脚本，无需复杂的回调配置），代码如下：

Function GetGraphAccessToken(clientId As String, tenantId As String) As String
    Dim xmlHttp As Object
    Dim response As String
    Dim jsonObj As Object
    
    Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    ' 第一步：请求设备授权码
    xmlHttp.Open "POST", "https://login.microsoftonline.com/" & tenantId & "/oauth2/v2.0/devicecode", False
    xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    xmlHttp.send "client_id=" & clientId & "&scope=Chat.ReadWrite User.Read.All ChatMember.ReadWrite offline_access"
    
    response = xmlHttp.responseText
    Set jsonObj = JsonConverter.ParseJson(response)
    
    ' 提示用户完成浏览器端授权
    MsgBox "请打开以下链接并输入验证码：" & vbCrLf & _
           jsonObj("verification_uri") & vbCrLf & _
           "验证码：" & jsonObj("user_code"), vbInformation, "Teams权限授权"
    
    ' 第二步：轮询获取访问Token
    Do
        xmlHttp.Open "POST", "https://login.microsoftonline.com/" & tenantId & "/oauth2/v2.0/token", False
        xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        xmlHttp.send "grant_type=urn:ietf:params:oauth:grant-type:device_code&client_id=" & clientId & "&device_code=" & jsonObj("device_code")
        
        response = xmlHttp.responseText
        Set jsonObj = JsonConverter.ParseJson(response)
        
        ' 成功获取Token则返回
        If jsonObj.Exists("access_token") Then
            GetGraphAccessToken = jsonObj("access_token")
            Exit Function
        End If
        
        ' 按API要求的间隔等待后重试
        Wait jsonObj("interval")
    Loop
End Function

' 辅助等待函数（避免脚本假死）
Sub Wait(seconds As Integer)
    Dim endTime As Date
    endTime = DateAdd("s", seconds, Now())
    Do While Now() < endTime
        DoEvents
    Loop
End Sub

2. 检查指定群聊是否存在 #

这个函数会调用Graph API获取当前用户的所有聊天，通过匹配聊天主题（仅群聊有主题，一对一聊天无主题）判断是否存在：

Function ChatExists(chatName As String, accessToken As String) As Boolean
    Dim xmlHttp As Object
    Dim response As String
    Dim jsonObj As Object
    Dim chat As Object
    
    Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    xmlHttp.Open "GET", "https://graph.microsoft.com/v1.0/me/chats?$select=id,topic", False
    xmlHttp.setRequestHeader "Authorization", "Bearer " & accessToken
    xmlHttp.send
    
    response = xmlHttp.responseText
    Set jsonObj = JsonConverter.ParseJson(response)
    
    ' 遍历所有聊天，忽略大小写匹配主题
    For Each chat In jsonObj("value")
        If chat.Exists("topic") Then
            If LCase(chat("topic")) = LCase(chatName) Then
                ChatExists = True
                Exit Function
            End If
        End If
    Next chat
    
    ChatExists = False
End Function

3. 创建新群聊并完成初始化 #

如果聊天不存在，调用这个函数创建新群聊、发送初始消息，并添加指定用户（支持传入邮箱数组）：

Sub CreateTeamsChat(chatName As String, initialMessage As String, userEmails As Variant, accessToken As String)
    Dim xmlHttp As Object
    Dim postData As String
    Dim jsonObj As Object
    Dim chatId As String
    Dim i As Integer
    
    ' 1. 创建群聊
    Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    xmlHttp.Open "POST", "https://graph.microsoft.com/v1.0/chats", False
    xmlHttp.setRequestHeader "Authorization", "Bearer " & accessToken
    xmlHttp.setRequestHeader "Content-Type", "application/json"
    
    ' 构造请求体：包含聊天主题和成员列表
    Set jsonObj = CreateObject("Scripting.Dictionary")
    jsonObj("topic") = chatName
    
    Dim memberList As Collection
    Set memberList = New Collection
    
    ' 添加当前用户为群所有者
    Dim ownerMember As Object
    Set ownerMember = CreateObject("Scripting.Dictionary")
    ownerMember("@odata.type") = "#microsoft.graph.aadUserConversationMember"
    ownerMember("roles") = Array("owner")
    ownerMember("user@odata.bind") = "https://graph.microsoft.com/v1.0/me"
    memberList.Add ownerMember
    
    ' 添加指定外部用户为群成员
    For i = LBound(userEmails) To UBound(userEmails)
        Dim newMember As Object
        Set newMember = CreateObject("Scripting.Dictionary")
        newMember("@odata.type") = "#microsoft.graph.aadUserConversationMember"
        newMember("roles") = Array("member")
        newMember("user@odata.bind") = "https://graph.microsoft.com/v1.0/users/" & userEmails(i)
        memberList.Add newMember
    Next i
    
    jsonObj("members") = memberList
    postData = JsonConverter.ConvertToJson(jsonObj)
    xmlHttp.send postData
    
    ' 获取新创建的聊天ID
    chatId = JsonConverter.ParseJson(xmlHttp.responseText)("id")
    
    ' 2. 发送初始消息
    Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    xmlHttp.Open "POST", "https://graph.microsoft.com/v1.0/chats/" & chatId & "/messages", False
    xmlHttp.setRequestHeader "Authorization", "Bearer " & accessToken
    xmlHttp.setRequestHeader "Content-Type", "application/json"
    
    Dim messageObj As Object
    Set messageObj = CreateObject("Scripting.Dictionary")
    messageObj("body") = CreateObject("Scripting.Dictionary")
    messageObj("body")("contentType") = "text"
    messageObj("body")("content") = initialMessage
    
    postData = JsonConverter.ConvertToJson(messageObj)
    xmlHttp.send postData
    
    MsgBox "新聊天【" & chatName & "】已创建完成！" & vbCrLf & "初始消息已发送，指定用户已添加。", vbInformation
End Sub

三、主程序入口（可直接运行） #

把你的业务参数填入后，运行这个主程序即可完成全流程：

Sub Main()
    ' 替换为你的Azure AD应用信息
    Dim clientId As String: clientId = "你的客户端ID"
    Dim tenantId As String: tenantId = "你的租户ID"
    
    ' 替换为你的业务参数
    Dim targetChatName As String: targetChatName = "Q3项目协作群"
    Dim initialMsg As String: initialMsg = "这是Excel VBA自动创建的协作群，请大家进群同步项目进度！"
    Dim userEmails As Variant: userEmails = Array("user1@yourcompany.com", "user2@yourcompany.com")
    
    Dim accessToken As String
    
    ' 获取Graph API访问Token
    accessToken = GetGraphAccessToken(clientId, tenantId)
    
    ' 检查聊天是否存在
    If ChatExists(targetChatName, accessToken) Then
        MsgBox "聊天【" & targetChatName & "】已存在，无需重复创建！", vbInformation
    Else
        ' 创建新聊天
        CreateTeamsChat targetChatName, initialMsg, userEmails, accessToken
    End If
End Sub

四、关键注意事项 #

• 权限踩坑提醒：我当时只开了Chat.ReadWrite权限，结果添加用户时一直报错，后来才发现必须同时开通ChatMember.ReadWrite和User.Read.All
• VBA-JSON导入：需要把VBA-JSON的代码导入到VBA项目的独立模块中，命名为JsonConverter，否则无法解析JSON
• Token过期处理：如果脚本需要长期运行，记得添加Token过期检测逻辑，或利用offline_access权限实现Token刷新
• 一对一聊天适配：如果需求是检查一对一聊天，不能用topic匹配，需要通过成员列表是否为指定的两个用户来判断，逻辑需稍作调整

如果调试时遇到API错误，可以打印xmlHttp.responseText查看详细错误信息，Graph API的错误提示非常直观。希望这个方案能帮到你，有问题随时沟通！

BR,
[你的昵称]