도형 그림 색칠하기

 

 

슬라이드쇼에서 색깔을 선택해서 도형영역을 채워서 그림을 색칠하는 방식입니다.

 

좌측 상단에는 미리보기 그림(확대축소 그림)이 있고

아래에 물감 팔레트가 있습니다.

원하는 색상을 클릭하고 오른쪽 조각 도형을 다시 클릭해서 채웁니다.

Auto 색상은 다음 슬라이드의 해당 도형의 색상을 자동으로 골라서 채워줍니다.

Color 에는 현재 선택한 색상이 뜨고 그 오른쪽 아이콘은 색상지우기, 모두 지우기 아이콘입니다.

 

현재 세 가지 샘플은 pixabay.com의 polygon 이미지를 샘플로 가져와서 벡터 도형으로 변환한 것입니다.

 

 

고양이 polygon

 

 

사자 polygon

 

 

인물 polygon

 

 

위와 같은 작업을 편리하게 도와주는 매크로를 포함합니다.

 

GetColorsAndDrawPalette:

현재 슬라이드의 Freeform 도형의 색상을 정리해서 팔레트를 자동으로 만들어줍니다.

원본 그림에 사용된 색상을 추출하는 작업은 번거롭기 때문에 자동으로 사용된 색상을 정리해줍니다.

물감 팔레트의 열 개수와 여백, 크기 등을 미리 설정하고 실행하세요.

 

ApplyAction:

선택한 물감 팔레트 둥근네모 도형과 Freeform 도형에 대해

PickColor 매크로와 DropColor 매크로를 삽입 > 실행에 연결해줍니다.

100여개가 넘은 Freeform 도형에 실행을 걸어주기란 여간 번거로운 일입니다.

 

 

현재 사용된 코드들입니다.

Option Explicit

Public CurColor As Long

'색상 선택
Sub PickColor(shp As Shape)
    Dim sld As Slide

    Set sld = shp.Parent
    
    If shp.Name = "Col_Auto" Then
        CurColor = -2
        sld.Shapes("Col_CurColor").Fill.Visible = msoFalse
        sld.Shapes("Col_CurColor").TextFrame.TextRange.Text = "Auto"
    Else
        CurColor = shp.Fill.ForeColor.RGB
        sld.Shapes("Col_CurColor").Fill.Visible = msoTrue
        sld.Shapes("Col_CurColor").Fill.ForeColor.RGB = CurColor
        sld.Shapes("Col_CurColor").TextFrame.TextRange.Text = "Color"
    End If
End Sub

'칠한 색상 제거
Sub EraseColor(shp As Shape)
    Dim sld As Slide
    CurColor = -1
    Set sld = shp.Parent
    sld.Shapes("Col_CurColor").Fill.Visible = msoFalse
    sld.Shapes("Col_CurColor").TextFrame.TextRange.Text = "Color"
End Sub

'칠한 모든 색상 제거
Sub RemoveColors(shp As Shape)
    Dim sld As Slide
    Dim oShp As Shape
    If MsgBox("모든 색상을 초기화할까요?", vbOKCancel + vbInformation) = vbOK Then
        Set sld = shp.Parent
        For Each oShp In sld.Shapes
            If oShp.Name Like "Freeform *" Then
                oShp.Fill.Visible = msoFalse
            End If
        Next oShp
        sld.Shapes("Col_CurColor").Fill.Visible = msoFalse
        sld.Shapes("Col_CurColor").TextFrame.TextRange.Text = "Color"
    End If
End Sub

'색상 칠하기
Sub DropColor(shp As Shape)
    Dim sld As Slide
    
    Set sld = shp.Parent
    If CurColor = -1 Then
        shp.Fill.Visible = msoFalse
    ElseIf CurColor = -2 Then
        shp.Fill.Visible = msoTrue
        shp.Fill.ForeColor.RGB = sld.Parent.Slides(sld.SlideIndex + 1).Shapes(shp.Name).Fill.ForeColor.RGB
    ElseIf CurColor = 0 Or sld.Shapes("Col_CurColor").Fill.Visible = msoFalse Then
        MsgBox "먼저 색상을 선택하세요.", vbCritical
        Exit Sub
    Else
        shp.Fill.Visible = msoTrue
        shp.Fill.ForeColor.RGB = CurColor
    End If

