none
Powerpoint2010で、pptxファイル全体から、Osakaなど特定のフォントの文字の位置を知りたい RRS feed

  • 質問

  • Officeコミュニティ-Powerpointに質問したところ、
    Powerpoint2010で、Osaka フォントなどをMS Pゴシックに置換する際のエラー表示、当該フォントの場所の探し方
    こちらのVBAフォーラムを勧められましたので、質問させていただきます。
    (両方ご覧になられた方、すみません)

    職場の先輩・同僚から代々引き継がれたスライドの体裁統一をするために、
    Powerpoint2010 で、ホーム-編集-置換-フォントの置換 を施そうしたところ、
    置換前のフォント置換前のフォントに、日本語Windows PCでは見慣れない
    Osaka と、Overpass、とハングル(すみません読み書きできません)が出てきました。

    Powerpointの置換機能による置換がうまくできなかった場合(Officeフォーラムで継続問合せ中です)や、
    置換した後の文字ずれなどを漏れなく修正したいので、
    そもそもこれらのフォントがpptxファイル中のどのスライドのどこにあるかが、
    スライドが大量にあるため、目視では探しきれない状況です。

    フォントを指定しての検索はPowerpoint2010には無い、と以前どこかで読みました。
    VBA(少しずつ勉強し始めました)を使って探すことはできますでしょうか?

    下記のようなFor Each ループまでは考えついたのですが、
    スライドの中で、当該フォントの文字を探索する際に、どのような単位(Shape?)でループを
    まわした方がよいか、が見当つきません。

    アドバイスをお願いできますでしょうか?

    For Each mySlide In ActivePresentation.Slides
    mySlide.Select
     For Each (何の単位?) In mySlide.(対象)
      (対象).select
       If ….….Font.name = "Osaka"
        MsgBox "Osakaフォント発見!"
       Endif
          …(以下略)

    以上、よろしくお願いいたします。

     
    2013年10月22日 8:59

