|
最新修改版本 : 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 Sub
Public 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.Text
End 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 = True
End Sub
8hljQQz1.rar
(39.4 KB, 下载次数: 842)
[此贴子已经被作者于2005-9-5 21:41:18编辑过] | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-8-12 14:26
楼主
