DeepSeek自定义函数在测量中的应用

Dim BASE_URL As String
Dim API_KEY As String
Dim API_MODEL As String

‘ 添加单元格处理相关常量
Private Const CELL_PLACEHOLDER As String = “□” ‘ 空单元格占位符
Private Const CELL_SEPARATOR As String = ” | ” ‘ 单元格分隔符
Private Const ROW_SEPARATOR As String = vbNewLine ‘ 行分隔符

‘部分源码来源：bilibili UP主

Function Chat_Function(userContent As String, Optional systemMessage As String = “你是一个乐于助人的AI助手，请根据用户的问题给出详细的解答。”) As String ‘对话函数
Dim httpRequest As Object
Dim requestBody As String
Dim responseText As String
Dim csp As String
On Error GoTo ErrorHandler
Application.Calculation = xlManual ‘关闭自动重算

csp = “硅基流动” ‘云服务商(必填)，以硅基流动为例
BASE_URL = “https://api.siliconflow.cn/v1/chat/completions” ‘base_url(必填)
API_KEY = “请输入你在硅基流动申请的API密钥” ‘api_key(必填)
API_MODEL = “Pro/deepseek-ai/DeepSeek-V3” ‘模型名model(必填)

‘ 创建HTTP对象（兼容64位Excel）
Set httpRequest = CreateObject(“MSXML2.XMLHTTP.6.0”)

If csp = “火山引擎” Then

‘ 构建符合火山引擎要求的请求体
requestBody = “{ ” & _
“””model””: “”” & API_MODEL & “””, ” & _
“””messages””: [” & _
“{“”role””: “”system””, “”content””: “”” & json_Encode(systemMessage) & “””},” & _
“{“”role””: “”user””, “”content””: “”” & json_Encode(userContent) & “””}” & _
“]” & _
“}”

ElseIf csp = “DeepSeek” Then

‘ 构建符合DeepSeek要求的请求体
requestBody = “{ ” & _
“””model””: “”” & API_MODEL & “””, ” & _
“””messages””: [” & _
“{“”role””: “”system””, “”content””: “”” & systemMessage & “””},” & _
“{“”role””: “”user””, “”content””: “”” & json_Encode(userContent) & “””}” & _
“], ” & _
“””stream””: false” & _
“}”

ElseIf csp = “硅基流动” Then

‘ 构建符合硅基流动要求的请求体
requestBody = “{ ” & _
“””model””: “”” & API_MODEL & “””, ” & _
“””messages””: [” & _
“{“”role””: “”system””, “”content””: “”” & systemMessage & “””},” & _
“{“”role””: “”user””, “”content””: “”” & json_Encode(userContent) & “””}” & _
“], ” & _
“””temperature””: 0″ & _
“}”

End If

‘ 发送API请求
With httpRequest
.Open “POST”, BASE_URL, False
.setRequestHeader “Content-Type”, “application/json”
.setRequestHeader “Authorization”, “Bearer ” & API_KEY
.send requestBody
End With

‘ 处理响应
If httpRequest.status = 200 Then
responseText = httpRequest.responseText

‘ 使用正则表达式提取内容
Dim regEx As Object
Set regEx = CreateObject(“VBScript.RegExp”)
regEx.Global = True
regEx.Pattern = “””content””\s*:\s*””((?:\\””|[^””])*)”””

Dim matches As Object
Set matches = regEx.Execute(responseText)

If matches.Count > 0 Then
Chat_Function = DecodeJSON(matches(0).SubMatches(0))
Else
Chat_Function = “错误：未找到有效响应内容”
End If
Else
Chat_Function = GetStatusError(httpRequest.status, httpRequest.statusText)
End If

Application.Calculation = xlAutomatic ‘开启自动计算
Set httpRequest = Nothing

Exit Function

ErrorHandler:
Chat_Function = “运行时错误：” & Err.Description
Set httpRequest = Nothing

End Function

