20170814xlVBA PowerPoint分类插图加说明

Public Sub AddPictures()
    Dim ppApp As PowerPoint.Application
    Set ppApp = New PowerPoint.Application
    Dim Pre As PowerPoint.Presentation
    Dim NewSld As PowerPoint.Slide
    Dim tShp As PowerPoint.Shape
    Dim pShp As PowerPoint.Shape

    Const PPT_NAME  As String = "图片.ppt"
    Dim pptPath As String

    pptPath = ThisWorkbook.Path & "\" & PPT_NAME
    Set Pre = ppApp.Presentations.Add(msoTrue)
    Pre.SaveAs pptPath

    Dim PicIndex As Long
    Dim SldIndex As Long
    SldIndex = 0
    With ThisWorkbook.Sheets("数据")
        '预先排序
        CustomSort .UsedRange
        '逐个类别 逐个单位
        endrow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
        For i = 2 To endrow
            If .Cells(i, "G").Text <> .Cells(i - 1, "G").Text Then
                '若类别不同
                SldIndex = SldIndex + 1
                PicIndex = 1
                Debug.Print i; "插入新幻灯片"; SldIndex
                Set NewSld = Pre.Slides.Add(Pre.Slides.Count + 1, ppLayoutBlank)
                NewSld.Name = SldIndex
                Debug.Print i; "插入图片"; PicIndex
                Set pShp = InsertPicture(Pre, NewSld, .Cells(i, 12).Text, PicIndex)
                Text = .Cells(i, 2).Text & "  " & .Cells(i, 3).Text & "  " & .Cells(i, 4).Text & "  " & .Cells(i, 5).Text & Chr(13) & .Cells(i, 6).Text
                Set tShp = InsertTextBox(NewSld, pShp, Text)
            Else
                '若类别相同
                If .Cells(i, "D").Text <> .Cells(i - 1, "D").Text Then
                    '若单位不同
                    PicIndex = 1
                    SldIndex = SldIndex + 1
                    Debug.Print i; "插入新幻灯片"; SldIndex
                    Set NewSld = Pre.Slides.Add(Pre.Slides.Count + 1, ppLayoutBlank)
                    NewSld.Name = SldIndex
                    Debug.Print i; "插入图片1"
                    Set pShp = InsertPicture(Pre, NewSld, .Cells(i, 12).Text, PicIndex)
                    Text = .Cells(i, 2).Text & "  " & .Cells(i, 3).Text & "  " & .Cells(i, 4).Text & "  " & .Cells(i, 5).Text & Chr(13) & .Cells(i, 6).Text
                    Set tShp = InsertTextBox(NewSld, pShp, Text)
                Else
                    '若单位相同
                    PicIndex = PicIndex + 1
                    PicIndex = (PicIndex - 1) Mod 4 + 1
                    If PicIndex = 1 Then  '当同类超过一页幻灯片时
                    SldIndex = SldIndex + 1
                    Debug.Print i; ">5插入新幻灯片"; SldIndex
                    Set NewSld = Pre.Slides.Add(Pre.Slides.Count + 1, ppLayoutBlank)
                    NewSld.Name = SldIndex
                    Debug.Print i; ">5同类同单位插入图片"; PicIndex
                    Set pShp = InsertPicture(Pre, NewSld, .Cells(i, 12).Text, PicIndex)
                    Text = .Cells(i, 2).Text & "  " & .Cells(i, 3).Text & "  " & .Cells(i, 4).Text & "  " & .Cells(i, 5).Text & Chr(13) & .Cells(i, 6).Text
                    Set tShp = InsertTextBox(NewSld, pShp, Text)
                Else
                    Debug.Print i; "同类同单位插入图片"; PicIndex
                    Set pShp = InsertPicture(Pre, NewSld, .Cells(i, 12).Text, PicIndex)
                    Text = .Cells(i, 2).Text & "  " & .Cells(i, 3).Text & "  " & .Cells(i, 4).Text & "  " & .Cells(i, 5).Text & Chr(13) & .Cells(i, 6).Text
                    Set tShp = InsertTextBox(NewSld, pShp, Text)
                End If
            End If
        End If
    Next i
