|
|
最新修改版本 : PowerPoint2000转换为WORD文件！( 005.9.5)原来忘了加个调用的菜单，现在修改好了！
加载宏 ppToWord2000.ppa (For Office2000)(office97,OfficeXP的用户请和我联系)效果：如果你的PP中的表格不多，主要是用文本框的话，基本可以完美的在WORD中再现！欢迎大家一起探讨！
Public Sub 保留格式PP转换为WORD() Call PowerPointToWord(True) MsgBox "转换完毕 ！(表格未做处理，请核对！)", vbInformation + vbOKOnly, "OK"End SubPublic Sub 删除格式PP转换为WORD() Call PowerPointToWord(False) MsgBox "转换完毕 ！(表格未做处理，请核对！)", vbInformation + vbOKOnly, "OK"End Sub
Private Sub PowerPointToWord(blStyle As Boolean)'-------------------------------------------------------------------------'作用：主要是把文本框、占位符、艺术字、图片、公式里面得内容转换到WORD里面。'图表、WORD表格、组织结构图等 OLE、表格暂时处理不好，主要是位置处理不好'保持格式: blStyle = False ，= True 删除格式'那位处理得好，麻烦通知一下：'msOfficeman@126.com'补充：PP2000中的表格是用文本框模拟的，在PP2003中此问题微软已经修正，故你可以修改本程序直接在PP2003中处理表格。'-------------------------------------------------------------------------On Error Resume Next Dim wdApp As Object Dim mr As SlideRange Dim tx As TextRange Dim i As Integer Dim iCount As Integer Dim iCunCount As Integer Dim iShapeType As Integer Set wdApp = CreateObject("Word.Application") wdApp.Visible = True 'wdApp.Application.ScreenUpdating = False '关闭屏幕刷新 wdApp.documents.Add Set mySlides = ActivePresentation.Slides.Range iCount = mySlides.Count For i = 1 To iCount DoEvents ActiveWindow.View.GotoSlide Index:=i iCunCount = ActiveWindow.Selection.SlideRange.Shapes.Count ' For j = 1 To iCunCount ActiveWindow.Selection.SlideRange.Shapes(j).Select iShapeType = ActiveWindow.Selection.SlideRange.Shapes(j).Type '1--自选图形 '7---公式 、（图表、WORD表格、组织结构图等 OLE） '17--文本框 19--表格 15--艺术字 14--占位符 '13---图片 ' Debug.Print iShapeType Select Case iShapeType Case 1, 14, 17 Set tx = ActiveWindow.Selection.ShapeRange.TextFrame.TextRange tx.Select If tx.Text "" Then'----------------------------------------------------------------------If blStyle Then'保持格式 ActiveWindow.Selection.Copy ActiveWindow.Selection.Copy wdApp.documents(1).Activate wdApp.Selection.Paste'----------------------------------------------------------------------Else'删除格式 wdApp.documents(1).Range.InsertAfter tx.TextEnd If End If Case 7, 13, 15 '图片、公式 ActiveWindow.Selection.Copy 'wdApp.Documents(1).Activate wdApp.Selection.Paste Case 19 '表格不处理' ActiveWindow.Selection.Copy' wdApp.Activate' wdApp.Selection.Paste End Select Next j Next i' wdApp.Application.ScreenUpdating = TrueEnd Sub
8hljQQz1.rar
(39.4 KB, 下载次数: 224)
|
|
