你是否也想拥有PPT AI？看看吧，麻烦点个小心心，球球了~

注意：

由于本人不会对错误进行修改，所以使用了AI来检查错误，代码部分可能含有AI味（已声明）

本文章针对DeepSeek编写，同时文章的文案部分由AI辅助编写

由于直接把错误丢给AI修改，所以代码风格可能全是AI，请见谅（毕竟AI不懂我写代码的风格）

准备

API可前往DeepSeek开放平台获取点击前往

在PPT中启用宏

打开PowerPoint，点击左上角「文件」→「选项」→「信任中心」→「信任中心设置」→「宏设置」。
选择「启用所有宏」（或者「禁用所有宏，并发出通知」，然后每次打开时启用）。
同时勾选「信任对VBA工程对象模型的访问」。

控件教程

如果你不会VBA控件的使用，请查看POSM的教程点击前往

页面素材准备

准备三个文本框和一个圆角矩形（模拟按钮）即可：

一个文本框：输入问题
一个文本框：获取答复
一个文本框：存放API密钥
一个圆角矩形：触发AI请求按钮

开始制作

首先，你可以先新建一个模块写入代码，先搭基础壳：

Sub AI()

End Sub

其次我们解析代码部分（代码需自行整合，我只提供方法思路）

1. 声明变量 / 检测放映状态

声明DeepSeek接口常量：

Const AIURL As String = "https://api.deepseek.com/v1/chat/completions"

如果你想要检测是否在放映中，可以使用：

If SlideShowWindows.Count = 0 Then
    MsgBox "请先进入幻灯片放映模式。", vbExclamation
    Exit Sub
End If

2. 检测文本框是否为空

If Trim(ActivePresentation.SlideShowWindow.View.Slide.Shapes("111").OLEFormat.Object.Text) = "" Then 
    MsgBox "请输入内容"
End If

3. 核心函数分步讲解

3.1 建立网络请求对象

Private Function SendRequest(body As String, apiKey As String) As String
    Dim http As Object
    Set http = CreateObject("MSXML2.XMLHTTP.6.0")

教学：上网发送请求用的MSXML2.XMLHTTP.6.0 是Windows系统自带，无需额外安装任何软件。

3.2 打开POST地址

http.Open "POST", "https://api.deepseek.com/v1/chat/completions", False

教学：用于记录需要访问哪个地址，False参数表示访问不成功就直接结束访问（同步等待响应）。

3.3 填写请求头鉴权

http.setRequestHeader "Content-Type", "application/json"
http.setRequestHeader "Authorization", "Bearer " & apiKey

教学：这段是递交信息格式与密钥鉴权，api参数需要提前读取文本框声明。

3.4 发送JSON包体

http.Send body

教学：把拼装好的问题JSON数据包正式传给AI服务器。

3.5 判断返回是否成功

If http.Status = 200 Then SendRequest = http.responseText
End Function

教学：如果访问状态码为「200」就是访问成功，返回一整段原始JSON；不成功直接为空。

3.5.1 读取文本框并拼装调用

question = 幻灯片上那个叫「发送问题」的文本框里面的文字
apiKey = 幻灯片叫「APIKey」的文本框里面的文字
body = 把 question 装进JSON格式的信封里
resp = SendRequest(body, apiKey)

3.6 处理JSON取出纯文字

AI返回来的JSON并不是直接可读文字，示例：
{"choices":[{"message":{"content":"你好！我是AI，有什么可以帮你？"}}]}

3.6.1 函数与变量声明

Private Function ExtractContent(json As String) As String
    Dim pos As Long, startPos As Long, endPos As Long

3.6.2 定位内容起始标记

pos = InStr(json, """content"":""")

教学：InStr 是VBA查找位置函数。从json里找 "content":" 第一次出现位置。
代码写成三重双引号是转义规则，实际匹配就是 "content":"。

3.6.3 偏移算出答案起点

startPos = pos + 11

教学："content":" 固定占11个字符，真正回答内容从后面开始。

3.6.4 找到结束双引号

