도넛모양 다이아그램 만들기

 

1. 관련 질문:

https://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020103&docId=349489953&page=1#answer1

파워포인트 도형 편집 문의

https://kin.naver.com/qna/detail.nhn?d1id=1&dirId=1020201&docId=288456170&qb=64+E7ZiVIOu5vOq4sA==#answer1

파워포인트 도표 만드는 방법

 

2. 수작업으로 도넛도형과 갈매기수장 도형을 서로 도형병합/조각내는 방법으로 만들 수 있습니다.

 

2-1. 도넛 도형을 쉬프트 누른채로 그립니다.

노란조절점을 조절해 도넛 두께를 조절합니다.

​

2-2. 그리고 아래 갈매기형 수장 도형을 5개를 삽입하고 크기와 각도를 조절해줍니다.

​

2-3. 그리고 도넛도형과 갈매기 도형들을 모두 선택한 상태에서

서식-도형병합- 조각으로 모두 조각냅니다.

(도형 조각내기는 파워포인트 2010년 이하 버전은 지원이 되지 않습니다.)

2-4. 그리고 나서 필요없는 조각들을 모두 삭제해줍니다.

​

2-5. 스포이드로 색깔을 가져와서 각 도형을 채워주고

텍스트박스를 추가하여 완성합니다.

 

3. 위 과정을 VBA로 자동작업으로 만들어봤습니다.

Option Explicit

Dim sld As Slide
Dim SW As Single, SH As Single
Dim userCount As Integer

Sub Action_Main()
    Dim pres As Presentation

    Dim shp As Shape
    'Dim userCount As Integer
    
    Set pres = ActivePresentation
    With pres.PageSetup
        SW = .SlideWidth
        SH = .SlideHeight
    End With
    
    '현재 슬라이드
    Set sld = ActiveWindow.Selection.SlideRange(1)
    
    clearDonuts
    
    drawDonut
    
    userCount = CInt(InputBox("내부 도형개수는? (2-10개가 적당함)", , "3"))
    drawChevrons
    
    cutOut
    
    removeSmallShapes
    
    adjustCenter

End Sub

Sub Action_바로위Main을실행하세요()
    Call Action_Main
End Sub

Sub clearDonuts()

    Dim shp As Shape
    If sld Is Nothing Then Set sld = ActiveWindow.Selection.SlideRange(1)
    If SW = 0 Then _
        With sld.Parent.PageSetup: SW = .SlideWidth: SH = .SlideHeight: End With

    For Each shp In sld.Shapes
        If shp.Name Like "_*" Then
            If MsgBox("기존 도넛도형(" & shp.Name & ")을 지울까요? (지우지 않으면 에러 발생)", _
                vbOKCancel) <> vbCancel Then shp.Delete
        End If
    Next shp
    
End Sub

Sub drawDonut()   '도넛

    Dim shp As Shape
    If sld Is Nothing Then Set sld = ActiveWindow.Selection.SlideRange(1)
    If SW = 0 Then _
        With sld.Parent.PageSetup: SW = .SlideWidth: SH = .SlideHeight: End With
    Set shp = sld.Shapes.AddShape(msoShapeDonut, SW / 2 - SH / 2, 0, SH, SH)
    With shp
        .Name = "_Donut"
        .Line.Visible = msoFalse
        .Adjustments(1) = 0.25
        '.Select msoFalse
    End With
    
End Sub

Sub drawChevrons()    '갈매기 수장

    'Dim userCount As Integer
    Dim i As Integer
    Dim cw As Single, ch As Single
    Dim shp As Shape
    If sld Is Nothing Then Set sld = ActiveWindow.Selection.SlideRange(1)
    If SW = 0 Then _
        With sld.Parent.PageSetup: SW = .SlideWidth: SH = .SlideHeight: End With
    
    'userCount = 3
    cw = SH / 10
    ch = SH / 4 + 10
    ActiveWindow.Selection.Unselect
    For i = 1 To userCount
        '임시 원
        Set shp = sld.Shapes.AddShape(msoShapeOval, SW / 2 - SH / 2, 0, SH, SH)
        With shp
            .Name = "_Circle_" & i
            .Fill.ForeColor.RGB = rgbRed
            .Line.Visible = msoFalse
            .Select msoTrue
        End With
        'chevron
        Set shp = sld.Shapes.AddShape(msoShapeChevron, SW / 2 - cw / 2, 0, cw, ch)
        With shp
            .Name = "_Chevron_" & i
            .Fill.ForeColor.RGB = rgbLightBlue
            .Line.Visible = msoFalse
            .Adjustments(1) = 0.8
            .Select msoFalse
        End With
        '그룹, 회전, 그룹해제 후 원도형은 다시 삭제
        Set shp = ActiveWindow.Selection.ShapeRange.Group
        shp.Name = "_Group_" & i
        shp.Rotation = (i - 1) * (360 / userCount)
        shp.Ungroup
        sld.Shapes("_Circle_" & i).Delete
    
    Next i
End Sub

