【API-VBA】Web APIを使ってWord文書を翻訳をする（DeepL API）

Sub WordTranlsation()

    Dim FileName As String
    Dim wb As Workbook
    
    'Wordファイルを選択する
    FileName = Application.GetOpenFilename(FileFilter:="Wordファイル,*.doc*")
    If FileName = "False" Then
        Exit Sub
    End If
    
    'Wordファイルを開く
    Dim wd As Word.Application
    Dim doc As Document
    
    Set wd = New Word.Application
    wd.Visible = True
    Set doc = wd.Documents.Open(FileName, False, True)
    
    Dim par As Paragraph
    Dim SourceSentense As String '原文
    Dim TranslatedSentense As String  '翻訳文
    
    '各段落を取得し、翻訳する
    For Each par In doc.Paragraphs
        SourceSentense = par.Range.Text
        If SourceSentense <> Chr(13) Then '改段落のみは処理しない
            TranslatedSentense = getTranslation(SourceSentense)
            TranslatedSentense = Replace(TranslatedSentense, vbCrLf, "") 'Deeplの場合翻訳文にvbCrLfが含まれている為削除
            '段落の末尾に翻訳文を追加する
            doc.Range(0, par.Range.End - 1).InsertAfter (vbVerticalTab & TranslatedSentense)
        End If
    Next

    Application.DisplayAlerts = False
    doc.SaveAs2 doc.Path & "\(JP-EN)" & Dir(FileName)
    Application.DisplayAlerts = True

End Sub

Function getTranslation(ByVal SourceSentense As String) As String

    'DeepLで取得したkey
    Const APIkey As String = "取得したAPIキー"
    
    Dim http As MSXML2.XMLHTTP60
    Set http = New MSXML2.XMLHTTP60
   
   
    With http
    
        'HTTPリクエスト（POSTメソッド）
        Call .Open("POST", "https://api-free.deepl.com/v2/translate?text=" & SourceSentense & "&source_lang=EN&target_lang=JA")
        Call .setRequestHeader("Authorization", "DeepL-Auth-Key " & APIkey)
        Call .send
        
        Do
            If .readyState = 4 Then Exit Do
            DoEvents
        Loop
        
        'HTTPレスポンスの内容確認
        '*成功時：｛Res="status":200, "message":"ok"}
        'Debug.Print .responseText
        'Debug.Print .Status
        
        'ダブルクォーテーションで区切って配列として取得
        Dim buf As Variant
        Dim TranslatedSentense As String
        
        buf = Split(http.responseText, """")
        getTranslation = buf(9)
        'Debug.Print TranslatedSentense
               
    End With
    
End Function

FileName = Application.GetOpenFilename(FileFilter:="Wordファイル,*.doc*")

    '各段落を取得し、翻訳する
    For Each par In doc.Paragraphs
        SourceSentense = par.Range.Text
        If SourceSentense <> Chr(13) Then '改段落のみは処理しない
            TranslatedSentense = getTranslation(SourceSentense)
            TranslatedSentense = Replace(TranslatedSentense, vbCrLf, "") 'Deeplの場合翻訳文にvbCrLfが含まれている為削除

   doc.Range(0, par.Range.End - 1).InsertAfter (vbVerticalTab & TranslatedSentense)

doc.SaveAs2 doc.Path & "\(JP-EN)" & Dir(FileName)