차트(Moon Chart) 자동으로 그리기

PPT+VBA 2023. 9. 4. 16:38

위와 같이 간단히 차트를 표시하고 싶을 때 문자코드를 이용할 수 있습니다.

 

일단 아래와 같은 유니코드 기호를 이용할 수 있습니다.

●◐◑◒◓◔◕◖◗

◰ ◱ ◲ ◳ ◴ ◵ ◶◷

 

 

경우에 따라서는 Win+'.'이모지를 이용할 수도 있습니다.

이모지는 사용하는 시스템에 따라 안보일 수도 있고 다르게 보일 수도 있습니다.

 

파워포인트에서 도형(부분 원형,  ARC) 을 삽입하고 조절점을 돌리고 원 도형과 그룹지어 만들 수 있습니다.

 

 

하지만 부분 원형의 2개의 조절점을 정확하게 45도, 90도 등의 각도를 그리는 것이 어렵고 귀찮습니다.

그래서 VBA를 이용해서 자동으로 문차트 도형을 삽입하는 방법입니다.

 

더보기 
Option Explicit

Const SZ As Single = 40         '원의 크기
Const LineSZ As Single = 2      '라인 굵기

Sub InsertMoonChart()

    Dim usr As String
    Dim t() As String
    Dim m As Integer
    Dim oSld As Slide
    
    usr = InputBox("문차트 수치를 (0~100)로 콤마로 구분하여 입력하세요(예:23, 89, 45)", "Moon Chart", "0, 25, 50, 75, 100")
    
    If usr = "" Then Exit Sub
    
    Set oSld = ActiveWindow.View.Slide
    
    t = Split(usr, ",")
  
    
    For m = LBound(t) To UBound(t)
        
         DrawMoon oSld, m, CSng(Trim(t(m))), m * SZ, , True
        
    Next m
    
End Sub

Function DrawMoon(sld As Slide, i As Integer, v As Single, x As Single, Optional y As Single = 0, Optional AsPic As Boolean = False)
    
    Dim shp1 As Shape, shp2 As Shape
    
    '원 그리기
    Set shp1 = sld.Shapes.AddShape(msoShapeOval, x, y, SZ, SZ)
    shp1.Name = "Oval_" & i
    shp1.Line.Visible = msoTrue
    shp1.Line.Weight = LineSZ
    shp1.Line.ForeColor.RGB = rgbBlack
    'shp1.Fill.Visible = msoFalse
    shp1.Fill.ForeColor.RGB = rgbWhite
    
    '칠하기
    Set shp2 = sld.Shapes.AddShape(msoShapeArc, x + SZ / 2, y, SZ / 2, SZ / 2)
    shp2.Adjustments(1) = -90
    shp2.Adjustments(2) = v * 360 / 100 - 90
    shp2.Name = "Arc_" & i
    shp2.Line.Visible = msoFalse
    If v = 0 Then
        shp2.Fill.Visible = msoFalse        '0이면 채우기 없이
    Else
        shp2.Fill.ForeColor.RGB = rgbBlack
    End If

    '그룹으로 묶기
    Set shp1 = sld.Shapes.Range(Array(shp1.Name, shp2.Name)).Group
    shp1.Name = "Moon_" & v
        
    'EMF형식으로 붙여넣기
    If AsPic Then
        shp1.Copy
        DoEvents
        Set shp2 = sld.Shapes.PasteSpecial(ppPasteEnhancedMetafile)(1)
        DoEvents
        shp2.Left = shp1.Left
        shp2.Top = shp1.Top
        shp2.Name = shp1.Name
        shp1.Delete
    End If
End Function

Sub InsertMoonChart100()
 
    Dim m As Integer, yy As Single
    Dim oSld As Slide
    
     
    Set oSld = ActiveWindow.View.Slide
 
    For m = 0 To 100
        
         DrawMoon oSld, m, CSng(m), (m Mod 20) * SZ, Int(m / 20) * SZ, True
        
    Next m
    
End Sub

 

첨부파일을 매크로허용해서 열고 Alt-F8누르고 InsertMoonChart 를 실행합니다.

 

그리고 "0, 25, 50, 75, 100" 와 같이 문차트를 채울 값을 0~100 사이의 값과 콤마로 구분해서 입력합니다.

 

화면 왼쪽 상단에 입력한 수치의 문차트가 삽입됩니다.

기본적으로 그림으로 삽입됩니다.

'// y좌표와 그림여부는 생략가능

DrawMoon(슬라이드, 순서, 값, x좌표, y좌표, 그림여부)

DrawMoon을 호출할 때 마지막 인수를 생략하거나 False로 실행하면 그림이 아니라 2개의 도형이 합쳐진 그룹도형으로 삽입합니다. True이면 그룹도형을 EMF형식 그림으로 재삽입합니다.

 

원모양의 크기는 40인데 소스 맨 위의 SZ값을 변경하세요.

