VBA:ChatGPT返答取得関数

Option Explicit

Function GetGPTres(strQuestion As Variant) As Variant
 
    Dim APIKey As String
    Dim strModel As String
    
    Dim Url As String
    Dim http As Object
    Dim strMessages  As String
    Dim strResponse As String
 
    '*** 初期値設定 *****
    If Len(ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.count).Range("D3").value) < 70 Then
        GetGPTres = "【【【【APIキーが無いためChatGPTを使用できませんでした。】】】】"
        MsgBox "APIキーが無いためAPIを使用できません。"
        Exit Function
    Else
        APIKey = ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.count).Range("D3").value
    End If
    
    strModel = "gpt-3.5-turbo"  'モデル名
    
    'strQuestion = Application.InputBox("質問")  '**質問を変数にセット
    
    If strQuestion = False Or strQuestion = "" Then
    Exit Function
    End If

    
    '*** API処理 ****
    Url = "https://api.openai.com/v1/chat/completions"
    
    Set http = CreateObject("MSXML2.XMLHTTP")

    'リクエストヘッダー
    http.Open "POST", Url, False
    http.setRequestHeader "Content-Type", "application/json"
    http.setRequestHeader "Authorization", "Bearer " & APIKey
    
    'メッセージ作成
    strMessages = "{""model"": """ & strModel & """," & _
                  """messages"": [{""role"": ""user"", ""content"": """ & strQuestion & """}]}"
  
    'リクエスト送信
    http.Send strMessages
    
    strResponse = http.responseText         '結果を変数に代入
    'MsgBox strResponse
    
    If InStr(1, strResponse, "invalid_request", vbTextCompare) > 0 Then
            GetGPTres = "APIキーが無いためChatGPTを使用できませんでした。"
            MsgBox "【【【【APIキーが無いためAPIを使用できません。】】】】"
            Exit Function
        End If
    
    
    Dim JSON As Object
    Set JSON = JsonConverter.ParseJson(strResponse)
  
    ' contentを取得
    On Error Resume Next ' エラーを無視して処理を続ける
    strResponse = JSON("choices")(1)("message")("content")
    On Error GoTo 0 ' エラー無視を解除
    GetGPTres = strResponse
    
    
    
End Function