回答

  • とりあえず、フォントがありそうな場所を検索してみた。
    #2010が手元に無く2013で試してやってるので、バージョン違いで動かない場所があるかも。

    Option Explicit
    
    Sub Test()
        Dim col As Collection
        Set col = FindByFont(ActivePresentation, "HG行書体") 'フォント名は任意に変更する
        
        Dim obj As Object
        For Each obj In col
            Debug.Print obj.Text
            On Error Resume Next
            Err.Clear
            Call obj.Select
            If Err.Number <> 0 Then
                '現在の表示モードで表示できない場合、別のモードに変更して表示できないか試す
                If (Not TryChangeView(ActivePresentation, obj)) Then
                    If vbCancel = MsgBox(Err.Description & vbCrLf _
                        & "現在の表示モードでは表示できません" & vbCrLf _
                        & obj.Text, vbOKCancel) Then
                        Exit Sub
                    End If
                Else
                    If vbCancel = MsgBox(obj.Text, vbOKCancel) Then
                        Exit Sub
                    End If
                End If
            Else
                If vbCancel = MsgBox(obj.Text, vbOKCancel) Then
                    Exit Sub
                End If
            End If
            On Error GoTo 0
        Next
    End Sub
    
    Private Function TryChangeView(ByVal pre As Presentation, ByVal obj As Object) As Boolean
        Dim colVT As New Collection
        colVT.Add (ppViewNormal)
        
        colVT.Add (ppViewHandoutMaster)
        colVT.Add (ppViewMasterThumbnails)
        colVT.Add (ppViewNotesMaster)
        colVT.Add (ppViewNotesPage)
        colVT.Add (ppViewOutline)
        'colVT.Add (ppViewPrintPreview)
        colVT.Add (ppViewSlide)
        colVT.Add (ppViewSlideMaster)
        colVT.Add (ppViewSlideSorter)
        colVT.Add (ppViewThumbnails)
        colVT.Add (ppViewTitleMaster)
        
        Dim pt As Variant
        Dim wnd As DocumentWindow
            
        Set wnd = pre.Windows(1)
        On Error Resume Next
        For Each pt In colVT
            Err.Clear
            wnd.ViewType = pt
            DoEvents
            obj.Select
            If (Err.Number = 0) Then
                TryChangeView = True
                Exit Function
            End If
        Next
        wnd.ViewType = ppViewNormal
        On Error GoTo 0
        TryChangeView = False
    End Function
    
    Private Function FindByFont(ByVal pre As Presentation, ByVal fontName As String) As Collection
        Dim col As New Collection
        Dim sl As Slide
        For Each sl In pre.Slides '各スライド内を探す
            Call DumpFromShapes(col, sl.shapes, fontName)
            Call DumpFromShapes(col, sl.NotesPage.shapes, fontName)
            Call DumpFromShapes(col, sl.NotesPage.shapes, fontName)
        Next
        
        '各マスタ内を探す
        Call DumpFromShapes(col, pre.HandoutMaster.shapes, fontName)
        Call DumpFromShapes(col, pre.SlideMaster.shapes, fontName)
        Call DumpFromShapes(col, pre.NotesMaster.shapes, fontName)
        
        Set FindByFont = col
    End Function
    
    Private Sub DumpFromShapes(ByVal col As Collection, ByVal shapes As Variant, ByVal fontName As String)
        Dim shp As Shape
        For Each shp In shapes
            Call DumpFromShape(col, shp, fontName)
        Next
    End Sub
    
    Private Sub DumpFromShape(ByVal col As Collection, ByVal shp As Shape, ByVal fontName As String)
        If (shp Is Nothing) Then
            Exit Sub
        End If
    
        Dim fra As TextFrame
        Dim tr As TextRange
        Dim shpChild As Shape
        
        Dim hasGroup As Boolean
        hasGroup = False
        On Error Resume Next
        hasGroup = shp.GroupItems.Count > 0
        On Error GoTo 0
        
        If (hasGroup) Then
            'グループ化していたら、各部品ごとにさらに調べる。
            Call DumpFromShapes(col, shp.GroupItems, fontName)
            Exit Sub
        End If
        
        If (shp.HasTable) Then
            'テーブルの中のShapeを調べる
            Dim r As Row
            For Each r In shp.Table.Rows
                Dim c As Cell
                For Each c In r.Cells
                    Call DumpFromShape(col, c.Shape, fontName)
                Next
            Next
        End If
        
        If (shp.HasTextFrame) Then
            Set fra = shp.TextFrame
    
            Dim hasTextRange As Boolean
            hasTextRange = False
            On Error Resume Next
            hasTextRange = fra.TextRange.Length > 0
            On Error GoTo 0
            
            If ((fra.HasText <> msoFalse) And hasTextRange) Then
                '指定したフォントの連続している部分を取り出す。
                Dim rangeStart As TextRange
                Dim rangeEnd As TextRange
                Dim isContinue As Boolean
                
                Set rangeStart = Nothing
                Set rangeEnd = Nothing
                Dim rangeFont As TextRange
                isContinue = False
                For Each tr In fra.TextRange.Characters
                    If (tr.Font.Name = fontName) Then
                        If (isContinue) Then
                            Set rangeEnd = tr
                        Else
                            Set rangeStart = tr
                            Set rangeEnd = tr
                        End If
                        isContinue = True
                    Else
                       If (isContinue) Then
                            Set rangeFont = fra.TextRange.Characters(rangeStart.Start, rangeEnd.Start - rangeStart.Start + 1)
                            Call col.Add(rangeFont)
                            Set rangeStart = Nothing
                            Set rangeEnd = Nothing
                        End If
                        isContinue = False
                    End If
                Next
                If (isContinue) Then
                    Set rangeFont = fra.TextRange.Runs(rangeStart.Start, rangeEnd.Start - rangeStart.Start + 1)
                    Call col.Add(rangeFont)
                    Set rangeStart = Nothing
                    Set rangeEnd = Nothing
                 End If
             End If
        Else
            Dim tef As TextEffectFormat
            Set tef = Nothing
            On Error Resume Next
            Set tef = shp.TextEffect
            On Error GoTo 0
            If Not (tef Is Nothing) Then
                On Error Resume Next
                    Dim hasTextEffect As Boolean
                    Dim effectFontName As String
                    effectFontName = shp.TextEffect.fontName
                    hasTextEffect = (Err.Number = 0)
                On Error GoTo 0
                
                If (hasTextEffect And effectFontName = fontName) Then
                    Call col.Add(shp.TextEffect)
                End If
            End If
        End If
    End Sub
    #Slide以外の場所にもフォント適用可能な場所があるのでめんどくさい

    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    2013年10月22日 17:55

