窓の杜連動企画・出版記念特別レシピWord「Myプロンプト」

執筆させていただいた「生成AIをWord&Excel&PowerPoint&Outlookで自在に操る超実用VBAプログラミング術」、2/7にインプレスより発刊され、売れ行きも好調で嬉しい限り。Microsoft 365 Copilotと同様、OfficeVBAを使用して各アプリ上から、OpenAIのChatGPT、DALL-E、EmbeddingsのAPIを呼び出し、要約や文体変更、スライド作成、返信メール作成、画像生成、画像解析など、様々な便利機能を実装するマクロをレシピ形式で解説する書籍です。全てのマクロコードや、すぐに使えるアドインもダウンロードできるのでVBA初心者でも親しめる内容となっていて、さらにはMyGPTsのような、PDFなどの文書を参照したり、CSVデータを分析して回答するオリジナルのチャットボットも作れるので、これが2,530円（買い切り）とは、月額3,200円のMicrosoft 365 Copilotと比較しても、超お買い得と言えるのではないでしょうか。

全ての生成AIメニューは「OpenAI」タブのリボンに表示され、次に例示しているような業務シーンで、1クリックで利用できるようになります。

Word
PowerPoint
Outlook
Excel
出版記念特別レシピWord「Myプロンプト」

Word

・丁重な文体に変えたい
・議事メモから発言形式の議事録を作りたい
・大量PDFのファイルを読み込ませ、要約表示させたい
・よく使用するプロンプトを登録して、Word上で実行したい（今回のプレゼント！）

PowerPoint

・スライド全体を要約表示させたい
・文字が多いスライドを端的なキーワードと画像のスライドにしたい
・類似度の高いスライドをチェック、枚数削減に活用したい
・プレゼンのシナリオ下書きテキストから、指定した枚数で画像付きスライドを作成したい

Outlook

・承諾や反対などの返信メールを作成したい
・大量のメールを要約したい
・メールからタスクを抽出したい
・苦情など、注意が必要なメールを自然言語処理で特定したい

Excel

・セルに入力されている関数の解説が欲しい
・生成した画像をさらに修正したい。
・複雑な構成図を説明させたい
・OCRでテキスト化したい
・文書やスライドのレイアウトに関してアドバイスが欲しい

出版記念特別レシピWord「Myプロンプト」

発刊に伴いインプレス「窓の杜」で集中連載させていただいた記事に連動して、出版記念追加レシピ「Myプロンプト（Word）」をプレゼントさせていただきます。任意のプロンプトを登録でき、いつでも呼び出せて、選択したテキストや指定した文書ファイル（docx、pdf、txt、複数選択可）に対して実行できる機能で、例えば、「①次のテキストを英語に翻訳して＜以下テキスト＞」と登録すると、複数の文書を一気に英文翻訳することができます。あるいは「②次の活動メモから上司への報告書を作ってください＜以下活動メモ＞」を登録すると、下書きレベルの活動記録を立派な報告書に仕上げてくれるはずです。

さらに私が実際に使用しているプロンプトも紹介しましょう。本書籍を執筆するにあたり何千回も使用したプロンプト「③次のテキストをわかりやすさの観点から100点満点で評価してください。そして改善すべき点を指摘し、ブラッシュアップした文章を提示してください＜以下テキスト＞」です。もちろん、レスポンステキストをそのまま採用することはないのですが、自分が書いた文章の問題点が明快となるのでリライトが容易となり、ChatGPTが起案してくれた言い回しや表現をパーツとして利用して文章のわかりやすさを向上させることもできます。ポイントは、ブラウザを介さず、全てがWord上でシームレスに進行することで、文章の校正が進む進む、これがなければ、本書籍の原稿は完成しなかったと言い切れちゃいます。さらには、プログラムコードもChatGPTに書いてもらうことができ、そのコツとポイントに関しても面白いのですが、それはまた別の機会に。

「Myプロンプト」の使い方は簡単、次の4つのプロシージャコードを、本書籍の読者特典でダウンロードできる、もしくは書籍に沿って作成した「OpenAI.dotm」のAIモジュールにペタッと貼ってもらえばOKです。

