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
的变量类型……是的,我很抱歉,我没有编译原始代码,我不确定它是从哪里来的。