Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
PowerPointのVBAで、縦書きテキストボックスに俳句を書き込むプログラムです。

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

  • Haiku-powerpoint.vb : Ver. 1.0 : 俳句を縦書きテキストボックスに俳句を書き込みます。
  • Haiku-powerpoint2.vb : Ver. 2.0 : ユーザーフォームから入力した任意の俳句を縦書きテキストボックスに書き込み、画像ファイルを出力します。
' 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
' 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.