'▲▲▲ API配置區(qū) ，ExcelHome祝各位道友新年快樂！@20250204▲▲▲Const AI_URL As String = "API網(wǎng)址，從官網(wǎng)獲取"Const AI_KEY As String = "API KEY，從官網(wǎng)獲取"Const AI_MODEL As String = "模型的名稱，按官網(wǎng)的指示填寫"
'AI交互函數(shù)，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. 網(wǎng)絡(luò)連接問題" & vbCrLf & _                                "2. API服務(wù)繁忙" & vbCrLf & _                                "是否重試？"    Const PROCESSING_MSG As String = "AI分析中，已耗時 "
    On Error GoTo ErrorHandlerSet oXmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
'▲▲▲ 超時參數(shù)配置 ▲▲▲    oXmlHttp.setTimeouts 5000, 8000, 20000, 60000
    '▼▼▼ 構(gòu)建專業(yè)請求 ▼▼▼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
    '▼▼▼ 響應(yīng)處理 ▼▼▼If oXmlHttp.Status = 200 Then        apiResponse = oXmlHttp.responseText        GetAIResponse = ExtractJSONContent(apiResponse)Else        Err.Raise vbObjectError + 1, , "API錯誤：" & oXmlHttp.Status & " - " & oXmlHttp.statusTextEnd If
Exit Function
ErrorHandler:If Err.Number = -2147012894 ThenIf MsgBox(TIMEOUT_MSG, vbExclamation + vbRetryCancel) = vbRetry Then ResumeElse        MsgBox "AI交互錯誤：" & Err.Description, vbCriticalEnd If    GetAIResponse = "錯誤：" & Err.DescriptionFinally:    Application.StatusBar = FalseSet oXmlHttp = NothingEnd Function
'輔助函數(shù)：JSON轉(zhuǎn)義Private Function JSONEscape(str As String) As String    JSONEscape = Replace(Replace(Replace(str, "\", "\\"), """", "\"""), vbCrLf, "\n")End Function
'輔助函數(shù)：提取JSON內(nèi)容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

'主任務(wù)：數(shù)據(jù)處理流程，ExcelHome祝各位道友新年快樂！Sub MainTask()    Dim prompt As String, aiResponse As String    Dim ws As Worksheet
    On Error GoTo ErrorHandler    Set ws = ActiveSheet
    '▼▼▼ 數(shù)據(jù)準備 ▼▼▼    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).ValueEnd With
'▲▲▲ 構(gòu)建專業(yè)提示詞 ▲▲▲    prompt = "請進行專業(yè)的命理推算分析：" & vbCrLf & _            "姓名：" & userName & vbCrLf & _            "出生日期：" & birthDate & vbCrLf & _            "性別：" & gender & vbCrLf & _            "要求：1. 簡要概括八字格局 2. 簡要解讀大運走勢 3. 給出人生建議 4. 使用小白能看懂的方式輸出，減少專業(yè)術(shù)語"
    '▼▼▼ AI交互 ▼▼▼    aiResponse = GetAIResponse(prompt)
'▲▲▲ 結(jié)果輸出 ▲▲▲    ws.Range("A4").Value = aiResponse    ws.Range("A4").WrapText = True    Exit Sub
ErrorHandler:    MsgBox "處理數(shù)據(jù)時發(fā)生錯誤：" & Err.Description, vbCriticalEnd Sub