[问题求助] 来挑战，VBS开发一个ppt实用工具

wnc1988

本人太笨，求指导。

Sub SaveShape()
  Dim mySlide As Slide
  Dim myShape As Shape, i_Temp As Integer
  On Error Resume Next
  For Each mySlide In ActivePresentation.Slides
     For Each myShape In mySlide.Shapes
       i_Temp = i_Temp + 1
       myShape.Export pathName:="D:\" & i_Temp & ".gif", Filter:=ppShapeFormatGIF
     Next
  Next
End Sub
复制代码

这是一段非常实用的VBA，运行后能将当前ppt中所有的艺术字，图形、图片都变成gif保存。
要求很简单，只需改写成vbs，最好是带命令行的。
如getpic.vbs 1.ppt就可以将1.ppt里的图形元素都抽到D盘来。

yu2n

下面是我所能做到的极限。循环体里很简单，就两句话，那句export提醒我缺少语句。
wnc1988 发表于 2014-2-26 23:00

    我也来凑个热闹：

命令参数: getPic4Ppt.vbs   /f:"C:\Users\yu\Desktop\1.pptx"   /p:"V:\"   /t:png
/f  幻灯片PPT文件所在位置
/p  图片保存路径
/t  图片类型。只能是GIF，JPG，PNG，BMP四种
复制代码

' 导出ppt中所有的艺术字，图形、图片
'cmd: getPic4Ppt.vbs  /f:"C:\Users\yu\Desktop\1.pptx"  /p:"V:\"  /t:png
strFileName  = "C:\Users\yu\Desktop\1.pptx" ' 这里是幻灯片PPT文件所在位置
strSaveFolder = "V:\"
strPicFormat = "png"

If WScript.Arguments.Named("f") <> "" Then strFileName = WScript.Arguments.Named("f")
If WScript.Arguments.Named("p") <> "" Then strSaveFolder = WScript.Arguments.Named("p")
If WScript.Arguments.Named("t") <> "" Then strPicFormat = WScript.Arguments.Named("t")

Call SavePIC4PPT(strFileName, strSaveFolder, strPicFormat)
WScript.Echo "完成!"

Function SavePIC4PPT(strFileName, strSaveFolder, strPicFormat)
  Const ppShapeFormatGIF = 0
  Const ppShapeFormatJPG = 1
  Const ppShapeFormatPNG = 2
  Const ppShapeFormatBMP = 3
  strPicFormat = UCase(strPicFormat)
  If Not InStr("|GIF|JPG|PNG|BMP|", "|" & strPicFormat & "|") > 0 Then
    Msgbox "图片类型错误！"
  End If
  Dim i, objPPT, objSlide, objShape
  Dim objPowerPoint
  Set objPowerPoint = CreateObject("PowerPoint.Application")
      objPowerPoint.Visible = True
      objPowerPoint.DisplayAlerts = False 
  Set objPPT = objPowerPoint.Presentations.Open(strFileName)
  For i = 1 To objPPT.Slides.Count
    Set objSlide = objPPT.Slides.Item(i)
    objSlide.Export strSaveFolder & "\" & i & "." & LCase(strPicFormat), strPicFormat
    For j = 1 To objSlide.Shapes.Count
      Set objShape = objSlide.Shapes.Item(j)
      Dim strSavePath, strSaveMode
      Select Case strPicFormat
      Case "GIF"
        strSavePath = strSaveFolder & "\" & i & "." & j & ".gif"
        strSaveMode = ppShapeFormatGIF
      Case "JPG"
        strSavePath = strSaveFolder & "\" & i & "." & j & ".jpg"
        strSaveMode = ppShapeFormatJPG
      Case "PNG"
        strSavePath = strSaveFolder & "\" & i & "." & j & ".png"
        strSaveMode = ppShapeFormatPNG
      Case "BMP"
        strSavePath = strSaveFolder & "\" & i & "." & j & ".bmp"
        strSaveMode = ppShapeFormatBMP
      End Select
      If objShape.Type = 14 Then ' 文本框    'objShape.Type = 14  ' 艺术字
        'WScript.Echo objShape.Type & vbTab & objShape.TextFrame.TextRange.Text
      Else
        objShape.Export strSavePath, strSaveMode
      End If
    Next
  Next
  objPPT.Close
  Set objPPT = Nothing
  objPowerPoint.Quit
End Function
复制代码

wnc1988

下面是我所能做到的极限。循环体里很简单，就两句话，那句export提醒我缺少语句。

Dim i, objPPT, objSlide,myShape, strFileName
Dim objPowerPoint
Set objPowerPoint = CreateObject("PowerPoint.Application")
    objPowerPoint.Visible = True
    objPowerPoint.DisplayAlerts = False 

strFileName  = "D:\1.ppt" ' 这里是幻灯片PPT文件所在位置
i = 0
Set objPPT = objPowerPoint.Presentations.Open(strFileName)
For Each objSlide In objPPT.Slides
For Each myShape In objSlide.Shapes
    myShape.Export pathName:="D:\PPT中导出的图片\" & i_Temp & ".gif", Filter:=ppShapeFormatGIF
    i = i+1
Next
Next
objPPT.Close
Set objPPT = Nothing
复制代码