雷軍看了都要哭了的幾行代碼，WPS AI會員的錢又省了

sulu637

發布于 2024-11-29 14:42

瀏覽

0收藏

首先，我們可以配置幾乎所有的大模型，而 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

本文轉載自??AI大模型世界??，作者： rocLv ????

標簽

代碼

會員

贊

回復

舉報

回復

成人免费xxxxx在线视频软件_久久精品久久久_亚洲国产精品久久久_天天色天天色_亚洲人成一区_欧美一级欧美三级在线观看

51CTO

51CTO博客

51CTO學堂