특정폰트가 사용된 개체(도형) 찾기

첨부한 VBA는 슬라이드에서 '궁서체'폰트로 작성한 개체(도형)를 찾아줍니다.

특히

• 슬라이드 마스터까지 검색합니다.
• 그룹으로 묶인 경우도 검색합니다. 표의 경우도 검색합니다.
• 만약 찾았다면 찾은 부분을 선택해줍니다.
• 그리고 기본폰트(.Name), 아시아폰트(.NameFarEast), 스크립트폰트(.NameComplexScript), 기타(,.NameOther) 등 어떤 폰트로 사용되었는지, 언어코드는 무엇인지 메시지 박스를 띄워줍니다.

'확인'을 누르면 계속 다음 개체를 찾습니다. '취소'를 누르면 찾기를 중단합니다.

다른 폰트를 검색하려면 FontName을 수정하고 매크로를 실행합니다.

 

 

Option Explicit
 
Const FontName = "궁서체"
 
Sub FontFind()
 
    Dim pres As Presentation
    Dim sld As Slide
    Dim shp As Shape
    Dim des As Design
    Dim cus As CustomLayout
    Dim FFound As Boolean
    
    Set pres = ActivePresentation
    
    ActiveWindow.ViewType = ppViewSlideMaster
    '슬라이드마스터 디자인별로 순환
    For Each des In pres.Designs
        '슬라이드 마스터
        For Each shp In des.SlideMaster.Shapes
            If ShapeFontFind(shp) Then Exit Sub
 
        Next shp
        If FFound Then Exit For
        '슬라이드마스터 안의 각 커스텀레이아웃 슬라이드마다 순환
        For Each cus In des.SlideMaster.CustomLayouts
            For Each shp In cus.Shapes
                If ShapeFontFind(shp) Then Exit Sub
            Next shp
            If FFound Then Exit For
        Next cus
        If FFound Then Exit For
    Next des
    
    ActiveWindow.ViewType = ppViewNormal
    '일반슬라이드 순환
    For Each sld In pres.Slides
        sld.Select
        For Each shp In sld.Shapes
            'shp.Select
            If ShapeFontFind(shp) Then Exit Sub
        Next shp
        If FFound Then Exit For
    Next sld
    
End Sub
 
 
Function ShapeFontFind(oShp As Shape) As Boolean
 
    Dim cShp As Shape
    Dim c As String
    Dim i As Integer, j As Integer
    Dim Found As Boolean
    
    '그룹 도형인 경우
    If oShp.Type = msoGroup Then
        For Each cShp In oShp.GroupItems
            If ShapeFontFind(cShp) Then
                ShapeFontFind = True
                Exit Function
            End If
        Next cShp
    Else
        '표인 경우
        If oShp.Type = msoTable Then
            With oShp.Table
                For i = 1 To .Rows.Count
                    For j = 1 To .Columns.Count
                        With .Cell(i, j).Shape
                            If .HasTextFrame Then
                                With .TextFrame
                                    If .HasText Then
                                        If CheckFont(.TextRange) Then
                                            ShapeFontFind = True: Exit Function
                                        End If
                                    End If
                                End With
                            End If
                        End With
                    Next j
                Next i
            End With
        ' 일반도형(텍스트가 있는)인 경우
        ElseIf oShp.HasTextFrame Then
            With oShp.TextFrame
                If .HasText Then
                    If CheckFont(.TextRange) Then
                        ShapeFontFind = True: Exit Function
                    End If
                End If
            End With
        End If
    End If
    'ShapeFontFind = False
End Function
 
Function CheckFont(tr As TextRange) As Boolean
    
    Dim sld As Variant  'Slide
    Dim shp As Shape, shpName As String
    Dim run As TextRange
    Dim str As String
    
    For Each run In tr.Runs
        If run.Font.Name = FontName Then _
            str = str & ".Name ": CheckFont = True
        If run.Font.NameAscii = FontName Then _
            str = str & ".NameAscii ": CheckFont = True
        If run.Font.NameComplexScript = FontName Then _
            str = str & ".NameComplexScript ": CheckFont = True
        If run.Font.NameFarEast = FontName Then _
            str = str & ".NameFarEast ": CheckFont = True
        If run.Font.NameOther = FontName Then _
            str = str & ".NameOther ": CheckFont = True
        If CheckFont Then Exit For
    Next run
    If CheckFont Then
        'Debug.Print run.Text
        str = str & "[langID: " & run.LanguageID & "]"
        Set shp = run.Parent.Parent
        shpName = ""
        On Error Resume Next
        shpName = shp.Name
        On Error GoTo 0
        Set sld = shp.Parent
        sld.Select
        run.Select
        If MsgBox("Font(" & FontName & ") was found in the shape(" & shpName & ")" & vbNewLine & vbNewLine & _
            "Text: """ & run.Text & """ (" & str & ")" & vbNewLine & vbNewLine & "찾기를 계속할까요?", vbOKCancel, "폰트찾기") = vbCancel Then _
                CheckFont = True Else CheckFont = False
    End If
    
End Function

 

실행 영상:

 

샘플 파일 받기:

폰트찾기1.pptm

0.06MB

 

알파버전

폰트찾기2.pptm

0.07MB