铁锹儿vba程序之word 文档转 ppt docin版

铁锹儿vba程序之word 文档转 docin版 铁锹儿vba程序之 Word to ppt 示例 教学课题, 7.4 重力势能 --样式和格式-教案 章 使用说明: 1.Word文本输入:把本Word内容删除掉，再输入，这样就能 保留样式和vba宏。格式按要求设置，点击菜单“格式”=> “样式和格式”，具体看文中示例 2.打开ppt程序 3.在Word里运行 “word转成ppt()“宏即可 Vba程序 Sub word转成ppt() '铁锹儿vba程序之 Word转化成ppt幻灯片 '铁锹儿制作 msgbox的调试功能,注意运用脚本编辑器的运用。 MsgBox "请先打开ppt程序～请用铁锹儿规定样式对Word排版，插入的图片或文本框的版式为嵌入型或否则不得转化～" + Chr$(CharCode:=13) + "公式必须为单独一行(段)或含有公式的这一行包括文字全用公式写～" 97993807.doc Page 1 of 5 铁锹儿vba程序之 Word to ppt 示例 'On Error Resume Next Dim wdp As Paragraph, wdr As Range, s As String, i As Integer, tx As Integer Set objpptapp = CreateObject("PowerPoint.application") objpptapp.Visible = True objpptapp.Presentations.Add WithWindow:=msoTrue Set pptPres = objpptapp.ActivePresentation Dim pptSlide tx = 1 i = 0 hhshu = 0 For Each wdp In ActiveDocument.Paragraphs Set wdr = wdp.Range yshi = wdp.Style.NameLocal s = CStr(wdr.Text) l = Asc(s) wdr.Select Selection.Copy tx_bl = 12 If yshi = "教案 节" Then jie = wdr.Text If yshi = "教案 节" Or yshi = "教案 章" Or tx = tx_bl Then 'MsgBox i & jie If i > 0 Then zs_shapes = pptSlide.Shapes.Count For ttx = 2 To zs_shapes 97993807.doc Page 2 of 5 铁锹儿vba程序之 Word to ppt 示例 With pptSlide.Shapes(ttx) bb = 35 * (ttx - 1 + hhshu) .IncrementTop bb '向下平移 End With '设置自定义动画 Set shpFirst = pptSlide.Shapes(ttx) Set effNew = pptPres.Slides(i).TimeLine.MainSequence.AddEffect _ (Shape:=shpFirst, effectId:=msoAnimEffectBlinds) If pptSlide.Shapes(ttx).Type = msoTextOrientationHorizontal Then With pptSlide.Shapes(ttx).TextFrame.TextRange If Len(Trim(.Text)) > 30 Then For char_chdu = 30 To Len(.Text) Step 28 .Characters(Start:=char_chdu, Length:=0).Text = Chr$(CharCode:=13) + " " hhshu = hhshu + 0.8 Next char_chdu End If With .Font .Size = 24 .Name = "宋体" .Bold = True .Color.RGB = RGB(0, 0, 255) End With 97993807.doc Page 3 of 5 铁锹儿vba程序之 Word to ppt 示例 End With End If Next ttx End If i = pptPres.Slides.Count + 1 Set pptSlide = pptPres.Slides.Add(i, 12) '当给引用的对 象赋值时，请使用 Set 语句。 hhshu = 0 If tx < tx_bl Or yshi = "教案 节" Then pptSlide.Shapes.Paste tx = 2 ElseIf tx = tx_bl Then pptSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 500, 25).TextFrame.TextRange.Text = jie chdu = Len(jie) pptSlide.Shapes(1).TextFrame.TextRange.Characters(Start:=7, Length:=1).Text = "" pptSlide.Shapes.Paste ' MsgBox "新建slide" & tx tx = 3 End If With pptSlide.Shapes(1).TextFrame.TextRange With .Font 97993807.doc Page 4 of 5 铁锹儿vba程序之 Word to ppt 示例 .Size = 28 .Name = "华文行楷" .Bold = True .Color.RGB = RGB(255, 0, 0) End With End With ElseIf (l <> 13 And l <> 11) Then '其他非text的shapes的定位及tx序号。 ' zs_shapes = pptSlide.Shapes.Count '此幻灯片中的shapes的总数 'If pptSlide.Shapes(tx).Type = msoTextOrientationHorizontal Then 文本框 'selection.CopyAsPicture pptSlide.Shapes.Paste tx = tx + 1 End If Next wdp End Sub 97993807.doc Page 5 of 5