提问人:user22857676 提问时间:11/4/2023 最后编辑:user22857676 更新时间:11/5/2023 访问量:73
如何使用VBA将excel单元格中的图像插入powerpoint?
How to insert an image from an excel cell into powerpoint using VBA?
问:
幻灯片输出 1 个文本 + 1 个图片,2 个文本 + 1 个图片我想再介绍 3 个文本占位符,总计到 4.My 图片位于 excelsheet 的第 4 列中。但是当我引入第二个 TextPlaceholder 时,图片不在图片占位符中。所以,我把代码修改为
Sld.Shapes.Placeholders(1).TextFrame.TextRange.Text = DataRow.Cells(1, 1)
Sld.Shapes.Placeholders(2).TextFrame.TextRange.Text = DataRow.Cells(1, 2)
Sld.Shapes.Placeholders(3).TextFrame.TextRange.Text = DataRow.Cells(1, 3)
sCell = DataRow.Cells(1, 4).Address
' Check if there is a shp in Column 3
If objDic.exists(sCell) Then
objDic(sCell).Copy
Sld.Shapes.Placeholders(4).Select
Sld.Shapes.PasteSpecial DataType:=ppPasteMetafilePicture
End If
即使有 4 个文本占位符,输出也是相同的。图片不在 PicturePlaceholder 中。 试了好几次。无法弄清楚我哪里出了问题?我能得到帮助吗?
前 2 行在文本框中包含图像,接下来的两行作为没有文本框的图像插入单元格我有一张包含三列 A、B 和 C 的 excelsheet。第一列有两列文本,第三列 C 在文本框中嵌入了图像。我有 1000 多行。我想将这些列导出到 PPT 幻灯片。我在PPT的幻灯片中有三个占位符。前两个占位符用于插入文本,第三个占位符用于插入图像。我编写了一个 vba 宏,用于将第一列的文本从 excel 导出到 ppt。我想知道如何从Excel工作表的第三列(图像在文本框中)插入图像的第三个占位符。 程序如下。
Sub LoopRowsSelected2Choices()
Dim DataRange As Range
Dim DataRow As Range
Dim AppPPT As PowerPoint.Application
Dim Prs As PowerPoint.Presentation
Dim Sld As PowerPoint.Slide
Set AppPPT = GetObject(, "PowerPoint.Application")
Set Pres = AppPPT.ActivePresentation
Set DataRange = Selection
For Each DataRow In DataRange.Rows
Set Sld = Pres.Slides.AddSlide(Pres.Slides.Count + 1, Pres.SlideMaster.CustomLayouts(2))
Sld.Shapes.Placeholders(1).TextFrame.TextRange.Text = DataRow.Cells(1, 1)
Sld.Shapes.Placeholders(2).TextFrame.TextRange.Text = DataRow.Cells(1, 2)
Next DataRow
End Sub
前两列的占位符工作正常。我在第三列中有图像,并希望在 ppt 中的第三个占位符中用于图片。有什么解决办法吗? 提前致谢
我尝试并成功插入文本,但没有插入图像。对 VBA 相当陌生。
答:
1赞
taller
11/5/2023
#1
细胞上的图片是一个很好的方法。使用VBA代码更容易操作。
Option Explicit
Sub LoopRows()
Dim DataRange As Range
Dim DataRow As Range
Dim AppPPT As PowerPoint.Application
Dim Pres As PowerPoint.Presentation
Dim Sld As PowerPoint.Slide
Dim objDic As Object, Shp As Shape, i As Integer
Dim sCell As String
Set AppPPT = GetObject(, "PowerPoint.Application")
Set Pres = AppPPT.ActivePresentation
' Verify the Selection is a Range object
If TypeName(Selection) = "Range" Then
' Load Dict, Key = TopLeftCell.Address, Value = Shp object
Set objDic = CreateObject("scripting.dictionary")
For i = 1 To ActiveSheet.Shapes.Count
Set Shp = ActiveSheet.Shapes(i)
If Not Application.Intersect(Shp.TopLeftCell, Selection) Is Nothing Then
Set objDic(Shp.TopLeftCell.Address) = Shp
End If
Next
Set DataRange = Selection
' Loop through data row
For Each DataRow In DataRange.Rows
Set Sld = Pres.Slides.AddSlide(Pres.Slides.Count + 1, Pres.SlideMaster.CustomLayouts(2))
Sld.Select
Sld.Shapes.Placeholders(1).TextFrame.TextRange.Text = DataRow.Cells(1, 1)
Sld.Shapes.Placeholders(2).TextFrame.TextRange.Text = DataRow.Cells(1, 2)
sCell = DataRow.Cells(1, 3).Address
' Check if there is a shp in Column 3
If objDic.exists(sCell) Then
objDic(sCell).Copy
Sld.Shapes.Placeholders(3).Select
Sld.Shapes.PasteSpecial DataType:=ppPasteMetafilePicture
End If
Next DataRow
End If
End Sub
Microsoft 文档:
评论
0赞
user22857676
11/5/2023
效果很好。完全如我所愿。再次感谢。
评论