선의 두께는 기본으로 2인데 소스에서 LineSZ를 바꾸세요.

 

그림이지만 우클릭하고 '그림 편집' > 오피스 개체로 변환하면 다시 도형으로 변환됩니다.

 

도형으로 삽입한 경우는 색상 조절이 쉽지만 그림인 경우는 제한이 있습니다.

그림인 경우 그림서식에서 색상 다시 칠하기를 이용할 수 있습니다.

아니면 우클릭 후 그림편집으로 도형으로 다시 변환해서 채우기나 색상을 바꾸세요.

 

색깔은 미리 소스에서 변경할 수도 있습니다. RGB(빨강, 녹색, 파랑)값으로 변경해도 됩니다.

Const COLOR_Line As Long = rgbBlack  '선 색깔
Const COLOR_Back As Long = rgbWhite  '배경 원 내부색깔
Const COLOR_Fill As Long = rgbBlack  '차트 Arc 내부색깔

자주 쓸만한 색상코드들은 링크를 참고하세요.

 

 

매크로 실행할 때 InsertMoonChart100 을 실행하면 100개의 문차트가 한꺼번에 삽입됩니다.

 

 

 

아래는 문차트를 활용한 예시 슬라이드입니다.

색깔까지 변화를 주면 데이터의 변화를 시각적으로 일목요연하게 잘 전달할 수 있습니다.

 

 

샘플 파일 첨부합니다.

 

Moon1.pptm
0.18MB

 

 

>> 관련 지식인 답변:

https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102020103&docId=453875097&page=1#answer2 

 

 

 

 

[2023.09.22. 추가]

 

표의 셀들을 선택한 상태에서 매크로를 실행해서 차트값을 입력하면

선택한 각각의 셀들 가운데에 문차트를 정확하게 삽입해주도록 추가했습니다.

 

 

실제 내부적으로는 간단하지 않은 처리입니다.

 

그림으로 붙여넣으면 선택된 셀이 사라지므로 선택된 셀들을 미리 기억시켜야 합니다.

병합된 셀의 경우 첫번째 셀에만 삽입해야 합니다.

지난번 표의 셀 병합확인하는 코드들을 활용했습니다.

 

더보기

 

Option Explicit

Dim sz As Single  '= 40         '원의 크기
Const LineSZ As Single = 2      '라인 굵기

'Const COLOR_Line As Long = rgbBlack  '선 색깔
'Const COLOR_Back As Long = rgbWhite  '배경 원 내부색깔
'Const COLOR_Fill As Long = rgbBlack  '차트 Arc 내부색깔
Const COLOR_Line As Long = rgbIndigo '선 색깔
Const COLOR_Back As Long = rgbWhite  '배경 원 내부색깔
Const COLOR_Fill As Long = rgbIndigo  '차트 Arc 내부색깔

Sub InsertMoonChart()

    Dim usr As String
    Dim t() As String
    Dim m As Integer, r As Integer, c As Integer
    Dim oSld As Slide
    Dim oShp As Shape
    Dim arr() As String
    Dim isTable As Boolean
    Const Margin As Single = 5
    
    usr = InputBox("문차트 수치를 (0~100)로 콤마로 구분하여 입력하세요(예:23, 89, 45)", "Moon Chart", "0, 25, 50, 75, 100")
    
    If usr = "" Then Exit Sub
    
    Set oSld = ActiveWindow.View.Slide
    
    t = Split(usr, ",")
  
    On Error Resume Next
    Set oShp = ActiveWindow.Selection.ShapeRange(1)
    If oShp Is Nothing Then
        isTable = False
    Else
        If oShp.Type = msoTable Then isTable = True Else isTable = False
    End If
    On Error GoTo 0
    
    If isTable Then '표의 셀을 선택한 경우

        With oShp.Table
            For r = 1 To .Rows.Count
                For c = 1 To .Columns.Count
                    If .Cell(r, c).Selected Then
                        '셀 병합된 경우 첫번째 셀만
                        If Not IsMerged(oShp.Table, r, c) Or isTopLeftCell(oShp.Table, r, c) Then
                            ReDim Preserve arr(m)
                            arr(m) = r & "," & c
                            m = m + 1
                        End If
                    End If
                Next c
            Next r
            
            For m = LBound(arr) To UBound(arr)
                If m <= UBound(t) Then
                    r = Int(Split(arr(m), ",")(0))
                    c = Int(Split(arr(m), ",")(1))
                    With .Cell(r, c).Shape
                        sz = .Width
                        If .Width > .Height Then sz = .Height
                        sz = sz - Margin * 2
                        DrawMoon oSld, m, CSng(Trim(t(m))), _
                            .Left + (.Width / 2 - sz / 2), _
                            .Top + (.Height / 2 - sz / 2), True
                    End With
                End If
            Next m
                 
             
        End With
        
    Else    '일반적인 경우

        sz = 40
        For m = LBound(t) To UBound(t)
            
             DrawMoon oSld, m, CSng(Trim(t(m))), m * sz, , True
            
        Next m
    End If
    
