Question

我正在尝试从下拉列表中选择一个选项（这将更改一些图形），然后将图形发送到Powerpoint演示文稿，保存演示文稿，然后移至下拉菜单中的下一个选项以重复操作。

让它执行一次是可以的，但是我一直在努力重复-我遇到了错误

运行时错误'70'权限被拒绝

当需要打开带有下拉菜单中下一个选项名称的PowerPoint的位时。错误在

上

FileCopy "K:\Data Analysis\Toxicology\Tox Customer MI" & "\" & Range("Customer_MI_Template"), PPReport_Name).

我认为可能是因为它实际上没有选择下一个下拉选项，所以文件名也是重复的。

起初我以为是因为它找不到文件位置，因为将其设置为“ ThisWorkbook.Path”，但是如果我将其更改为实际的驱动器和文件路径，则仍然无法使用。

然后我认为这是因为下拉菜单中的下一个内容包含非法字符，但是我删除了这些字符，但仍然没有。

Option Explicit

Sub MakePowerpoint()

ThisWorkbook.Save


Dim MyPath As String
Dim FileName As String

Dim objPPT As Object
Dim ppt As Object
Dim sld As Object
Dim shp As Object
Dim PPReport_Name As String
Dim DocName As String
Dim shpIndex As Long
Dim CurSlide As Long

Dim sh As Excel.Worksheet
Dim ObjName As String
Dim ObjType As String
Dim PPSldNum As Long
Dim PPObjName As String
Dim MyTop As Double
Dim MyLeft As Double
Dim MyHeight As Double
Dim MyWidth As Double
Dim cl As Range
Dim OldText As String
Dim NewText As String

Dim dvCell As Range
    Dim inputRange As Range
    Dim c As Range
    Dim i As Long

' which cell has data v to for each c in input from online

 'Which cell has data validation
    Set dvCell = Worksheets("Customer Homepage").Range("D11")
     'Determine where validation comes from
    Set inputRange = Evaluate(dvCell.Validation.Formula1)


    i = 1
     'Begin our loop
    Application.ScreenUpdating = False
    For Each c In inputRange

' Set up the pathname and the output PowerPoint Presentation Name
MyPath = ThisWorkbook.Path
PPReport_Name = MyPath & "\" & MonthName(Month(Range("D10"))) & "\" & Range("PPReport_Name")

' Copy the template file to the PowerPoint Presentation Name
***FileCopy "K:\Data Analysis\Toxicology\Tox Customer MI" & "\" & Range("Customer_MI_Template"), PPReport_Name***

' Open the PowerPoint Presentation
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
objPPT.presentations.Open PPReport_Name

Set ppt = objPPT.activepresentation

' Add objects
For Each cl In Range("Table_Objects[Excel Page]")
    ObjType = cl.Offset(0, 2).Value     ' Type of the thing to copy
    If ObjType <> "Text" Then
        Set sh = Sheets(cl.Value)       ' Excel Sheet
        ObjName = cl.Offset(0, 1).Value ' Name of the thing to copy
    End If

    PPSldNum = cl.Offset(0, 3).Value    ' PowerPoint slide number
    PPObjName = cl.Offset(0, 4).Value   ' PowerPoint object
    MyTop = cl.Offset(0, 5).Value       ' Top
    MyLeft = cl.Offset(0, 6).Value      ' Left
    MyHeight = cl.Offset(0, 7).Value    ' Height
    MyWidth = cl.Offset(0, 8).Value     ' Width
    OldText = cl.Offset(0, 9).Value     ' Old Text
    NewText = cl.Offset(0, 10)          ' New Text

    Set sld = ppt.slides(PPSldNum)      ' Active Slide

    Select Case ObjType
        Case "Text"
            sld.Shapes(PPObjName).TextFrame.TextRange.Text = _
                Replace(sld.Shapes(PPObjName).TextFrame.TextRange.Text, OldText, NewText)
        Case "Chart"
            sh.Shapes(ObjName).CopyPicture
        Case "Range"
            sh.Range(ObjName).CopyPicture
    End Select

    If ObjType = "Chart" Or ObjType = "Range" Then
        sld.Shapes.Paste
        shpIndex = sld.Shapes.Count
        With sld.Shapes(shpIndex)
            .LockAspectRatio = msoFalse
            .Top = 72 * MyTop
            .Left = 72 * MyLeft
            .Height = 72 * MyHeight
            .Width = 72 * MyWidth
        End With
    End If

Next


'Next c and screenupdate true from online

Next c

    Application.ScreenUpdating = True

End Sub

Function GetText(ObjName As String, Pos As Long) As String
Dim cl As Range
Dim Result As String

Result = "Value not found"

For Each cl In Range("Table_TextFrame[PPObjName]")
    If cl.Value = ObjName Then
        Result = cl.Offset(0, Pos).Value
        Exit For
    End If
Next
GetText = Result
End Function

该宏将根据我在下拉列表中选择的任何人运行并保存一个Powerpoint，但这不会对下拉列表中的下一个选项重复。

切换下拉菜单，将图形发送到Powerpoint并保存

0 个答案: