|
#2
小高梁2012-03-22 16:00
|
近来，为了将ppt转word，用了各种方法，查了N天网，仍找不到满意的。目前最接近的是用以下代码，但图形转出来是离散的。不知哪位高手能帮我修改？
strComputer = "."
'如果发生错误，继续执行
on error resume next
'____________________________设置区______________________________
'vis：可视性
'dia：有停顿
'zoomm：对象缩放比例
'fgf：显示幻灯片号码
vis=1
dia=1
fgf=1
zoomm=0.7
'1真0假
'____________________________设置区末______________________________
n=1
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
msgbox "此脚本可以批量将ppt文件中的文本转换为word文件。图片、表格等内容不跳过" & vbcrlf & "使用时请把所有要转换的ppt文件复制到目录d:\ppt\下。双击运行此文件即可。" & vbcrlf & "运行此脚本需要本机上安装了office"
'创建一个word对象
Set objWord = CreateObject("Word.Application")
'创建一个ppt对象
Set pptApp = CreateObject("PowerPoint.application")
'获得d:\ppt\目录下的文件集合
Set FileList = objWMIService.ExecQuery ("ASSOCIATORS OF {Win32_Directory.Name='d:\ppt'} Where " & "ResultClass = CIM_DataFile")
For Each objFile In FileList
'如果文件的扩展名是ppt
If objFile.Extension = "ppt" Then
if vis=1 or dia=1 then
pptApp.visible = true
else
pptApp.visible = false
end if
'打开这个ppt文件
Set pptSelection = pptApp.Presentations.Open("d:\ppt\" & objFile.FileName & "." & objFile.Extension)
'如果想让脚本处理得快些，把下面一行改为“objWord.Visible = false”,不推荐。
if vis=1 or dia=1 then
objWord.Visible = true
else
objWord.Visible = false
end if
'新建一个word，以保存ppt中的文本
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
'从ppt的第一页开始循环。Slides.Count即幻灯片的数量
For i = 1 To pptSelection.Slides.Count
'从每一张ppt的第一个文本框开始循环，Shapes.Count，即每张幻灯片中文本框的数量
For j = 1 To pptSelection.Slides(i).Shapes.Count
'如果是每页的第一行，就按标题处理，变成黑体字
if i =1 then
objSelection.Font.Name = "黑体"
'把文本框中的文字添加到word中
objSelection.TypeText pptSelection.Slides(i).Shapes(j).TextFrame.TextRange.text
objSelection.TypeParagraph()
objSelection.Font.Name = "宋体"
else
objSelection.TypeText pptSelection.Slides(i).Shapes(j).TextFrame.TextRange.text
end if
if pptSelection.Slides(i).Shapes(j).TextFrame.TextRange.text="" then
pptSelection.Slides(i).Shapes(j).copy
objSelection.paste
Selection.InlineShapes(n).Height = Selection.InlineShapes(n).Height*zoomm
Selection.InlineShapes(n).Width = Selection.InlineShapes(n).Width *zoomm
objSelection.MoveRight
n=n+1
end if
'加一个回车
objSelection.TypeText vbcrlf
Next
if fgf =1 then
objSelection.Font.Name = "黑体"
objSelection.TypeText "p"&i
objSelection.TypeText vbcrlf
objSelection.Font.Name = "宋体"
end if
next
'关闭这个ppt文件
pptSelection.close
'保存word文件。
objDoc.SaveAs("d:\ppt\" & objFile.FileName & ".doc")
'如果不需要关闭word，把下面这一行删掉
objDoc.close
'如果不想弹出消息框，把下面这一行删掉
if dia=1 then
msgbox "转换后的word已保存在d:\ppt\" & objFile.FileName & ".doc"
end if
else
'没有ppt文件
if dia=1 then
msgbox "错误：d:\ppt\下没有发现ppt文件！"
end if
End if
Next
pptApp.quit