End Sub

Function DrawMoon(sld As Slide, i As Integer, v As Single, x As Single, Optional y As Single = 0, Optional AsPic As Boolean = False)
    
    Dim shp1 As Shape, shp2 As Shape
    
    '원 그리기
    Set shp1 = sld.Shapes.AddShape(msoShapeOval, x, y, sz, sz)
    shp1.Name = "Oval_" & i & "_" & shp1.Id
    shp1.Line.Visible = msoTrue
    shp1.Line.Weight = LineSZ
    shp1.Line.ForeColor.RGB = COLOR_Line
    'shp1.Fill.Visible = msoFalse
    shp1.Fill.ForeColor.RGB = COLOR_Back
    
    '칠하기
    Set shp2 = sld.Shapes.AddShape(msoShapeArc, x + sz / 2, y, sz / 2, sz / 2)
    shp2.Adjustments(1) = -90
    shp2.Adjustments(2) = v * 360 / 100 - 90
    shp2.Name = "Arc_" & i & "_" & shp2.Id
    shp2.Line.Visible = msoFalse
    If v = 0 Then
        shp2.Fill.Visible = msoFalse        '0이면 채우기 없이
    Else
        shp2.Fill.ForeColor.RGB = COLOR_Fill
    End If

    '그룹으로 묶기
    Set shp1 = sld.Shapes.Range(Array(shp1.Name, shp2.Name)).Group
    shp1.Name = "Moon_" & v & "_" & shp1.Id
        
    'EMF형식으로 붙여넣기
    If AsPic Then
        shp1.Copy
        DoEvents
        Set shp2 = sld.Shapes.PasteSpecial(ppPasteEnhancedMetafile)(1)
        DoEvents
        shp2.Left = shp1.Left
        shp2.Top = shp1.Top
        shp2.Name = shp1.Name
        shp1.Delete
    End If
End Function

'simply check if the cell is merged
Function IsMerged(oTbl As Table, rr As Integer, cc As Integer) As Boolean
 
    Dim c As Cell
 
    'the current cell
    Set c = oTbl.Cell(rr, cc)
 
    'Check the width and height
    'horizonatally merged
    If c.Shape.Width <> oTbl.Columns(cc).Width Then IsMerged = True
    'vertically merged
    If c.Shape.Height <> oTbl.Rows(rr).Height Then IsMerged = True
 
End Function

'if the cell is the Top-Left(first) cell of the merged area
Function isTopLeftCell(oTbl As Table, rr As Integer, cc As Integer) As Boolean
    Dim i As Integer
    
    With oTbl.Cell(rr, cc).Shape
        'horizontally merged
        If .Width <> oTbl.Columns(cc).Width Then
            'count the left cells merged from the currnet cell
            For i = 1 To cc - 1
                If oTbl.Cell(rr, cc - i).Shape.Left <> .Left Then Exit For
            Next i
            'count the rows above
            If i = 1 Then
                For i = 1 To rr - 1
                    If oTbl.Cell(rr - i, cc).Shape.Top <> .Top Then Exit For
                Next i
                If i = 1 Then isTopLeftCell = True: Exit Function
            End If
        'vertically merged
        ElseIf .Height <> oTbl.Rows(rr).Height Then
            For i = 1 To rr - 1
                If oTbl.Cell(rr - i, cc).Shape.Top <> .Top Then Exit For
            Next i
            If i = 1 Then isTopLeftCell = True: Exit Function
        Else
            'isTopLeftCell = False
        End If
    End With
    
End Function

Sub InsertMoonChart100()
 
    Dim m As Integer, yy As Single
    Dim oSld As Slide
    
     
    Set oSld = ActiveWindow.View.Slide
 
    For m = 0 To 100
        
         DrawMoon oSld, m, CSng(m), (m Mod 20) * sz, Int(m / 20) * sz, True
        
    Next m
    
End Sub

 

실행화면:

 

 

두번째 버전 첨부합니다.

 

Moon2.pptm
0.20MB

 

저작자표시 비영리 동일조건

'PPT+VBA' 카테고리의 다른 글

특정 슬라이드쇼 설정으로 항상 쇼를 시작  (0) 2023.11.18
장바구니 결제 화면 구현  (0) 2023.11.05
모핑 슬라이드 사진앨범 생성  (0) 2023.10.06
프랙탈1 - Sierpinsky 삼각형 그리기  (0) 2023.09.27
도형의 Node를 대칭되게 조절  (0) 2023.08.23
파워포인트 표안의 셀 병합여부, 첫번째 셀인지, 병합된 순서, 범위 등 알아내기  (0) 2023.07.29
엑셀 데이터로 파워포인트 차트 일괄 생성  (0) 2023.06.28
스핀버튼을 눌러 총금액계산  (1) 2023.05.21

티스토리툴바