[新手上路]批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动[批处理精品]CMD命令50条不能说的秘密[在线下载]第三方命令行工具[在线帮助]VBScript / JScript 在线参考
返回列表 发帖

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

本人太笨,求指导。
  1. Sub SaveShape()
  2.   Dim mySlide As Slide
  3.   Dim myShape As Shape, i_Temp As Integer
  4.   On Error Resume Next
  5.   For Each mySlide In ActivePresentation.Slides
  6.      For Each myShape In mySlide.Shapes
  7.        i_Temp = i_Temp + 1
  8.        myShape.Export pathName:="D:\" & i_Temp & ".gif", Filter:=ppShapeFormatGIF
  9.      Next
  10.   Next
  11. End Sub
复制代码
这是一段非常实用的VBA,运行后能将当前ppt中所有的艺术字,图形、图片都变成gif保存。
要求很简单,只需改写成vbs,最好是带命令行的。
如getpic.vbs 1.ppt就可以将1.ppt里的图形元素都抽到D盘来。

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



    我也来凑个热闹:
  1. 命令参数: getPic4Ppt.vbs   /f:"C:\Users\yu\Desktop\1.pptx"   /p:"V:\"   /t:png
  2. /f  幻灯片PPT文件所在位置
  3. /p  图片保存路径
  4. /t  图片类型。只能是GIF,JPG,PNG,BMP四种
复制代码
  1. ' 导出ppt中所有的艺术字,图形、图片
  2. 'cmd: getPic4Ppt.vbs  /f:"C:\Users\yu\Desktop\1.pptx"  /p:"V:\"  /t:png
  3. strFileName  = "C:\Users\yu\Desktop\1.pptx" ' 这里是幻灯片PPT文件所在位置
  4. strSaveFolder = "V:\"
  5. strPicFormat = "png"
  6. If WScript.Arguments.Named("f") <> "" Then strFileName = WScript.Arguments.Named("f")
  7. If WScript.Arguments.Named("p") <> "" Then strSaveFolder = WScript.Arguments.Named("p")
  8. If WScript.Arguments.Named("t") <> "" Then strPicFormat = WScript.Arguments.Named("t")
  9. Call SavePIC4PPT(strFileName, strSaveFolder, strPicFormat)
  10. WScript.Echo "完成!"
  11. Function SavePIC4PPT(strFileName, strSaveFolder, strPicFormat)
  12.   Const ppShapeFormatGIF = 0
  13.   Const ppShapeFormatJPG = 1
  14.   Const ppShapeFormatPNG = 2
  15.   Const ppShapeFormatBMP = 3
  16.   strPicFormat = UCase(strPicFormat)
  17.   If Not InStr("|GIF|JPG|PNG|BMP|", "|" & strPicFormat & "|") > 0 Then
  18.     Msgbox "图片类型错误!"
  19.   End If
  20.   Dim i, objPPT, objSlide, objShape
  21.   Dim objPowerPoint
  22.   Set objPowerPoint = CreateObject("PowerPoint.Application")
  23.       objPowerPoint.Visible = True
  24.       objPowerPoint.DisplayAlerts = False
  25.   Set objPPT = objPowerPoint.Presentations.Open(strFileName)
  26.   For i = 1 To objPPT.Slides.Count
  27.     Set objSlide = objPPT.Slides.Item(i)
  28.     objSlide.Export strSaveFolder & "\" & i & "." & LCase(strPicFormat), strPicFormat
  29.     For j = 1 To objSlide.Shapes.Count
  30.       Set objShape = objSlide.Shapes.Item(j)
  31.       Dim strSavePath, strSaveMode
  32.       Select Case strPicFormat
  33.       Case "GIF"
  34.         strSavePath = strSaveFolder & "\" & i & "." & j & ".gif"
  35.         strSaveMode = ppShapeFormatGIF
  36.       Case "JPG"
  37.         strSavePath = strSaveFolder & "\" & i & "." & j & ".jpg"
  38.         strSaveMode = ppShapeFormatJPG
  39.       Case "PNG"
  40.         strSavePath = strSaveFolder & "\" & i & "." & j & ".png"
  41.         strSaveMode = ppShapeFormatPNG
  42.       Case "BMP"
  43.         strSavePath = strSaveFolder & "\" & i & "." & j & ".bmp"
  44.         strSaveMode = ppShapeFormatBMP
  45.       End Select
  46.       If objShape.Type = 14 Then ' 文本框    'objShape.Type = 14  ' 艺术字
  47.         'WScript.Echo objShape.Type & vbTab & objShape.TextFrame.TextRange.Text
  48.       Else
  49.         objShape.Export strSavePath, strSaveMode
  50.       End If
  51.     Next
  52.   Next
  53.   objPPT.Close
  54.   Set objPPT = Nothing
  55.   objPowerPoint.Quit
  56. End Function
复制代码
『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

TOP

下面是我所能做到的极限。循环体里很简单,就两句话,那句export提醒我缺少语句。
  1. Dim i, objPPT, objSlide,myShape, strFileName
  2. Dim objPowerPoint
  3. Set objPowerPoint = CreateObject("PowerPoint.Application")
  4.     objPowerPoint.Visible = True
  5.     objPowerPoint.DisplayAlerts = False
  6. strFileName  = "D:\1.ppt" ' 这里是幻灯片PPT文件所在位置
  7. i = 0
  8. Set objPPT = objPowerPoint.Presentations.Open(strFileName)
  9. For Each objSlide In objPPT.Slides
  10. For Each myShape In objSlide.Shapes
  11.     myShape.Export pathName:="D:\PPT中导出的图片\" & i_Temp & ".gif", Filter:=ppShapeFormatGIF
  12.     i = i+1
  13. Next
  14. Next
  15. objPPT.Close
  16. Set objPPT = Nothing
复制代码

TOP

返回列表