Sub Myプロンプト編集()

    Dim Path As String
    Dim fso As Object
    
    Path = ThisDocument.Path & "\MyPrompt.txt"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(Path) Then fso.CreateTextFile Path
    Set fso = Nothing
    MsgBox "■熟読してください！！" & vbLf & vbLf & _
            "MyPrompt.txtを開きます。プロンプトを編集して上書き保存してください。" & vbLf & vbLf & _
            "Word文書上で選択されているテキスト、または指定したファイルのテキストが、" & vbLf & _
            "＜以下テキスト＞の後に追加されてChatGPTへリクエストします。" & vbLf & _
            "（テキストが選択されていない場合は、プロンプトのみリクエストします。" & vbLf & vbLf & _
            "プロンプトの冒頭に丸数字（①、②など）を付与すると、別のプロンプトとして認識し、選択できるようになります。" & vbLf & _
            "（プロンプトの文中では丸数字を使用できませんのでご注意ください。)" & vbLf & vbLf & _
            "（記述例）" & vbLf & _
            "①次のテキストを日本語に翻訳してください。＜以下テキスト＞" & vbLf & _
            "②次のテキストを英語に翻訳してください。＜以下テキスト＞" & vbLf & _
            "③次のテキストを内容を省略することなく、かつ客観的にならないよう、要約してください。＜以下テキスト＞" & vbLf & _
            "④次のテキストを分かり易さの観点から問題点を指摘し、改善すべき点をアドバイス、修正見本も提示してください。＜以下テキスト＞" & vbLf & _
            "⑤次のテキストから上司への報告書を作成してください。＜以下テキスト＞", , "Myプロンプトの設定"
    Shell "notepad.exe " & Path, vbNormalFocus

End Sub

Sub Myプロンプト編集()

Dim Path As String

Dim fso As Object

Path = ThisDocument.Path & "\MyPrompt.txt"

Set fso = CreateObject("Scripting.FileSystemObject")

If Not fso.FileExists(Path) Then fso.CreateTextFile Path

Set fso = Nothing

MsgBox "■熟読してください！！" & vbLf & vbLf & _

"MyPrompt.txtを開きます。プロンプトを編集して上書き保存してください。" & vbLf & vbLf & _

"Word文書上で選択されているテキスト、または指定したファイルのテキストが、" & vbLf & _

"＜以下テキスト＞の後に追加されてChatGPTへリクエストします。" & vbLf & _

"（テキストが選択されていない場合は、プロンプトのみリクエストします。" & vbLf & vbLf & _

"プロンプトの冒頭に丸数字（①、②など）を付与すると、別のプロンプトとして認識し、選択できるようになります。" & vbLf & _

"（プロンプトの文中では丸数字を使用できませんのでご注意ください。)" & vbLf & vbLf & _

"（記述例）" & vbLf & _

"①次のテキストを日本語に翻訳してください。＜以下テキスト＞" & vbLf & _

"②次のテキストを英語に翻訳してください。＜以下テキスト＞" & vbLf & _

"③次のテキストを内容を省略することなく、かつ客観的にならないよう、要約してください。＜以下テキスト＞" & vbLf & _

"④次のテキストを分かり易さの観点から問題点を指摘し、改善すべき点をアドバイス、修正見本も提示してください。＜以下テキスト＞" & vbLf & _

"⑤次のテキストから上司への報告書を作成してください。＜以下テキスト＞", , "Myプロンプトの設定"

Shell "notepad.exe " & Path, vbNormalFocus

End Sub

Sub Myプロンプトテキスト実行()

    Dim Text As String
    ' 選択されたテキストを取得
    Text = Selection.Text
    If Len(Text) <= 1 Then
        MsgBox "テキストが選択されていないため、Myプロンプトのみでリクエストします。", , "生成AI"
    Else
        MsgBox "選択されている以下のテキストを対象に、Myプロンプトを実行します。" & vbLf & _
                "（量が多い多い場合は、先頭のテキストみ表示しています）" & vbLf & vbLf & Text, , "生成AI"
    End If
    
    Dim strPrompt As String, ArrPrompt, MaxToken As Long
    MaxToken = 4096
    strPrompt = Myプロンプト選択
    If strPrompt = "" Then Exit Sub
    If InStr(strPrompt, ";;;") > 0 Then
        ArrPrompt = Split(strPrompt, ";;;")
        MaxToken = ArrPrompt(1)
        strPrompt = ArrPrompt(0)
    End If
    
    'リクエストを実行
    Dim Rsps As String
    Rsps = ChatGPT(strPrompt & Text, , , MaxToken, 600) & vbCrLf

    Dim selectedRange As Range
    Set selectedRange = Selection.Range
    With selectedRange
        .Collapse Direction:=wdCollapseEnd
        .Text = selectedRange.Text & vbCrLf & Rsps & vbCrLf
        .Select
    End With

