一分钟教会你在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 String
With 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