当前位置：首页>PPT>实用工具:PPT文件转图片格式的PPT

实用工具:PPT文件转图片格式的PPT

2026-03-30 08:36:02

实用工具:PPT文件转图片格式的PPT

我想懂得的人都知道为什么PPT文件为什么转图片格式的PPT吧！

为了保证转出图片的质量，我还修改了参数。嗯，如果没有这个工具，我的操作是

把PPT1文件，采用图片导出。

然后将导出的n个图片，以相册的形式，选定主题插入，

形成PPT2文件（这个图片顺序是不会变的，除非你去改图片的名称顺序，好吧，我也没给这个机会，因为一步到位的执行哈）。

然后再加上“非公开资料字样”。

嗯

一步步操作也不难，

反正就是废心神，毕竟再也不是天天就干这个了。但是偶尔又不是只一次。

然后我就突发其想，为什么不能搞一个程序。

过程省略，

结果，利用“宏”文件实现

宏文件加载

我一直在用office软件，提供的是office过程，如果您是wps，请自行摸索过程吧！关键节点应该是一样的。

1.保证你的开发者工具，是打开的。

如果没有，在文件→选项→自定义功能区，找到开发者工具，加载。

2.打开visual的窗口。

3.方法一：直接复制代码。

工具栏：插入 → 模块，调出模块窗口（右侧大白区哈）后，在窗口出粘贴下述代码。

选择复制从这里开始

' 模块名称：WatermarkExportAlbum

' 功能：完整流程 - 加水印 → 导出PNG → 创建带水印的相册PPT

Option Explicit

' ==================== 主程序 ====================

Public Sub RunCompleteWorkflow()

Dim sourcePPT As Presentation

Dim exportPath As String

Dim imageList As Collection

Dim newPPTPath As String

Set sourcePPT = ActivePresentation

' 步骤0：选择工作文件夹

exportPath = SelectFolder("选择工作文件夹（将创建子目录存放临时文件）")

If exportPath = "" Then Exit Sub

' 创建临时文件夹

exportPath = exportPath & "PPT_Process_" & Format(Now, "yyyymmdd_hhmmss") & "\"

MkDir exportPath

' 步骤1：在当前PPT每页右下角添加水印

Call AddWatermarkToAllSlides(sourcePPT)

' 步骤2：导出为高分辨率PNG（带水印的页面）

Set imageList = ExportSlidesToPNG(sourcePPT, exportPath)

' 检查是否有图片导出

If imageList.Count = 0 Then

MsgBox "没有成功导出图片，程序终止", vbExclamation

Exit Sub

End If

' 步骤3：用导出的PNG创建新PPT（白色背景，全页填充，水印已烧录在图片中）

' 传递原PPT的页面设置参数，确保新PPT尺寸一致

newPPTPath = CreateAlbumPPT(imageList, exportPath, sourcePPT)

' 完成提示

MsgBox "处理完成！" & vbCrLf & vbCrLf & _

"新PPT位置：" & newPPTPath & vbCrLf & _

"共处理 " & imageList.Count & " 页" & vbCrLf & _

"页面尺寸与原PPT一致" & vbCrLf & _

"水印已永久嵌入图片中", vbInformation, "完成"

' 可选：打开新PPT

If MsgBox("是否立即打开新PPT？", vbYesNo + vbQuestion) = vbYes Then

Presentations.Open newPPTPath

End If

End Sub

' ==================== 步骤1：添加水印 ====================

Private Sub AddWatermarkToAllSlides(ppt As Presentation)

Dim sld As Slide

Dim wm As Shape

Dim slideWidth As Single

Dim slideHeight As Single

Dim rightMargin As Single

Dim bottomMargin As Single

' 获取幻灯片尺寸

slideWidth = ppt.PageSetup.slideWidth

slideHeight = ppt.PageSetup.slideHeight

rightMargin = 30

bottomMargin = 30

For Each sld In ppt.Slides

Set wm = sld.Shapes.AddTextbox( _

Orientation:=msoTextOrientationHorizontal, _

Left:=slideWidth - 150 - rightMargin, _

Top:=slideHeight - 40 - bottomMargin, _

Width:=150, _

Height:=40)

With wm.TextFrame.TextRange

.Text = "非公开资料"

.Font.Name = "微软雅黑"

.Font.Size = 16

.Font.Color.RGB = RGB(128, 128, 128)

.Font.Bold = msoFalse

End With

With wm

.Name = "Watermark_Copyright"

.Line.Visible = msoFalse

.Fill.Visible = msoFalse

.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight

End With

Next sld

End Sub

' ==================== 步骤2：导出高分辨率PNG ====================

Private Function ExportSlidesToPNG(ppt As Presentation, savePath As String) As Collection

Dim sld As Slide

Dim imgPath As String

Dim idx As Integer

Dim imgList As New Collection

Dim slideWidth As Long

Dim slideHeight As Long

Call SetHighResolutionExport

' 计算高分辨率尺寸（保持原比例）

' 原尺寸是磅，转换为像素（1磅≈1.333像素，300DPI下再乘以300/72）

