'▲▲▲ 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 ErrorHandler
Set 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.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
'輔助函數(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).Value
End 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, vbCritical
End Sub