'綁定到本地計算機

strComputer = "."

'如果發生錯誤，繼續執行

on error resume next

Set objWMIService = GetObject("winmgmts:" _

& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")

msgbox "此腳本可以批量將ppt文件中的文本轉換為word文件。圖片、表格等內容則自動跳過" & vbcrlf & "使用時請把所有要轉換的ppt文件復制到目錄c:\下。雙擊運行此文件即可。" & vbcrlf & "運行此腳本需要本機上安裝了office"

'創建一個word對象

Set objWord = CreateObject("Word.Application")

'創建一個ppt對象

Set pptApp = CreateObject("PowerPoint.application")

'獲得c:\目錄下的文件集合

Set FileList = objWMIService.ExecQuery _

("ASSOCIATORS OF {Win32_Directory.Name='c:'} Where " _

& "ResultClass = CIM_DataFile")

For Each objFile In FileList

'如果文件的擴展名是ppt

If objFile.Extension = "ppt" Then

pptApp.visible = true

'打開這個ppt文件

Set pptSelection = pptApp.Presentations.Open("c:\" & objFile.FileName & "." & objFile.Extension)

'如果想讓腳本處理得快些，把下面一行改為“objWord.Visible = false”,不推薦。

objWord.Visible = true

'新建一個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 = "宋體"

end if

objSelection.TypeText pptSelection.Slides(i).Shapes(j).TextFrame.TextRange.text

'加一個回車

objSelection.TypeText vbcrlf

Next

next

'關閉這個ppt文件

pptSelection.close

'保存word文件。

objDoc.SaveAs("c:\" & objFile.FileName & ".doc")

'如果不需要關閉word，把下面這一行刪掉

objDoc.close

'如果不想彈出消息框，把下面這一行刪掉

msgbox "轉換后的word已保存在c:\" & objFile.FileName & ".doc"

else '沒有ppt文件

'msgbox "錯誤：c:\下沒有發現ppt文件！"

End If

Next

pptApp.quit