엑셀 VBA GPT 함수

' ==========================================================
' ChatGPT GPT() 커스텀 함수 (Excel VBA)
' 사용법:
'   =GPT("안녕")                                ' 단순 질문
'   =GPT("B2를 영어로 번역", A2)                 ' 단일 셀 참조
'   =GPT("이 데이터 읽고 인사이트 도출해줘", A1:C10) ' 범위 참조
' ==========================================================

Const API_KEY As String = "여기에_본인_OPENAI_API_키_붙여넣기"
Const MODEL_ID As String = "gpt-4.1"
Const MAX_TOKENS As Long = 2000

Public Function GPT(ByVal prompt As String, Optional ByRef data As Variant) As String
    On Error GoTo ErrHandler
    Dim stage As String: stage = "init"

    If Len(Trim(prompt)) = 0 Then
        GPT = "Error: Please provide a valid prompt."
        Exit Function
    End If

    ' 범위/셀 인자가 넘어왔으면 [DATA] 블록으로 덧붙임
    stage = "range"
    Dim fullPrompt As String
    fullPrompt = prompt
    If Not IsMissing(data) Then
        fullPrompt = fullPrompt & vbLf & vbLf & "[DATA]" & vbLf & RangeToText(data)
    End If

    ' JSON Body 구성
    stage = "body"
    Dim bodyJson As String
    bodyJson = "{""model"":""" & MODEL_ID & """," & _
               """messages"":[" & _
                 "{""role"":""system"",""content"":""You are a helpful assistant.""}," & _
                 "{""role"":""user"",""content"":""" & JsonEscape(fullPrompt) & """}" & _
               "]," & _
               """max_tokens"":" & MAX_TOKENS & "}"

    ' HTTP 요청
    stage = "http"
    Dim http As Object
    Set http = CreateObject("MSXML2.XMLHTTP.6.0")
    http.Open "POST", "https://api.openai.com/v1/chat/completions", False
    http.setRequestHeader "Content-Type", "application/json"
    http.setRequestHeader "Authorization", "Bearer " & API_KEY
    http.send bodyJson

    stage = "parse"
    GPT = ExtractContent(http.responseText)
    Exit Function
ErrHandler:
    GPT = "Error[" & stage & "]: " & Err.Description
End Function

' 셀 하나의 값을 안전하게 문자열로 변환 (Error/Empty/Null/Object 모두 처리)
Private Function CellToText(ByRef v As Variant) As String
    On Error Resume Next
    Dim s As String
    If IsObject(v) Then
        s = CStr(v.Value2)
    ElseIf IsError(v) Then
        s = "#ERR"
    ElseIf IsNull(v) Or IsEmpty(v) Then
        s = ""
    Else
        s = CStr(v)
    End If
    If Err.Number <> 0 Then
        s = ""
        Err.Clear
    End If
    On Error GoTo 0
    CellToText = s
End Function

' 범위/배열/단일값을 탭(열) + 줄바꿈(행) 텍스트로 변환
Private Function RangeToText(ByRef data As Variant) As String
    On Error GoTo RangeErr
    Dim arr As Variant
    Dim result As String

    If IsObject(data) Then
        arr = data.Value2
    Else
        arr = data
    End If

    If IsArray(arr) Then
        Dim rLo As Long, rHi As Long, cLo As Long, cHi As Long
        Dim is2D As Boolean: is2D = False
        rLo = LBound(arr, 1): rHi = UBound(arr, 1)
        On Error Resume Next
        cLo = LBound(arr, 2)
        cHi = UBound(arr, 2)
        If Err.Number = 0 Then is2D = True
        Err.Clear
        On Error GoTo RangeErr

        Dim r As Long, c As Long
        If is2D Then
            For r = rLo To rHi
                If r > rLo Then result = result & vbLf
                For c = cLo To cHi
                    If c > cLo Then result = result & vbTab
                    result = result & CellToText(arr(r, c))
                Next c
            Next r
        Else
            For r = rLo To rHi
                If r > rLo Then result = result & vbLf
                result = result & CellToText(arr(r))
            Next r
        End If
    Else
        result = CellToText(arr)
    End If

    RangeToText = result
    Exit Function
RangeErr:
    RangeToText = "[Range 변환 실패: " & Err.Description & "]"
End Function

' JSON 문자열 이스케이프 (요청 본문용)
Private Function JsonEscape(ByVal s As String) As String
    s = Replace(s, "\", "\\")
    s = Replace(s, """", "\""")
    s = Replace(s, vbCrLf, "\n")
    s = Replace(s, vbLf, "\n")
    s = Replace(s, vbCr, "\n")
    s = Replace(s, vbTab, "\t")
    JsonEscape = s
End Function

' 응답 JSON에서 assistant의 content 값만 추출 (간이 파서)
' - 공백/줄바꿈이 섞인 pretty JSON 모두 대응
' - \uXXXX 유니코드 이스케이프도 처리
Private Function ExtractContent(ByVal json As String) As String
    Const KEY As String = """content"":"
    Dim i As Long
    i = InStr(1, json, KEY)
    If i = 0 Then
        ExtractContent = "Error: " & json
        Exit Function
    End If
    i = i + Len(KEY)

    Do While i <= Len(json)
        Dim c As String: c = Mid(json, i, 1)
        If c = " " Or c = vbTab Or c = vbLf Or c = vbCr Then
            i = i + 1
        Else
            Exit Do
        End If
    Loop

    If i > Len(json) Or Mid(json, i, 1) <> """" Then
        ExtractContent = "Error: cannot find content opening quote"
        Exit Function
    End If
    i = i + 1

    Dim ch As String, nxt As String, result As String, hex4 As String
    Do While i <= Len(json)
        ch = Mid(json, i, 1)
        If ch = "\" Then
            nxt = Mid(json, i + 1, 1)
            Select Case nxt
                Case """": result = result & """":       i = i + 2
                Case "\":  result = result & "\":        i = i + 2
                Case "/":  result = result & "/":        i = i + 2
                Case "n":  result = result & vbLf:       i = i + 2
                Case "r":  result = result & vbCr:       i = i + 2
                Case "t":  result = result & vbTab:      i = i + 2
                Case "b":  result = result & Chr(8):     i = i + 2
                Case "f":  result = result & Chr(12):    i = i + 2
                Case "u"
                    hex4 = Mid(json, i + 2, 4)
                    result = result & ChrW(CLng("&H" & hex4))
                    i = i + 6
                Case Else: result = result & nxt:        i = i + 2
            End Select
        ElseIf ch = """" Then
            Exit Do
        Else
            result = result & ch
            i = i + 1
        End If
    Loop
    ExtractContent = result
End Function