PowerPointのVBAで、縦書きテキストボックスに俳句を書き込むプログラムです。

Abstract.md

このGistに上がっているVBAソースファイルの概要

• Haiku-powerpoint.vb : Ver. 1.0 : 俳句を縦書きテキストボックスに俳句を書き込みます。
• Haiku-powerpoint2.vb : Ver. 2.0 : ユーザーフォームから入力した任意の俳句を縦書きテキストボックスに書き込み、画像ファイルを出力します。

Haiku-powerpoint.vb

' Auther : Nia Tomonaka
' Twitter : https://twitter.com/nia_tn1012

Option Explicit

Sub Haiku()
    
    Dim sld As slide
    Dim haikuTb As Object
    Dim autherTb As Object
    Dim i As Integer
    
    ' 1番目のスライドを取得します。
    Set sld = ActivePresentation.Slides.Item(1)
    
    ' そのスライド内の図形を全て削除します。
    If sld.Shapes.Count > 0 Then
        For i = 1 To sld.Shapes.Count
            sld.Shapes(1).Delete
        Next
    End If
    
    With sld
        .Layout = ppLayoutBlank
        .BackgroundStyle = msoBackgroundStylePreset4
    End With
    
    ' 背景画像「定式幕」を追加します。
    ' ActivePresentation.Pathはこのプレゼンテーションファイルのディレクトリを表しています。
    ' あらかじめ、定式幕.pngをこのプレゼンテーションファイルと同じディレクトリに配置しておきます。
    sld.Shapes.AddPicture(ActivePresentation.Path + "\定式幕.png", msoFalse, msoTrue, 0, 0).Select
    
    ' 俳句用の縦書きテキストボックスを作成します。
    Set haikuTb = sld.Shapes.AddTextbox( _
        msoTextOrientationVerticalFarEast, _
        sld.Master.Width / 2 - 50, 50, _
        180, 360)
    
    ' テキストボックスに文字列とフォントを設定します。
    With haikuTb.TextFrame2.TextRange.Characters
        .Text = "初桜" + vbCrLf + "折しも今日は" + vbCrLf + "よき日なり"
        .Font.NameFarEast = "HGS行書体"
        .Font.Size = "50"
    End With
        
    ' 作者用の縦書きのテキストボックスを作成します。
    Set autherTb = sld.Shapes.AddTextbox( _
        msoTextOrientationVerticalFarEast, _
        sld.Master.Width / 2 - 150, 300, _
        60, 180)
        
    ' テキストボックスに文字列とフォントを設定します。
    With autherTb.TextFrame2.TextRange.Characters
        .Text = "松尾芭蕉"
        .Font.NameFarEast = "HGS行書体"
        .Font.Size = "30"
        .ParagraphFormat.Alignment = 3      ' 右寄せ（縦書きでは下寄せ）にします。
    End With
    
    ' 図形の背景色を黒色にします。
    For i = 1 To sld.Shapes.Count
        sld.Shapes(i).Fill.ForeColor.SchemeColor = 1
    Next
    
End Sub

' Haiku-powerpoint.vb ( PowerPointのVBA用 )
' Copyright (c) 2014-2015 Myoga-TN.net All Rights Reserved.
' This software is released under the MIT License.
' http://opensource.org/licenses/mit-license.php

Haiku-powerpoint2.vb

' Auther : Nia Tomonaka
' Twitter : https://twitter.com/nia_tn1012

' PowerPointスライドに縦書きテキストボックスを追加して任意の俳句を書き込み、
' 画像ファイルを出力するモジュールです。
' ユーザーフォーム（HaikuRegister）にテキストボックス
' （Phrase1、Phrase2、Phrase3、Auther）を用意し、そこに俳句と作者を入力します。
' 俳句を生成するボタンを押すとこのイベントが呼び出されます。
Private Sub Register_Click()
    
    Dim sld As slide
    Dim haikuTb As Object
    Dim autherTb As Object
    Dim i As Integer
    
    ' 1番目のスライドを取得します。
    Set sld = ActivePresentation.Slides.Item(1)
    
    ' そのスライド内の図形を全て削除します。
    If sld.Shapes.Count > 0 Then
        For i = 1 To sld.Shapes.Count
            sld.Shapes(1).Delete
        Next
    End If
    
    ' スライドレイアウトを「白紙」にし、背景のスタイルを黒地にします。
    With sld
        .Layout = ppLayoutBlank
        .BackgroundStyle = msoBackgroundStylePreset4
    End With
    
    ' 背景画像「定式幕」を追加します。
    ' ActivePresentation.Pathはこのプレゼンテーションファイルのディレクトリを表しています。
    ' あらかじめ、定式幕.pngをこのプレゼンテーションファイルと同じディレクトリに配置しておきます。
    sld.Shapes.AddPicture ActivePresentation.Path + "\定式幕.png", msoFalse, msoTrue, 0, 0
    
    ' 俳句用の縦書きテキストボックスを作成します。
    Set haikuTb = sld.Shapes.AddTextbox( _
        msoTextOrientationVerticalFarEast, _
        sld.Master.Width / 2 - 50, 50, _
        180, 430)
    
    ' テキストボックスに文字列とフォントを設定します。
    With haikuTb.TextFrame2.TextRange.Characters
        .Text = Phrase1.Text + vbCrLf + Phrase2.Text + vbCrLf + Phrase3.Text
        .Font.NameFarEast = "HGS行書体"
        .Font.Size = "50"
    End With
        
    ' 作者用の縦書きのテキストボックスを作成します。
    Set autherTb = sld.Shapes.AddTextbox( _
        msoTextOrientationVerticalFarEast, _
        sld.Master.Width / 2 - 150, 180, _
        60, 300)
        
    ' テキストボックスに文字列とフォントを設定します。
    With autherTb.TextFrame2.TextRange.Characters
        .Text = Auther.Text
        .Font.NameFarEast = "HGS行書体"
        .Font.Size = "30"
        .ParagraphFormat.Alignment = 3      ' 右寄せ（縦書きでは下寄せ）にします。
    End With
    
    ' 図形の背景色を黒色にします。
    For i = 1 To sld.Shapes.Count
        sld.Shapes(i).Fill.ForeColor.SchemeColor = 1
    Next
    
    ' スライドを画像として保存します。
    sld.Export ActivePresentation.Path + "\" + Auther + "さんの俳句.png", "PNG", 1280, 720
        
    Unload HaikuRegister
            
End Sub

' Haiku-powerpoint2.vb ( PowerPointのVBA用 )
' Copyright (c) 2014-2015 Myoga-TN.net All Rights Reserved.
' This software is released under the MIT License.
' http://opensource.org/licenses/mit-license.php