그림 삽입 및 표(테이블)에 그림 삽입 VBA 매크로

사진을 삽입하고 맨 뒤로 보내는 간단한 작업을 VBA 매크로로 만들어 보았습니다.

 

실행영상:

 

개발도구 - 매크로에서 실행하거나 빠른 실행에 추가할 수도 있는데

첨부파일의 경우는 매크로 허용하면 자동으로 오른쪽 마우스 메뉴에 myAddPicture 명령을 추가합니다.

​

간단히 마우스 우클릭 후 그림 선택해서 삽입할 수 있습니다.

• 현재는 슬라이드 한 가운데 삽입합니다.
• 그림을 여러개 삽입할 수도 있습니다.
• 그림의 이름은 파일명으로 수정합니다.
• 그림이 슬라이드보다 클 경우 슬라이드에 맞춥니다.
• 기본폴더는 매크로파일의 현재 위치인데
  Alt-F11 Module1에서 Defaultfolder 값을 "C:\Temp\" 처럼 수정할 수 있습니다.
• 첨부파일은 onLoad 함수가 매크로 허용되면 자동으로 실행되어 마우스오른쪽 메뉴가 추가되는데 이렇게 하려면 이 파일을 파워포인트에 추가기능(.ppam)으로 넣거나 각각의 해당 파일마다 onLoad가 자동 실행되도록 CustomUI.xml 을 편집해서 추가해줘야 합니다. 직접 onLoad를 실행해줘도 됩니다.

​

(만일 슬라이드에 표(테이블)가 있다면 특정 셀 위치에 그림을 삽입할 수 있는데 관련 내용은 

링크를 참고하세요.)

 

표에 그림 삽입하는 화면 캡쳐:

 

​

소스는 더보기를 누르세요.

Module1:

 

Option Explicit

Const LockRatio As Boolean = True  '가로세로 비율고정 여부
Const MarginW As Single = 0        '가로 여백(한쪽)
Const MarginH As Single = 0        '세로 여백(한쪽)
Const DefaultFolder As String = ""  '="C:\Temp\"    '기본 그림파일 폴더

Sub onLoad()
   Module2.AddRightMenu
End Sub

