excel - 为每张图片创建幻灯片
问题描述
我有下面的宏,它将文件从保存的文件从 excel 带到 PowerPoint 我需要更新宏以使每张幻灯片一个文件,而不是把所有文件都放在一张幻灯片中
Sub CreatePagePerComment()
Dim PowerPointApp As Object
Dim myPPTX As Object
Dim mySlide As Object
Dim pptxNm As String
Dim pptNm As Range
Dim rSht As Worksheet
Dim oSht As Worksheet
Dim oPicture As Object
Set pptNm = ThisWorkbook.Sheets("Sheet1").[PPTX_File]
Sheets("Sheet1").[PPTX_File].Value = pptNm.Value
CONFIRM_PPTX_APP:
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then
'Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
With pptNm.Validation
.Delete 'delete previous validation
End With
MsgBox "No PowerPoint file is open. Please open the PowerPoint file to where you " & _
"would like to export this table.", vbOKOnly + vbCritical, ThisWorkbook.Name
Exit Sub
End If
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
GET_PPTX_FILENAME:
If pptNm.Value = "" Then
MsgBox "Please select the PowerPoint file name, from the drop down list, to where you want to export the Headcount Review summary table." & _
Chr(10) & Chr(10) & "This Macro has selected the cell that contains a list of all open PowerPoint files. " & Chr(10) & Chr(10) & _
"If your file is not listed, please confirm it is open, then select any other cell, then return to this cell for " & _
"a refreshed file name list.", vbOKOnly + vbCritical, "No PowerPoint File Selected"
pptNm.Select
Exit Sub
Else:
If InStr(1, pptNm.Value, "ppt") > 0 Then
pptxNm = pptNm.Value
ElseIf InStr(1, pptNm.Value, "pptx") > 0 Then
pptxNm = pptNm.Value & ".pptx"
ElseIf InStr(1, pptNm.Value, "pptm") > 0 Then
pptxNm = pptNm.Value & ".pptm"
End If
End If
pptxNm = "NN Commitment Cards.pptm"
Set myPPTX = PowerPointApp.Presentations(pptxNm)
PowerPointApp.Visible = True
PowerPointApp.Activate
'Adds second slide
'MsgBox SlideShowWindows(1).View.Slide.SlideIndex
Dim Nm_shp As Shape, sld_no As Integer
Dim pIndex As Integer, pName As String
sld_no = myPPTX.Slides.Count
pName = "Blue Transition"
pIndex = 3
ADD_NEW_SLIDE:
Dim SlideCnt As Integer
Set mySlide = myPPTX.Slides.Add(sld_no + 1, 12)
mySlide.Select
mySlide.CustomLayout = myPPTX.Designs("N_PPTX_Theme").SlideMaster.CustomLayouts(pIndex)
'mySlide.Shapes.AddOLEObject Left:=10, Top:=10, Width:=(7.5 * 72), Height:=(10 * 72),
' Filename:=[B1].Value & "\" & [A132].Value & ".pdf", displayasicon:=msoFalse, link:=msoTrue
For Each cel In [A3:A4]
If Cells(cel.Row, [A1].Column).Value <> "" Then
Set oPicture = mySlide.Shapes.AddPicture([B1].Value & "\" & cel.Value & ".png", _
msoFalse, msoTrue, Left:=10, Top:=10, Width:=(6 * 72), Height:=(7 * 72))
Set oSlide = myPPTX.Slides(1)
With oPicture
.Width = 7 * 72
.Height = 8 * 72
.PictureFormat.CropLeft = 0
.PictureFormat.CropTop = 0
.PictureFormat.CropRight = 0
.PictureFormat.CropBottom = oPicture.Height / 1.85
.Name = cel.Value
.Line.Weight = 0.5
.Line.Visible = msoTrue
.LockAspectRatio = msoTrue
.Left = 1.5 * 72
.Top = 1.5 * 72
With myPPTX.PageSetup
oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
End With
End With
End If
End Sub
为此,我需要在此宏中更新什么所需的调整?
解决方案
我假设您的其余代码正在工作并且只关注您的特定问题。首先,您的代码中没有引用oSlide
,所以我认为这是一些错字。根据我对您的代码的阅读,您向当前幻灯片添加了一张新幻灯片并向其添加图片(或者没有,因为该部分代码已被注释掉)。然后,根据 的内容[A3:A4]
,您要添加新幻灯片,每张幻灯片都有一张新图片。在提供此解决方案时,我已丢弃注释代码并尽可能保持您的代码未修改(更改代码所需的部分):
'Adds second slide
'MsgBox SlideShowWindows(1).View.Slide.SlideIndex
Dim Nm_shp As Shape, sld_no As Integer
Dim pIndex As Integer, pName As String
sld_no = myPPTX.Slides.Count
pName = "Blue Transition"
pIndex = 3
ADD_NEW_SLIDE:
Dim SlideCnt As Integer
SlidCnt = 0
For Each cel In [A3:A4]
If Cells(cel.Row, [A1].Column).Value <> "" Then
SlideCnt = SlideCnt + 1
Set mySlide = myPPTX.Slides.Add(sld_no + SlideCnt, 12)
mySlide.CustomLayout = myPPTX.Designs("N_PPTX_Theme").SlideMaster.CustomLayouts(pIndex)
Set oPicture = mySlide.Shapes.AddPicture([B1].Value & "\" & cel.Value & ".png", _
msoFalse, msoTrue, Left:=10, Top:=10, Width:=(6 * 72), Height:=(7 * 72))
With oPicture
.Width = 7 * 72
.Height = 8 * 72
.PictureFormat.CropLeft = 0
.PictureFormat.CropTop = 0
.PictureFormat.CropRight = 0
.PictureFormat.CropBottom = oPicture.Height / 1.85
.Name = cel.Value
.Line.Weight = 0.5
.Line.Visible = msoTrue
.LockAspectRatio = msoTrue
.Left = 1.5 * 72
.Top = 1.5 * 72
With myPPTX.PageSetup
oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
End With
End With
End If
Next cel
推荐阅读
- python - Django Allauth 忽略适配器
- ionic4 - 当我们通过 fcm 收到来自应用服务器的通知时,即使应用被杀死,如何触发回调函数?
- python - cv2.VideoCapture() 用于 IP 网络摄像头安卓
- javascript - 在 React 中使用 Onclick 更改 div 中的图像
- torch - 火炬。如何扩展张量中的维度(从 [[1, 2, 3]] 到 [[1, 2, 3, 4]])?
- powerbi - 如何统计ALL返回的成员
- python - R中的循环交互
- javascript - Bootstrap 4中输入字段相邻的标签没有响应
- javascript - 如何使用javascript在单击父行时使子行可见
- apache-kafka - 卡夫卡与 Kerberos