Attribute VB_Name = "modGemini"
Option Explicit

'==============================================================================
' modGemini - call Google Gemini from your VBA macros
'
' MAIN FUNCTION
'   GetGeminiAnswer(prompt, [systemPrompt], [temperature]) As String
'
'   - Sends the prompt to Gemini and RETURNS the answer text to your macro.
'   - On failure it returns an empty string ("") and puts the reason
'     in the public variable GeminiLastError.
'
'   Example:
'       Dim answer As String
'       answer = GetGeminiAnswer("What is the capital of France?")
'       If answer = "" Then
'           MsgBox GeminiLastError
'       Else
'           Range("A1").Value = answer
'       End If
'
' RETRIES
'   Temporary errors (rate limit 429, server errors 5xx, network problems)
'   are retried up to MAX_RETRIES (10) times, with growing waits between
'   attempts: 2, 4, 8, 16, 30, 30, 30... seconds.
'   Permanent errors (wrong key, bad request) are NOT retried.
'
' API KEY
'   Asked once and saved in the Windows registry of the current user,
'   NOT inside the workbook. Sharing the file does not share your key.
'   Macros: SetGeminiKey (enter / replace), DeleteGeminiKey (remove).
'
' REQUIREMENTS
'   Excel for Windows. No references to add (uses late binding).
'==============================================================================

' ---------- Settings you may change ----------
Private Const GEMINI_MODEL As String = "gemini-3.6-flash"  ' model name from Google AI Studio
Private Const MAX_RETRIES As Long = 10                     ' retries after the first attempt
Private Const FIRST_RETRY_WAIT_SEC As Long = 2             ' first wait; doubles every retry
Private Const MAX_RETRY_WAIT_SEC As Long = 30              ' upper limit for a single wait
Private Const REQUEST_TIMEOUT_SEC As Long = 60             ' max time to wait for one answer

' ---------- Internal constants ----------
Private Const API_BASE As String = "https://generativelanguage.googleapis.com/v1beta/models/"
Private Const REG_APP As String = "ExcelGemini"
Private Const REG_SECTION As String = "Settings"
Private Const REG_KEY As String = "ApiKey"

' ---------- Settings for the example macro ClassifyExpenses ----------
Private Const FIRST_DATA_ROW As Long = 2      ' row 1 = headers
Private Const COL_DESCRIPTION As Long = 2     ' column B - merchant / description
Private Const COL_AMOUNT As Long = 3          ' column C - amount
Private Const COL_CATEGORY As Long = 4        ' column D - category (filled by the macro)
Private Const CATEGORIES_RANGE_NAME As String = "Categories"
Private Const PAUSE_BETWEEN_ROWS_SEC As Long = 1

' Reason for the last failure of GetGeminiAnswer ("" if it succeeded)
Public GeminiLastError As String


'==============================================================================
'  PART 1 - THE FUNCTION YOU CALL FROM YOUR MACROS
'==============================================================================

Public Function GetGeminiAnswer(ByVal prompt As String, _
                                Optional ByVal systemPrompt As String = "", _
                                Optional ByVal temperature As Double = 0) As String
    Dim apiKey As String
    Dim body As String
    Dim attempt As Long
    Dim statusCode As Long
    Dim responseText As String
    Dim reason As String
    Dim waitSec As Long
    Dim answer As String

    GeminiLastError = ""
    GetGeminiAnswer = ""

    apiKey = GetGeminiKey()
    If apiKey = "" Then
        GeminiLastError = "No API key. Run the macro SetGeminiKey and paste your key."
        Exit Function
    End If

    body = BuildRequestBody(prompt, systemPrompt, temperature)

    ' attempt 0 = first try, attempts 1..MAX_RETRIES = retries
    For attempt = 0 To MAX_RETRIES

        If attempt > 0 Then
            waitSec = RetryWaitSeconds(attempt, responseText)
            Application.StatusBar = "Gemini: " & reason & " - retry " & attempt & " of " & _
                                    MAX_RETRIES & " in " & waitSec & " seconds..."
            Debug.Print Now, "Gemini retry " & attempt & "/" & MAX_RETRIES & " after: " & reason
            Application.Wait Now + TimeSerial(0, 0, waitSec)
        End If

        SendRequest body, apiKey, statusCode, responseText, reason

        Select Case statusCode

            Case 200    ' success
                answer = JsonStringField(responseText, "text")
                If attempt > 0 Then Application.StatusBar = False
                If answer <> "" Then
                    GetGeminiAnswer = answer
                Else
                    ' Usually blocked by a safety filter. Retrying will not help.
                    GeminiLastError = "Gemini returned no text (finishReason: " & _
                                      JsonStringField(responseText, "finishReason") & ")."
                End If
                Exit Function

            Case 0, 429, 500 To 599
                ' Temporary problem: network, rate limit or server busy.
                ' Do nothing here - the loop waits and tries again.

            Case Else
                ' Permanent problem (400 bad request / invalid key, 403, 404 wrong model...).
                If attempt > 0 Then Application.StatusBar = False
                GeminiLastError = "HTTP " & statusCode & ": " & ErrorMessage(responseText)
                Exit Function

        End Select
    Next attempt

    Application.StatusBar = False
    GeminiLastError = "Failed after " & MAX_RETRIES & " retries. Last error: " & reason
    If responseText <> "" Then GeminiLastError = GeminiLastError & " - " & ErrorMessage(responseText)
