【ppt】フォント一括変換

フォント一括変換のソースコードを示します。
メルマガと連動していますので、必要に応じてご確認をお願いします。

Option Explicit

Sub Font_Convert()

   '変数宣言 (7/15 メルマガ)
   Dim slide_max As Long  'スライド枚数
   Dim I As Long, J As Long, K As Long '繰り返し用の変数
   Dim shp As Shape   '(図形)オブジェクトの一時格納用
   Dim tbl As Table '表オブジェクトの一時格納用
   Dim j_font As String '日本語フォント
   Dim eu_font As String '英数字フォント
   Dim hantei As Long '一括変換するかどうかの確認結果

   'slide数を取得(7/15 メルマガ)
   slide_max = ActivePresentation.Slides.Count

   '現在のフォント情報を取得 (7/18 メルマガ)
   With ActiveWindow.Selection
     If .Type = ppSelectionNone Or .Type = ppSelectionSlides Then
       MsgBox "フォント情報を取得するテキストオブジェクトを選択してください"
       Exit Sub
     Else
       eu_font = .ShapeRange.TextFrame.TextRange.Font.Name
       j_font = .ShapeRange.TextFrame.TextRange.Font.NameFarEast
       hantei = MsgBox("日本語:" & j_font & vbCrLf & "欧米:" & eu_font & vbCrLf & "一括変換してよいですか?", _
                       vbOKCancel)
     End If
   End With

   '現在のフォント情報を取得 (7/19メルマガ)
   If hantei = vbOK Then
     'スライド全体を1枚1枚繰り返し実行する(7/19メルマガ)
     For I = 1 To slide_max
       ActiveWindow.View.GotoSlide Index:=I

       '現在のスライドから図形オブジェクトを1つ1つ確認する(7/19メルマガ)
       For Each shp In ActiveWindow.Selection.SlideRange.Shapes
         'Text情報があるかどうか判定(7/20メルマガ)
         If shp.HasTextFrame Then
           shp.TextFrame.TextRange.Font.Name = eu_font ' "Meiryo UI"
           shp.TextFrame.TextRange.Font.NameFarEast = j_font ' "Meiryo UI"

         '表内のテキスト情報の確認(7/20メルマガ)
         ElseIf shp.HasTable Then
           Set tbl = shp.Table
           For J = 1 To tbl.Rows.Count
             For K = 1 To tbl.Columns.Count
               tbl.Cell(J, K).Shape.TextFrame.TextRange.Font.Name = eu_font
               tbl.Cell(J, K).Shape.TextFrame.TextRange.Font.NameFarEast= j_font
             Next K
           Next J
         End If
       Next 'for each

     Next I
   End If

End Sub

Option Explicit

Sub Font_Convert()

'変数宣言 (7/15 メルマガ)

Dim slide_max As Long 'スライド枚数

Dim I As Long, J As Long, K As Long '繰り返し用の変数

Dim shp As Shape '(図形)オブジェクトの一時格納用

Dim tbl As Table '表オブジェクトの一時格納用

Dim j_font As String '日本語フォント

Dim eu_font As String '英数字フォント

Dim hantei As Long '一括変換するかどうかの確認結果

'slide数を取得(7/15 メルマガ)

slide_max = ActivePresentation.Slides.Count

'現在のフォント情報を取得 (7/18 メルマガ)

With ActiveWindow.Selection

If .Type = ppSelectionNone Or .Type = ppSelectionSlides Then

MsgBox "フォント情報を取得するテキストオブジェクトを選択してください"

Exit Sub

Else

eu_font = .ShapeRange.TextFrame.TextRange.Font.Name

j_font = .ShapeRange.TextFrame.TextRange.Font.NameFarEast

hantei = MsgBox("日本語:" & j_font & vbCrLf & "欧米:" & eu_font & vbCrLf & "一括変換してよいですか?", _

vbOKCancel)

End If

End With

'現在のフォント情報を取得 (7/19メルマガ)

If hantei = vbOK Then

'スライド全体を1枚1枚繰り返し実行する(7/19メルマガ)

For I = 1 To slide_max

ActiveWindow.View.GotoSlide Index:=I

'現在のスライドから図形オブジェクトを1つ1つ確認する(7/19メルマガ)

For Each shp In ActiveWindow.Selection.SlideRange.Shapes

'Text情報があるかどうか判定(7/20メルマガ)

If shp.HasTextFrame Then

shp.TextFrame.TextRange.Font.Name = eu_font ' "Meiryo UI"

shp.TextFrame.TextRange.Font.NameFarEast = j_font ' "Meiryo UI"

'表内のテキスト情報の確認(7/20メルマガ)

ElseIf shp.HasTable Then

Set tbl = shp.Table

For J = 1 To tbl.Rows.Count

For K = 1 To tbl.Columns.Count

tbl.Cell(J, K).Shape.TextFrame.TextRange.Font.Name = eu_font

tbl.Cell(J, K).Shape.TextFrame.TextRange.Font.NameFarEast= j_font

Next K

Next J

End If

Next 'for each

Next I

End If

End Sub

MENU

VBA関連

VBA関連