‘ JSON转义处理
Private Function EscapeJSON(ByVal text As String) As String
Dim result As String
result = Replace(text, “\”, “\\”)
result = Replace(result, “”””, “\”””)
result = Replace(result, vbCr, “\r”)
result = Replace(result, vbLf, “\n”)
result = Replace(result, vbTab, “\t”)
result = Replace(result, vbBack, “\b”)
result = Replace(result, Chr(12), “\f”)
EscapeJSON = result
End Function

‘ JSON解码处理
Private Function DecodeJSON(ByVal text As String) As String
DecodeJSON = text
DecodeJSON = Replace(DecodeJSON, “\”””, “”””)
DecodeJSON = Replace(DecodeJSON, “\\”, “\”)
DecodeJSON = Replace(DecodeJSON, “\r”, vbCr)
DecodeJSON = Replace(DecodeJSON, “\n”, vbLf)
DecodeJSON = Replace(DecodeJSON, “\t”, vbTab)
DecodeJSON = Replace(DecodeJSON, “\b”, vbBack)
DecodeJSON = Replace(DecodeJSON, “\f”, Chr(12))
‘处理特殊字符
DecodeJSON = Replace(DecodeJSON, “\u003e”, “>”)
DecodeJSON = Replace(DecodeJSON, “\u003c”, “<“)
DecodeJSON = Replace(DecodeJSON, “\u003d”, “=”)
DecodeJSON = Replace(DecodeJSON, “\u0022”, “”””)
DecodeJSON = Replace(DecodeJSON, “\u0027”, “‘”)
DecodeJSON = Replace(DecodeJSON, “\u005c”, “\”)
DecodeJSON = Replace(DecodeJSON, “\u0026”, “&”)
End Function

‘ 状态码错误处理
Private Function GetStatusError(status As Long, statusText As String) As String
Select Case status
Case 400: GetStatusError = “请求参数错误(400)”
Case 401: GetStatusError = “认证失败，请检查API密钥(401)”
Case 403: GetStatusError = “权限不足(403)”
Case 429: GetStatusError = “请求过于频繁，请稍后重试(429)”
Case 500: GetStatusError = “服务器内部错误(500)”
Case 503: GetStatusError = “服务不可用(503)”
Case Else: GetStatusError = “API错误 [” & status & “] ” & statusText
End Select
End Function

‘ 处理单元格引用的函数
Private Function fw(prompt As String) As String
Dim result As String
result = prompt

‘ 正则表达式模式匹配单元格引用
Dim regEx As Object
Set regEx = CreateObject(“VBScript.RegExp”)

‘ 匹配模式：单元格引用（如A1, B2:C3等）
regEx.Pattern = “([A-Za-z]+[0-9]+)(:[A-Za-z]+[0-9]+)?”
regEx.Global = True

Dim matches As Object
Set matches = regEx.Execute(prompt)

‘ 处理每个匹配的单元格引用
Dim match As Object
For Each match In matches
Dim cellRef As String
cellRef = match.Value

‘ 获取单元格值
Dim cellValue As String
On Error Resume Next

If InStr(cellRef, “:”) > 0 Then
‘ 处理单元格范围
cellValue = qy(range(cellRef))
Else
‘ 处理单个单元格
cellValue = d_dyg(range(cellRef))
End If
On Error GoTo 0

‘ 替换提示中的单元格引用为实际值
result = Replace(result, cellRef, cellValue)
Next match

fw = result
End Function

‘ 获取单元格范围的值的函数
Private Function qy(rng As range) As String
If rng Is Nothing Then
qy = “无效区域引用”
Exit Function
End If

Dim result As String
Dim cell As range
Dim currentRow As Long
Dim isFirstCell As Boolean

‘ 添加区域标识，去掉$符号
Dim rangeAddr As String
rangeAddr = Replace(rng.Address(False, False), “$”, “”)
result = rangeAddr & “区域数据：” & ROW_SEPARATOR