End Function


'==============================================================================
'  PART 2 - API KEY MANAGEMENT
'==============================================================================

' Run this macro to enter or replace your key
Public Sub SetGeminiKey()
    Dim k As String
    k = Trim$(InputBox("Paste your Gemini API key (from aistudio.google.com):", "Gemini API key"))
    If k = "" Then Exit Sub
    SaveSetting REG_APP, REG_SECTION, REG_KEY, k
    MsgBox "The API key was saved on this computer.", vbInformation, "Gemini"
End Sub

' Run this macro to remove your key from this computer
Public Sub DeleteGeminiKey()
    On Error Resume Next
    DeleteSetting REG_APP, REG_SECTION, REG_KEY
    On Error GoTo 0
    MsgBox "The API key was deleted from this computer.", vbInformation, "Gemini"
End Sub

' Returns the saved key; asks for it the first time
Private Function GetGeminiKey() As String
    Dim k As String
    k = GetSetting(REG_APP, REG_SECTION, REG_KEY, "")
    If k = "" Then
        k = Trim$(InputBox("Paste your Gemini API key (from aistudio.google.com):", "Gemini API key"))
        If k <> "" Then SaveSetting REG_APP, REG_SECTION, REG_KEY, k
    End If
    GetGeminiKey = k
End Function


'==============================================================================
'  PART 3 - EXAMPLE MACRO: CLASSIFY EXPENSES
'
'  Works on the ACTIVE sheet:
'     column B = description (input), column C = amount (input),
'     column D = category (output - written by this macro).
'  The allowed categories come from the named range "Categories".
'  Rows that already have a category are skipped, so if the macro stops
'  in the middle you can simply run it again.
'  Answers that are not in the list are marked in yellow for review.
'==============================================================================

Public Sub ClassifyExpenses()
    Dim ws As Worksheet
    Dim catCells As Range
    Dim c As Range
    Dim validCategories As Object
    Dim catList As String
    Dim catName As String
    Dim systemPrompt As String
    Dim lastRow As Long
    Dim r As Long
    Dim description As String
    Dim prompt As String
    Dim answer As String
    Dim doneCount As Long
    Dim skippedCount As Long
    Dim flaggedCount As Long

    Set ws = ActiveSheet

    ' --- 1. Read the category list from the named range ---
    On Error Resume Next
    Set catCells = ws.Parent.Names(CATEGORIES_RANGE_NAME).RefersToRange
    On Error GoTo 0
    If catCells Is Nothing Then
        MsgBox "The named range '" & CATEGORIES_RANGE_NAME & "' was not found in this workbook.", _
               vbExclamation, "Gemini"
        Exit Sub
    End If
    If catCells.Worksheet.Name = ws.Name Then
        MsgBox "You are on the categories sheet." & vbLf & _
               "Go to the expenses sheet and run the macro again.", vbExclamation, "Gemini"
        Exit Sub
    End If

    Set validCategories = CreateObject("Scripting.Dictionary")
    validCategories.CompareMode = 1   ' not case sensitive
    For Each c In catCells.Cells
        catName = Trim$(CStr(c.Value))
        If catName <> "" Then
            If Not validCategories.Exists(catName) Then
                validCategories.Add catName, True
                catList = catList & "- " & catName & vbLf
            End If
        End If
    Next c
    If validCategories.Count = 0 Then
        MsgBox "The category list is empty.", vbExclamation, "Gemini"
        Exit Sub
    End If

    ' --- 2. Instructions for the model (same for every row) ---
    systemPrompt = "You classify credit card and bank transactions. " & _
        "The description is usually in Hebrew and is the merchant name as it appears on the statement. " & _
        "Choose exactly ONE category from the list the user gives you. " & _
        "Reply with the category name only, copied exactly as written in the list - " & _
        "no explanation, no quotes, no punctuation. " & _
        "If no category fits, or you are not sure, reply with the LAST category in the list."

    ' --- 3. Loop over the expense rows ---
    lastRow = ws.Cells(ws.Rows.Count, COL_DESCRIPTION).End(xlUp).Row
    If lastRow < FIRST_DATA_ROW Then
        MsgBox "No expense rows were found on this sheet.", vbExclamation, "Gemini"
        Exit Sub
    End If

    For r = FIRST_DATA_ROW To lastRow
        description = Trim$(CStr(ws.Cells(r, COL_DESCRIPTION).Value))

        If description = "" Then
            ' empty row - nothing to do

        ElseIf Trim$(CStr(ws.Cells(r, COL_CATEGORY).Value)) <> "" Then
            skippedCount = skippedCount + 1     ' already classified

        Else
            Application.StatusBar = "Classifying row " & r & " of " & lastRow & "..."

            prompt = "Categories:" & vbLf & catList & vbLf & _
                     "Transaction description: " & description & vbLf & _
                     "Amount: " & ws.Cells(r, COL_AMOUNT).Text

            ' >>> THE CALL TO GEMINI <<<
            answer = GetGeminiAnswer(prompt, systemPrompt, 0)

            If answer = "" Then
                Application.StatusBar = False
                MsgBox "Stopped at row " & r & "." & vbLf & vbLf & _
                       GeminiLastError & vbLf & vbLf & _
                       doneCount & " rows were classified before the stop and were kept." & vbLf & _
                       "Run the macro again to continue from where it stopped.", _
                       vbExclamation, "Gemini"
                Exit Sub
            End If

            answer = CleanAnswer(answer)

            With ws.Cells(r, COL_CATEGORY)
                .Value = answer
                If validCategories.Exists(answer) Then
                    .Interior.Pattern = xlNone
                Else
                    .Interior.Color = RGB(255, 235, 156)   ' yellow = check manually
                    flaggedCount = flaggedCount + 1
                End If
            End With
            doneCount = doneCount + 1

            ' small pause to stay under the free-tier requests-per-minute limit
            If PAUSE_BETWEEN_ROWS_SEC > 0 Then
                Application.Wait Now + TimeSerial(0, 0, PAUSE_BETWEEN_ROWS_SEC)
            End If
        End If
    Next r

    Application.StatusBar = False
    MsgBox "Done." & vbLf & vbLf & _
           "Classified now: " & doneCount & vbLf & _
           "Skipped (already had a category): " & skippedCount & vbLf & _
           "Not in the category list (marked yellow): " & flaggedCount, _
           vbInformation, "Gemini"