Public Sub myAddPicture()

    Dim sld As Slide
    Dim shp As Shape
    Dim SW!, SH!
    Dim ImageFile() As String
    Dim i As Integer, t As Integer
    
    On Error GoTo Oops
    '일반 편집화면의 현재 슬라이드(슬라이드 쇼X)
    Set sld = ActiveWindow.Selection.SlideRange(1)
    With ActivePresentation.PageSetup
        SW = .SlideWidth: SH = .SlideHeight
    End With
 
    If sld Is Nothing Then MsgBox "슬라이드를 먼저 선택하세요.": Exit Sub
    
    '파일 선택 상자
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "Select Image File", "*.jpg;*.png;*.gif;*.bmp;*.emf"
        .InitialFileName = ActivePresentation.Path & "\"
        If Len(DefaultFolder) Then .InitialFileName = DefaultFolder
        On Error Resume Next
        If .Show = True Then
            t = .SelectedItems.Count
            On Error GoTo Oops
            If t = 0 Then Exit Sub
            ReDim Preserve ImageFile(1 To t)
            For i = 1 To t
                ImageFile(i) = .SelectedItems(i)
            Next i
        End If
    End With
    
    i = 1

    For i = 1 To t
        If LockRatio Then
            Set shp = sld.Shapes.AddPicture(ImageFile(i), False, True, _
            0 + MarginW, 0 + MarginH) '.Width, .Height)
        Else
            Set shp = sld.Shapes.AddPicture(ImageFile(i), False, True, _
            0 + MarginW, 0 + MarginH, 0, 0)
        End If
    
            
        With shp
            .Name = Mid(ImageFile(i), InStrRev(ImageFile(i), "\") + 1) ' 파일명
 
            .LockAspectRatio = True
            .ScaleWidth 1, msoTrue  '원본사이즈로 복구
            .ScaleHeight 1, msoTrue
            If .Width > .Height Then    '가로 사진
                If .Height > SH Then .Height = SH
                If .Width > SW Then .Width = SW
            Else                        '세로 사진
                If .Width > SW Then .Width = SW
                If .Height > SH Then .Height = SH
            End If
            .Top = SH / 2 - .Height / 2 + MarginH '가운데로
            .Left = SW / 2 - .Width / 2 + MarginW '가운데로
            
            shp.ZOrder msoSendToBack        '맨 뒤로
        End With
    Next i

Oops:
    If Err.Number Then MsgBox Err.Description
    
End Sub

 

Module2: 마우스 오른쪽 메뉴 추가 관련

'CommandBar 가 "Frames"인 경우는 슬라이드 마우스 오른쪽 메뉴가 지원됨.
'Const CmdBar as String = "Frames"
'https://bettersolutions.com/vba/ribbon/code-snippets-list-shortcut-menus.htm

Const CmdBar As String = "Frames"   '"Selections"
Const myCommand As String = "myAddPicture"

'우측버튼 컨트롤 삭제
Private Sub RightClick_Deactivate()
    On Error Resume Next
        With Application
            .CommandBars(CmdBar).Controls(myCommand).Delete
        End With
    On Error GoTo 0
End Sub

Function AddRightMenu()
    RightClick_Activate
End Function

'우측버튼 클릭시
Private Sub RightClick_Activate()
    
    Dim cmdBtn As CommandBarButton
    Dim strCmd As Variant
    Dim i As Integer
    
    strCmd = Array(myCommand)
    
    For i = LBound(strCmd) To UBound(strCmd)
        On Error Resume Next
        With Application
            .CommandBars(CmdBar).Controls(strCmd(i)).Delete
            On Error GoTo 0
            Set cmdBtn = .CommandBars(CmdBar).Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
        End With
        With cmdBtn
            .Caption = strCmd(i) '& "(&" & i & ")"
            .OnAction = strCmd(i)
            
        End With

    Next i
End Sub

Private Sub ListAllCommandBarControls()
    On Error Resume Next
    With Application.CommandBars(CmdBar).Controls
        For i = 1 To .Count
            Debug.Print .Item(i).Caption, .Item(i).OnAction, .Item(i).Index
        Next i
    End With
End Sub

Private Sub ListAllCommandBars()
    On Error Resume Next
    With Application.CommandBars
        For i = 1 To .Count
            'If InStr(.Item(i).Name, "F") Then
            Debug.Print .Item(i).Name, .Item(i).NameLocal
        Next i
    End With
    
'[0] "Custom Animation"
'[1] "Comments"
'[2] "Task Pane"
'[3] " "
'[4] "Property Editor"
'[5] "Office Clipboard"
'[6] "XML Source"
'[7] "Research"
'[8] "XML Document"
'[9] "Signatures"
'[10] "Document Actions"
'[11] "Clip Art"
'[12] "Selection"
'[13] "Format Object"
'[14] "Document Management"
'[15] "Document Updates"
'[16] "Mail Merge Panes"
'[17] "Fax Service"
'[18] "Meeting Workspace"
'[19] "Attachment Options"
'[20] "Accessibility Checker"
'[21] "Proofing"
'[22] "Dictionaries"
'[23] "Thesaurus"
'[24] "Menu Bar"
'[25] "Menu Bar (Slide Show)"
'[26] "&Legacy Keyboard Support"
'[27] "Standard"
'[28] "Formatting"
'[29] "Slide Sorter"
'[30] "Web"
'[31] "Drawing"
'[32] "Print Preview"
'[33] "Stop Recording"
'[34] "Slide Master View"
'[35] "Handout Master View"
'[36] "Notes Master View"
'[37] "Grayscale View"
'[38] "WordArt"
'[39] "Picture"
'[40] "Drawing Canvas"
'[41] "Diagram"
'[42] "Ink Drawing and Writing"
'[43] "Ink Annotations"
'[44] "Tables and Borders"
'[45] "Organization Chart"
'[46] "Recording"
'[47] "Slide Show"
'[48] "Reviewing"
'[49] "Shadow Settings"
'[50] "3-D Settings"
'[51] "Control Toolbox"
'[52] "Visual Basic"
'[53] "Outlining"
'[54] "Shortcut Menus"
'[55] "Reuse Slides"
'[56] "Revisions"
'[57] "Slider Sorter"
'[58] "Thumbnails"
'[59] "Slide Gap"
'[60] "Section Label"
'[61] "SlideShow Go To Section"
'[62] "Notes Pane"
'[63] "Outliner"
'[64] "Slide Show"
'[65] "Slide Show"
'[66] "Nondefault Drag and Drop"
'[67] "Curve"
'[68] "OLE Object"
'[69] "Connector"
'[70] "WordArt Context Menu"
'[71] "Rotate Mode"
'[72] "Curve Segment"
'[73] "Curve Node"
'[74] "ActiveX Control"
'[75] "Spelling"
'[76] "Pictures Context Menu"
'[77] "Canvas Popup"
'[78] "Frames"
'[79] "Shapes"
'[80] "Notes View Slide"
'[81] "Slide Show Browse"
'[82] "PowerPoint Previewer"
'[83] "Hyperlinked Object"
'[84] "Tables"
'[85] "Table Cells"
'[86] "Organization Chart Popup"
'[87] "Diagram"
'[88] "OrgChart Text Edit PopUp"
'[89] "Comment Popup"
'[90] "Slide View Ink Annotation Popup"
'[91] "Revision Marker Popup"
'[92] "Fill Color"
'[93] "Line Color"
'[94] "Font Color"
'[95] "Annotation Pens"
'[96] "Drawing and Writing Pens"
'[97] "Annotation Pens"
'[98] "Drawing and Writing Pens"
'[99] "Order"
'[100] "Nudge"
'[101] "Rotate or Flip"
'[102] "Align or Distribute"
'[103] "Insert Shape"
'[104] "Lines"
'[105] "Connectors"
'[106] "Basic Shapes"
'[107] "Callouts"
'[108] "Flowchart"
'[109] "Block Arrows"
'[110] "Stars & Banners"
'[111] "Action Buttons"
'[112] "Borders"
'[113] "AutoShapes"
'[114] "Clipboard"
'[115] "Envelope"
'[116] "System"
'[117] " "
'[118] "Status Bar"
'[119] "Ribbon"
End Sub

 

매크로파일 다운로드:

그림삽입맨뒤로.pptm

0.04MB