如何把word转换成ppt

zzpsx

如何把word转换成ppt.rar (16.12 KB, 下载次数: 15)

2020-4-4 16:32 上传

点击文件名下载附件

如何把word转换成ppt，第一段放在第一张ppt上，第二段第二张ppt上，下同。

大纲视图方法太麻烦

Researchers believe they have solved one ofscience's greatest mysteries. They think they have found out why a dog's noseis cold. Scientists from universities in Sweden and Hungary have posited thatdogs' noses are constantly cold because they act as "ultra-sensitive heatdetectors". Canines can sense the temperature of something before theytouch it.

They added that dogs use their noses todetect tiny changes in temperature, such as when possible predators or prey arenearby. Humans generally only know something is hot after touching it, oftenwith painful consequences. It was common belief that the only reason dogs'noses are cold is to control and regulate their own body temperature.

The researchers conducted experiments onsixteen dogs that had to detect the temperature of different objects in a room.The objects had different temperatures that humans could only differentiate bytouching them. The scientists said that the brain activity in the dogs showedthat they could discern which objects were warmer than others.

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr()
   
4.   Dim pptApp As PowerPoint.Application
   
5.   Dim pptPre As PowerPoint.Presentation
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   m = 0
   
9.   With ThisDocument
   
10.     For i = 1 To .Paragraphs.Count
    
11.       ss = .Paragraphs(i).Range.Text
    
12.       ss = Left(ss, Len(ss) - 1)
    
13.       If Len(ss) <> 0 Then
    
14.         m = m + 1
    
15.         ReDim Preserve arr(1 To m)
    
16.         arr(m) = Replace(.Paragraphs(i).Range.Text, Chr(13), "")
    
17.       End If
    
18.     Next
    
19.   End With
    
20.   If m = 0 Then
    
21.     MsgBox "Word文件中没有数据！"
    
22.     Exit Sub
    
23.   End If
    
24.   
    
25.   Set pptApp = New PowerPoint.Application
    
26.   pptApp.Visible = msoTrue
    
27.   Set pptPre = pptApp.Presentations.Add
    
28.   With pptPre
    
29.     For k = 1 To UBound(arr)
    
30.       With .Slides.Add(Index:=.Slides.Count + 1, Layout:=ppLayoutTitleOnly)
    
31.         ileft = (.CustomLayout.Width - 820) / 2
    
32.         itop = (.CustomLayout.Height - 450) / 2
    
33.         With .Shapes("Title 1")
    
34.           .Left = ileft
    
35.           .Top = itop
    
36.           .Width = 820
    
37.           .Height = 450
    
38.           With .TextFrame
    
39.             With .TextRange
    
40.               .Text = arr(k)
    
41.               With .Font
    
42.                 .Name = "等线(正文)"
    
43.                 .Size = 30
    
44.                 .Bold = True
    
45.               End With
    
46.               .ParagraphFormat.Alignment = 1
    
47.             End With
    
48.           End With
    
49.         End With
    
50.       End With
    
51.     Next
    
52.     .SaveAs Filename = ThisDocument.Path & "\结果"
    
53. '    .Close
    
54.   End With
    
55. '  pptApp.Quit
    
56. '  Set pptPre = Nothing
    
57. '  Set pptApp = Nothing
    
58.   Application.ScreenUpdating = True
    
59.   MsgBox "幻片生成完毕！"
    
60. End Sub

复制代码

chxw68

详见附件。

zzpsx

chxw68 发表于 2020-4-4 16:57
详见附件。

谢谢，非常厉害的高手作品，太强大了。要是能保留word文档的下划线，颜色等格式到ppt，那就更好了。 有格式的word文档.rar (17.35 KB, 下载次数: 7)

2020-4-4 18:08 上传

点击文件名下载附件

zzpsx

chxw68 发表于 2020-4-4 16:55

请问在word上能直接alt+f8运行这个代码吗？

chxw68

zzpsx 发表于 2020-4-4 18:07
谢谢，非常厉害的高手作品，太强大了。要是能保留word文档的下划线，颜色等格式到ppt，那就更好了。

保留这些格式非常繁琐。

zzpsx

chxw68 发表于 2020-4-4 18:32
保留这些格式非常繁琐。

您说得对，还不如在ppt中运行代码批量加下划线或标红

zzpsx

chxw68 发表于 2020-4-4 16:55

请问在word上能直接alt+f8运行这个代码吗？

chxw68

zzpsx 发表于 2020-4-4 21:13
请问在word上能直接alt+f8运行这个代码吗？

WORD上不是加了按钮吗？

zzpsx

chxw68 发表于 2020-4-4 21:16
WORD上不是加了按钮吗？

如图不加按钮，能直接通过alt+F8运行代码吗？还是代码上要加一句？