End Sub

' Clears column D on the active sheet, so you can run the demo again
Public Sub ClearCategories()
    Dim ws As Worksheet
    Dim lastRow As Long
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, COL_DESCRIPTION).End(xlUp).Row
    If lastRow < FIRST_DATA_ROW Then Exit Sub
    If MsgBox("Clear all categories in column D of the active sheet?", _
              vbYesNo + vbQuestion, "Gemini") = vbNo Then Exit Sub
    With ws.Range(ws.Cells(FIRST_DATA_ROW, COL_CATEGORY), ws.Cells(lastRow, COL_CATEGORY))
        .ClearContents
        .Interior.Pattern = xlNone
    End With
End Sub

' Removes extra text the model sometimes adds (quotes, bullets, a final period...)
Private Function CleanAnswer(ByVal s As String) As String
    s = Replace(s, vbCr, "")
    s = Trim$(s)
    Do While Left$(s, 1) = vbLf
        s = Trim$(Mid$(s, 2))
    Loop
    If InStr(s, vbLf) > 0 Then s = Left$(s, InStr(s, vbLf) - 1)   ' first line only
    s = Replace(s, "*", "")
    s = Replace(s, """", "")
    s = Trim$(s)
    If Left$(s, 2) = "- " Then s = Mid$(s, 3)
    If Right$(s, 1) = "." Then s = Left$(s, Len(s) - 1)
    CleanAnswer = Trim$(s)
End Function


'==============================================================================
'  PART 4 - INTERNAL HELPERS (no need to change)
'==============================================================================

' Sends one HTTP request. Never raises an error: network problems return statusCode = 0.
Private Sub SendRequest(ByVal body As String, ByVal apiKey As String, _
                        ByRef statusCode As Long, ByRef responseText As String, ByRef reason As String)
    Dim http As Object
    statusCode = 0
    responseText = ""
    reason = ""

    On Error GoTo NetworkError
    Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    http.Open "POST", API_BASE & GEMINI_MODEL & ":generateContent", False
    http.setRequestHeader "Content-Type", "application/json; charset=utf-8"
    http.setRequestHeader "x-goog-api-key", apiKey
    http.setTimeouts 10000, 10000, REQUEST_TIMEOUT_SEC * 1000, REQUEST_TIMEOUT_SEC * 1000
    http.send Utf8Bytes(body)

    statusCode = http.Status
    responseText = Utf8Decode(http.responseBody)

    Select Case statusCode
        Case 429:        reason = "rate limit (HTTP 429)"
        Case 500 To 599: reason = "server error (HTTP " & statusCode & ")"
        Case Else:       reason = "HTTP " & statusCode
    End Select
    Exit Sub

NetworkError:
    statusCode = 0
    reason = "network error: " & Err.description
End Sub

' Wait before retry number n: 2, 4, 8, 16, 30, 30... seconds.
' If Gemini says how long to wait ("retryDelay": "37s"), that is respected.
Private Function RetryWaitSeconds(ByVal retryNumber As Long, ByVal lastResponse As String) As Long
    Dim w As Double
    Dim suggested As Double

    w = FIRST_RETRY_WAIT_SEC * 2 ^ (retryNumber - 1)
    If w > MAX_RETRY_WAIT_SEC Then w = MAX_RETRY_WAIT_SEC

    suggested = Val(JsonStringField(lastResponse, "retryDelay"))
    If suggested > w Then w = suggested + 1
    If w > 120 Then w = 120

    RetryWaitSeconds = CLng(w)
End Function

Private Function BuildRequestBody(ByVal prompt As String, ByVal systemPrompt As String, _
                                  ByVal temperature As Double) As String
    Dim s As String
    Dim t As String

    ' Str$ always uses a dot as decimal separator (unlike CStr, which follows Windows settings)
    t = Trim$(Str$(temperature))
    If Left$(t, 1) = "." Then t = "0" & t

    s = "{"
    If systemPrompt <> "" Then
        s = s & """systemInstruction"":{""parts"":[{""text"":""" & JsonEscape(systemPrompt) & """}]},"
    End If
    s = s & """contents"":[{""role"":""user"",""parts"":[{""text"":""" & JsonEscape(prompt) & """}]}],"
    s = s & """generationConfig"":{""temperature"":" & t & "}"
    s = s & "}"
    BuildRequestBody = s
End Function

Private Function ErrorMessage(ByVal responseText As String) As String
    ErrorMessage = JsonStringField(responseText, "message")
    If ErrorMessage = "" Then ErrorMessage = Left$(responseText, 300)
End Function

Private Function JsonEscape(ByVal s As String) As String
    Dim i As Long
    Dim ch As String
    Dim code As Long
    Dim out As String

    For i = 1 To Len(s)
        ch = Mid$(s, i, 1)
        code = AscW(ch)
        Select Case True
            Case ch = """":                 out = out & "\"""
            Case ch = "\":                  out = out & "\\"
            Case ch = vbLf:                 out = out & "\n"
            Case ch = vbCr:                 out = out & "\r"
            Case ch = vbTab:                out = out & "\t"
            Case code >= 0 And code < 32:   out = out & "\u" & Right$("000" & Hex$(code), 4)
            Case Else:                      out = out & ch
        End Select
    Next i
    JsonEscape = out
End Function

' Returns the first string value of a field in a JSON text (enough for Gemini answers)
Private Function JsonStringField(ByVal json As String, ByVal fieldName As String) As String
    Dim p As Long
    Dim i As Long
    Dim ch As String
    Dim out As String

    p = InStr(1, json, """" & fieldName & """", vbBinaryCompare)
    If p = 0 Then Exit Function
    p = InStr(p + Len(fieldName) + 2, json, ":")
    If p = 0 Then Exit Function
    p = InStr(p, json, """")
    If p = 0 Then Exit Function

    i = p + 1
    Do While i <= Len(json)
        ch = Mid$(json, i, 1)
        If ch = "\" Then
            i = i + 1
            Select Case Mid$(json, i, 1)
                Case "n": out = out & vbLf
                Case "t": out = out & vbTab
                Case "r": ' ignore
                Case "u"
                    out = out & ChrW$(CLng("&H" & Mid$(json, i + 1, 4)))
                    i = i + 4
                Case Else: out = out & Mid$(json, i, 1)   ' \"  \\  \/
            End Select
        ElseIf ch = """" Then
            Exit Do
        Else
            out = out & ch
        End If
        i = i + 1
    Loop
    JsonStringField = out
End Function

Private Function Utf8Bytes(ByVal s As String) As Byte()
    Dim st As Object
    Set st = CreateObject("ADODB.Stream")
    st.Type = 2
    st.Charset = "utf-8"
    st.Open
    st.WriteText s
    st.Position = 0
    st.Type = 1
    st.Position = 3          ' skip the UTF-8 BOM
    Utf8Bytes = st.Read
    st.Close
End Function

Private Function Utf8Decode(ByVal bytes As Variant) As String
    Dim st As Object
    Set st = CreateObject("ADODB.Stream")
    st.Type = 1
    st.Open
    st.Write bytes
    st.Position = 0
    st.Type = 2
    st.Charset = "utf-8"
    Utf8Decode = st.ReadText
    st.Close
End Function