すべての返信

  • とりあえず、フォントがありそうな場所を検索してみた。
    #2010が手元に無く2013で試してやってるので、バージョン違いで動かない場所があるかも。

    Option Explicit
    
    Sub Test()
        Dim col As Collection
        Set col = FindByFont(ActivePresentation, "HG行書体") 'フォント名は任意に変更する
        
        Dim obj As Object
        For Each obj In col
            Debug.Print obj.Text
            On Error Resume Next
            Err.Clear
            Call obj.Select
            If Err.Number <> 0 Then
                '現在の表示モードで表示できない場合、別のモードに変更して表示できないか試す
                If (Not TryChangeView(ActivePresentation, obj)) Then
                    If vbCancel = MsgBox(Err.Description & vbCrLf _
                        & "現在の表示モードでは表示できません" & vbCrLf _
                        & obj.Text, vbOKCancel) Then
                        Exit Sub
                    End If
                Else
                    If vbCancel = MsgBox(obj.Text, vbOKCancel) Then
                        Exit Sub
                    End If
                End If
            Else
                If vbCancel = MsgBox(obj.Text, vbOKCancel) Then
                    Exit Sub
                End If
            End If
            On Error GoTo 0
        Next
    End Sub
    
    Private Function TryChangeView(ByVal pre As Presentation, ByVal obj As Object) As Boolean
        Dim colVT As New Collection
        colVT.Add (ppViewNormal)
        
        colVT.Add (ppViewHandoutMaster)
        colVT.Add (ppViewMasterThumbnails)
        colVT.Add (ppViewNotesMaster)
        colVT.Add (ppViewNotesPage)
        colVT.Add (ppViewOutline)
        'colVT.Add (ppViewPrintPreview)
        colVT.Add (ppViewSlide)
        colVT.Add (ppViewSlideMaster)
        colVT.Add (ppViewSlideSorter)
        colVT.Add (ppViewThumbnails)
        colVT.Add (ppViewTitleMaster)
        
        Dim pt As Variant
        Dim wnd As DocumentWindow
            
        Set wnd = pre.Windows(1)
        On Error Resume Next
        For Each pt In colVT
            Err.Clear
            wnd.ViewType = pt
            DoEvents
            obj.Select
            If (Err.Number = 0) Then
                TryChangeView = True
                Exit Function
            End If
        Next
        wnd.ViewType = ppViewNormal
        On Error GoTo 0
        TryChangeView = False
    End Function
    
    Private Function FindByFont(ByVal pre As Presentation, ByVal fontName As String) As Collection
        Dim col As New Collection
        Dim sl As Slide
        For Each sl In pre.Slides '各スライド内を探す
            Call DumpFromShapes(col, sl.shapes, fontName)
            Call DumpFromShapes(col, sl.NotesPage.shapes, fontName)
            Call DumpFromShapes(col, sl.NotesPage.shapes, fontName)
        Next
        
        '各マスタ内を探す
        Call DumpFromShapes(col, pre.HandoutMaster.shapes, fontName)
        Call DumpFromShapes(col, pre.SlideMaster.shapes, fontName)
        Call DumpFromShapes(col, pre.NotesMaster.shapes, fontName)
        
        Set FindByFont = col
    End Function
    
    Private Sub DumpFromShapes(ByVal col As Collection, ByVal shapes As Variant, ByVal fontName As String)
        Dim shp As Shape
        For Each shp In shapes
            Call DumpFromShape(col, shp, fontName)
        Next
    End Sub
    
    Private Sub DumpFromShape(ByVal col As Collection, ByVal shp As Shape, ByVal fontName As String)
        If (shp Is Nothing) Then
            Exit Sub
        End If
    
        Dim fra As TextFrame
        Dim tr As TextRange
        Dim shpChild As Shape
        
        Dim hasGroup As Boolean
        hasGroup = False
        On Error Resume Next
        hasGroup = shp.GroupItems.Count > 0
        On Error GoTo 0
        
        If (hasGroup) Then
            'グループ化していたら、各部品ごとにさらに調べる。
            Call DumpFromShapes(col, shp.GroupItems, fontName)
            Exit Sub
        End If
        
        If (shp.HasTable) Then
            'テーブルの中のShapeを調べる
            Dim r As Row
            For Each r In shp.Table.Rows
                Dim c As Cell
                For Each c In r.Cells
                    Call DumpFromShape(col, c.Shape, fontName)
                Next
            Next
        End If
        
        If (shp.HasTextFrame) Then
            Set fra = shp.TextFrame
    
            Dim hasTextRange As Boolean
            hasTextRange = False
            On Error Resume Next
            hasTextRange = fra.TextRange.Length > 0
            On Error GoTo 0
            
            If ((fra.HasText <> msoFalse) And hasTextRange) Then
                '指定したフォントの連続している部分を取り出す。
                Dim rangeStart As TextRange
                Dim rangeEnd As TextRange
                Dim isContinue As Boolean
                
                Set rangeStart = Nothing
                Set rangeEnd = Nothing
                Dim rangeFont As TextRange
                isContinue = False
                For Each tr In fra.TextRange.Characters
                    If (tr.Font.Name = fontName) Then
                        If (isContinue) Then
                            Set rangeEnd = tr
                        Else
                            Set rangeStart = tr
                            Set rangeEnd = tr
                        End If
                        isContinue = True
                    Else
                       If (isContinue) Then
                            Set rangeFont = fra.TextRange.Characters(rangeStart.Start, rangeEnd.Start - rangeStart.Start + 1)
                            Call col.Add(rangeFont)
                            Set rangeStart = Nothing
                            Set rangeEnd = Nothing
                        End If
                        isContinue = False
                    End If
                Next
                If (isContinue) Then
                    Set rangeFont = fra.TextRange.Runs(rangeStart.Start, rangeEnd.Start - rangeStart.Start + 1)
                    Call col.Add(rangeFont)
                    Set rangeStart = Nothing
                    Set rangeEnd = Nothing
                 End If
             End If
        Else
            Dim tef As TextEffectFormat
            Set tef = Nothing
            On Error Resume Next
            Set tef = shp.TextEffect
            On Error GoTo 0
            If Not (tef Is Nothing) Then
                On Error Resume Next
                    Dim hasTextEffect As Boolean
                    Dim effectFontName As String
                    effectFontName = shp.TextEffect.fontName
                    hasTextEffect = (Err.Number = 0)
                On Error GoTo 0
                
                If (hasTextEffect And effectFontName = fontName) Then
                    Call col.Add(shp.TextEffect)
                End If
            End If
        End If
    End Sub
    #Slide以外の場所にもフォント適用可能な場所があるのでめんどくさい

    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    2013年10月22日 17:55
  • gekka さん

    早々のご回答ありがとうございます。 また、返信が遅くなり申し訳ありません。

    slide以外のoutlineなどまで考慮・網羅されていて凄いです。

    早速、「HG行書体」を「Osaka」に書き直して使ってみました、

    が、40ページくらいの文書、3分くらいで何も表示されずに終わってしまいました…

    切分けのために、一番多用されている"MS Pゴシック"にしても、
    何も表示されずに終わり(MSとPの間が半角または全角スペースではないのかしら?)

    次に多い、"Arial"にすると、"Arial"があるテキストボックスでMsgが表示されるのですが、
    それ以外の、日本語しかないテキストボックスでも表示が出てしまいました。

    留意事項に記載いただいた、

    「バージョン違いで動かない場所があるかも」

    かもしれません。デバグ用のMsgBoxを少しはさんで試してみます。

    らちが明かないようでしたら、また質問させていただきます。

    取り急ぎ、お礼まで。重ね重ねありがとうございました。

    2013年10月23日 13:14
  • 早速、「HG行書体」を「Osaka」に書き直して使ってみました、
    が、40ページくらいの文書、3分くらいで何も表示されずに終わってしまいました…

    質問のVBAと関係ありませんが、私の会社で使用されているPowerPointテンプレートですと、マスタースライドにOsakaフォントが使われていました。

    もしかすると書かれたVBAの検索対象外の範囲で使われているのかもしれませんね。

    2013年10月23日 13:44