endPos = InStr(startPos, json, """")

教学：从起点往后找下一个双引号，这就是回答结尾边界。

3.6.5 截取原始回答

ExtractContent = Mid(json, startPos, endPos - startPos)

教学：Mid 截取一段字符串，此时内容仍可能带 \n 转义符。

3.6.6 还原换行与符号

ExtractContent = Replace(ExtractContent, "\\", "\")
ExtractContent = Replace(ExtractContent, "\n", vbCrLf)
ExtractContent = Replace(ExtractContent, "\r", "")
ExtractContent = Replace(ExtractContent, "\t", vbTab)
ExtractContent = Replace(ExtractContent, "\""", """")
End Function

教学：把JSON转义符变回正常显示：\n变PPT真实换行、\变回单斜杠等。

举个栗子解析流程

原始JSON：
{"choices":[{"message":{"content":"你好！\n我是AI。"}}]}

运行过程：

InStr 找到 "content":" 位置（假设第30位）
startPos = 30 + 11 = 41
往后找到结尾双引号（假设第55位）
截取得到：你好！\n我是AI。

替换转义最终显示：

你好！
我是AI。

3.7 内容转义防JSON报错

发给AI必须是标准JSON，用户输入含 " \ 换行极易炸格式，所以先转义。

3.7.1 入口复制原文

Private Function EscapeJson(text As String) As String
    Dim result As String
    result = text

3.7.2 转义反斜杠

result = Replace(result, "\", "\\")

教学：单个\必须写成\，否则JSON会误认转义符。

3.7.3 转义双引号

result = Replace(result, """", "\""")

教学：用户说话带引号必须加转义，否则JSON提前断句崩溃。

3.7.4 转义常规换行

result = Replace(result, vbCrLf, "\n")
result = Replace(result, vbLf, "\n")

3.7.5 转义回车

result = Replace(result, vbCr, "\r")

3.7.6 转义Tab制表

result = Replace(result, vbTab, "\t")

3.7.7 输出安全文本

EscapeJson = result
End Function

最终整合：三大核心完整代码

Private Function SendRequest(body As String, apiKey As String) As String
    Dim http As Object
    Set http = CreateObject("MSXML2.XMLHTTP.6.0")
    http.Open "POST", "https://api.deepseek.com/v1/chat/completions", False
    http.setRequestHeader "Content-Type", "application/json"
    http.setRequestHeader "Authorization", "Bearer " & apiKey
    http.Send body
    If http.Status = 200 Then SendRequest = http.responseText
End Function

Private Function ExtractContent(json As String) As String
    Dim pos As Long, startPos As Long, endPos As Long
    pos = InStr(json, """content"":""")
    If pos = 0 Then Exit Function
    startPos = pos + 11
    endPos = InStr(startPos, json, """")
    If endPos = 0 Then Exit Function
    ExtractContent = Mid(json, startPos, endPos - startPos)
    ExtractContent = Replace(ExtractContent, "\\", "\")
    ExtractContent = Replace(ExtractContent, "\n", vbCrLf)
    ExtractContent = Replace(ExtractContent, "\r", "")
    ExtractContent = Replace(ExtractContent, "\t", vbTab)
    ExtractContent = Replace(ExtractContent, "\""", """")
End Function

Private Function EscapeJson(text As String) As String
    Dim result As String
    result = text
    result = Replace(result, "\", "\\")
    result = Replace(result, """", "\""")
    result = Replace(result, vbCrLf, "\n")
    result = Replace(result, vbLf, "\n")
    result = Replace(result, vbCr, "\r")
    result = Replace(result, vbTab, "\t")
    EscapeJson = result
End Function

这个就是核心函数了，核心部分就讲完了，其他部分自己看着制作就行

可能特别像ai，但初稿是本人一个字母一个字母打出来的，制作不易，点个赞吧

当然了，我可以免费适配，不过前提是我得设工程密码，所以可以在你的pptos完成后再来让我帮忙适配

本人自愿，完全免费😀😀😀