slideWidth = Round(ppt.PageSetup.slideWidth * 300 / 72)

slideHeight = Round(ppt.PageSetup.slideHeight * 300 / 72)

idx = 1

For Each sld In ppt.Slides

imgPath = savePath & "Slide_" & Format(idx, "000") & ".png"

' 导出：使用计算后的高分辨率尺寸，保持原PPT的宽高比

sld.Export imgPath, "PNG", slideWidth, slideHeight

' 检查文件是否成功创建

If Dir(imgPath) <> "" Then

Set ExportSlidesToPNG = imgList

End Function

Private Sub SetHighResolutionExport()

Dim wsh As Object

Set wsh = CreateObject("WScript.Shell")

On Error Resume Next

wsh.RegWrite "HKCU\Software\Microsoft\Office\" & Application.Version & _

"\PowerPoint\Options\ExportBitmapResolution", 300, "REG_DWORD"

On Error GoTo 0

Set wsh = Nothing

End Sub

' ==================== 步骤3：创建相册PPT ====================

Private Function CreateAlbumPPT(imgList As Collection, workPath As String, sourcePPT As Presentation) As String

Dim newPPT As Presentation

Dim sld As Slide

Dim pic As Shape

Dim imgPath As Variant

Dim slideIdx As Integer

Dim savePath As String

Dim slideWidth As Single

Dim slideHeight As Single

Set newPPT = Presentations.Add(msoFalse)

' 关键修复：复制原PPT的页面设置，确保尺寸比例完全一致

With newPPT.PageSetup

.slideWidth = sourcePPT.PageSetup.slideWidth

.slideHeight = sourcePPT.PageSetup.slideHeight

.SlideOrientation = sourcePPT.PageSetup.SlideOrientation

' 如果是自定义尺寸，也复制SlideSize属性

On Error Resume Next

.SlideSize = sourcePPT.PageSetup.SlideSize

On Error GoTo 0

End With

' 获取新PPT的幻灯片尺寸（应该与sourcePPT一致）

slideWidth = newPPT.PageSetup.slideWidth

slideHeight = newPPT.PageSetup.slideHeight

slideIdx = 1

For Each imgPath In imgList

' 每张图片对应一页，页数与imgList.Count一致（即原PPT页数）

If slideIdx = 1 Then

' 第一张：使用默认的第一页或新建

If newPPT.Slides.Count = 0 Then

Set sld = newPPT.Slides.Add(1, ppLayoutBlank)

Else

Set sld = newPPT.Slides(1)

End If

Else

' 后续页：逐页添加

Set sld = newPPT.Slides.Add(slideIdx, ppLayoutBlank)

End If

With sld.Background.Fill

.Solid

.ForeColor.RGB = RGB(255, 255, 255)

End With

Set pic = sld.Shapes.AddPicture( _

FileName:=imgPath, _

LinkToFile:=msoFalse, _

SaveWithDocument:=msoTrue, _

Left:=0, Top:=0)

With pic

.LockAspectRatio = msoFalse

.Left = 0

.Top = 0

.Width = slideWidth

.Height = slideHeight

End With

pic.ZOrder msoSendToBack

slideIdx = slideIdx + 1

Next imgPath

savePath = workPath & "Album_" & Format(Now, "hhmmss") & ".pptx"

newPPT.SaveAs savePath

newPPT.Close

CreateAlbumPPT = savePath

End Function

' ==================== 工具函数 ====================

Private Function SelectFolder(promptText As String) As String

With Application.FileDialog(msoFileDialogFolderPicker)

.Title = promptText

.AllowMultiSelect = False

If .Show = -1 Then

SelectFolder = .SelectedItems(1) & "\"

4.方法二：下载bas直接加载。

在visual窗口，文件→导入文件→选择你需要的bas文件。

下载链接：

ppt加密导出.bas https://www.alipan.com/s/axW2ovcfoUk 提取码: o2t7 点击链接保存，或者复制本段内容，打开「阿里云盘」APP ，无需下载极速在线查看，视频原画倍速播放。

从发文开始，30天内有效哈！过期，您私信我！不希望被转走，无备注哈！

5.运行：

方法一：在visual窗口，保证对应的模块是激活状态哈，然后，点击工具栏运行。

方法二：ppt窗口，

耐心等待吧！生成的图片和最后的ppt2，都保存到ppt1所在同根目录下的 PPT_Process_时间戳文件夹里。

如果你想把图片汇集到pdf呢，所以，我的这个bas没有加删除图片。

节日快乐！

本文来自网友投稿或网络内容，如有侵犯您的权益请联系我们删除，联系邮箱：wyl860211@qq.com 。

实用工具:PPT文件转图片格式的PPT

最新文章

热门文章

随机文章

实用工具:PPT文件转图片格式的PPT

为什么别人开题一次过?这套 PPT + 报告范文免费分享,无套路领取助你稳稳通关毕业答辩(附上链接)

PPT|1分钟学会高级感圆形制作技巧️

最新文章

热门文章

随机文章