End Sub

Sub Myプロンプトテキスト実行()

Dim Text As String

' 選択されたテキストを取得

Text = Selection.Text

If Len(Text) <= 1 Then

MsgBox "テキストが選択されていないため、Myプロンプトのみでリクエストします。", , "生成AI"

Else

MsgBox "選択されている以下のテキストを対象に、Myプロンプトを実行します。" & vbLf & _

"（量が多い多い場合は、先頭のテキストみ表示しています）" & vbLf & vbLf & Text, , "生成AI"

End If

Dim strPrompt As String, ArrPrompt, MaxToken As Long

MaxToken = 4096

strPrompt = Myプロンプト選択

If strPrompt = "" Then Exit Sub

If InStr(strPrompt, ";;;") > 0 Then

ArrPrompt = Split(strPrompt, ";;;")

MaxToken = ArrPrompt(1)

strPrompt = ArrPrompt(0)

End If

'リクエストを実行

Dim Rsps As String

Rsps = ChatGPT(strPrompt & Text, , , MaxToken, 600) & vbCrLf

Dim selectedRange As Range

Set selectedRange = Selection.Range

With selectedRange

.Collapse Direction:=wdCollapseEnd

.Text = selectedRange.Text & vbCrLf & Rsps & vbCrLf

.Select

End With

End Sub

