Using OpenAI ChatGPT and Anthropic Claude in Excel VBA

Igor Krupitsky
0.00/5 (No votes)
10 Jul 2024CPOL
2.2K
This codes provides and example of how to use Chat GPT in your Excel Macro
My goal is to create the smallest possible example of how to use Chat GPT and Anthropic Claude in your Excel Macro.
Download OpenAI_Anthropic3.zip
Introduction

This Excel Macro enabled file provides the smallest possible example of how to use Chat GPT and Anthropic Claude in your Excel Macro.
These VBA functions can be used in formulas.
Vision support.
Image generation.
Background

This is a sequel to my earlier article, Chat GPT in VB.NET and C#.
Using the code

Get Anthropic API key https://console.anthropic.com/settings/keys
Paste the Key to cell B1
Get OpenAI API key https://platform.openai.com/settings/profile?tab=api-keys
Paste the Key to cell B8
Here is the code. Basically, it uses MSXML2.ServerXMLHTTP to post JSON to OpenAI (https://api.openai.com/v1/chat/completions) and Anthropic (https://api.anthropic.com/v1/messages) endpoints.
VBScript
Dim oRequestList As Scripting.Dictionary
Dim bTimerEnabled As Boolean

Public Sub TestAnthropic()
    Dim oSheet As Worksheet
    Set oSheet = Application.ActiveSheet
    
    sApiKey = oSheet.Range("B1").value
    If sApiKey = "" Then
        MsgBox "Provide key"
        Exit Sub
    End If
    
    sQuestion = oSheet.Range("B2").value
    If sQuestion = "" Then
        MsgBox "Provide your question"
        Exit Sub
    End If
    
    oSheet.Range("B3").value = SendAnthropicMsg(sApiKey, sQuestion)
End Sub

Public Sub TestAnthropicImg()
    Dim oSheet As Worksheet
    Set oSheet = Application.ActiveSheet
    
    sApiKey = oSheet.Range("B1").value
    If sApiKey = "" Then
        MsgBox "Provide key"
        Exit Sub
    End If
    
    sImagePath = oSheet.Range("E1").value
    If sImagePath = "" Then
        MsgBox "Provide image path"
        Exit Sub
    End If
    
    sQuestion = oSheet.Range("E2").value
    If sQuestion = "" Then
        MsgBox "Provide image question"
        Exit Sub
    End If
    
    oSheet.Range("E3").value = SendAnthropicImg(sApiKey, sImagePath, sQuestion)
End Sub

Public Sub TestOpenAiImg()
    Dim oSheet As Worksheet
    Set oSheet = Application.ActiveSheet
    
    sApiKey = oSheet.Range("B7").value
    If sApiKey = "" Then
        MsgBox "Provide key"
        Exit Sub
    End If
    
    sImagePath = oSheet.Range("E7").value
    If sImagePath = "" Then
        MsgBox "Provide image path"
        Exit Sub
    End If
    
    sQuestion = oSheet.Range("E8").value
    If sQuestion = "" Then
        MsgBox "Provide image question"
        Exit Sub
    End If
    
    oSheet.Range("E9").value = SendOpenAiImg(sApiKey, sImagePath, sQuestion)
End Sub


Public Sub TestOpenAI()
    Dim oSheet As Worksheet
    Set oSheet = Application.ActiveSheet
    
    sApiKey = oSheet.Range("B7").value
    If sApiKey = "" Then
        MsgBox "Provide key"
        Exit Sub
    End If
    
    sQuestion = oSheet.Range("B8").value
    If sQuestion = "" Then
        MsgBox "Provide your question"
        Exit Sub
    End If
    
    oSheet.Range("B9").value = SendOpenAiMsg(sApiKey, sQuestion)
End Sub


Public Function Anthropic(ByVal sQuestion As String) As String
    Dim oSheet As Worksheet
    Set oSheet = Application.Sheets("Sheet1")
    sApiKey = oSheet.Range("B1").value
    
    If sApiKey & "" = "" Or sQuestion & "" = "" Then
        Exit Function
    End If
    
    Anthropic = SendAnthropicMsg(sApiKey, sQuestion)
End Function


Public Function SendAnthropicImg(ByVal sAnthropicKey As String, ByVal sImagePath As String, ByVal sQuestion As String) As String
    Const sModel = "claude-3-5-sonnet-20240620"
    Const sUrl = "https://api.anthropic.com/v1/messages"
    Const iMaxTokens = 1024
    
    'https://docs.anthropic.com/en/docs/build-with-claude/vision
    Dim oHttp As Object: Set oHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    oHttp.Open "POST", sUrl, False
    oHttp.setRequestHeader "Content-Type", "application/json"
    oHttp.setRequestHeader "x-api-key", sAnthropicKey
    oHttp.setRequestHeader "anthropic-version", "2023-06-01"
        
    Dim image_data: image_data = GetFile64(sImagePath)
    Dim data As String: data = "{"
    data = data & """model"": """ & sModel & ""","
    data = data & """max_tokens"": " & iMaxTokens & ","
    data = data & """messages"": [{""role"":""user"", ""content"": ["
    data = data & "{""type"": ""image"", ""source"": {""type"": ""base64"", ""media_type"": ""image/jpeg"",""data"": """ & image_data & """}},"
    data = data & "{""type"": ""text"", ""text"": """ & PadQuotes(sQuestion) & """}]}]}"
    'OpenNotepad data, "json"
    
    oHttp.Send data
    
    Dim sJson As String: sJson = oHttp.responseText
    Dim html As Object: Set html = CreateObject("htmlfile")
    html.parentWindow.execScript "var oJson = " & sJson & "; var sRet = oJson.content[0].text", "JScript"
    SendAnthropicImg = html.parentWindow.sRet
End Function


Function SendOpenAiImg(ByVal sOpenAiApiKey As String, ByVal sImagePath As String, ByVal sQuestion As String) As String
    'https://platform.openai.com/docs/guides/vision
    Const sModel = "gpt-4o"
    Const sUrl = "https://api.openai.com/v1/chat/completions"
    Dim oHttp As Object: Set oHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    oHttp.Open "POST", sUrl, False
    oHttp.setRequestHeader "Content-Type", "application/json"
    oHttp.setRequestHeader "Authorization", "Bearer " & sOpenAiApiKey
    
    Dim image_data: image_data = GetFile64(sImagePath)
    Dim data As String: data = "{"
    data = data & " ""model"":""" & sModel & ""","
    data = data & """messages"": [{""role"":""user"", ""content"": ["
    data = data & "{""type"": ""image_url"", ""image_url"": {""url"": ""data:image/jpeg;base64," & image_data & """}},"
    data = data & "{""type"": ""text"", ""text"": """ & PadQuotes(sQuestion) & """}]}]}"
    oHttp.Send data
    
    Dim sJson As String: sJson = oHttp.responseText
    Dim html As Object: Set html = CreateObject("htmlfile")
    html.parentWindow.execScript "var oJson = " & sJson & "; var sRet = oJson.choices[0].message.content", "JScript"
    SendOpenAiImg = html.parentWindow.sRet
End Function

Function SendAnthropicMsg(ByVal sAnthropicKey As String, ByVal sQuestion As String) As String
    Const sModel = "claude-3-5-sonnet-20240620"
    Const sUrl = "https://api.anthropic.com/v1/messages"
    Const iMaxTokens = 1024
    Const dTemperature = 0.7
    
    Dim oHttp As Object: Set oHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    oHttp.Open "POST", sUrl, False
    oHttp.setRequestHeader "Content-Type", "application/json"
    oHttp.setRequestHeader "x-api-key", sAnthropicKey
    oHttp.setRequestHeader "anthropic-version", "2023-06-01"
        
    Dim data As String: data = "{"
    data = data & """model"": """ & sModel & ""","
    data = data & """messages"": [{""role"":""user"", ""content"": """ & PadQuotes(sQuestion) & """}],"
    data = data & """system"": ""You are Claude, an AI assistant created by Anthropic to be helpful, harmless, and honest."","
    data = data & """max_tokens"": " & iMaxTokens & ","
    data = data & """temperature"": " & dTemperature
    data = data & "}"
    oHttp.Send data
    
    Dim sJson As String: sJson = oHttp.responseText
    Dim html As Object: Set html = CreateObject("htmlfile")
    html.parentWindow.execScript "var oJson = " & sJson & "; var sRet = oJson.content[0].text", "JScript"
    SendAnthropicMsg = html.parentWindow.sRet
End Function

Function SendOpenAiMsg(ByVal sOpenAiApiKey As String, ByVal sQuestion As String) As String
    Const sModel = "gpt-3.5-turbo"
    Const sUrl = "https://api.openai.com/v1/chat/completions"
    Dim oHttp As Object: Set oHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    oHttp.Open "POST", sUrl, False
    oHttp.setRequestHeader "Content-Type", "application/json"
    oHttp.setRequestHeader "Authorization", "Bearer " & sOpenAiApiKey
    
    Dim data As String: data = "{"
    data = data & " ""model"":""" & sModel & ""","
    data = data & " ""messages"": [{""role"":""user"", ""content"": """ & PadQuotes(sQuestion) & """}]"
    data = data & "}"
    oHttp.Send data
    
    Dim sJson As String: sJson = oHttp.responseText
    Dim html As Object: Set html = CreateObject("htmlfile")
    html.parentWindow.execScript "var oJson = " & sJson & "; var sRet = oJson.choices[0].message.content", "JScript"
    SendOpenAiMsg = html.parentWindow.sRet
End Function

Private Function PadQuotes(ByVal s As String) As String
    s = Replace(s, "\", "\\")
    s = Replace(s, vbCrLf, "\n")
    s = Replace(s, vbCr, "\r")
    s = Replace(s, vbLf, "\f")
    s = Replace(s, vbTab, "\t")
    PadQuotes = Replace(s, """", "\""")
End Function

Function GetFile64(imagePath)
    Dim oStream: Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1 ' Binary
    oStream.LoadFromFile imagePath

    Dim oXMLDOM: Set oXMLDOM = CreateObject("Microsoft.XMLDOM")
    Dim e: Set e = oXMLDOM.createElement("tmp")
    e.DataType = "bin.base64"
    e.nodeTypedValue = oStream.Read
    image_data = e.Text
    oStream.Close
    
    image_data = Replace(image_data, vbCrLf, "")
    image_data = Replace(image_data, vbCr, "")
    image_data = Replace(image_data, vbLf, "")
    GetFile64 = image_data
End Function

Sub OpenNotepad(s, sExt)
    Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFolder: Set oFolder = fso.GetSpecialFolder(2)
    Dim sFilePath: sFilePath = oFolder.path & "\" & fso.GetTempName() & "." & sExt
    Dim oFile: Set oFile = fso.CreateTextFile(sFilePath, True)
    oFile.Write s
    oFile.Close
    Dim oShell: Set oShell = CreateObject("WScript.Shell")
    oShell.Run sFilePath
End Sub


Function GetOpenAiKey() As String
    Dim oSheet1 As Worksheet
    Set oSheet1 = Application.Sheets("Sheet1")
    GetOpenAiKey = oSheet1.Range("B7").value
End Function

Public Sub TestOpenAIGenerate()
    sApiKey = GetOpenAiKey()
    If sApiKey = "" Then
        MsgBox "Provide key"
        Exit Sub
    End If
    
    Dim oSheet As Worksheet
    Set oSheet = Application.ActiveSheet
    Dim sPrompt As String: sPrompt = oSheet.Range("B1").value & ""
    If sPrompt = "" Then
        MsgBox "Provide your Prompt"
        Exit Sub
    End If
    
    Const sSize = "1024x1024" '1024x1024, 1024x1792 or 1792x1024
    Dim sImageUrl: sImageUrl = GenerateOpenAiImage(sApiKey, sPrompt, sSize)
    ProcessOpenAiImageResult sImageUrl, sPrompt, "B2"
End Sub
 
Function GenerateOpenAiImage(ByVal sOpenAiApiKey As String, ByRef sPrompt As String, Optional ByVal sSize As String = "1024x1024") As String
    'https://platform.openai.com/docs/guides/images/usage?lang=curl
    Const sModel = "dall-e-3"
    Const sUrl = "https://api.openai.com/v1/images/generations"
    Dim xmlhttp As Object: Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    xmlhttp.Open "POST", sUrl, True
    xmlhttp.setRequestHeader "Content-Type", "application/json"
    xmlhttp.setRequestHeader "Authorization", "Bearer " & sOpenAiApiKey
    
    Dim data As String: data = "{"
    data = data & " ""model"":""" & sModel & ""","
    data = data & " ""prompt"": """ & PadQuotes(sPrompt) & ""","
    data = data & " ""n"": 1,"
    data = data & " ""size"": """ & sSize & """"
    data = data & "}"
    xmlhttp.Send data
    
    ' Wait for the response to be fully received
    Do While xmlhttp.readyState <> 4
        DoEvents
    Loop
    
    Dim sJson As String: sJson = xmlhttp.responseText
    Dim html As Object: Set html = CreateObject("htmlfile")
    
    On Error Resume Next
    html.parentWindow.execScript "var oJson = " & sJson & "; var sUrl = oJson.data[0].url; var sPrompt = oJson.data[0].revised_prompt", "JScript"
    If Err.Number <> 0 Then
        MsgBox "GenerateOpenAiImage Error: " & Err.Description
        OpenNotepad sJson, "json"
    End If
    On Error GoTo 0
    
    sPrompt = html.parentWindow.sPrompt
    GenerateOpenAiImage = html.parentWindow.sUrl
End Function

 

'======GetImage==========

Public Function GetImage(ByVal sPrompt As String) As String

    sOpenAiApiKey = GetOpenAiKey()
    If sOpenAiApiKey = "" Or sPrompt = "" Then
        GetImage = ""
        Exit Function
    End If

    Dim oCell As Range: Set oCell = Application.Caller
    Dim sAddress As String: sAddress = Replace(oCell.Address, "$", "")


    Dim oSheet As Worksheet
    Set oSheet = oCell.Worksheet

    For Each oShape In oSheet.Shapes
        If oShape.Type = 13 Then
            If oShape.Name = sAddress Then
                'oShape.AlternativeText = sPrompt
                GetImage = "Loaded"
                Exit Function
            End If
        End If
    Next

    If oRequestList Is Nothing Then
        Set oRequestList = CreateObject("Scripting.Dictionary")
    End If

    If oRequestList.Exists(sAddress) Then
        GetImage = "Loading...."
        Exit Function
    End If

    'https://platform.openai.com/docs/guides/images/usage?lang=curl
    Const sSize = "1024x1024"
    Const sModel = "dall-e-3"
    Const sUrl = "https://api.openai.com/v1/images/generations"
    Dim oHttp As Object: Set oHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    Set oRequestList(sAddress) = oHttp
    oHttp.Open "POST", sUrl, True
    oHttp.setRequestHeader "Content-Type", "application/json"
    oHttp.setRequestHeader "Authorization", "Bearer " & sOpenAiApiKey
    
    Dim data As String: data = "{"
    data = data & " ""model"":""" & sModel & ""","
    data = data & " ""prompt"": """ & PadQuotes(sPrompt) & ""","
    data = data & " ""n"": 1,"
    data = data & " ""size"": """ & sSize & """"
    data = data & "}"
    
    oHttp.Send data
    GetImage = "Loading..."
End Function

Sub StartTimer()
    If bTimerEnabled = False Then
        bTimerEnabled = True
        OnTick
    End If
End Sub

Sub StopTimer()
    bTimerEnabled = False
End Sub

Sub OnTick()
    'Fires every second
    GetImage_StateChange
    ResizeImages
    
    If bTimerEnabled Then
        Application.OnTime Now + TimeValue("00:00:01"), "OnTick"
    End If
End Sub


Sub GetImage_StateChange()
    Dim oHttp As Object
    Dim sAddress
    Dim i As Long
    Dim oSheet As Worksheet
    Dim oCell As Range

    If oRequestList Is Nothing Then
        Exit Sub
    End If
    
    If oRequestList.Count = 0 Then
        Exit Sub
    End If
    
    For Each sAddress In oRequestList.Keys
        Set oHttp = oRequestList(sAddress)
        If oHttp.readyState = 4 Then
        
            If oHttp.Status = 200 Then
                Dim sJson As String: sJson = oHttp.responseText
                Dim html As Object: Set html = CreateObject("htmlfile")
                
                On Error Resume Next
                html.parentWindow.execScript "var oJson = " & sJson & "; var sUrl = oJson.data[0].url; var sPrompt = oJson.data[0].revised_prompt", "JScript"
                If Err.Number <> 0 Then
                    'oCell.value = "GetImage Error: " & Err.Description
                    OpenNotepad sJson, "json"
                    Exit Sub
                End If
                On Error GoTo 0

                ProcessOpenAiImageResult html.parentWindow.sUrl, html.parentWindow.sPrompt, sAddress
            Else
                MsgBox "GetImage Error: " & oHttp.Status & " - " & oHttp.statusText '& " - " & oHttp.responseText
            End If
            
            oRequestList.Remove sAddress
            Exit For
        End If
    Next
End Sub

Sub ProcessOpenAiImageResult(ByVal sImageUrl As String, ByVal sPrompt As String, ByVal sAddress As String)

    If sImageUrl = "" Then
        Exit Sub
    End If
    
    Dim sImagePath: sImagePath = DownloadImage(sImageUrl)
    If sImagePath = "" Then
        Exit Sub
    End If
    
    Dim oSheet As Worksheet: Set oSheet = Application.ActiveSheet
    Dim oCell As Range: Set oCell = oSheet.Range(sAddress)
    
    Dim oImage, oShape, iTop, iLeft
    Set oImage = Nothing
    For Each oShape In oSheet.Shapes
        If oShape.Name = sAddress Then
            Set oImage = oShape
            Exit For
        End If
    Next

    Dim oShape2
    Set oShape2 = oSheet.Shapes.AddPicture(sImagePath, msoFalse, msoTrue, oCell.Left, oCell.Top, oCell.Width, oCell.Height)
    oShape2.AlternativeText = sPrompt
    oShape2.LockAspectRatio = msoTrue
    oCell.Calculate
    
    If Not oImage Is Nothing Then
        oImage.Delete
    End If

    oShape2.Name = sAddress
End Sub

Function DownloadImage(url)
    Set oHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    Set stream = CreateObject("ADODB.Stream")
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim oFolder: Set oFolder = fso.GetSpecialFolder(2)
    Dim sFilePath: sFilePath = oFolder.path & "\" & fso.GetTempName() & ".jpg"

    If fso.FileExists(sFilePath) Then
        fso.DeleteFile sFilePath
    End If

    oHttp.Open "GET", url, False
    oHttp.Send

    If oHttp.Status = 200 Then
        stream.Open
        stream.Type = 1 ' Binary data
        stream.Write oHttp.responseBody
        stream.Position = 0

        stream.SaveToFile sFilePath, 2 ' 2 = adSaveCreateOverWrite
        stream.Close

        DownloadImage = sFilePath
    Else
        ' Return an error message if the download failed
        DownloadImage = "Error: Unable to download image. Status code: " & oHttp.Status
    End If

    ' Clean up
    Set oHttp = Nothing
    Set stream = Nothing
    Set fso = Nothing
End Function


Sub ResizeImages()
    Dim oSheet As Worksheet
    Set oSheet = Application.ActiveSheet
    Dim oCell As Range

    On Error Resume Next

    For Each oShape In oSheet.Shapes
        If oShape.Type = 13 Then
            Set oCell = oSheet.Range(oShape.Name)
            oShape.LockAspectRatio = 0 'msoFalse
            oShape.Width = oCell.Width
            oShape.Height = oCell.Height
            oShape.Top = oCell.Top
            oShape.Left = oCell.Left
        End If
    Next
End Sub
This code is self-contained and does not require any libraries to be installed.
History

Version 1 - July 10, 2024
Version 2 - July 11, 2024 - Vision an Formula support
Version 3 - July 13, 2024 - Image Generation
Version 4 - July 13, 2024 - Synchronous Image Generation
License

This article, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)