PPT转png（VBScript）

偷油贼

之前看前辈的帖子，有excel转csv的VBS脚本，很方便。
Excel转CSV（VBScript） - 吾爱破解 - 52pojie.cn
照猫画虎整了个ppt转png的脚本，实现拖入文件到脚本(PPT2PNG.vbs)上，转换为png的功能。

[Python] 纯文本查看 复制代码

' PowerPoint to PNG Converter
' 支持拖放PPT/PPTX文件进行转换 

Option Explicit

Dim objFSO, objShell, objPPT, objPresentation
Dim strFilePath, strFolderPath, strFileName, strBaseName
Dim strOutputFolder, strOutputPath
Dim intSlideCount, i, userChoice
Dim slideWidth, slideHeight

' 创建文件系统对象
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")

' 检查是否有拖放文件
If WScript.Arguments.Count = 0 Then
    MsgBox "请拖放PPT/PPTX文件到此脚本上运行！", vbExclamation, "提示"
    WScript.Quit
End If

' 获取拖放的文件路径
strFilePath = WScript.Arguments(0)

' 检查文件是否存在
If Not objFSO.FileExists(strFilePath) Then
    MsgBox "文件不存在: " & strFilePath, vbCritical, "错误"
    WScript.Quit
End If

' 检查文件扩展名
Dim strExt
strExt = LCase(objFSO.GetExtensionName(strFilePath))
If strExt <> "ppt" And strExt <> "pptx" Then
    MsgBox "不支持的文件格式: " & strExt & vbCrLf & "请拖放PPT或PPTX文件！", vbExclamation, "错误"
    WScript.Quit
End If

' 获取文件信息
strFolderPath = objFSO.GetParentFolderName(strFilePath)
strFileName = objFSO.GetFileName(strFilePath)
strBaseName = objFSO.GetBaseName(strFilePath)

' 显示选择对话框
userChoice = MsgBox("请选择转换方式：" & vbCrLf & vbCrLf & _
    "【是】转换第一张幻灯片" & vbCrLf & _
    "【否】转换所有幻灯片" & vbCrLf & _
    "【取消】退出", vbYesNoCancel + vbQuestion, "PPT转PNG - " & strFileName)

If userChoice = vbCancel Then
    WScript.Quit
End If

' 创建PowerPoint应用程序对象
On Error Resume Next
Set objPPT = CreateObject("PowerPoint.Application")
If Err.Number <> 0 Then
    MsgBox "无法创建PowerPoint对象，请确保已安装Microsoft PowerPoint！", vbCritical, "错误"
    WScript.Quit
End If
On Error GoTo 0

' 设置PowerPoint可见（避免某些版本报错）
objPPT.Visible = True

' 将窗口移出屏幕外（变相隐藏）
objPPT.WindowState = 1 ' ppWindowNormal
objPPT.Left = -5000
objPPT.Top = -5000
objPPT.Width = 100
objPPT.Height = 100

' 打开演示文稿
On Error Resume Next
Set objPresentation = objPPT.Presentations.Open(strFilePath, , , False)
If Err.Number <> 0 Then
    MsgBox "无法打开文件: " & strFileName & vbCrLf & "错误信息: " & Err.Description, vbCritical, "错误"
    objPPT.Quit
    WScript.Quit
End If
On Error GoTo 0

' 获取幻灯片尺寸（使用Slides集合的Parent属性）
On Error Resume Next
' 方法1: 通过Slides集合获取Presentation对象，然后访问PageSetup
Dim objPres
Set objPres = objPresentation.Slides(1).Parent
slideWidth = objPres.PageSetup.SlideSize.Width
slideHeight = objPres.PageSetup.SlideSize.Height

If Err.Number <> 0 Then
    Err.Clear
    ' 方法2: 直接尝试PageSetup
    slideWidth = objPresentation.PageSetup.SlideSize.Width
    slideHeight = objPresentation.PageSetup.SlideSize.Height

    If Err.Number <> 0 Then
        Err.Clear
        ' 方法3: 使用SlideMaster
        slideWidth = objPresentation.SlideMaster.Width
        slideHeight = objPresentation.SlideMaster.Height

        If Err.Number <> 0 Then
            Err.Clear
            ' 方法4: 使用默认值（宽屏16:9）
            slideWidth = 960
            slideHeight = 540
        End If
    End If
End If
On Error GoTo 0

' 转换为像素（点转像素，96 DPI）
slideWidth = slideWidth * 96 / 72
slideHeight = slideHeight * 96 / 72

intSlideCount = objPresentation.Slides.Count

If userChoice = vbYes Then
    ' 转换第一张幻灯片
    strOutputPath = strFolderPath & "\" & strBaseName & ".png"
    
    ' 如果文件已存在，先删除
    If objFSO.FileExists(strOutputPath) Then
        objFSO.DeleteFile strOutputPath, True
    End If
    
    ' 导出第一张幻灯片（使用原始尺寸）
    objPresentation.Slides(1).Export strOutputPath, "PNG", slideWidth, slideHeight
    
    MsgBox "转换完成！" & vbCrLf & vbCrLf & _
           "文件: " & strBaseName & ".png" & vbCrLf & _
           "位置: " & strFolderPath & vbCrLf & _
           "尺寸: " & CInt(slideWidth) & " x " & CInt(slideHeight), vbInformation, "成功"
    
ElseIf userChoice = vbNo Then
    ' 转换所有幻灯片
    strOutputFolder = strFolderPath & "\" & strBaseName
    
    ' 创建输出文件夹
    If Not objFSO.FolderExists(strOutputFolder) Then
        objFSO.CreateFolder(strOutputFolder)
    End If
    
    ' 导出所有幻灯片（使用原始尺寸）
    Dim strNum
    For i = 1 To intSlideCount
        ' 格式化序号（补零）
        If i < 10 Then
            strNum = "0" & i
        Else
            strNum = CStr(i)
        End If
        strOutputPath = strOutputFolder & "\Slide_" & strNum & ".png"
        
        objPresentation.Slides(i).Export strOutputPath, "PNG", slideWidth, slideHeight
    Next
    
    MsgBox "转换完成！" & vbCrLf & vbCrLf & _
           "共转换 " & intSlideCount & " 张幻灯片" & vbCrLf & _
           "位置: " & strOutputFolder & vbCrLf & _
           "尺寸: " & CInt(slideWidth) & " x " & CInt(slideHeight), vbInformation, "成功"
End If

' 清理
objPresentation.Close
objPPT.Quit

Set objPresentation = Nothing
Set objPPT = Nothing
Set objFSO = Nothing
Set objShell = Nothing

dork

PPT不是可以直接另存为png格式的图片？

picoyiyi

这个好啊，不然只能先保存成PDF再另存为，很慢。

怜渠客

能不能设置图片清晰度呀

偷油贼

怜渠客 发表于 2026-2-15 18:30
能不能设置图片清晰度呀

不能。但是测试了一下，和直接另存为png格式的图片大小是一样的。

ccnacomputer

成品链接在哪里？不要搞什么代码

zpwz

这个真的实用→在办公

风云0928

好资料，理应点赞！感谢分享

error3

WPS可以直接导出为图片的

feiyang2024

这个用着也挺方便的。