Sub cutOut()
    Dim shp As Shape
    If sld Is Nothing Then Set sld = ActiveWindow.Selection.SlideRange(1)
    If SW = 0 Then _
        With sld.Parent.PageSetup: SW = .SlideWidth: SH = .SlideHeight: End With
    
    ActiveWindow.Selection.Unselect
    'select all shapes
    For Each shp In sld.Shapes
        If shp.Name Like "_*" Then
            shp.Select msoFalse
        End If
    Next shp
    'Application.CommandBars.ExecuteMso ("ShapesFragment")
    'Above Office v2013
    ActiveWindow.Selection.ShapeRange.MergeShapes (msoMergeFragment)
    
    'msoMergeCombine 2   Creates a new shape from selected shapes. If the selected shapes overlap, the area where they overlap is cut out, or discarded.
    'msoMergeFragment    5   Breaks a shape into smaller parts or creates new shapes from intersecting lines or from shapes that overlap.
    'msoMergeIntersect   3   Forms a new closed shape from the area where selected shapes overlap, eliminating non-overlapping areas.
    'msoMergeSubtract    4   Creates a new shape by subtracting from the primary selection the areas where subsequent selections overlap.
    'msoMergeUnion   1   Creates a new shape from the perimeter of two or more overlapping shapes. The new shape is a set of all the points from the original shapes.
End Sub

Sub removeSmallShapes()
    Dim shp As Shape
    Dim i As Integer, j As Integer
    
    If sld Is Nothing Then Set sld = ActiveWindow.Selection.SlideRange(1)
    If SW = 0 Then _
        With sld.Parent.PageSetup: SW = .SlideWidth: SH = .SlideHeight: End With
    
    Randomize
    ActiveWindow.Selection.Unselect
    'check and remove small shapes
    For Each shp In sld.Shapes
        If shp.Name Like "Freeform*" Then
            If shp.Width < SH / 4 Or shp.Height < SH / 4 Or _
                Abs(shp.Width - shp.Height) < 1 Then '원에 가까우면
                    'shp.Select msoFalse
                    j = j + 1
                    shp.Name = "__myShp_" & j
                    shp.Fill.ForeColor.RGB = rgbWhite
            Else
                i = i + 1
                shp.Name = "_myShp_" & i
                shp.Fill.ForeColor.RGB = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
                shp.Select msoFalse
            End If
        End If
    Next shp
    
    Set shp = ActiveWindow.Selection.ShapeRange.Group
    shp.Name = "_InnerDonut"
    
    ActiveWindow.Selection.Unselect
    For Each shp In sld.Shapes
        If shp.Name Like "__*" Then shp.Select msoFalse
    Next shp
    
    Set shp = ActiveWindow.Selection.ShapeRange.Group
    shp.Name = "_Group2delete"
    'shp.Visible = msoFalse
End Sub

Sub adjustCenter()
    Dim shp As Shape
    Dim size As Single
    
    If sld Is Nothing Then Set sld = ActiveWindow.Selection.SlideRange(1)
    If SW = 0 Then _
        With sld.Parent.PageSetup: SW = .SlideWidth: SH = .SlideHeight: End With
    
    ActiveWindow.Selection.Unselect
    With sld.Shapes("_InnerDonut")
        size = SW - (.Left * 2)
        If (SW / 2 - (SW - (.Left + .Width))) * 2 > size Then size = (SW / 2 - (SW - (.Left + .Width))) * 2
        If .Height > size Then size = .Height
        .Select msoFalse
        '프레임 투명도형
        Set shp = sld.Shapes.AddShape(msoShapeOval, SW / 2 - size / 2, SH / 2 - size / 2, size, size)
        With shp
            .Name = "_CircleFrame"
            .Fill.Visible = msoFalse
            .Line.Visible = msoFalse
            .Select msoFalse
        End With
    End With
    
    Set shp = ActiveWindow.Selection.ShapeRange.Group
    shp.Name = "_GroupDonut1"
End Sub

Sub getAdjustments()
    
    Dim shp As Shape
    Dim i As Integer
    On Error Resume Next
    For Each shp In ActiveWindow.Selection.ShapeRange
        Debug.Print shp.Name; shp.Rotation; shp.Width; shp.Height; "SH/10=" & SH / 10; "SH/4=" & SH / 4
        If shp.Adjustments.Count > 0 Then
            For i = 1 To shp.Adjustments.Count
                Debug.Print shp.Adjustments.Item(i)
            Next i
        End If
    Next shp
    On Error GoTo 0
End Sub

 

3-1. 첨부파일을 받아서 매크로를 허용해서 열어줍니다.

 

myDonutDiagram1.pptm

0.38MB

 

 

매크로 사용방법:

3-2. 도넛 다이아그램이 들어갈 슬라이드를 먼저 선택한 상태에서

Alt-F8 누르고 

Action_Main 매크로를 실행합니다.

 

3-3. 기존 도넛도형이 있으면 삭제할까요에 "예'라고 답합니다.

그리고 내부에 도넛 조각의 개수를 입력합니다.

2개에서 10개이내가 적당합니다.

 

3-4. 생성결과입니다.

크게 두개의 그룹도형이 생성되는데 GroupDonut1 도형과

Group2Delete 도형이 만들어집니다. Group2Delete 는 지워줘도 됩니다.

 

혹시라도 회전을 할 수 있기 때문에 

도넛도형이 슬라이드의 중앙에 오도록 더 큰 투명 원도형과 그룹으로 묶어주었습니다.

랜덤으로 채워진 색상은 원하는 다른 색으로 채워주고

텍스트박스도 추가해주면 되겠습니다.

 

첨부파일에는 2슬라이드부터 10슬라이드까지

각각 2,3,4,5,6,7,8,9,10개짜리 도넛 도형을 자동 매크로로 만들어서 첨부하였습니다.

 

도넛모양 다이아그램 만드는데 수고가 덜어졌으면 합니다.