登録プロンプトによるChatgptAPI返答取得関数

Option Explicit


Function UseChatGPTAndGetRes(Inputs As Range, Optional QorRequestKeyNo As Variant) As String


Dim Temp As String

    If IsMissing(QorRequestKeyNo) Then
        UseChatGPTAndGetRes = "第二引数を入力してください。例:(A1.""数か質問"")"
        Exit Function
    End If


If IsError(QorRequestKeyNo) Then
    UseChatGPTAndGetRes = "エラー: 第二引数はダブルクォーテーションで囲んで入力してください。例:(""数or質問"")"
    Exit Function
End If

Debug.Print QorRequestKeyNo
If Len(QorRequestKeyNo) <= 2 And IsNumeric(QorRequestKeyNo) Or Len(QorRequestKeyNo) <= 1 And Not IsNumeric(QorRequestKeyNo) Then
    
    Temp = "テンプレ"
    
    If VarType(QorRequestKeyNo) <> vbString Then
        UseChatGPTAndGetRes = "エラー: 第二引数は質問か数字を入力してください。例:(""数or質問"")"
        
        Exit Function
    End If

    If Not IsNumeric(QorRequestKeyNo) Then
        UseChatGPTAndGetRes = "エラー: 第二引数には数値のみ入力してください"
        Exit Function
    End If
    
ElseIf Not IsNumeric(QorRequestKeyNo) Then

End If


Dim cell As Range
    Dim combinedText As String

    ' 各セルの値を改行で結合
    For Each cell In Inputs.Cells
        If Not IsEmpty(cell.Value) Then
            combinedText = combinedText & cell.Value & "<br>"
        End If
    Next cell

    ' 最後の改行を削除（任意）
        combinedText = Left(combinedText, Len(combinedText) - 4)

'Inputs = combinedText

Debug.Print combinedText

    'UseChatGPTtoGetRes1 = "正常: " & Vals.Cells(1, 1).Value & "/KeyNo: " & RequestKeyNo
  

Dim ReqKeyNoi, PromptWs As Worksheet, FullPrompts As String
Dim Wants As String, Prompts As String
Set PromptWs = ThisWorkbook.Worksheets(1)


Debug.Print ReqKeyNoi

If Temp <> "" Then
    
    ReqKeyNoi = CLng(StrConv(QorRequestKeyNo, vbNarrow))
    ReqKeyNoi = WorksheetFunction.Match(ReqKeyNoi, PromptWs.Range("B:B"), 0)

    Wants = PromptWs.Cells(ReqKeyNoi, 3).Value
    Prompts = PromptWs.Cells(ReqKeyNoi, 4).Value
    FullPrompts = PromptWs.Range("C4")

    Dim TargetArr As Variant, InputArr As Variant
    TargetArr = Array("#Wants#", "#Prompts#", "#Inputs#")
    InputArr = Array(Wants, Prompts, combinedText)
    Dim i As Long

    For i = LBound(TargetArr) To UBound(TargetArr)
        
        FullPrompts = Replace(FullPrompts, TargetArr(i), InputArr(i))
    
    Next


Else
     
     FullPrompts = QorRequestKeyNo & "-- " & combinedText

End If



UseChatGPTAndGetRes = GetGPTresp(Replace(Replace(FullPrompts, vbLf, ""), vbCrLf, ""))


End Function

Private Function GetGPTresp(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
 
    '*** 初期値設定 *****
    APIKey = ThisWorkbook.Worksheets(1).Range("C3").Value '"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"
    strModel = ThisWorkbook.Worksheets(1).Range("C2").Value ' "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         '結果を変数に代入
    
    'Range("B3") = strResponse
    'MsgBox strResponse
    
    Dim JSON As Object
    Set JSON = JsonConverter.ParseJson(strResponse)

    ' contentを取得
    On Error Resume Next ' エラーを無視して処理を続ける
    strResponse = JSON("choices")(1)("message")("content")
    On Error GoTo 0 ' エラー無視を解除
    GetGPTresp = strResponse
    
End Function