End Sub

Private Sub GetColorsAndDrawPalette()
    
    Dim sld As Slide
    Dim shp As Shape
    Dim Col As New Collection
    Dim l As Long
    Dim SW!, SH!, x!, y!, w!, h!, m!, c%
    
    With ActivePresentation.PageSetup
        SW = .SlideWidth
        SH = .SlideHeight
    End With
        
    Set sld = ActiveWindow.View.Slide
    
    For Each shp In sld.Shapes
        If shp.Name Like "Freeform *" Then
            
            If Not ExistColor(Col, shp.Fill.ForeColor.RGB) Then
                Col.Add shp.Fill.ForeColor.RGB
            End If
        End If
    Next shp
    
    c = 4   ' 물감색깔 열 개수
    m = 10  ' 물감 여백
    For l = 1 To Col.Count
        w = 50: h = 50
        x = 100 + ((l - 1) Mod c) * (w + m)
        y = 200 + Int((l - 1) / c) * (h + m)
        Set shp = sld.Shapes.AddShape(msoShapeRoundedRectangle, x, y, w, h)
        shp.Name = "Col_" & Col(l)
        shp.Fill.ForeColor.RGB = Col(l)
        shp.Line.ForeColor.RGB = rgbBlack
    Next l
    
End Sub

Function ExistColor(co As Collection, newColor As Long) As Boolean
    Dim c As Long
    For c = 1 To co.Count
        If co(c) = newColor Then
            ExistColor = True: Exit Function
        End If
    Next c
End Function


'첫번째 Adjustment를 나머지 도형에 똑같이 적용
Private Sub AdjustAll()

    Dim shp As Shape
    Dim i%, j%

    With ActiveWindow.Selection
        For Each shp In .ShapeRange
            i = i + 1
            If i > 1 Then
                For j = 1 To shp.Adjustments.Count
                    shp.Adjustments(j) = .ShapeRange(1).Adjustments(j)
                Next j
            End If
        Next shp
    End With

End Sub

'선택된 도형에 색상 채우기
Private Sub FillColor()

    Dim sr As ShapeRange
    Dim i%
    
    Set sr = ActiveWindow.Selection.ShapeRange
    For i = 1 To sr.Count
        sr(i).Fill.ForeColor.RGB = RGB(200 + Int((i - 1) / 10) * 5, 200 - Int((i - 1) / 10) * 10, 50)
    Next i
    
End Sub

'선택된 그룹 도형 내부의 모든 도형에 특정 매크로 지정
Private Sub ApplyAction()
    Dim shp As Shape, cshp As Shape
 
    For Each shp In ActiveWindow.Selection.ShapeRange
        ApplyActionFunc shp
    Next shp
End Sub

Function ApplyActionFunc(oShp As Shape)
    Dim cshp As Shape
    If oShp.Type = msoGroup Then
        For Each cshp In oShp.GroupItems
            ApplyActionFunc cshp
        Next cshp
    Else
        With oShp.ActionSettings(ppMouseClick)
            .Action = ppActionRunMacro
            If oShp.Name Like "Col_*" Then
                .Run = "PickColor"
            ElseIf oShp.Name Like "Freeform *" Then
                .Run = "DropColor"
            Else
            
            End If
        End With
    End If
End Function

Private Sub ChangeDotStyle()
    Dim shp As Shape
    Set shp = ActiveWindow.Selection.ShapeRange(1)
    shp.Line.DashStyle = msoLineSysDot
End Sub

 

 

실행화면:

 

 

샘플파일입니다. 

다운로드 후 차단해제에 체크하시고 매크로 컨텐트 허용해서 열어야 합니다.

 

Painter1.pptm

0.48MB