차트를 완전한 자유형 도형(FreeForm)으로 변환

파워포인트 차트를 EMF로 저장했다가 다시 삽입 후

우클릭하고 오피스 도형으로 변환해도

축이나 제목 등의 글자가 있는 부분은 여전히 변경 가능한 텍스트박스상태로 남아있습니다.

나중에 편집이 가능한 점은 있지만

폰트가 없으면 다른 폰트로 보이게 되고

확대 축소 등의 사이즈를 변경할 때 폰트 크기가 변경이 안되어 불편하기도 합니다.

 

텍스트 박스를 순수한 자유형도형으로 변환할 수 있습니다. 텍스트박스나 글자가 있는 도형은

2013이후 도입된 기능인 도형병합(빼기)를 이용하면 점편집이 가능한 순수한 자유형도형으로 변환됩니다.

도형병합으로 처리하는 방법은 바로 해당 텍스트 도형에서 아무 빈 도형을 빼주면 됩니다.

 

이 방법을 이용해서 차트 > EMF 로 저장하여 도형으로 변환해서 그룹을 해제하고 내부 텍스트 도형들을

일괄로 순수 자유형 도형으로 변환해주는 VBA입니다.

 

 

 

Option Explicit

Const NewSlide As Boolean = False 'False이면 현재 슬라이드에 만들고 True 이면 새슬라이드에 만듬

Sub Chart2Shapes()
    Dim sld As Slide
    Dim shp As Shape, tshp As Shape
    Dim target As String
    Dim l!, t!, w!, h!, cname$
    
    On Error Resume Next
    Set shp = ActiveWindow.Selection.ShapeRange(1)
    On Error GoTo 0
    
    If shp Is Nothing Then MsgBox "차트를 선택하세요.": Exit Sub
    If shp.Type <> msoChart Then MsgBox "차트를 선택하세요.": Exit Sub
    
    '기존 차트 위치와 크기 기억
    With shp
        l = .Left: t = .Top: w = .Width: h = .Height
        cname = .Name
    End With
    
    '차트 emf 그림으로 저장
    target = ActivePresentation.Path & "\" & cname & ".emf"
    shp.Export target, ppShapeFormatEMF
    Set sld = shp.Parent
    Set sld = ActivePresentation.Slides.Add(sld.SlideIndex + 1, ppLayoutBlank)
    DoEvents
    sld.Select
    
    'emf 그림을 다시 삽입
    Set shp = sld.Shapes.AddPicture(target, msoFalse, msoTrue, l, t, w, h)
    DoEvents
    Kill target
    shp.Select
    
    '도형개체로 변환 -> 확인 클릭 필요    'Call CommandBars.ExecuteMso("SVGEdit")
    Call CommandBars.ExecuteMso("PictureEdit")
    myWait 1
    SendKeys "{ENTER}" '효과 없음
    myWait 1

    '그룹 해제
    Set shp = sld.Shapes(sld.Shapes.Count)
    shp.Ungroup
    myWait 1
    
    '도형 변환 취소 확인
    If sld.Shapes.Count = 1 Then MsgBox "도형변환 취소됨": Exit Sub
    '필요 없는 AutoShape 삭제
    For l = sld.Shapes.Count To 1 Step -1
        If sld.Shapes(l).Name Like "AutoShape *" Then sld.Shapes(l).Delete
    Next l
    myWait 1
    
    '차트 내부에서 텍스트가 있는 경우 빈 도형과 도형병합(빼기)를 이용해서 Freeform으로 변환(2013dltkd)
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            If shp.TextFrame.HasText Then
                '빈 도형 추가
                Set tshp = sld.Shapes.AddShape(msoShapeRectangle, 0, -10, 1, 1)
                tshp.Line.Visible = msoFalse
                shp.Select msoTrue
                tshp.Select msoFalse
                '빈 도형과 도형병합(빼기)
                ActiveWindow.Selection.ShapeRange.MergeShapes msoMergeSubtract
                'Call CommandBars.ExecuteMso("ShapesSubtract")
                DoEvents    ' myWait 0.1
            End If
        End If
    Next shp
    
    '모두 선택후 그룹으로 묶기
    sld.Shapes.SelectAll
    Set shp = ActiveWindow.Selection.ShapeRange.Group
    shp.Name = cname
    
    If NewSlide Then Exit Sub
    '원래 슬라이드로 복사
    shp.Copy
    With ActivePresentation.Slides(sld.SlideIndex - 1)
        .Shapes(cname).Visible = msoFalse
        .Shapes.Paste (1)
    End With
    DoEvents
    sld.Delete
    
End Sub

Function myWait(t As Double)
    Dim tick As Double
    tick = Timer
    While Timer - tick < t:  DoEvents:   Wend
End Function

 

중간에 간혹 에러가 날 수 있습니다.

개체가 많아서 작업시간이 더 걸릴 수도 있습니다.

차트도 원형, 막대, 선 등 기본 차트인 경우 잘 되고

최신 차트 형태는 변환해도 비트맵 그림인 경우가 많습니다.

 

샘플 파일 첨부합니다.

Chart2Shapes1.pptm

0.11MB