在 Excel VBA 中使用 OpenAI ChatGPT 和 Anthropic Claude
0/5 (0投票)
此代码提供了一个如何在 Excel 宏中使用 Chat GPT 的示例。
引言
此启用宏的 Excel 文件提供了在 Excel 宏中使用 Chat GPT 和 Anthropic Claude 的最小示例。
这些 VBA 函数可以在公式中使用。
支持视觉功能。
支持图像生成。
背景
这是我对先前文章 Chat GPT 在 VB.NET 和 C# 中 的续篇。
使用代码
- 获取 Anthropic API 密钥 https://console.anthropic.com/settings/keys
- 将密钥粘贴到单元格 B1
- 获取 OpenAI API 密钥 https://platform.openai.com/settings/profile?tab=api-keys
- 将密钥粘贴到单元格 B8
这是代码。基本上，它使用 MSXML2.ServerXMLHTTP 将 JSON 发布到 OpenAI (https://api.openai.com/v1/chat/completions) 和 Anthropic (https://api.anthropic.com/v1/messages) 端点。
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
此代码是自包含的，不需要安装任何库。
历史
版本 1 - 2024 年 7 月 10 日
版本 2 - 2024 年 7 月 11 日 - 支持视觉功能和公式
版本 3 - 2024 年 7 月 13 日 - 支持图像生成
版本 4 - 2024 年 7 月 13 日 - 同步图像生成