回复
雷军看了都要哭了的几行代码，WPS AI会员的钱又省了
首先，我们可以配置几乎所有的大模型，而 WPS 却不可以，其次，这些几乎都是免费的。
下面，我来给大家分享一下。
这里我们用的是OpenAI，当然你可以用其他的大模型，不过需要修改以下对返回字符串的修改。
你可以先下载文件，然后安装一下。
您需要做的第一件事是使加载项文件受信任，以便 Microsoft 不会阻止它们运行。此安全警告并非特定于此加载项。这是您需要对从 Internet 下载的每个 excel 加载项执行的操作。请参阅以下步骤
右键单击加载项文件，然后选择 Properties （属性）。选择安全选项下的取消阻止复选框，然后单击确定
请按照以下步骤安装和激活加载项
- 打开 Excel 并单击文件 标签。
- 单击选项 ，然后从左侧菜单中选择 Add-ins。
- 在屏幕底部的Manage 下拉菜单中，选择 Excel Add-ins 并单击 Go 按钮。
- 单击浏览 按钮并选择您下载的加载项文件。点击 OK 按钮。
- 选中ChatGPT 插件旁边的框以激活它。
以下是功能介绍
AI 搜索引擎
在 Excel 中使用 ChatGPT 有两种搜索方法。一个是通过插件按钮，另一个是通过 Excel 功能。
如果您没有 ChatGPT 的 API 密钥， 根据国内的环境，我们使用的是智谱清言的 API。下一步是生成 API 密钥并复制它以在加载项中使用它。
AIAssistant
单击 ChatGPT 选项卡中的 AIAssistant 按钮，然后选择输入提示（问题）的单元格。例如，您在单元格 B2 中有文本 “Capital city of Spain”。您需要在输入框中选择单元格 B2。如果您是第一次使用 API Key，它会要求提供 API Key。请确保在此之前已生成 ChatGPT 的 API Key。
对于类似的功能，您还可以 AIAssistant（ ） 函数。使用该函数的好处是，您可以通过向下拖动该函数来针对多个提示运行
语法
AIAssistant（“文本”， [word_count]）
- 文本 ： 你想在 ChatGPT 中搜索的文本
- word_count ：可选。为 ChatGPT 生成的输出指定所需的字数
多轮次对话（如聊天）
要在插件中启用多轮次对话，请按照以下说明操作 - 指南：激活聊天
AIAssistant_Chat(“文本”, [reset])
- 文本 ： 你想在 ChatGPT 中搜索的文本
- reset ：可选。是否重置
填充缺失数据
函数 AIAssistant_FillData（ ） 使用现有数据来训练 ChatGPT 并填充不完整的数据。
语法
AIAssistant_FillData（rng_existingdata， rng_fill）
- rng_existingdata ： 现有数据的范围
- rng_fill ： 指定需要填写的数据范围
通过使用 AIAssistant_Extractor（ ） 功能，可以从 ChatGPT 中提取姓名、位置、组织详细信息等重要信息。
语法
AIAssistant_Extractor（提示、关键字）
- prompt ：要从中提取关键数据的文本
- 关键字 ： 关键字可以是名称、地点、组织、数字等。
掌握 Excel 公式
AIAssistant_Explain（ ） 函数可帮助您学习任何 excel 公式。
语法
AIAssistant_Explain（cell_formula， [详细]）
- cell_formula ：指定包含您需要学习的 excel 公式的单元格
- detail ：可选。默认值为 TRUE。如果想要更详细的响应，请设置 FALSE
洞察生成
AIAssistant_Insights（ ） 函数可帮助您从数据中生成见解。该插件就像分析师一样，会为您分析数据。要了解更多信息，请查看此链接 - 使用 ChatGPT 在 Excel 中进行自动数据分析
语法
AIAssistant_Insights（rng_data、[提示]）
- rng_data ：指定包含要分析的数据的单元格。
- prompt ：可选。指定要了解的有关数据的信息。
翻译文本
AIAssistant_Translator（ ） 函数可帮助您翻译任何文本。这就像在 Excel 中嵌入 Google 翻译的功能。
语法
AIAssistant_Translator（文本、语言）
- text ：指定包含需要翻译的文本的单元格。
- language ：指定包含语言名称的单元格。
使用图像
- 最新的 ChatGPT 模型可以将图像作为输入处理。要在 Excel 中使用它，您可以使用该功能 -=AIAssistant_Image("Explain this image","C:\Downloads\myimage.png")
- 要在 Excel 中使用 ChatGPT 创建图像，您可以使用该功能 -=createImage("monk in orange dress", "1024x1024")
Add-In 的其他功能
- 要修复插件中的非英文字母，请参考本指南：修复编码问题
- 您可以通过单击Update Key （更新密钥） 按钮来更新您的 API 密钥。同样，您可以通过单击 Check Key 按钮来检查您现有的 API 密钥。
- 您可以通过单击微调响应按钮来更改温度参数，从而提高 ChatGPT 的响应质量。该参数的值介于 0 和 2 之间。较高的值（如 1.5）将生成更随机的输出，而较低的值（如 0.5）将生成更集中的输出。
API 密钥存储在此加载项中的什么位置？
它仅存储在您的系统中的注册表中。
我们在Excel 中点开开发工具，然后输入以下脚本：
Function AIAssistant(text As String, Optional word_count As Long = 0) As String
Dim API, api_key, DisplayText, error_result As String
Dim startPos, endPos, status_code As Long
Dim rng As Range
Dim myApp As String, Sett As String, secretKey, ModelValue As String
Dim TemperatureValue As Double
Dim json As Object
Dim jsonObject As Object
Dim contentValue As String
'API Info
API = "https://api.openai.com/v1/chat/completions"
'Application name
myApp = "My Application"
Sett = "API Keys"
secretKey = "OpenAI"
'Check registry for existing API key
api_key = GetSetting(myApp, Sett, secretKey, "No value")
If api_key = "No value" Or Trim(api_key) = "" Then
ChatGPTForm.Show vbModal
api_key = GetSetting(myApp, Sett, secretKey, "No value")
End If
'Input Text
If word_count > 0 Then
text = text & ". Provide response in maximum " & word_count & " words"
End If
text = Replace(text, Chr(34), Chr(39))
text = Replace(text, vbLf, "\n")
'Application name
myApp = "ChatGPT Excel"
Sett = "Temperature"
secretKey = "Params"
'Check registry for existing API key
TemperatureValue = GetSetting(myApp, Sett, secretKey, 0.7)
'Application name
myApp = "My Application2"
Sett = "Model"
secretKey = "ModelType"
ModelValue = GetSetting(myApp, Sett, secretKey, "gpt-3.5-turbo")
'Send request to API
Dim client As New WebClient
Dim request As New WebRequest
Dim response As WebResponse
Dim requestBody As New Dictionary
Dim responseBody As String
client.TimeoutMs = 30000
client.BaseUrl = API
request.RequestFormat = WebFormat.json
request.Method = HttpPost
request.AddHeader "Authorization", "Bearer " & api_key
Dim messagePrompt() As Dictionary
Dim message As New Dictionary
message.Add "content", text
message.Add "role", "user"
ReDim messagePrompt(0)
Set messagePrompt(0) = message
requestBody.Add "model", ModelValue
requestBody.Add "messages", messagePrompt
requestBody.Add "temperature", TemperatureValue
requestBody.Add "top_p", 1
Set request.body = requestBody
Set response = client.Execute(request)
status_code = response.StatusCode
responseBody = response.content
'Parse response from API
If status_code = 200 Then
Set jsonObject = ParseJson(responseBody)
DisplayText = jsonObject("choices")(1)("message")("content")
Else
Set jsonObject = ParseJson(responseBody)
DisplayText = jsonObject("error")("message")
If DisplayText = "" Then
DisplayText = jsonObject("error")("code")
End If
End If
If word_count > 0 And Right(DisplayText, 1) = "." Then
DisplayText = Left(DisplayText, Len(DisplayText) - 1)
Else
DisplayText = DisplayText
End If
'Return result
AIAssistant = DisplayText
End Function将上面的KEY替换成自己的，就可以在Excel里面对话了。
多轮对话
我们还可以进行多轮对话
Public Function AIAssistant_Chat(text As String, Optional reset As Boolean = False) As String
Dim API, api_key, error_result As String
Dim startPos, endPos, status_code As Long
Dim myApp As String, Sett As String, secretKey, ModelValue As String
Dim TemperatureValue As Double
Dim json As Object
Dim jsonObject As Object
Dim contentValue As String
Dim DisplayText As String
Dim DisplayText0 As String
API = "https://api.openai.com/v1/chat/completions"
'Application name
myApp = "My Application"
Sett = "API Keys"
secretKey = "OpenAI"
'Check registry for existing API key
api_key = GetSetting(myApp, Sett, secretKey, "No value")
If api_key = "No value" Or Trim(api_key) = "" Then
ChatGPTForm.Show vbModal
api_key = GetSetting(myApp, Sett, secretKey, "No value")
End If
text = Replace(text, Chr(34), Chr(39))
text = Replace(text, vbLf, "\n")
'Application name
myApp = "ChatGPT Excel"
Sett = "Temperature"
secretKey = "Params"
'Check registry for existing API key
TemperatureValue = GetSetting(myApp, Sett, secretKey, 0.7)
'Application name
myApp = "My Application2"
Sett = "Model"
secretKey = "ModelType"
ModelValue = GetSetting(myApp, Sett, secretKey, "gpt-3.5-turbo")
'Send request to API
Dim client As New WebClient
Dim request As New WebRequest
Dim response As WebResponse
Dim requestBody As New Dictionary
Dim responseBody As String
client.TimeoutMs = 30000
client.BaseUrl = API
request.RequestFormat = WebFormat.json
request.Method = HttpPost
request.AddHeader "Authorization", "Bearer " & api_key
If reset Then
Erase messages
End If
Dim message As New Dictionary
message.Add "content", text
message.Add "role", "user"
If IsEmpty(messages) Then
ReDim messages(0)
Else
ReDim Preserve messages(UBound(messages) + 1)
End If
Set messages(UBound(messages)) = message
requestBody.Add "model", ModelValue
requestBody.Add "messages", messages
requestBody.Add "temperature", TemperatureValue
requestBody.Add "top_p", 1
Set request.body = requestBody
Set response = client.Execute(request)
status_code = response.StatusCode
responseBody = response.content
'Parse response from API
If status_code = 200 Then
Set jsonObject = ParseJson(responseBody)
DisplayText = jsonObject("choices")(1)("message")("content")
DisplayText0 = ExtractContent(DisplayText)
'Update chatHistory
Dim message2 As New Dictionary
message2.Add "content", DisplayText0
message2.Add "role", "assistant"
ReDim Preserve messages(UBound(messages) + 1)
Set messages(UBound(messages)) = message2
Else
Set jsonObject = ParseJson(responseBody)
DisplayText = jsonObject("error")("message")
If DisplayText = "" Then
DisplayText = jsonObject("error")("code")
End If
End If
' return
AIAssistant_Chat = DisplayText
End Function当然我们也可以用它来解释Excel自带的函数
Function AIAssistant_Explain(cell_formula As Range, Optional detail As Boolean = True)
Dim formulaText, formulaText2 As String
If cell_formula.HasFormula Then
formulaText = cell_formula.Formula
If detail Then
formulaText2 = "Explain this MS Excel Function " & formulaText
Else
formulaText2 = "Explain this MS Excel Function. Less Verbose. " & formulaText
End If
AIAssistant_Explain = AIAssistant(formulaText2)
Else
AIAssistant_Explain = "Cell does not contain MS Excel formula"
End If
End Function
批量翻译
Function AIAssistant_Translator(text As String, language As String)
Dim translateText As String
translateText = "Act like a translator. Translate the following text to " & language & "." & "\n" & text
AIAssistant_Translator = CleanMsg(AIAssistant(translateText))
End Function
批量生成假数据
Function AIAssistant_FillData(rng_existingdata As Range, rng_fill As Range)
Dim API, api_key, prompt, prompt2 As String
Dim myData, myData2 As String
Dim i As Long
Dim words() As String
Dim outputText() As String
Dim myApp As String, Sett As String, secretKey, ModelValue As String
Dim TemperatureValue As Double
Dim json As Object
Dim jsonObject As Object
Dim contentValue As String
Dim delimiter As String
delimiter = "-->"
'API
API = "https://api.openai.com/v1/chat/completions"
myData = rng_existingdata.value
'Application name
myApp = "My Application"
Sett = "API Keys"
secretKey = "OpenAI"
'Check registry for existing API key
api_key = GetSetting(myApp, Sett, secretKey, "No value")
If api_key = "No value" Or Trim(api_key) = "" Then
ChatGPTForm.Show vbModal
api_key = GetSetting(myApp, Sett, secretKey, "No value")
End If
'Application name
myApp = "ChatGPT Excel"
Sett = "Temperature"
secretKey = "Params"
'Check registry for existing API key
TemperatureValue = GetSetting(myApp, Sett, secretKey, 0.7)
'Application name
myApp = "My Application2"
Sett = "Model"
secretKey = "ModelType"
ModelValue = GetSetting(myApp, Sett, secretKey, "gpt-3.5-turbo")
' Generate prompt string
If rng_fill.Count > 1 Then
AIAssistant_FillData = "second argument can't have range with more than 1 cell"
Exit Function
Else
myData2 = Replace(rng_fill.value, Chr(34), "")
myData2 = Replace(myData2, vbLf, " ")
myData2 = Application.Trim(Replace(myData2, Chr(39), ""))
End If
prompt = ""
For i = LBound(myData, 1) To UBound(myData, 1)
cleaned = Application.Trim(Replace(myData(i, 1), vbLf, " "))
prompt = prompt & cleaned & delimiter & myData(i, 2) & "\n"
Next i
prompt = Replace(prompt, Chr(34), "")
prompt = Replace(prompt, Chr(39), "")
' query build
query = "Do not write explanations on replies.\n"
If rng_fill.Count > 1 Then
AIAssistant_FillData = "second argument can't have range with more than 1 cell"
Exit Function
Else
myData2 = Replace(rng_fill.value, Chr(34), "")
myData2 = Replace(myData2, vbLf, " ")
myData2 = Application.Trim(Replace(myData2, Chr(39), ""))
End If
prompt2 = query & myData2 & delimiter
' Send POST request to OpenAI API
Dim client As New WebClient
Dim request As New WebRequest
Dim response As WebResponse
Dim requestBody As New Dictionary
Dim responseBody As String
client.TimeoutMs = 30000
client.BaseUrl = API
request.RequestFormat = WebFormat.json
'request.Resource = API
request.Method = HttpPost
request.AddHeader "Authorization", "Bearer " & api_key
Dim messagePrompt() As Dictionary
Dim message As New Dictionary
Dim message2 As New Dictionary
message.Add "content", prompt
message.Add "role", "system"
message2.Add "content", prompt2
message2.Add "role", "user"
ReDim messagePrompt(1)
Set messagePrompt(0) = message
Set messagePrompt(1) = message2
requestBody.Add "model", ModelValue
requestBody.Add "messages", messagePrompt
requestBody.Add "temperature", TemperatureValue
requestBody.Add "top_p", 1
Set request.body = requestBody
Set response = client.Execute(request)
status_code = response.StatusCode
responseBody = response.content
'Check status code
If status_code = 200 Then
Set jsonObject = ParseJson(responseBody)
DisplayText = jsonObject("choices")(1)("message")("content")
DisplayText = Replace(DisplayText, "\\", "\")
DisplayText = Replace(DisplayText, delimiter, "")
'Extract after line break
words = Split(DisplayText, "\n")
x = UBound(words)
If x >= 1 Then
If Len(words(1)) >= 1 Then
ReDim outputText(1 To x + 1)
outputText(1) = words(1)
DisplayText = Join(outputText, " ")
Else
DisplayText = Replace(DisplayText, "\n", "")
End If
End If
'Check if prompt exists in output
If InStr(DisplayText, myData2) > 0 Then
DisplayText = Replace(DisplayText, myData2, "")
End If
'Remove full stops at end of the reply
words = Split(DisplayText, ".")
x = UBound(words)
If x = 1 And Right(DisplayText, 1) = "." Then
DisplayText = Left(DisplayText, Len(DisplayText) - 1)
End If
Else
' ERROR MESSAGE
Set jsonObject = ParseJson(responseBody)
DisplayText = jsonObject("error")("message")
If DisplayText = "" Then
DisplayText = jsonObject("error")("code")
End If
End If
AIAssistant_FillData = DisplayText
End Function关键信息提取
Function AIAssistant_Extractor(prompt As Range, keyword As String)
Dim API, api_key, prompt2 As String
Dim myData, myData2 As String
Dim i As Long
Dim words() As String
Dim outputText() As String
Dim myApp As String, Sett As String, secretKey, ModelValue As String
Dim TemperatureValue As Double
Dim json As Object
Dim jsonObject As Object
Dim contentValue As String
'API
API = "https://api.openai.com/v1/chat/completions"
myData = prompt.value
'Application name
myApp = "My Application"
Sett = "API Keys"
secretKey = "OpenAI"
'Check registry for existing API key
api_key = GetSetting(myApp, Sett, secretKey, "No value")
If api_key = "No value" Or Trim(api_key) = "" Then
ChatGPTForm.Show vbModal
api_key = GetSetting(myApp, Sett, secretKey, "No value")
End If
'Application name
myApp = "ChatGPT Excel"
Sett = "Temperature"
secretKey = "Params"
'Check registry for existing API key
TemperatureValue = GetSetting(myApp, Sett, secretKey, 0.7)
'Application name
myApp = "My Application2"
Sett = "Model"
secretKey = "ModelType"
ModelValue = GetSetting(myApp, Sett, secretKey, "gpt-3.5-turbo")
' Generate prompt string
myData2 = Replace(myData, Chr(34), "")
myData2 = Application.Trim(Replace(myData2, vbLf, " "))
prompt2 = "Extract " & keyword & " from " & "\n" & "'" & myData & "'" & ". Be less verbose on replies."
' Send POST request to OpenAI API
Dim client As New WebClient
Dim request As New WebRequest
Dim response As WebResponse
Dim requestBody As New Dictionary
Dim responseBody As String
client.TimeoutMs = 30000
client.BaseUrl = API
request.RequestFormat = WebFormat.json
'request.Resource = API
request.Method = HttpPost
request.AddHeader "Authorization", "Bearer " & api_key
Dim messagePrompt() As Dictionary
Dim message As New Dictionary
message.Add "content", prompt2
message.Add "role", "user"
ReDim messagePrompt(0)
Set messagePrompt(0) = message
requestBody.Add "model", ModelValue
requestBody.Add "messages", messagePrompt
requestBody.Add "temperature", TemperatureValue
requestBody.Add "top_p", 1
Set request.body = requestBody
Set response = client.Execute(request)
status_code = response.StatusCode
responseBody = response.content
'Check status code
If status_code = 200 Then
Set jsonObject = ParseJson(responseBody)
DisplayText = jsonObject("choices")(1)("message")("content")
'Extract after line break
words = Split(DisplayText, ":")
x = UBound(words)
ReDim outputText(1 To x + 1)
If x >= 1 Then
outputText(1) = words(1)
DisplayText = Join(outputText, " ")
End If
' Check if the string contains a tab character
hasTab = InStrRev(DisplayText, "\t")
If hasTab > 0 Then
DisplayText = Mid(DisplayText, hasTab + 2)
End If
If Right(DisplayText, 1) = "." Then
DisplayText = Left(DisplayText, Len(DisplayText) - 1)
End If
Else
Set jsonObject = ParseJson(responseBody)
DisplayText = jsonObject("error")("message")
If DisplayText = "" Then
DisplayText = jsonObject("error")("code")
End If
End If
'Check if prompt exists in output
If InStr(DisplayText, keyword) > 0 Then
DisplayText = Replace(DisplayText, keyword, "")
End If
AIAssistant_Extractor = Application.Trim(DisplayText)
End Function负责从返回内容中提取文本
Function ExtractContent(content As String) As String
content = Replace(content, Chr(34), Chr(39))
'Fix for excel forumulas as response
If Left(Trim(content), 1) = "=" Then
content = "'" & content
End If
If Right(content, 1) = """" Then
content = Left(content, Len(content) - 1)
End If
If Right(content, 1) = "\" Then
content = Left(content, Len(content) - 1)
End If
ExtractContent = content
End Function中文支持
虽然我看不懂这段代码，不过真的管用
Public Function CleanMsg(ByVal strText As String) As String
Dim i&, l1&, l2&, l3&, l4&, l&
For i = 1 To Len(strText)
l1 = AscW(Mid(strText, i, 1))
If i + 1 <= Len(strText) Then l2 = AscW(Mid(strText, i + 1, 1))
If i + 2 <= Len(strText) Then l3 = AscW(Mid(strText, i + 2, 1))
If i + 3 <= Len(strText) Then l4 = AscW(Mid(strText, i + 3, 1))
Select Case l1
Case 1 To 127
l = l1
Case 194 To 223
l = ((l1 And &H1F) * 2 ^ 6) Or (l2 And &H3F)
i = i + 1
Case 224 To 239
l = ((l1 And &HF) * 2 ^ 12) Or ((l2 And &H3F) * 2 ^ 6) Or (l3 And &H3F)
i = i + 2
Case 240 To 255
l = ((l1 And &H7) * 2 ^ 18) Or ((l2 And &H3F) * 2 ^ 12) Or ((l3 And &H3F) * 2 ^ 6) Or (l4 And &H3F)
i = i + 4
Case Else
l = 63
End Select
CleanMsg = CleanMsg & IIf(l < 55296, WorksheetFunction.Unichar(l), "?")
Next i
End Function
观点提炼
Sub AIAssistant_Insights2(Control As IRibbonControl)
Dim mytext As String
Dim splitArr() As String
Dim Format As Integer
Dim promptRange As Range
Dim rng As Range
Dim rng2 As Range
Dim promptArray As Variant
Dim header As String
Dim data As String
Dim i As Long
On Error GoTo errhandler
Set promptRange = Application.InputBox("Please select cells containing data (including header)", Title:="Select Data (with Header)", Type:=8)
promptArray = promptRange.value
' Concatenate header values
For j = 1 To UBound(promptArray, 2)
header = header & promptArray(1, j) & "|"
Next j
' Concatenate data rows
Dim value As String
For i = 2 To UBound(promptArray, 1)
For j = 1 To UBound(promptArray, 2)
If promptArray(i, j) = "" Then
value = "NA"
Else
value = promptArray(i, j)
End If
data = data & value & "|"
Next j
data = data & " "
Next i
mytext = "Act like analyst. Generate key insights based on the following data." & "\n" & header & "\n" & data
frmProgressForm.Show
Result = AIAssistant(mytext)
Unload frmProgressForm
'Clear multiple line breaks
Result = Replace(Result, vbCrLf & vbCrLf, vbCrLf)
On Error GoTo errhandler2
Set rng = Application.InputBox("Please choose a cell where the output will be saved.", Title:="Output", Type:=8)
splitArr = Split(Result, vbCrLf)
If UBound(splitArr) > 0 Then
Format = MsgBox("Since output is lengthy, would you like it to be displayed in multiple cells?", vbYesNo)
If Format = vbNo Then
rng.value = Result
With rng
.WrapText = True
.EntireColumn.AutoFit
.VerticalAlignment = xlTop
End With
Else
Set rng2 = Range(rng.Offset(1, 0), rng.Offset(10, 0))
rng2.Clear
For i = LBound(splitArr) To UBound(splitArr)
x = splitArr(i)
If Left(Trim(x), 1) = "=" Then
x = "'" & x
End If
rng.Offset(i, 0).value = x
Next i
With rng2
.WrapText = True
.EntireColumn.AutoFit
.VerticalAlignment = xlTop
End With
End If
Else
rng.value = Result
End If
Exit Sub
errhandler2:
MsgBox ("No cell is selected to save the output")
Unload frmProgressForm
errhandler:
MsgBox ("No input found")
Unload frmProgressForm
End Sub
Function AIAssistant_Insights(rng_data As Range, Optional prompt As String = "Key Insights")
Dim mytext As String
Dim splitArr() As String
Dim Format As Integer
Dim promptRange As Range
Dim rng As Range
Dim rng2 As Range
Dim promptArray As Variant
Dim header As String
Dim data As String
Dim i As Long
Set promptRange = rng_data
promptArray = promptRange.value
' Concatenate header values
For j = 1 To UBound(promptArray, 2)
header = header & promptArray(1, j) & "|"
Next j
' Concatenate data rows
Dim value As String
For i = 2 To UBound(promptArray, 1)
For j = 1 To UBound(promptArray, 2)
If promptArray(i, j) = "" Then
value = "NA"
Else
value = promptArray(i, j)
End If
data = data & value & "|"
Next j
data = data & " "
Next i
If prompt = "Key Insights" Then
mytext = "Act like analyst. Generate key insights based on the following data." & "\n" & header & "\n" & data
Else
mytext = "Act like analyst. Do not write explanations on replies. " & prompt & "." & "\n" & header & "\n" & data
End If
Result = AIAssistant(mytext)
AIAssistant_Insights = Result
End Function微调
Function AIAssistant_QnA(query As Variant, passage As Variant) As String
Dim prompt As String
Dim cell As Range
Dim fullPassage As String
Dim fullquery As String
' Concatenate all cells
If TypeName(passage) = "Range" Then
For Each cell In passage
fullPassage = fullPassage & " " & cell.value
Next cell
Else
fullPassage = CStr(passage)
End If
If TypeName(query) = "Range" Then
For Each cell In query
fullquery = fullquery & " " & cell.value
Next cell
Else
fullquery = CStr(query)
End If
fullPassage = Replace(Replace(Replace(fullPassage, "'", ""), """", ""), vbLf, " ")
fullPassage = Trim(fullPassage)
fullquery = Replace(Replace(Replace(fullquery, "'", ""), """", ""), vbLf, " ")
fullquery = Trim(fullquery)
prompt = "Act like a customer care executive that answers questions using text from the reference passage included below. " & _
"Be less verbose." & vbLf & _
"QUESTION: '" & fullquery & "'" & vbLf & _
"PASSAGE: '" & fullPassage & "'" & vbLf & vbLf & _
"ANSWER:" & vbLf
AIAssistant_QnA = AIAssistant(prompt)
End Function图片生成
Function AIAssistant_Image(prompt As String, image_path As String, Optional detail As String = "high", Optional max_tokens As Long = 300) As String
Dim API, api_key, DisplayText, error_result As String
Dim startPos, endPos, status_code As Long
Dim rng As Range
Dim myApp As String, Sett As String, secretKey, ModelValue As String
Dim TemperatureValue As Double
Dim json As Object
Dim jsonObject As Object
Dim contentValue As String
Dim base64String As String
'API Info
API = "https://api.openai.com/v1/chat/completions"
'Application name
myApp = "My Application"
Sett = "API Keys"
secretKey = "OpenAI"
'Check registry for existing API key
api_key = GetSetting(myApp, Sett, secretKey, "No value")
If api_key = "No value" Or Trim(api_key) = "" Then
ChatGPTForm.Show vbModal
api_key = GetSetting(myApp, Sett, secretKey, "No value")
End If
'Input Text
text = Replace(prompt, Chr(34), Chr(39))
text = Replace(text, vbLf, "\n")
'Application name
myApp = "My Application2"
Sett = "Model"
secretKey = "ModelType"
ModelValue = GetSetting(myApp, Sett, secretKey, "gpt-3.5-turbo")
'Image
base64String = EncodeImageToBase64(image_path)
base64String = "data:image/jpeg;base64," + base64String
Dim client As New WebClient
Dim request As New WebRequest
Dim response As WebResponse
Dim requestBody As New Dictionary
Dim responseBody As String
client.TimeoutMs = 30000
client.BaseUrl = API
request.RequestFormat = WebFormat.json
request.Method = HttpPost
request.AddHeader "Authorization", "Bearer " & api_key
Dim messagePrompt() As Dictionary
Dim message As New Dictionary
Dim contentText As New Dictionary
Dim contentImageUrl As New Dictionary
Dim imageUrl As New Dictionary
contentText.Add "type", "text"
contentText.Add "text", text
contentImageUrl.Add "type", "image_url"
imageUrl.Add "url", base64String
imageUrl.Add "detail", detail
contentImageUrl.Add "image_url", imageUrl
message.Add "role", "user"
message.Add "content", Array(contentText, contentImageUrl)
ReDim messagePrompt(0)
Set messagePrompt(0) = message
requestBody.Add "model", ModelValue
requestBody.Add "messages", messagePrompt
requestBody.Add "max_tokens", max_tokens
Set request.body = requestBody
Set response = client.Execute(request)
status_code = response.StatusCode
responseBody = response.content
'Parse response from API
If status_code = 200 Then
Set jsonObject = ParseJson(responseBody)
DisplayText = jsonObject("choices")(1)("message")("content")
Else
Set jsonObject = ParseJson(responseBody)
DisplayText = jsonObject("error")("message")
If DisplayText = "" Then
DisplayText = jsonObject("error")("code")
End If
End If
'Return result
AIAssistant_Image = DisplayText
End Function
Function EncodeImageToBase64(imagePath As String) As String
#If Mac Then
Dim web_Command As String
web_Command = "cat " & imagePath & " | openssl base64"
EncodeImageToBase64 = ExecuteInShell(web_Command).Output
#Else
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
stream.Type = 1 ' adTypeBinary
stream.Open
stream.LoadFromFile imagePath
Dim xml As Object
Set xml = CreateObject("MSXML2.DOMDocument")
Dim node As Object
Set node = xml.createElement("b64")
node.DataType = "bin.base64"
node.nodeTypedValue = stream.Read
EncodeImageToBase64 = node.text
stream.Close
Set stream = Nothing
Set xml = Nothing
#End If
End Function
Function createImage(prompt As String, Optional size As String = "1024x1024") As String
Dim API, api_key, DisplayText, error_result As String
Dim startPos, endPos, status_code As Long
Dim rng As Range
Dim myApp As String, Sett As String, secretKey, ModelValue As String
Dim TemperatureValue As Double
Dim json As Object
Dim jsonObject As Object
Dim contentValue As String
'API Info
API = "https://api.openai.com/v1/images/generations"
'Application name
myApp = "My Application"
Sett = "API Keys"
secretKey = "OpenAI"
'Check registry for existing API key
api_key = GetSetting(myApp, Sett, secretKey, "No value")
If api_key = "No value" Or Trim(api_key) = "" Then
ChatGPTForm.Show vbModal
api_key = GetSetting(myApp, Sett, secretKey, "No value")
End If
'Input Text
text = Replace(prompt, Chr(34), Chr(39))
text = Replace(text, vbLf, "\n")
Dim client As New WebClient
Dim request As New WebRequest
Dim response As WebResponse
Dim requestBody As New Dictionary
Dim responseBody As String
client.TimeoutMs = 30000
client.BaseUrl = API
request.RequestFormat = WebFormat.json
request.Method = HttpPost
request.AddHeader "Authorization", "Bearer " & api_key
requestBody.Add "prompt", text
requestBody.Add "n", 1
requestBody.Add "size", size
requestBody.Add "response_format", "url"
Set request.body = requestBody
Set response = client.Execute(request)
status_code = response.StatusCode
responseBody = response.content
'Parse response from API
Set jsonObject = ParseJson(responseBody)
If status_code = 200 Then
DisplayText = jsonObject("data")(1)("url")
Else
DisplayText = jsonObject("error")("message")
If DisplayText = "" Then
DisplayText = jsonObject("error")("code")
End If
End If
'Return result
createImage = DisplayText
End Function
Sub createImage2(Control As IRibbonControl)
Dim val As String
Dim selectedCell, cellr, rng As Range
Dim splitArr() As String
Dim delimiter As String
Dim Format As Integer
delimiter = "\n"
On Error GoTo errhandler
Set selectedCell = Application.InputBox("Please select a cell containing the image description", Type:=8)
If selectedCell Is Nothing Then
MsgBox "No cell selected"
Else
Set cellr = selectedCell.Offset(1, 0)
If Trim(selectedCell.text) = "" Then
MsgBox "Seems to be a blank cell."
Exit Sub
End If
frmProgressForm.Show
val = createImage(selectedCell.text)
Unload frmProgressForm
cellr.value = val
End If
Exit Sub
errhandler:
MsgBox ("No input found")
End Sub
赞
收藏
回复
相关推荐
