如何自动将word中内容生成ppt

qdog988

有时修改材料很晚，或者先生成一个基本的ppt，再进一步完善
初步想法是将一级标题生成目录，然后每个一级标题及二级标题都生成一页，可将加黑的内容自动添加到相应页中

daibao88

vba可以生成，ppt后期调整美化，需要人工进行。可以百度代码，修改一下。

qdog988

1. Set ppt = VBA.CreateObject("powerpoint.application")
   
2.     With ppt
   
3.         .Visible = msoTrue
   
4.         Dim pReport
   
5.         If .presentations.Count > 0 Then
   
6.             Set pReport = .presentations(1)
   
7.         Else
   
8.             Set pReport = .presentations.Add(True)
   
9.             pReport.Slides.Add 1, 12
   
10.             pReport.SaveAs "a1.pptx"
    
11.         End If
    
12. 
    
13.         'deal with word
    
14.         pcount = ActiveDocument.Paragraphs.Count
    
15.         For i = 1 To pcount
    
16.             If ActiveDocument.Paragraphs(i).OutlineLevel = wdOutlineLevel2 Then
    
17.                 Debug.Print (ActiveDocument.Paragraphs(i).Range.Text)
    
18.                 Call addPPT(ActiveDocument.Paragraphs(i).Range.Text, pReport)
    
19.             End If
    
20.         Next
    
21.         
    
22.         For i = 1 To pcount
    
23.             If ActiveDocument.Paragraphs(i).OutlineLevel = wdOutlineLevel3 Then
    
24.                 Debug.Print (ActiveDocument.Paragraphs(i).Range.Text)
    
25.                 Call addPPT(ActiveDocument.Paragraphs(i).Range.Text, pReport)
    
26.                 pWords = ActiveDocument.Paragraphs(i + 1).Range.Words.Count
    
27.                 For j = 1 To pWords
    
28.                     Debug.Print (ActiveDocument.Paragraphs(i + 1).Range.Words(j).Text)
    
29.                     If ActiveDocument.Paragraphs(i + 1).Range.Words(j).Font.Underline = wdUnderlineSingle Then
    
30.                         Debug.Print (ActiveDocument.Paragraphs(i + 1).Range.Words(j).Text)
    
31.                         Call addPPT(ActiveDocument.Paragraphs(i + 1).Range.Words(j).Text, pReport)
    
32.                     End If
    
33.                 Next
    
34.             End If
    
35.         Next
    
36.         'end deal with word

复制代码

1. Function addPPT(ByRef content, ByRef pReport)
   
2.     With pReport
   
3.         Dim oSlide
   
4.         cSlide = .Slides.Count
   
5.         If cSlide > 0 Then
   
6.             pReport.Slides.Add cSlide + 1, 12
   
7.             Set oSlide = .Slides(cSlide + 1)
   
8.             Set ptShape = oSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
   
9.                             Left:=10, Top:=17, Width:=300, Height:=50)
   
10.             With ptShape.TextFrame
    
11.                 .TextRange.Font.Name = "方正小标宋简体"
    
12.                 .TextRange.Text = content
    
13.                 .TextRange.Font.Size = 30
    
14.                 .TextRange.Font.Bold = True
    
15.                 .TextRange.Font.Color.RGB = RGB(Red:=255, Green:=0, Blue:=0)
    
16.             End With
    
17.         Else
    
18.             Set oSlide = .Slides.Add(1, ppLayoutBlank)
    
19.             Set ptShape = oSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
    
20.                             Left:=10, Top:=17, Width:=30, Height:=50)
    
21.             With ptShape.TextFrame
    
22.                 .TextRange.Text = "mfb"
    
23.                 .TextRange.Font.Name = "楷体_GB2312"
    
24.                 .TextRange.Font.Size = 30
    
25.                 .TextRange.Font.Bold = True
    
26.                
    
27.             End With
    
28.         End If
    
29.     End With
    
30. End Function

复制代码

yhs185

飞驰的椒麻鸡

踩一下踩一下踩一下踩一下踩一下踩一下