在 Excel 裡用 ChatGPT 翻譯圖片上的文字

1. 他需要手動把圖片裡的文字一個一個寫出來（在電腦上）
2. 他需要翻譯這些文字

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

=TranslateCell ([你要翻譯的 EXCEL CELL], "[你需要的語言]")

VBA 自身其實並不支持 JSON 解讀。JSON 解讀其實有好幾種方法，我們這裡選用的是源自 Daniel Ferry 的方法。