PowerPoint (一般・VBA)

PowerPoint 一般・VBAに関する話題を扱うフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(指定なし : PowerPoint 2016)
数字のみ「Century Gothic」フォントに置換するマクロ
投稿日時: 19/03/29 00:18:37
投稿者: r6023

いつもお世話になってます。
 
今回、お聞きしたいのは、フォントの置換についてです。
数字を「Century Gothic」フォントで統一するよう指示が出ているのですが、毎回数字を打つ度にフォントを変えるのがとても手間です。。
 
一気に数字のみを「Century Gothic」に置換してくれるマクロは存在しますでしょうか?
 
何卒知恵をお貸しください。。
 

回答
投稿日時: 19/03/29 09:18:04
投稿者: sk

引用:
数字を「Century Gothic」フォントで統一するよう指示が出ている

引用:
一気に数字のみを「Century Gothic」に置換してくれるマクロ

「英数字用のフォント」ではなく「数字のみ」なのでしょうか。
 
また、半角/全角の区別はどのような扱いになるのでしょうか。

投稿日時: 19/03/29 10:53:02
投稿者: r6023

sk様
 
ご返信いただき誠に有難うございます。
 
こちら、「数字のみ」での対応を希望しております。
また、すべて半角での入力を想定しています。
 
厚かましく申し訳ございませんが何卒宜しくお願いいたします。

回答
投稿日時: 19/03/29 13:50:14
投稿者: sk

引用:
こちら、「数字のみ」での対応を希望しております。

引用:
また、すべて半角での入力を想定しています。

(標準モジュール)
----------------------------------------------------------------
Option Explicit
 
Private Const FontNameNumber As String = "Century Gothic"
 
Private Sub subSetSlides()
 
    Dim pptPresentation As PowerPoint.Presentation
    Dim pptSlide As PowerPoint.Slide
    Dim pptShape As PowerPoint.Shape
     
    Set pptPresentation = Application.ActivePresentation
     
    For Each pptSlide In pptPresentation.Slides
        For Each pptShape In pptSlide.Shapes
            Call subSetShape(pptShape)
        Next
    Next
 
    Set pptPresentation = Nothing
 
End Sub
 
Private Sub subSetShape(Shape As PowerPoint.Shape)
     
    If Shape.HasTextFrame = msoFalse Then
        Exit Sub
    End If
     
    If Shape.TextFrame.HasText = msoFalse Then
        Exit Sub
    End If
         
    Dim pptCharacter As PowerPoint.TextRange
    Dim lngPosition As Long
         
    With Shape.TextFrame.TextRange
        For lngPosition = 1 To .Characters.Count
            Set pptCharacter = .Characters(lngPosition, 1)
            If (pptCharacter.Text Like "#") And _
               (LenB(StrConv(pptCharacter.Text, vbFromUnicode)) = 1) Then
                pptCharacter.Font.NameAscii = FontNameNumber
            End If
            Set pptCharacter = Nothing
        Next
    End With
 
End Sub
----------------------------------------------------------------
 
もし全角数字が紛れていても、上記のコードでは
フォントが変更されませんのでご注意下さい。

投稿日時: 19/03/29 22:27:14
投稿者: r6023

sk様
 
有難うございます!!!!!!!!!!!!
ご教示いただきましたマクロで無事解決いたしました。
 
お忙しい中、誠に有難うございます。
 
ちなみに、こちら半角英数字のみに対象を絞り「Century Gothic」に置換というのは可能なものでしょうか。。
追加のご質問となり誠に申し訳ございません、、

回答
投稿日時: 19/04/01 09:29:20
投稿者: sk

引用:
ちなみに、こちら半角英数字のみに対象を絞り
「Century Gothic」に置換というのは可能なものでしょうか。。

その場合は個々の文字ごとにフォントを設定するのではなく、
テキスト全体の英数字用のフォントを設定なさればよいでしょう。
 
引用:
Private Sub subSetShape(Shape As PowerPoint.Shape)
      
    If Shape.HasTextFrame = msoFalse Then
        Exit Sub
    End If
      
    If Shape.TextFrame.HasText = msoFalse Then
        Exit Sub
    End If
          
    Dim pptCharacter As PowerPoint.TextRange
    Dim lngPosition As Long
          
    With Shape.TextFrame.TextRange
        For lngPosition = 1 To .Characters.Count
            Set pptCharacter = .Characters(lngPosition, 1)
            If (pptCharacter.Text Like "#") And _
               (LenB(StrConv(pptCharacter.Text, vbFromUnicode)) = 1) Then
                pptCharacter.Font.NameAscii = FontNameNumber
            End If
            Set pptCharacter = Nothing
        Next
    End With
  
End Sub

Private Sub subSetShape(Shape As PowerPoint.Shape)
      
    If Shape.HasTextFrame = msoFalse Then
        Exit Sub
    End If
      
    If Shape.TextFrame.HasText = msoFalse Then
        Exit Sub
    End If
          
    Shape.TextFrame.TextRange.Font.NameAscii = FontNameNumber
  
End Sub

投稿日時: 19/04/07 10:35:04
投稿者: r6023

SK様
 
誠に有難うございます!!
 
本当に助かりました。
今後とも宜しくお願いいたします。