你應該已經聽說了 OpenAI ChatGPT 是如何如何強大，如何如何創造奇跡。。。我就不再畫蛇添足多加描述了。我們不如來讓它來為我們做點正經事（而不是把它當成玩具）。最近我有個朋友和我說了以下的問題：
- 他需要手動把圖片裡的文字一個一個寫出來（在電腦上）
- 他需要翻譯這些文字
其實。。。以上我們可以用一種方法，一石二鳥，一次性解決以上的問題。我的方案是，在 Excel 上用 OpenAI ChatGPT 來解決。 OpenAI ChatGPT.
1. 首先，你得先建立一個 Excel 文件，儲存為 .xlsm 文件格式，也就是可以用 Macro 的格式。
2. 在菜單裡，點擊 Developer 選項，然後選擇 Visual Basic。如果你沒辦法找到 Developer 選項，看這裡。
3. 在 Visual Basic 的視窗裡，點擊 Tools，然後 References，得注意主要加入 “Microsoft XML, v6.0” 庫。
4. 在主要菜單裡選擇 Insert，然後是 Module。
5. 這時候，你會看見 Module 1 出現在 Project 的對話框。點擊它，把以下的代碼粘貼到編輯器裡。記得把你的 OpenAPI 的密鑰也寫進去。看不明白？別擔心。。。這裡本來就是低代碼，我們為你准備就是。
Option Explicit
Private p&, token, dic
Function TranslateCell(cellContent As Range, targetLanguage As String) As String
Dim httpRequest As Object
Dim apiKey As String
Dim apiUrl As String
Dim postData As String
Dim response As String
Dim jsonResponse As Object
Dim translatedText As String
' Replace with your OpenAI API key
apiKey = "YOUR-OPEN-API-KEY"
' Set the API URL for ChatGPT 3.5
apiUrl = "https://api.openai.com/v1/chat/completions"
' Prepare the POST data
postData = "{""model"": ""gpt-3.5-turbo"", ""messages"": [{""role"": ""system"", ""content"": ""You are an expert translator""}, {""role"": ""user"", ""content"": ""Translate this word into " & targetLanguage & ", answer only: " & cellContent.Text & """}], ""temperature"":0.7, ""max_tokens"":1000, ""top_p"":1, ""frequency_penalty"":0, ""presence_penalty"":0}"
' Clean up escape caharacters
postData = Replace(postData, "'", "")
' Create an HTTP request object
Set httpRequest = CreateObject("MSXML2.ServerXMLHTTP.6.0")
' Configure the HTTP request
With httpRequest
.Open "POST", apiUrl, False
.SetRequestHeader "Content-Type", "application/json"
.SetRequestHeader "Authorization", "Bearer " & apiKey
.Send postData
End With
' Get the HTTP response
response = httpRequest.ResponseText
' Parse the JSON response
Set jsonResponse = ParseJSON(response)
' Get the translated text
translatedText = jsonResponse("obj.choices(0).message.content")
' Return the translated text
TranslateCell = translatedText
End Function
Function ParseJSON(json$, Optional key$ = "obj") As Object
p = 1
token = Tokenize(json)
Set dic = CreateObject("Scripting.Dictionary")
If token(p) = "{" Then ParseObj key Else ParseArr key
Set ParseJSON = dic
End Function
Function ParseObj(key$)
Do: p = p + 1
Select Case token(p)
Case "]"
Case "[": ParseArr key
Case "{"
If token(p + 1) = "}" Then
p = p + 1
dic.Add key, "null"
Else
ParseObj key
End If
Case "}": key = ReducePath(key): Exit Do
Case ":": key = key & "." & token(p - 1)
Case ",": key = ReducePath(key)
Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
End Select
Loop
End Function
Function ParseArr(key$)
Dim e&
Do: p = p + 1
Select Case token(p)
Case "}"
Case "{": ParseObj key & ArrayID(e)
Case "[": ParseArr key
Case "]": Exit Do
Case ":": key = key & ArrayID(e)
Case ",": e = e + 1
Case Else: dic.Add key & ArrayID(e), token(p)
End Select
Loop
End Function
'-------------------------------------------------------------------
' Support Functions
'-------------------------------------------------------------------
Function Tokenize(s$)
Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"
Tokenize = RExtract(s, Pattern, True)
End Function
Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)
Dim c&, m, n, v
With CreateObject("vbscript.regexp")
.Global = bGlobal
.MultiLine = False
.IgnoreCase = True
.Pattern = Pattern
If .TEST(s) Then
Set m = .Execute(s)
ReDim v(1 To m.Count)
For Each n In m
c = c + 1
v(c) = n.Value
If bGroup1Bias Then If Len(n.submatches(0)) Or n.Value = """""" Then v(c) = n.submatches(0)
Next
End If
End With
RExtract = v
End Function
Function ArrayID$(e)
ArrayID = "(" & e & ")"
End Function
Function ReducePath$(key$)
If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1) Else ReducePath = key
End Function
Function ListPaths(dic)
Dim s$, v
For Each v In dic
s = s & v & " --> " & dic(v) & vbLf
Next
Debug.Print s
End Function
Function GetFilteredValues(dic, match)
Dim c&, i&, v, w
v = dic.keys
ReDim w(1 To dic.Count)
For i = 0 To UBound(v)
If v(i) Like match Then
c = c + 1
w(c) = dic(v(i))
End If
Next
ReDim Preserve w(1 To c)
GetFilteredValues = w
End Function
Function GetFilteredTable(dic, cols)
Dim c&, i&, j&, v, w, z
v = dic.keys
z = GetFilteredValues(dic, cols(0))
ReDim w(1 To UBound(z), 1 To UBound(cols) + 1)
For j = 1 To UBound(cols) + 1
z = GetFilteredValues(dic, cols(j - 1))
For i = 1 To UBound(z)
w(i, j) = z(i)
Next
Next
GetFilteredTable = w
End Function
Function OpenTextFile$(f)
With CreateObject("ADODB.Stream")
.Charset = "utf-8"
.Open
.LoadFromFile f
OpenTextFile = .ReadText
End With
End Function
6. 好了，你基本上已經完成，現在可以復制你要翻譯的圖片。
7. 回到你主要的 Excel 文件，在菜單裡，選擇 Data，點擊 From Picture 選項，然後再選擇是否來自文件還是粘貼版。有時候你會見到服務器繁忙的錯誤訊息，等一會再嘗試就是。
8. 這時候，你應該看到文字已經從圖片解析出來。選擇那些你要翻譯的文字，然後用以下的方程式
=TranslateCell ([你要翻譯的 EXCEL CELL], "[你需要的語言]")9. 你可以翻譯成任何語言，只要用同一個方程式就是。
VBA 自身其實並不支持 JSON 解讀。JSON 解讀其實有好幾種方法，我們這裡選用的是源自 Daniel Ferry 的方法。
