VBA脚本: ppt删除所有图片脚本 【图文】

  • 一个如何通过 VBA 脚本在 PowerPoint 中删除所有图片脚本的示例。

打开开发工具功能

在这里插入图片描述

在这里插入图片描述

vba代码

  • 按下 Alt + F11 打开 VBA 编辑器(或者点击Visual Basic按钮)
    在这里插入图片描述
  • 右键点击工程,选择插入,新建模块

在这里插入图片描述

  • 编写代码
Sub SelectAllPicturesOnSlide()
    Dim sld As slide
    Dim shp As Shape
    
    ' 获取当前活动的幻灯片
    Set sld = ActiveWindow.View.slide
    
    
    ' 遍历幻灯片上的每个形状
    For Each shp In sld.Shapes
        ' 检查形状是否为图片
        If shp.Type = msoPicture Then
            ' 删除图片
            shp.Delete
        End If
    Next shp
End Sub
  • 可以进行调试
    在这里插入图片描述

运行

  • 关闭 VBA 编辑器,并返回到 PowerPoint,按下 Alt + F8(或者点击“宏”),选择 SelectAllPicturesOnSlide函数,然后点击“运行”。

在这里插入图片描述

CG

HelloWorld

Sub HelloWorld()
    Dim slideIndex As Integer
    Dim slide As slide
    Dim textBox As Shape
    
    ' 添加一个新幻灯片
    slideIndex = ActivePresentation.Slides.Count + 1
    Set slide = ActivePresentation.Slides.Add(slideIndex, ppLayoutText)
    
    ' 在新幻灯片上添加一个文本框
    Set textBox = slide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 400, 200)
    
    ' 设置文本框的内容为 "Hello World"
    textBox.TextFrame.TextRange.Text = "Hello World"
End Sub

循环

Sub DeletePictures100Times()
    Dim i As Integer
    
    ' 循环执行 DeleteAllPicturesOnSlide() 函数100For i = 1 To 100
        DeleteAllPicturesOnSlide
    Next i
End Sub

在这里插入图片描述

Sub DeleteAllPicturesOnSlide()
    Dim sld As slide
    Dim shp As Shape
    
    ' 获取当前活动的幻灯片
    Set sld = ActiveWindow.View.slide
    
    
    ' 遍历幻灯片上的每个形状
    For Each shp In sld.Shapes
        ' 检查形状是否为图片
        If shp.Type = msoPicture Then
            ' 删除图片
            shp.Delete
        End If
    Next shp
End Sub

Sub DeletePictures100Times()
    Dim i As Integer
    
    ' 循环执行 DeleteAllPicturesOnSlide() 函数100For i = 1 To 100
        DeleteAllPicturesOnSlide
    Next i
End Sub
  • 8
    点赞
  • 4
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
以下是一个简单的VBA脚本,可以实现将多个相同表头的Excel文件合并到一个新的Excel文件中,以第一个Excel文件的表头为准: ``` Sub MergeExcelFiles() Dim FolderPath As String, SelectedFiles() As Variant Dim FileName As String, SheetName As String, TableRange As String Dim NewWorkbook As Workbook, CurrentWorkbook As Workbook Dim CurrentWorksheet As Worksheet, NewWorksheet As Worksheet Dim TableStartRow As Long, TableEndRow As Long Dim TableStartColumn As Long, TableEndColumn As Long Dim i As Long, j As Long, k As Long '选择要合并的Excel文件 SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True) '如果没有选择文件则退出 If IsEmpty(SelectedFiles) Then Exit Sub End If '获取第一个Excel文件的表头信息 FileName = SelectedFiles(1) Set CurrentWorkbook = Workbooks.Open(FileName) Set CurrentWorksheet = CurrentWorkbook.Sheets(1) TableRange = CurrentWorksheet.ListObjects(1).Range.Address TableStartRow = CurrentWorksheet.ListObjects(1).HeaderRowRange.Row TableEndRow = CurrentWorksheet.ListObjects(1).DataBodyRange.Rows.Count + TableStartRow - 1 TableStartColumn = CurrentWorksheet.ListObjects(1).HeaderRowRange.Column TableEndColumn = CurrentWorksheet.ListObjects(1).ListColumns.Count + TableStartColumn - 1 '创建新的Excel文件 Set NewWorkbook = Workbooks.Add '将第一个Excel文件的表头复制到新的Excel文件中 Set NewWorksheet = NewWorkbook.Sheets.Add(After:=NewWorkbook.Sheets(NewWorkbook.Sheets.Count)) CurrentWorksheet.ListObjects(1).Range.Copy Destination:=NewWorksheet.Range("A1") NewWorksheet.ListObjects(1).Name = CurrentWorksheet.ListObjects(1).Name '将其余Excel文件的数据复制到新的Excel文件中 For i = 2 To UBound(SelectedFiles) FileName = SelectedFiles(i) Set CurrentWorkbook = Workbooks.Open(FileName) For j = 1 To CurrentWorkbook.Sheets.Count Set CurrentWorksheet = CurrentWorkbook.Sheets(j) For k = 1 To CurrentWorksheet.ListObjects.Count If CurrentWorksheet.ListObjects(k).Range.Address = TableRange Then TableStartRow = CurrentWorksheet.ListObjects(k).HeaderRowRange.Row TableEndRow = CurrentWorksheet.ListObjects(k).DataBodyRange.Rows.Count + TableStartRow - 1 TableStartColumn = CurrentWorksheet.ListObjects(k).HeaderRowRange.Column TableEndColumn = CurrentWorksheet.ListObjects(k).ListColumns.Count + TableStartColumn - 1 Set NewWorksheet = NewWorkbook.Sheets(1) CurrentWorksheet.ListObjects(k).Range.Copy Destination:=NewWorksheet.Cells(TableEndRow + 1, TableStartColumn) Exit For End If Next k Next j CurrentWorkbook.Close SaveChanges:=False Next i '自动调整列宽和行高 NewWorksheet.Cells.EntireColumn.AutoFit NewWorksheet.Cells.EntireRow.AutoFit '显示新的Excel文件 NewWorkbook.Activate End Sub ``` 使用方法: 1. 打开 Excel,按下 `ALT + F11` 快捷键打开 VBA 编辑器; 2. 在 VBA 编辑器中,选择 `插入` > `模块`,将以上代码复制粘贴到新建的模块中; 3. 按下 `F5` 运行代码; 4. 选择要合并的 Excel 文件,点击 `确定`; 5. 程序将会自动合并所有 Excel 文件到一个新的 Excel 文件中,并保存在当前工作目录下。 注意:如果要合并的 Excel 文件中包含多个表格,程序会合并第一个表格。如果要合并其他表格,需要修改代码中的 ListObjects 索引。

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值