Sub Myプロンプトファイル実行()
    
    Dim dlg As FileDialog, Files() As String, i As Long
    ' ファイル選択ダイアログ
    Set dlg = Application.FileDialog(msoFileDialogOpen)
    dlg.InitialFileName = ThisDocument.Path
    With dlg
        .Title = "ファイルを選択してください（複数選択可）"
        .Filters.Clear
        .Filters.Add "Document Files", "*.docx; *.pdf; *.txt"
        .AllowMultiSelect = True
        ' ダイアログを表示
        If .Show <> -1 Then
            MsgBox "ファイルが選択されなかったため終了します", , "生成AI"
            Exit Sub
        End If
        ReDim Files(1 To .SelectedItems.Count)
        For i = 1 To .SelectedItems.Count
            Files(i) = .SelectedItems(i)
        Next i
    End With
    
    Dim strPrompt As String, ArrPrompt, MaxToken As Long
    MaxToken = 4096
    strPrompt = Myプロンプト選択
    If strPrompt = "" Then Exit Sub
    If InStr(strPrompt, ";;;") > 0 Then
        ArrPrompt = Split(strPrompt, ";;;")
        MaxToken = ArrPrompt(1)
        strPrompt = ArrPrompt(0)
    End If
    
    'ファイルのテキストを取得
    Dim Text As String, Rsps As String
    Dim Doc As Document, docTemp As Document
    Set Doc = Documents.Add

    For i = 1 To UBound(Files)
        'ファイル名を表示
        Doc.Content.Text = Doc.Content.Text & Mid(Files(i), InStrRev(Files(i), "\"), 255) & vbCrLf
        Set docTemp = Application.Documents.Open(Files(i))
        Text = docTemp.Content.Text
        Text = Replace(Replace(Text, vbCr, ""), vbLf, "")
        docTemp.Close SaveChanges:=wdDoNotSaveChanges
        'リクエストを実行
        Rsps = ChatGPT(strPrompt & Text, , , MaxToken, 600) & vbCrLf
        Doc.Content.Text = Doc.Content.Text & Rsps & vbCrLf
    Next i
    Doc.Activate
    MsgBox "完了しました", , "生成AI"
    Set Doc = Nothing: Set docTemp = Nothing: Set dlg = Nothing

End Sub

Sub Myプロンプトファイル実行()

Dim dlg As FileDialog, Files() As String, i As Long

' ファイル選択ダイアログ

Set dlg = Application.FileDialog(msoFileDialogOpen)

dlg.InitialFileName = ThisDocument.Path

With dlg

.Title = "ファイルを選択してください（複数選択可）"

.Filters.Clear

.Filters.Add "Document Files", "*.docx; *.pdf; *.txt"

.AllowMultiSelect = True

' ダイアログを表示

If .Show <> -1 Then

MsgBox "ファイルが選択されなかったため終了します", , "生成AI"

Exit Sub

End If

ReDim Files(1 To .SelectedItems.Count)

For i = 1 To .SelectedItems.Count

Files(i) = .SelectedItems(i)

Next i

End With

Dim strPrompt As String, ArrPrompt, MaxToken As Long

MaxToken = 4096

strPrompt = Myプロンプト選択

If strPrompt = "" Then Exit Sub

If InStr(strPrompt, ";;;") > 0 Then

ArrPrompt = Split(strPrompt, ";;;")

MaxToken = ArrPrompt(1)

strPrompt = ArrPrompt(0)

End If

'ファイルのテキストを取得

Dim Text As String, Rsps As String

Dim Doc As Document, docTemp As Document

Set Doc = Documents.Add

For i = 1 To UBound(Files)

'ファイル名を表示

Doc.Content.Text = Doc.Content.Text & Mid(Files(i), InStrRev(Files(i), "\"), 255) & vbCrLf

Set docTemp = Application.Documents.Open(Files(i))

Text = docTemp.Content.Text

Text = Replace(Replace(Text, vbCr, ""), vbLf, "")

docTemp.Close SaveChanges:=wdDoNotSaveChanges

'リクエストを実行

Rsps = ChatGPT(strPrompt & Text, , , MaxToken, 600) & vbCrLf

Doc.Content.Text = Doc.Content.Text & Rsps & vbCrLf

Next i

Doc.Activate

MsgBox "完了しました", , "生成AI"

Set Doc = Nothing: Set docTemp = Nothing: Set dlg = Nothing

End Sub

Function Myプロンプト選択() As String
    
    Dim Path As String, allTxt As String
    Path = ThisDocument.Path & "\MyPrompt.txt"
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    With stream
        .Type = 2
        .Charset = "utf-8"
        .Open
        .LoadFromFile Path
        allTxt = .ReadText
        .Close
    End With
    
    '①～⑳までで分割
    Dim i As Long, ArrPrompt
    For i = -30912 To -30892
        allTxt = Replace(allTxt, Chr(i), ";;;" & Chr(i))
    Next i
    ArrPrompt = Split(allTxt, ";;;")
    
    '表示メッセージの構築
    Dim strMsg As String
    For i = 1 To UBound(ArrPrompt)
        strMsg = strMsg & Split(ArrPrompt(i), vbLf)(0) & vbLf
    Next i
        
    Dim MyRtn
    MyRtn = InputBox("実行するMyプロンプトを番号で入力してください。" & vbCrLf & vbCrLf & strMsg, "生成AI")
    If MyRtn = "" Or IsNumeric(MyRtn) = False Then
        MsgBox "番号の入力がなかったため終了します", , "生成AI"
        Myプロンプト選択 = ""
        Exit Function
    End If
    
    If IsNumeric(MyRtn) = False Then
        MsgBox "Myプロンプト以外の文字が入力されたため終了します", , "生成AI"
        Exit Function
    ElseIf MyRtn < 1 Or MyRtn > UBound(ArrPrompt) Then
        MsgBox "Myプロンプト以外の数字が入力されたため終了します", , "生成AI"
        Exit Function
    End If
    
    Dim MyRtn2, MyRtn3
    MyRtn2 = MsgBox("回答の最大文字数を4096トークン（2700文字程度）としてリクエストを実行します" & vbLf & _
                    "(2700文字以上の長文レスポンスが必要な場合、「いいえ」をクリックしてください。", vbYesNo, "回答文字数の確認（通常は「はい」をクリックします）")
    If MyRtn2 = vbNo Then
        MyRtn3 = InputBox("トークン数を指定してください｡多すぎるとエラーとなるのご注意ください｡", "トークン数の入力")
    End If
    
    If MyRtn3 <> "" Then
        If IsNumeric(MyRtn3) = False Then
            MsgBox "数字が入力されなかったため、終了します", , "入力トークン数チェック"
            Exit Function
        ElseIf MyRtn3 < 1 Then
            MsgBox "マイナスの数字が入力されため、終了します", , "入力トークン数チェック"
            Exit Function
        End If
    End If
    
    If Val(MyRtn3) > 0 Then
        Myプロンプト選択 = ArrPrompt(MyRtn) & ";;;" & Int(MyRtn3)
    Else
        Myプロンプト選択 = ArrPrompt(MyRtn)
    End If
    
End Function

Function Myプロンプト選択() As String

Dim Path As String, allTxt As String

Path = ThisDocument.Path & "\MyPrompt.txt"

Dim stream As Object

Set stream = CreateObject("ADODB.Stream")

With stream

.Type = 2

.Charset = "utf-8"

.Open

.LoadFromFile Path

allTxt = .ReadText

.Close

End With

'①～⑳までで分割

Dim i As Long, ArrPrompt

For i = -30912 To -30892

allTxt = Replace(allTxt, Chr(i), ";;;" & Chr(i))

Next i

ArrPrompt = Split(allTxt, ";;;")

'表示メッセージの構築

Dim strMsg As String

For i = 1 To UBound(ArrPrompt)

strMsg = strMsg & Split(ArrPrompt(i), vbLf)(0) & vbLf

Next i

Dim MyRtn

MyRtn = InputBox("実行するMyプロンプトを番号で入力してください。" & vbCrLf & vbCrLf & strMsg, "生成AI")

If MyRtn = "" Or IsNumeric(MyRtn) = False Then

MsgBox "番号の入力がなかったため終了します", , "生成AI"

Myプロンプト選択 = ""

Exit Function

End If

If IsNumeric(MyRtn) = False Then

MsgBox "Myプロンプト以外の文字が入力されたため終了します", , "生成AI"

Exit Function

ElseIf MyRtn < 1 Or MyRtn > UBound(ArrPrompt) Then

MsgBox "Myプロンプト以外の数字が入力されたため終了します", , "生成AI"

Exit Function

End If

Dim MyRtn2, MyRtn3

MyRtn2 = MsgBox("回答の最大文字数を4096トークン（2700文字程度）としてリクエストを実行します" & vbLf & _

"(2700文字以上の長文レスポンスが必要な場合、「いいえ」をクリックしてください。", vbYesNo, "回答文字数の確認（通常は「はい」をクリックします）")

If MyRtn2 = vbNo Then

MyRtn3 = InputBox("トークン数を指定してください｡多すぎるとエラーとなるのご注意ください｡", "トークン数の入力")

End If

If MyRtn3 <> "" Then

If IsNumeric(MyRtn3) = False Then

MsgBox "数字が入力されなかったため、終了します", , "入力トークン数チェック"

Exit Function

ElseIf MyRtn3 < 1 Then

MsgBox "マイナスの数字が入力されため、終了します", , "入力トークン数チェック"

Exit Function

End If

If Val(MyRtn3) > 0 Then

Myプロンプト選択 = ArrPrompt(MyRtn) & ";;;" & Int(MyRtn3)

Else

Myプロンプト選択 = ArrPrompt(MyRtn)

End If

End Function

おっと、リボンから利用できるようにするため、カスタムリボンにボタンを追加しましょう。P193「OpenAIカスタムリボンの作成」の手順に沿って、P194の④「cusutomUI」フォルダーに入っているcustumUI.xlm（中身の解説はP200）をどこかにコピーしてメモ帳で開き、真ん中らへんにある</group>と<group id=”Group2″ label=”DALL=E”>の間に次のタグを挿入し上書き保存します。そのファイルをzipファイの元の場所にコピペして上書き保存すれば完了です。

<group id="GroupS" label="Myプロンプト">
<button id="WS-1" label="テキストに実行" imageMso="WrapText" size="large" tag="Myプロンプトテキスト実行" onAction="リボンからの呼び出し処理"/>
<button id="WS-2" label="ファイルに実行" imageMso="MasterDocumentInsertSubdocument" size="large" tag="Myプロンプトファイル実行" onAction="リボンからの呼び出し処理"/>
<button id="WS-3" label="指示編集" imageMso="DocumentLibraryProperties" size="large" tag="Myプロンプト編集" onAction="リボンからの呼び出し処理"/>
</group>