‘ 添加列标题（如果范围超过1列）
If rng.Columns.Count > 1 Then
isFirstCell = True
Dim col As range
For Each col In rng.Columns
If Not isFirstCell Then
result = result & CELL_SEPARATOR
End If
result = result & Replace(Split(col.Cells(1).Address, “$”)(1), “$”, “”)
isFirstCell = False
Next col
result = result & ROW_SEPARATOR
End If

‘ 初始化行追踪
currentRow = rng.Row
isFirstCell = True

‘ 处理每个单元格
For Each cell In rng.Cells
‘ 检查是否需要换行
If cell.Row > currentRow Then
result = result & ROW_SEPARATOR
currentRow = cell.Row
isFirstCell = True
End If

‘ 添加分隔符
If Not isFirstCell Then
result = result & CELL_SEPARATOR
End If

‘ 添加单元格值
result = result & IIf(Len(cell.text) = 0, CELL_PLACEHOLDER, cell.text)
isFirstCell = False
Next cell

qy = result
End Function

‘ 处理单个单元格内容的函数
Private Function d_dyg(cell As range) As String
If cell Is Nothing Then
d_dyg = “无效单元格引用”
Exit Function
End If

‘ 获取单元格的实际值，去掉$符号
Dim cellAddr As String
cellAddr = Replace(cell.Address(False, False), “$”, “”)

d_dyg = cellAddr & “的值为” & _
IIf(Len(cell.text) = 0, CELL_PLACEHOLDER, cell.text)
End Function

‘选区：选择工作表某个区域返回的字符串
Function xuanqu(rng As range) As String
Dim result_a As String
Dim result_b As String
Dim cell As range
Dim currentRow As Long
Dim isFirstCell As Boolean

If rng Is Nothing Then
xuanqu = “无效区域引用”
Exit Function
End If

‘ 添加区域标识，去掉$符号
Dim rangeAddr As String
rangeAddr = Replace(rng.Address(False, False), “$”, “”)
result_a = rangeAddr & “区域数据：” & ROW_SEPARATOR

‘ 添加列标题（如果范围超过1列）
If rng.Columns.Count > 1 Then
isFirstCell = True
Dim col As range
For Each col In rng.Columns
If Not isFirstCell Then
result_a = result_a & CELL_SEPARATOR
End If
result_a = result_a & Replace(Split(col.Cells(1).Address, “$”)(1), “$”, “”)
isFirstCell = False
Next col
result_a = result_a & ROW_SEPARATOR
End If

‘ 初始化行追踪
currentRow = rng.Row
isFirstCell = True

‘ 处理每个单元格
For Each cell In rng.Cells
‘ 检查是否需要换行
If cell.Row > currentRow Then
result_a = result_a & ROW_SEPARATOR
currentRow = cell.Row
isFirstCell = True
End If

‘ 添加分隔符
If Not isFirstCell Then
result_a = result_a & CELL_SEPARATOR
End If

‘ 添加单元格值
result_a = result_a & IIf(Len(cell.text) = 0, CELL_PLACEHOLDER, cell.text)
isFirstCell = False
Next cell

result_b = result_a

‘ 正则表达式模式匹配单元格引用
Dim regEx As Object
Set regEx = CreateObject(“VBScript.RegExp”)

‘ 匹配模式：单元格引用（如A1, B2:C3等）
regEx.Pattern = “([A-Za-z]+[0-9]+)(:[A-Za-z]+[0-9]+)?”
regEx.Global = True

Dim matches As Object
Set matches = regEx.Execute(prompt)

‘ 处理每个匹配的单元格引用
Dim match As Object
For Each match In matches
Dim cellRef As String
cellRef = match.Value

‘ 获取单元格值
Dim cellValue As String
On Error Resume Next

If InStr(cellRef, “:”) > 0 Then
‘ 处理单元格范围
cellValue = qy(range(cellRef))
Else
‘ 处理单个单元格
cellValue = d_dyg(range(cellRef))
End If
On Error GoTo 0

‘ 替换提示中的单元格引用为实际值
result_b = Replace(result_b, cellRef, cellValue)
Next match

xuanqu = result_b
End Function