Option Explicit' WinINet api定义Private Declare Function InternetOpenW Lib "wininet.dll" (ByVal lpszAgent As Long, ByVal dwAccessType As Long, ByVal lpszProxy As Long, ByVal lpszProxyBypass As Long, ByVal dwFlags As Long) As LongPrivate Declare Function InternetConnectW Lib "wininet.dll" (ByVal hInternet As Long, ByVal lpszServerName As Long, ByVal nServerPort As Long, ByVal lpszUsername As Long, ByVal lpszPassword As Long, ByVal dwService As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As LongPrivate Declare Function HttpOpenRequestW Lib "wininet.dll" (ByVal hConnect As Long, ByVal lpszVerb As Long, ByVal lpszObjectName As Long, ByVal lpszVersion As Long, ByVal lpszReferrer As Long, ByVal lplpszAcceptTypes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As LongPrivate Declare Function HttpSendRequestW Lib "wininet.dll" (ByVal hRequest As Long, ByVal lpszHeaders As Long, ByVal dwHeadersLength As Long, ByRef lpOptional As Any, ByVal dwOptionalLength As Long) As LongPrivate Declare Function HttpQueryInfoW Lib "wininet.dll" (ByVal hRequest As Long, ByVal dwInfoLevel As Long, ByRef lpvBuffer As Any, ByRef lpdwBufferLength As Long, ByRef lpdwIndex As Long) As LongPrivate Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal dwNumberOfBytesToRead As Long, ByRef lpdwNumberOfBytesRead As Long) As LongPrivate Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInternet As Long) As LongPrivate Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)' WinINet 网络常量定义Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1Private Const INTERNET_SERVICE_HTTP As Long = 3Private Const INTERNET_DEFAULT_HTTPS_PORT As Long = 443Private Const INTERNET_FLAG_SECURE As Long = &H800000 ' 启用 HTTPS/SSLPrivate Const INTERNET_FLAG_RELOAD As Long = &H80000000 ' 强制从服务器下载Private Const INTERNET_FLAG_NO_CACHE_WRITE As Long = &H400000 ' 禁用本地缓存Private Const HTTP_QUERY_STATUS_CODE As Long = 19 ' 获取 HTTP 状态码的指令' 定义事件Event DeepSeekResult(content)' 全局属性Private m_SystemPrompt As StringPrivate m_ApiKey As StringPrivate m_Thinking As BooleanPrivate m_model As String' -- apikey 设置 ----Public Property Get ApiKey() As String ApiKey = m_ApiKeyEnd PropertyPublic Property Let ApiKey(ByVal vNewValue As String) m_ApiKey = vNewValueEnd Property' -- 系统提示词 设置 ----Public Property Get SystemPrompt() As String SystemPrompt = m_SystemPromptEnd PropertyPublic Property Let SystemPrompt(ByVal vNewValue As String) m_SystemPrompt = vNewValueEnd Property' -- 思考 设置 ----Public Property Get Thinking() As Boolean Thinking = m_ThinkingEnd PropertyPublic Property Let Thinking(ByVal vNewValue As Boolean) m_Thinking = vNewValueEnd Property' -- 模型 设置 ----Public Property Get Model() As String Model = m_modelEnd PropertyPublic Property Let Model(ByVal vNewValue As String) m_model = vNewValueEnd Property' DeepSeek 实时流式请求与异常捕获Sub RunDeepSeekRealTimeSSE(inputText As String) ' 定义网络句柄 Dim hInternet As Long, hConnect As Long, hRequest As Long ' 配置参数 Dim serverName As String: serverName = "api.deepseek.com" Dim objectName As String: objectName = "/chat/completions" ' ---- Dim think As String If Thinking Then think = "enabled" Else think = "disabled" End If ' 构造你给出的 JSON 请求体 Dim postData As String postData = "{""messages"":[{""content"":""" & JsonEscape(SystemPrompt) & """,""role"":""system""},{""content"":""" & inputText & """,""role"":""user""}],""model"":""" & Model & """,""thinking"":{""type"":""" & think & """},""reasoning_effort"":""high"",""max_tokens"":4096,""response_format"":{""type"":""text""},""stream"":true,""temperature"":1}" ' Debug.Print postData ' 构造标准的网络请求头 Dim headers As String headers = "Accept: text/event-stream" & vbCrLf & _ "Authorization: Bearer " & ApiKey & vbCrLf & _ "Content-Type: application/json" & vbCrLf & _ "Cache-Control: no-cache" & vbCrLf ' 将 String 转换为符合现代网络 API 要求的 UTF-8 二进制字节流 Dim postBytes() As Byte postBytes = StringToUTF8Bytes(postData) ' 开始建立底层连接 hInternet = InternetOpenW(StrPtr("VBA_DeepSeek_SSE_Client"), INTERNET_OPEN_TYPE_DIRECT, 0, 0, 0) If hInternet = 0 Then MsgBox "初始化 WinINet 环境失败", vbCritical GoTo CleanUp End If hConnect = InternetConnectW(hInternet, StrPtr(serverName), INTERNET_DEFAULT_HTTPS_PORT, 0, 0, INTERNET_SERVICE_HTTP, 0, 0) If hConnect = 0 Then MsgBox "连接服务器失败", vbCritical GoTo CleanUp End If hRequest = HttpOpenRequestW(hConnect, StrPtr("POST"), StrPtr(objectName), 0, 0, 0, _ INTERNET_FLAG_SECURE Or INTERNET_FLAG_RELOAD Or INTERNET_FLAG_NO_CACHE_WRITE, 0) If hRequest = 0 Then MsgBox "创建 HTTP 请求句柄失败", vbCritical GoTo CleanUp End If ' 发送请求并校验连接状态 Dim sendResult As Long sendResult = HttpSendRequestW(hRequest, StrPtr(headers), Len(headers), postBytes(0), UBound(postBytes) + 1) If sendResult = 0 Then MsgBox "请求发送失败，可能无法触达 API 服务器（请检查网络连接）。", vbCritical GoTo CleanUp End If ' 捕获 HTTP 状态异常 Dim statusCode As Long Dim statusCodeBuffer(0 To 31) As Byte Dim bufferLength As Long: bufferLength = UBound(statusCodeBuffer) + 1 Dim index As Long: index = 0 ' 提取 HTTP 状态头中的 Code 字符串 If HttpQueryInfoW(hRequest, HTTP_QUERY_STATUS_CODE, statusCodeBuffer(0), bufferLength, index) <> 0 Then Dim statusStr As String statusStr = Left(statusCodeBuffer, bufferLength / 2) ' Unicode双字节转换 statusCode = Val(statusStr) Else statusCode = 0 End If ' 状态异常拦截 If statusCode <> 200 Then Debug.Print "捕获到 HTTP 状态异常! 状态码: " & statusCode RaiseEvent DeepSeekResult("捕获到 HTTP 状态异常! 状态码: " & statusCode) ' 抓取服务器返回的详细错误文本（如 401 鉴权未通过、400 参数格式错误等详细提示） Dim errBuffer(0 To 4096) As Byte Dim errBytesRead As Long Dim errText As String If InternetReadFile(hRequest, errBuffer(0), UBound(errBuffer) + 1, errBytesRead) <> 0 Then errText = BytesToBstr(errBuffer, errBytesRead) Debug.Print "服务器详细报错信息: " & errText RaiseEvent DeepSeekResult("HTTP 请求异常 (状态码 " & statusCode & "): " & vbCrLf & errText) Else RaiseEvent DeepSeekResult("网络请求失败，响应状态码: " & statusCode) End If GoTo CleanUp ' 发生异常，拦截并终止后续的 SSE 接收逻辑 End If ' 状态码 200 OK，开始“真·实时”按行接收流式数据 Dim buffer(0 To 4096) As Byte ' 4KB 接收缓冲区 Dim bytesRead As Long Dim lineBuffer As String Dim chunkText As String Dim lfPos As Long Dim line As String Dim dataContent As String lineBuffer = "" ' 循环读取数据 Do ' 直接面向 TCP 套接字读取驱动层刚到达的字节 If InternetReadFile(hRequest, buffer(0), UBound(buffer) + 1, bytesRead) = 0 Then Exit Do If bytesRead = 0 Then Exit Do ' 数据全部传输完毕，服务器正常关闭连接 ' 立即转换当前抓取到的这几百个/几千个字节为 UTF-8 文本并追加到行缓冲区 chunkText = BytesToBstr(buffer, bytesRead) lineBuffer = lineBuffer & chunkText ' 读取流数据 lfPos = InStr(lineBuffer, vbLf) Do While lfPos > 0 line = Trim(Left(lineBuffer, lfPos - 1)) lineBuffer = Mid(lineBuffer, lfPos + 1) ' 解析标准 SSE 协议结构 If Len(line) > 0 And Left(line, 5) = "data:" Then dataContent = Trim(Mid(line, 6)) ' 捕获大模型结束标记 [DONE] If UCase(dataContent) = "[DONE]" Then GoTo CleanUp ' 终止流程 End If ' 这里是真正的逐行实时响应输出 ' Debug.Print dataContent RaiseEvent DeepSeekResult(Replace(GetJsonContent(dataContent), "\n", vbLf)) End If ' 继续检索这一批到达的缓冲区文本中是否还有换行符 lfPos = InStr(lineBuffer, vbLf) Loop ' 让出 CPU 时间片 DoEvents Sleep 5 LoopCleanUp: ' 释放和关闭底层网络句柄，防止内存泄露和句柄死锁 If hRequest <> 0 Then InternetCloseHandle hRequest If hConnect <> 0 Then InternetCloseHandle hConnect If hInternet <> 0 Then InternetCloseHandle hInternetEnd Sub' 底层高效率的编码转化辅助函数' 【二进制字节流 转 UTF-8字符串】Function BytesToBstr(ByRef bytes() As Byte, ByVal length As Long) As String If length <= 0 Then Exit Function Dim xStr As Object Set xStr = CreateObject("ADODB.Stream") xStr.Type = 1: xStr.Open Dim tempBytes() As Byte: ReDim tempBytes(0 To length - 1) Dim i As Long: For i = 0 To length - 1: tempBytes(i) = bytes(i): Next i xStr.Write tempBytes: xStr.Position = 0 xStr.Type = 2: xStr.Charset = "utf-8" BytesToBstr = xStr.ReadText: xStr.CloseEnd Function' 【字符串 转 UTF-8二进制字节流】Function StringToUTF8Bytes(ByVal Text As String) As Byte() If Text = "" Then: StringToUTF8Bytes = Split(""): Exit Function Dim xStr As Object Set xStr = CreateObject("ADODB.Stream") xStr.Type = 2: xStr.Charset = "utf-8": xStr.Open xStr.WriteText Text: xStr.Position = 0: xStr.Type = 1 xStr.Position = 3 ' 剔除文本前端自动携带的 3 字节 UTF-8 BOM 头 StringToUTF8Bytes = xStr.Read: xStr.CloseEnd Function' 解析jsonFunction GetJsonContent(ByVal jsonStr As String) As String On Error GoTo ErrHandle Dim jsCov As Object: Set jsCov = JsonConverter.ParseJson(jsonStr) If TypeOf jsCov Is Dictionary Then Dim jsDic As Dictionary: Set jsDic = jsCov If jsDic.Exists("choices") Then Dim jsChoices As Collection: Set jsChoices = jsDic.Item("choices") If jsChoices.Count > 0 Then Dim jsDicChoItem As Dictionary: Set jsDicChoItem = jsChoices.Item(1) If jsDicChoItem.Exists("delta") Then Dim jsDelta As Dictionary: Set jsDelta = jsDicChoItem.Item("delta") If jsDelta.Exists("content") Then Dim jsContent As Variant: jsContent = jsDelta.Item("content") If Not IsNull(jsContent) And VarType(jsContent) = vbString Then GetJsonContent = CStr(jsContent) End If End If End If End If End If End If Exit FunctionErrHandle: GetJsonContent = ""End FunctionPublic Function JsonEscape(ByVal strSrc As String) As String Dim s As String ' 第一步：优先标准化换行（解决vbCrLf拆分丢失字符） s = Replace(strSrc, vbCrLf, "\n") s = Replace(s, vbLf, "\n") s = Replace(s, vbCr, "\r") s = Replace(s, vbTab, "\t") ' 第二步：转义关键JSON符号 s = Replace(s, "\", "\\") ' 先转义反斜杠！顺序绝对不能乱 s = Replace(s, """", "\""") ' 第三步：清除 0~31 真正的非法控制字符（保留所有可见内容） Dim res As String Dim i As Long Dim c As Long res = "" For i = 1 To Len(s) c = AscW(Mid$(s, i, 1)) ' 只删除：空字符、退格等无效控制码 ' 已经转义的 \n \r \t 字符码会正常保留，不会被误删 If (c < 32) And (c <> 9 And c <> 10 And c <> 13) Then ' 跳过非法控制字符 Else res = res & Mid$(s, i, 1) End If Next i JsonEscape = resEnd Function
