使用VBA批量插入幻灯片

dul

① 以InsertFromFile来进行插入，无法保持源格式：

1. 
   
2. Sub InsertSlides()
   
3.     Dim FileName As String
   
4.     Dim K As Integer
   
5. 
   
6.     For i = 1 To 60
   
7. 
   
8.         FileName = "****(" & i & ").ppt"  ‘注：****为文件名，包括其路径
   
9.         K = Application.ActivePresentation.Slides.Count
   
10.         
    
11.         Application.ActivePresentation.Slides.InsertFromFile FileName, K
    
12. 
    
13.     Next i
    
14. 
    
15. End Sub
    

复制代码

[ 本帖最后由 dul 于 2011-7-1 14:54 编辑 ]

dul

1. Sub CopyWithSourceFormating()
   
2. 
   
3.     Dim oSource As Presentation
   
4.     Dim oTarget As Presentation
   
5.     Dim oSlide As Slide
   
6.     Dim dlgOpen As FileDialog
   
7.     Dim bMasterShapes As Boolean
   
8.     Dim i As Integer
   
9.     Dim FileName As String
   
10. 
    
11.     Set oTarget = ActivePresentation
    
12. 
    
13. For i = 1 To 60
    
14. 
    
15.         FileName = "※※ (" & i & ").ppt"    ’注 ※※为文件名称，包括路径
    
16. 
    
17.         Set oSource = Presentations.Open(FileName, , , False)
    
18. 
    
19.         For Each oSlide In oSource.Slides
    
20.             oSlide.Copy
    
21.             With oTarget.Slides.Paste
    
22.                 .Design = oSlide.Design
    
23.                 .ColorScheme = oSlide.ColorScheme
    
24.                 If oSlide.FollowMasterBackground = False Then
    
25.                     .FollowMasterBackground = False
    
26.                     With .Background.Fill
    
27.                         .Visible = oSlide.Background.Fill.Visible
    
28.                         .ForeColor = oSlide.Background.Fill.ForeColor
    
29.                         .BackColor = oSlide.Background.Fill.BackColor
    
30.                     End With
    
31.                     Select Case oSlide.Background.Fill.Type
    
32.                         Case Is = msoFillTextured
    
33.                             Select Case oSlide.Background.Fill.TextureType
    
34.                                 Case Is = msoTexturePreset
    
35.                                     .Background.Fill.PresetTextured _
    
36.                                             (oSlide.Background.Fill.PresetTexture)
    
37.                                 Case Is = msoTextureUserDefined
    
38.                             End Select
    
39.                         Case Is = msoFillSolid
    
40.                             .Background.Fill.Transparency = 0#
    
41.                             .Background.Fill.Solid
    
42.                         Case Is = msoFillPicture
    
43.                             With oSlide
    
44.                                 If .Shapes.Count > 0 Then .Shapes.Range.Visible = False
    
45.                                 bMasterShapes = .DisplayMasterShapes
    
46.                                 .DisplayMasterShapes = False
    
47.                                 .Export oSource.Path & .SlideID & ".png", "PNG"
    
48.                             End With
    
49.                             .Background.Fill.UserPicture _
    
50.                                     oSource.Path & oSlide.SlideID & ".png"
    
51.                             Kill (oSource.Path & oSlide.SlideID & ".png")
    
52.                             With oSlide
    
53.                                 .DisplayMasterShapes = bMasterShapes
    
54.                                 If .Shapes.Count > 0 Then .Shapes.Range.Visible = True
    
55.                             End With
    
56.                         Case Is = msoFillPatterned
    
57.                             .Background.Fill.Patterned _
    
58.                                     (oSlide.Background.Fill.Pattern)
    
59.                         Case Is = msoFillGradient
    
60.                             Select Case oSlide.Background.Fill.GradientColorType
    
61.                                 Case Is = msoGradientTwoColors
    
62.                                     .Background.Fill.TwoColorGradient _
    
63.                                             oSlide.Background.Fill.GradientStyle, _
    
64.                                             oSlide.Background.Fill.GradientVariant
    
65.                                 Case Is = msoGradientPresetColors
    
66.                                     .Background.Fill.PresetGradient _
    
67.                                             oSlide.Background.Fill.GradientStyle, _
    
68.                                             oSlide.Background.Fill.GradientVariant, _
    
69.                                             oSlide.Background.Fill.PresetGradientType
    
70.                                 Case Is = msoGradientOneColor
    
71.                                     .Background.Fill.OneColorGradient _
    
72.                                             oSlide.Background.Fill.GradientStyle, _
    
73.                                             oSlide.Background.Fill.GradientVariant, _
    
74.                                             oSlide.Background.Fill.GradientDegree
    
75.                             End Select
    
76.                         Case Is = msoFillBackground
    
77.                     End Select
    
78.                 End If
    
79.             End With
    
80.         Next oSlide
    
81.         oSource.Close
    
82.         Set oSource = Nothing
    
83. 
    
84.     Next i
    
85. 
    
86. End Sub

复制代码

dsd999

谢谢分享，学习了，以后可能会用到。

eyeeye

虽然 不会 但是真了不起

zuiaidh2004

谢谢楼主分享

zzpsx

03版本的ppt可用第一个代码吗？

mawei2

Dim oSource As Presentation
    Dim oTarget As Presentation
定义一样，不对吧

gareth

非常老师，请教一下，导入的PPT，有什么办法可以保留尺寸大小？