Warning: file_get_contents(/data/phpspider/zhask/data//catemap/5/excel/27.json): failed to open stream: No such file or directory in /data/phpspider/zhask/libs/function.php on line 167

Warning: Invalid argument supplied for foreach() in /data/phpspider/zhask/libs/tag.function.php on line 1116

Notice: Undefined index: in /data/phpspider/zhask/libs/function.php on line 180

Warning: array_chunk() expects parameter 1 to be array, null given in /data/phpspider/zhask/libs/function.php on line 181
VBA Excel到PPT导出_Vba_Excel_Excel 2007 - Fatal编程技术网

VBA Excel到PPT导出

VBA Excel到PPT导出,vba,excel,excel-2007,Vba,Excel,Excel 2007,我试图将一些代码从一个工作簿转移到另一个工作簿,但我很难弄清楚为什么它不起作用。我将工作表转移到新工作簿中,并在代码中进行必要的更新,以引用正确的工作表。工作簿之间的所有其他内容都是一致的,但我一直收到一个编译错误:未定义用户定义的类型。我尝试过调试,但我不确定它指向什么。提前谢谢 Sub CreatePP() Dim ppApp As Object Dim ppSlide As Object On Error Resume Next Se

我试图将一些代码从一个工作簿转移到另一个工作簿,但我很难弄清楚为什么它不起作用。我将工作表转移到新工作簿中,并在代码中进行必要的更新,以引用正确的工作表。工作簿之间的所有其他内容都是一致的,但我一直收到一个编译错误:未定义用户定义的类型。我尝试过调试,但我不确定它指向什么。提前谢谢

Sub CreatePP()

    Dim ppApp       As Object
    Dim ppSlide     As Object

    On Error Resume Next
    Set ppApp = GetObject(, "Powerpoint.Application")
    On Error GoTo 0

    If ppApp Is Nothing Then
        Set ppApp = CreateObject("Powerpoint.Application")
        ppApp.Visible = True
        ppApp.Presentations.Add
    End If


    Dim MySheets, i As Long

    MySheets = Array(Sheet44, Sheet45, Sheet46, Sheet47, Sheet43, Sheet42, Sheet41, Sheet40, Sheet48)  'these are sheet codenames not sheet name.
    MyRanges = Array("A1:Q45", "A1:Q45", "A1:Q45", "A1:Q45", "A1:Q45", "A1:Q45", "A1:Q45", "A1:Q45", "A1:Q45")

    For i = LBound(MySheets) To UBound(MySheets)
        If ppApp.ActivePresentation.Slides.Count = 0 Then
            Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, 12) 'ppLayoutBlank
        Else
            ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, 12
            Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
        End If
        Copy_Paste_to_PowerPoint ppApp, ppSlide, MySheets(i), MySheets(i).Range(MyRanges(i)), xl_Bitmap
    Next




End Sub


Sub Copy_Paste_to_PowerPoint(ByRef ppApp As Object, ByRef ppSlide As Object, ByVal ObjectSheet As Worksheet, _
                                    ByRef PasteObject As Object, Optional ByVal Paste_Type As PasteFormat)


    Dim PasteRange      As Boolean
    Dim objChart        As ChartObject
    Dim lngSU           As Long

    Select Case TypeName(PasteObject)
        Case "Range"
            If Not TypeName(Selection) = "Range" Then Application.GoTo PasteObject.Cells(1)
            PasteRange = True
        Case "Chart": Set objChart = PasteObject.Parent
        Case "ChartObject": Set objChart = PasteObject
        Case Else
            MsgBox PasteObject.Name & " is not a valid object to paste. Macro will exit", vbCritical
            Exit Sub
    End Select

    With Application
        lngSU = .ScreenUpdating
        .ScreenUpdating = 0
    End With

    ppApp.ActiveWindow.View.GotoSlide ppSlide.SlideNumber

    On Error GoTo -1: On Error GoTo 0
    DoEvents

    If PasteRange Then
        If Paste_Type = xl_Bitmap Then
            '//Paste Range as Picture
            PasteObject.CopyPicture Appearance:=1, Format:=-4147
            ppSlide.Shapes.Paste.Select
        ElseIf Paste_Type = xl_HTML Then
            '//Paste Range as HTML
            PasteObject.Copy
            ppSlide.Shapes.PasteSpecial(8, link:=1).Select  'ppPasteHTML
        ElseIf Paste_Type = xl_Link Then
            '//Paste Range as Linked
            PasteObject.Copy
            ppSlide.Shapes.PasteSpecial(0, link:=1).Select   'ppPasteDefault
        End If
    Else
        If Paste_Type = xl_Link Then
            '//Copy & Paste Chart Linked
            objChart.Chart.ChartArea.Copy
            ppSlide.Shapes.PasteSpecial(link:=True).Select
        Else
            '//Copy & Paste Chart Not Linked
            objChart.Chart.CopyPicture Appearance:=1, Size:=1, Format:=2
            ppSlide.Shapes.Paste.Select
        End If
    End If

    '//Center pasted object in the slide
    With ppApp.ActiveWindow
        If .Height > .Selection.ShapeRange.Height Then
            .Selection.ShapeRange.LockAspectRatio = True
            .Selection.ShapeRange.Height = .Height * 0.82
        End If
        If .Selection.ShapeRange.Width > 708 Then
            .Selection.ShapeRange.LockAspectRatio = True
            .Selection.ShapeRange.Width = 708
        End If
        .Selection.ShapeRange.Align msoAlignCenters, True
        .Selection.ShapeRange.Align msoAlignMiddles, True
    End With

    With Application
        .CutCopyMode = False
        .ScreenUpdating = lngSU
    End With

    'AppActivate ("Microsoft Excel")

End Sub

复制复制粘贴到PowerPoint功能时,忘记复制枚举

Public Enum PasteFormat
    xl_Link = 0
    xl_HTML = 1
    xl_Bitmap = 2
End Enum

你是从什么地方弄来的?它看起来有点像那个版本。看起来你或是你从中得到的任何人,都去掉了属性。您真的应该在其中添加一条注释,说明代码片段的来源。这不仅是stackoverflow这样的地方的法律要求,而且对于找出代码的用途、来源以及可能的错误也非常有用。

可选的ByVal Paste\u Type As PasteFormat
我找不到名为
PasteFormat
的变量类型……是的,我很抱歉,我没有编译原始代码,我不确定它是从哪里来的。