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