End With
Pre.Save
Pre.Close
ppApp.Quit
Set ppApp = Nothing

End Sub
Private Sub CustomSort(ByVal RngWithTitle As Range)
    With RngWithTitle
        .Sort _
        Key1:=RngWithTitle.Cells(1, 7), Order1:=xlAscending, _
        Key2:=RngWithTitle.Cells(1, 4), Order2:=xlAscending, _
              Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
    End With
End Sub

Private Function InsertPicture(ByVal Pre As PowerPoint.Presentation, ByVal NewSld As PowerPoint.Slide, _
                                        ByVal ImagePath As String, ByVal Pos As Long) As PowerPoint.Shape
    Dim Shp As PowerPoint.Shape
    Set Shp = NewSld.Shapes.AddPicture(ImagePath, msoFalse, msoTrue, CLeft(Pre, Pos), CTop(Pre, Pos), CWidth(Pre, Pos), CHeight(Pre, Pos))
    Set InsertPicture = Shp
    Set Shp = Nothing
End Function

Private Function CLeft(ByVal Pre As PowerPoint.Presentation, ByVal Pos As Long, Optional JG As Long = 10) As Double
    Dim SW As Double
    Dim SH As Double
    SW = Pre.PageSetup.SlideWidth
    SH = Pre.PageSetup.SlideHeight
        Select Case Pos
        Case 1, 3
        CLeft = JG
        Case 2, 4
        CLeft = JG * 3 + SW / 2
        End Select
End Function
Private Function CTop(ByVal Pre As PowerPoint.Presentation, ByVal Pos As Long, Optional JG As Long = 10) As Double
    Dim SW As Double
    Dim SH As Double
    SW = Pre.PageSetup.SlideWidth
    SH = Pre.PageSetup.SlideHeight
        Select Case Pos
        Case 1, 2
        CTop = JG
        Case 3, 4
        CTop = JG * 3 + SH / 2
        End Select
End Function
Private Function CWidth(ByVal Pre As Presentation, Optional JG As Long = 10) As Double
    Dim SW As Double
    Dim SH As Double
    SW = Pre.PageSetup.SlideWidth
    SH = Pre.PageSetup.SlideHeight
    CWidth = (SW - 4 * JG) / 2 - 30
End Function
Private Function CHeight(ByVal Pre As Presentation, Optional JG As Long = 10) As Double
    Dim SW As Double
    Dim SH As Double
    SW = Pre.PageSetup.SlideWidth
    SH = Pre.PageSetup.SlideHeight
    CHeight = (SH - 4 * JG) / 2 - 100
End Function

Private Function InsertTextBox(ByVal NewSld As PowerPoint.Slide, ByVal pShp As PowerPoint.Shape, ByVal Text As String) As PowerPoint.Shape

    Dim Shp As PowerPoint.Shape
    Dim Pos As Long
    Dim Tr As PowerPoint.TextRange

    With NewSld
        Set Shp = .Shapes.AddTextBox(msoTextOrientationHorizontal, pShp.Left, pShp.Top + pShp.Height, pShp.Width, 50)
        With Shp
            .TextFrame.WordWrap = msoTrue
            With .TextFrame.TextRange
                With .ParagraphFormat
                    .LineRuleWithin = msoTrue
                    .SpaceWithin = 1
                    .LineRuleBefore = msoTrue
                    .SpaceBefore = 0.5
                    .LineRuleAfter = msoTrue
                    .SpaceAfter = 0
                End With
                myText = Text
                .Text = myText
                Pos = InStr(myText, Chr(13))

                Set Tr = .Characters(1, Pos)
                With Tr
                    .Font.Size = 14
                    .Font.Color.RGB = RGB(Red:=255, Green:=51, Blue:=255)
                End With

                Set Tr = .Characters(Pos + 1, Len(myText) - Pos)
                With Tr
                    .Font.Size = 18
                    .Font.Color.RGB = RGB(Red:=255, Green:=51, Blue:=0)
                End With

            End With
        End With

    End With
    Set InsertTextBox = Shp
    Set Shp = Nothing
End Function