一分钟教你如何在Excel中接入DeepSeek! 我们一起帮哪吒逆天改命

'▲▲▲ API配置区 ，ExcelHome祝各位道友新年快乐！@20250204▲▲▲
Const AI_URL As String = "API网址，从官网获取"
Const AI_KEY As String = "API KEY，从官网获取"
Const AI_MODEL As String = "模型的名称，按官网的指示填写"
'AI交互函数，ExcelHome祝各位道友新年快乐！
Private Function GetAIResponse(prompt As String) As String    
Dim oXmlHttp As Object, requestBody As String    
Dim startTime As Double, apiResponse As String
Const TIMEOUT_MSG As String = "请求超时，可能原因：" & vbCrLf & _ "1. 网络连接问题" & vbCrLf & _ "2. API服务繁忙" & vbCrLf & _ "是否重试？"    
Const PROCESSING_MSG As String = "AI分析中，已耗时 "
On Error GoTo ErrorHandler
Set oXmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
'▲▲▲ 超时参数配置 ▲▲▲    
oXmlHttp.setTimeouts 5000, 8000, 20000, 60000
'▼▼▼ 构建专业请求 ▼▼▼
With oXmlHttp        
.Open "POST", AI_URL, False
.setRequestHeader "Content-Type", "application/json;"        
.setRequestHeader "Authorization", "Bearer " & AI_KEY        
.setRequestHeader "Accept", "*/*"
End With
requestBody = "{""model"":""" & AI_MODEL & """," & _"""messages"":[{""role"":""user"",""content"":""" & JSONEscape(prompt) & """}]," & _"""temperature"":0.7,""max_tokens"":512}"
'▲▲▲ 异步处理控制 ▲▲▲    
startTime = Timer    
oXmlHttp.send requestBody
Do While oXmlHttp.readyState <> 4        
If Timer - startTime > 60 Then            
If MsgBox(TIMEOUT_MSG & "耗时：" & Format(Timer - startTime, "0.0") & "秒", _                      
vbCritical + vbRetryCancel) = vbRetry Then                
oXmlHttp.abort                
startTime = Timer                
oXmlHttp.send requestBody            
Else                
Exit Function           
End If        
End If        
DoEvents        
Application.StatusBar = PROCESSING_MSG & Format(Timer - startTime, "0.0") & "秒"    
Loop
 '▼▼▼ 响应处理 ▼▼▼
 If oXmlHttp.Status = 200 Then        
 apiResponse = oXmlHttp.responseText        
 GetAIResponse = ExtractJSONContent(apiResponse)Else        
 Err.Raise vbObjectError + 1, , "API错误：" & oXmlHttp.Status & " - " & oXmlHttp.statusText
 End If
Exit Function
ErrorHandler:
If Err.Number = -2147012894 Then
If MsgBox(TIMEOUT_MSG, vbExclamation + vbRetryCancel) = vbRetry Then Resume
Else        
MsgBox "AI交互错误：" & Err.Description, vbCritical
End If    
GetAIResponse = "错误：" & Err.Description
Finally:    
Application.StatusBar = False
Set oXmlHttp = Nothing
End Function
'辅助函数：JSON转义
Private Function JSONEscape(str As String) As String
 JSONEscape = Replace(Replace(Replace(str, "\", "\\"), """", "\"""), vbCrLf, "\n")
End Function
'辅助函数：提取JSON内容
Private Function ExtractJSONContent(responseText As String) As String    
Dim contentStart As Long, contentEnd As Long    
contentStart = InStr(responseText, """content"":""") + 11    
contentEnd = InStr(contentStart, responseText, """")    
ExtractJSONContent = Replace(Mid(responseText, contentStart, contentEnd - contentStart), "\n", vbCrLf)
End Function
'主任务：数据处理流程，ExcelHome祝各位道友新年快乐！
Sub MainTask()    
Dim prompt As String, aiResponse As String    
Dim ws As Worksheet
On Error GoTo ErrorHandler    
Set ws = ActiveSheet
'▼▼▼ 数据准备 ▼▼▼    
Dim userName As String, birthDate As String, gender As StringWith ws.Range("A2:C2")        
userName = .Cells(1, 1).Value        
birthDate = .Cells(1, 2).Value        
gender = .Cells(1, 3).Value
End With
'▲▲▲ 构建专业提示词 ▲▲▲    
prompt = "请进行专业的命理推算分析：" & vbCrLf & _            
"姓名：" & userName & vbCrLf & _            
"出生日期：" & birthDate & vbCrLf & _            
"性别：" & gender & vbCrLf & _            
"要求：1. 简要概括八字格局 2. 简要解读大运走势 3. 给出人生建议 4. 使用小白能看懂的方式输出，减少专业术语"
 '▼▼▼ AI交互 ▼▼▼    
 aiResponse = GetAIResponse(prompt)
'▲▲▲ 结果输出 ▲▲▲    
ws.Range("A4").Value = aiResponse    
ws.Range("A4").WrapText = True    
Exit Sub
ErrorHandler:    
MsgBox "处理数据时发生错误：" & Err.Description, vbCritical
End Sub