プレゼンテーションを行う際、多言語対応が求められることが増えてきました。特にグローバルなビジネス環境では、異なる言語の聴衆に対して同じ情報を提供する必要があります。しかし、手作業でスライドのテキストを翻訳し、元のレイアウトやフォーマットを維持するのは非常に手間がかかります。そこで、PowerPointマクロとChatGPTのAPIを活用して、スライドのレイアウトや装飾をそのままに、効率的に翻訳する方法をご紹介します！
OfficeのVBAを使って、ChatGPTやDALL-E 3などのAPIを活用し、リボンUIに「スライド生成」や「画像解析」などのメニューをアドインとして実装する方法を解説した書籍を執筆しました。本書を使えば、Officeを簡単に生成AI対応にできます。発売から3か月でAmazonベストセラー1位になり、多くの方にご好評をいただいています。購入者特典として、出版社のサイトからアドインをダウンロードできるので、ぜひお試しください。参考になれば嬉しいです。
レイアウトと文字装飾を維持する重要性
スライドのレイアウトと文字装飾は、情報の伝達力を高めるために非常に重要です。テキストの配置、フォントの選択、色使いなどが一貫していることで、視覚的な理解が促進されます。以下は、レイアウトと文字装飾を維持することの主な利点です。
- 視覚的一貫性の維持: レイアウトや装飾が変わらないことで、視覚的な一貫性が保たれ、聴衆が情報を整理しやすくなります。
- 重要な情報の強調: 太字や色などの装飾は、重要な情報を強調するために使われます。これを維持することで、聴衆にとって重要なポイントが見やすくなります。
- プロフェッショナルな印象: 一貫したデザインはプロフェッショナルな印象を与え、ブランドイメージの向上に寄与します。
- プレゼンテーションの効果向上: レイアウトと装飾を維持することで、重要なポイントが強調され、プレゼンテーションの効果が向上します。
ChatGPTを活用した翻訳の実現方法
PowerPointVBAを用いてChatGPTのAPIを呼び出し、PowerPointスライドのテキストを翻訳、レイアウトや文字単位の装飾をそのまま維持する方法について解説します。この方法では、PowerPointの装飾付きテキストをHTMLに変換し、翻訳後に再度HTMLからPowerPointの装飾付きテキストに変換する手法を活用します。
メリット
- 自動化による効率化: 手作業での翻訳やレイアウト調整の手間を大幅に削減できます。
- 高品質な翻訳: ChatGPTの高い翻訳精度により、自然で正確な翻訳が可能です。
- 装飾情報の保持: HTML形式を介することで、文字単位の装飾情報をそのまま維持できます。
そのまま翻訳プロセスの概要
- スライド内のテキストを順に取得: スライドに存在するシェイプや表など全てのテキストを順に取得します。
- テキスト全体をHTMLに変換: テキストとその装飾をHTML形式に変換します。
- ChatGPT APIでテキストを翻訳: HTML形式のテキストをChatGPT APIを使用して、HTMLのタグの意味が損なわれないよう翻訳します。
- HTMLから元のテキスト形式に変換: 翻訳されたHTML形式のテキストを、FontColorやBold、Italicのタグ情報をPowerPointの装飾に変換しながら、装飾付きテキストに戻します。
この方法により、文脈を保ちながらテキスト全体を正確に翻訳し、元のフォーマットと装飾を保持することができます。
ポイントは2点あります。PowerPoint内の装飾付きテキストをマクロでHTMLに変換することと、そのHTMLをChatGPTにそのまま翻訳させることです。賢いChatGPTはHTMLのタグを解釈し、色や太字などの装飾を理解しながら翻訳を行います。これにより、装飾を損なうことなく正確に翻訳されたテキストが得られるのです。
翻訳したスライド結果
このように、スライド内のレイアウトや、文字単位の装飾も継承されていることがわかります。
コードの解説
次のコード全てを、PowerPointのモジュールに貼り付け、翻訳したいスライドを選択した状態で「スライドそのまま翻訳」を実行します。
実行に必要なFunctionプロシージャ「ChatGPT」のコードはこちらで紹介していますので、併せてご利用ください。
メインプロシージャ
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
Sub スライドそのまま翻訳() Dim MyRtn As String Dim htmlS As String Dim slide As slide Dim selectedSlides As SlideRange Dim slideIndex As Integer Dim shape As shape Dim groupShape As shape Dim textFrame As textFrame Dim cell As cell Dim i As Long, j As Long, Sn As Long ' 選択されているスライドを取得 On Error Resume Next Set selectedSlides = ActiveWindow.Selection.SlideRange On Error GoTo 0 ' スライドが選択されているか確認 If selectedSlides Is Nothing Then MsgBox "翻訳するスライドを選択してください", vbExclamation, "スライドが選択されていません" Exit Sub End If ' 翻訳する言語を入力 MyRtn = InputBox("翻訳する言語を入力してください。") If MyRtn = "" Then Exit Sub ' 言語とHTMLオプションの取得 If InStr(MyRtn, ",") > 0 Then htmlS = Split(MyRtn, ",")(1) MyRtn = Split(MyRtn, ",")(0) End If ' スライドごとに処理 ' 選択されているスライドを順に処理 Sn = selectedSlides.Count For slideIndex = 1 To Sn Set slide = selectedSlides(slideIndex) slide.Select For Each shape In slide.Shapes ' シェイプの処理 If shape.HasTextFrame Then ProcessTextFrame shape.textFrame, MyRtn, htmlS ' グループ化されたシェイプの処理 ElseIf shape.Type = msoGroup Then For Each groupShape In shape.GroupItems If groupShape.HasTextFrame Then ProcessTextFrame groupShape.textFrame, MyRtn, htmlS End If Next groupShape ' テーブルの処理 ElseIf shape.Type = msoTable Then For i = 1 To shape.Table.Rows.Count For j = 1 To shape.Table.Columns.Count Set cell = shape.Table.cell(i, j) If cell.shape.HasTextFrame Then ProcessTextFrame cell.shape.textFrame, MyRtn, htmlS End If Next j Next i ' スマートアートの処理 ElseIf shape.Type = msoSmartArt Then Dim Node As SmartArtNode For Each Node In shape.SmartArt.AllNodes If Node.TextFrame2.HasText Then ProcessSmartArtNode Node, MyRtn End If Next Node ' チャートの処理（対応しない） ElseIf shape.Type = msoChart Then ' グラフは対応せず End If Next shape Next slideIndex MsgBox Sn & "枚のスライド翻訳が完了しました", , "スライドそのまま翻訳" End Sub |
テキストフレームの処理
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
' テキストフレームの処理 Sub ProcessTextFrame(textFrame As textFrame, MyRtn As String, htmlS As String) ' テキストフレームのテキストを処理するプロシージャ Dim originalText As String ' 元のテキスト Dim translatedText As String ' 翻訳されたテキスト Dim originalWidth As Single ' 元のテキストフレームの幅 Dim originalHeight As Single ' 元のテキストフレームの高さ Dim lenText As Long ' 元のテキストの長さ ' テキストフレームにテキストがある場合 If textFrame.HasText Then originalWidth = textFrame.Parent.Width ' 元の幅を取得 originalHeight = textFrame.Parent.Height ' 元の高さを取得 lenText = Len(textFrame.textRange.Text) ' 元のテキストの長さを取得 ' HTMLSの値によって処理を分ける If htmlS = "1" Then ' プレーンテキストの翻訳 originalText = textFrame.textRange.Text ' 元のテキストを取得 translatedText = Translate(originalText, MyRtn) ' 翻訳する textFrame.textRange.Text = translatedText ' 翻訳されたテキストを設定 Else ' 文字色と太字を含むテキストの翻訳 originalText = ConvertRangeTextToHTML(textFrame.textRange) ' 元のテキストをHTMLに変換 translatedText = TranslateS(originalText, MyRtn) ' 翻訳する ApplyHTMLToTextRange translatedText, textFrame.textRange ' 翻訳されたテキストを設定 End If ' 文字数が変わった場合のフォントサイズの調整 If lenText <> Len(textFrame.textRange.Text) Then AdjustFontSize textFrame, originalWidth, originalHeight ' フォントサイズを調整 End If End If |
スマートアートノードの処理
|
1 2 3 4 5 6 7 8 9 10 11 |
Sub ProcessSmartArtNode(Node As SmartArtNode, MyRtn As String) Dim originalText As String Dim translatedText As String originalText = Node.TextFrame2.textRange.text translatedText = Translate(originalText, MyRtn) Node.TextFrame2.textRange.text = translatedText ' フォントサイズの調整（必要なら） ' AdjustFontSizeSmartArt node End Sub |
フォントサイズ調整処理
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
AdjustFontSize(textFrame As textFrame, originalWidth As Single, originalHeight As Single) Dim originalFontSize As Single Dim newFontSize As Single Dim parentShape As shape Dim maxFontSize As Single ' textFrame.ParentがShapeオブジェクトであるか確認 If TypeOf textFrame.Parent Is shape Then Set parentShape = textFrame.Parent Else ' Shapeオブジェクトでない場合のエラーハンドリング Exit Sub End If originalFontSize = textFrame.textRange.Font.Size maxFontSize = originalFontSize * 1.25 ' フォントサイズを小さくしていく Do While textFrame.textRange.BoundWidth > originalWidth Or textFrame.textRange.BoundHeight > originalHeight newFontSize = textFrame.textRange.Font.Size - 1 If newFontSize < 1 Then Exit Do ' フォントサイズが1未満にならないようにする textFrame.textRange.Font.Size = newFontSize Loop ' フォントサイズを大きくしていく Do While textFrame.textRange.BoundWidth < originalWidth And textFrame.textRange.BoundHeight < originalHeight newFontSize = textFrame.textRange.Font.Size + 1 If newFontSize > maxFontSize Then Exit Do ' フォントサイズが最大値を超えないようにする textFrame.textRange.Font.Size = newFontSize Loop ' 最後に1サイズ小さくする On Error Resume Next textFrame.textRange.Font.Size = textFrame.textRange.Font.Size - 1 On Error GoTo 0 DoEvents End Sub |
装飾付きテキストをHTMLに変換
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
Function ConvertRangeTextToHTML(rangeText As textRange) As String ' テキスト範囲をHTMLに変換する関数 Dim html As String ' 変換後のHTMLテキスト Dim i As Long ' ループカウンタ Dim currentColor As Long ' 現在の文字色 Dim tempText As String ' 一時的なテキスト Dim tempColor As Long ' 一時的な文字色 Dim tempBold As MsoTriState ' 一時的な太字属性 Dim tempItalic As MsoTriState ' 一時的な斜体属性 ' テキスト範囲が空の場合は空のHTMLを返す If rangeText.length = 0 Then ConvertRangeTextToHTML = html Exit Function End If ' 初期の文字色を取得 currentColor = rangeText.Font.color.rgb ' テキスト範囲の各Runを処理 For i = 1 To rangeText.Runs.Count tempText = rangeText.Runs(i).Text ' 現在のRunのテキストを取得 With rangeText.Runs(i).Font tempBold = .bold ' 太字属性を取得 tempItalic = .Italic ' 斜体属性を取得 tempColor = .color.rgb ' 文字色を取得 End With ' 太字なら<b>タグで囲む If tempBold = msoTrue Then tempText = "<b>" & tempText & "</b>" End If ' 斜体なら<i>タグで囲む If tempItalic = msoTrue Then tempText = "<i>" & tempText & "</i>" End If ' 文字色が変わった場合は<font>タグで囲む If tempColor <> currentColor Then tempText = "<font color=""#" & RGBToHex(tempColor) & """>" & tempText & "</font>" End If ' HTML文字列に結合 html = html & tempText Next i ' 変換後のHTMLを返す ConvertRangeTextToHTML = html End Function |
HTMLコードを装飾付きテキストに適用
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
Sub ApplyHTMLToTextRange(html As String, targetRange As textRange) ' HTML文字列を解析してtextRangeに適用するプロシージャ Dim pos As Long ' 現在の位置 Dim endPos As Long ' タグの終了位置 Dim currentText As String ' 現在のテキスト Dim currentColor As String ' 現在の文字色 Dim currentBold As Boolean ' 現在の太字状態 Dim currentItalic As Boolean ' 現在の斜体状態 Dim tag As String ' タグ名 Dim closeTag As String ' 閉じタグ名 Dim tempText As String ' 一時的なテキスト Dim i As Long ' ループカウンタ ' 初期化 targetRange.Text = "" ' ターゲット範囲のテキストをクリア currentColor = "" ' 文字色をクリア currentBold = False ' 太字をクリア currentItalic = False ' 斜体をクリア pos = 1 ' 開始位置 ' 配列の初期化 Dim textArray() As String ' テキスト配列 Dim colorArray() As String ' 文字色配列 Dim boldArray() As Boolean ' 太字配列 Dim italicArray() As Boolean ' 斜体配列 Dim startPosArray() As Long ' 開始位置配列 Dim lengthArray() As Long ' 長さ配列 Dim n As Long ' 配列インデックス n = 0 ' 初期インデックス ' HTMLを解析 Do While pos <= Len(html) ' タグを探す If Mid(html, pos, 1) = "<" Then endPos = InStr(pos, html, ">") If endPos > 0 Then tag = Mid(html, pos + 1, endPos - pos - 1) pos = endPos + 1 ' 閉じタグかどうかを確認 If Left(tag, 1) = "/" Then closeTag = Mid(tag, 2) If closeTag = "b" Then currentBold = False ElseIf closeTag = "i" Then currentItalic = False ElseIf Left(closeTag, 4) = "font" Then currentColor = "" End If Else ' 開始タグを解析 If tag = "b" Then currentBold = True ElseIf tag = "i" Then currentItalic = True ElseIf Left(tag, 4) = "font" Then Dim colorPos As Long colorPos = InStr(tag, "color=""#") If colorPos > 0 Then currentColor = Mid(tag, colorPos + 8, 6) End If End If End If End If Else ' テキスト部分を取得 tempText = "" Do While pos <= Len(html) And Mid(html, pos, 1) <> "<" tempText = tempText & Mid(html, pos, 1) pos = pos + 1 Loop ' 配列にテキストとスタイル情報を保存 ReDim Preserve textArray(n) ReDim Preserve colorArray(n) ReDim Preserve boldArray(n) ReDim Preserve italicArray(n) ReDim Preserve startPosArray(n) ReDim Preserve lengthArray(n) textArray(n) = tempText colorArray(n) = currentColor boldArray(n) = currentBold italicArray(n) = currentItalic If n = 0 Then startPosArray(n) = 1 Else startPosArray(n) = startPosArray(n - 1) + lengthArray(n - 1) End If lengthArray(n) = Len(tempText) n = n + 1 End If Loop ' 全てのテキストをtargetRangeに設定 For i = 0 To UBound(textArray) targetRange.Text = targetRange.Text & textArray(i) Next i ' スタイルを適用 For i = 0 To UBound(textArray) With targetRange.Characters(startPosArray(i), lengthArray(i)).Font If colorArray(i) <> "" Then .color = HexToRGB(colorArray(i)) End If .bold = boldArray(i) .Italic = italicArray(i) End With Next i End Sub |
RGB処理
|
1 2 3 4 5 6 7 8 9 |
Function RGBToHex(color As Long) As String RGBToHex = Right("000000" & hex(color), 6) End Function Function HexToRGB(hexColor As String) As Long HexToRGB = RGB(CInt("&H" & Mid(hexColor, 5, 2)), _ CInt("&H" & Mid(hexColor, 3, 2)), _ CInt("&H" & Mid(hexColor, 1, 2))) End Function |
ChatGPTへのリクエストプロンプト
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
Function Translate(Text As String, lang) As String If IsNoWord(Text) Then Translate = Text Exit Function End If Dim strTemp As String strTemp = ChatGPT("次のテキストを" & lang & "に翻訳して、マークダウンを使用せず、翻訳結果のみ回答してください｡ " & _ "URL文字列は翻訳せずそのままにしてください。" & _ "記号のみの場合は翻訳せずそのままにしてください。" & _ "数字は翻訳せずそのままにしてください。" & _ "マークダウンを使用せず回答してください。##以下、翻訳するテキストです##" & vbCrLf & Text) Translate = strTemp End Function Function TranslateS(Text As String, lang) As String If IsNoWord(Text) Then TranslateS = Text Exit Function End If Dim strTemp As String strTemp = ChatGPT("次のhtmlまたはテキストを" & lang & "のhtmlに翻訳してください。" & _ "与えられたテキストだけを翻訳、他の説明を禁止します。" & _ "<fontcolor>と<b>と<i>を再現してください。タグがない場合は、textだけを回答してください。" & _ "冒頭や文末の改行は削除してください。" & _ "元のテキストにタグがある場合、htmlコードの<body>内のinnerHtml部分のみを、Bodyタグやhタグ、spanタグ等を除去し、" & _ "<fontcolor>、<b>、<i>タグだけにしてください、" & _ "元のテキストに<fontcolor>タグや<b>タグや<i>タグがない場合は、元のテキストだけを回答してください。" & _ "URL文字列は翻訳せずそのままにしてください。" & _ "記号のみの場合は翻訳せずそのままにしてください。" & _ "数字は翻訳せずそのままにしてください。" & _ "マークダウンを使用せず回答してください。##以下、翻訳するhtmlまたはテキストです##" & vbCrLf & Text) TranslateS = strTemp End Function |
Htmlを翻訳させるプロンプト、ここが一番の試行錯誤でした。
長いコードにお付き合いありがとうございました。
それでは、よいPowerPointVBAライフを！
コメント