excel - PowerPoint 冻结和代码继续
问题描述
我有创建图表并将它们作为 PDF 保存在 PowerPoint 演示文稿中的 VBA 代码。
有时 PowerPoint 应用程序会冻结,并且代码会继续创建下一个文件。最后,代码关闭了应用程序,所以一些文件没有保存。
Sub ChartToPresentation(ByVal blz As String)
' Uses Early Binding to the PowerPoint Object Model
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim sht As Worksheet
Dim CurrentSheet As Worksheet
Dim cht As ChartObject
Dim i As Integer
Dim oSh As Object
Dim spkname As String
Dim quote As Double
Dim pptLayout As CustomLayout
Dim nutzerzahl As Integer
Dim bilanzsumme As Double
Dim verbandname As String
Dim filepath As String
i = 1
spkname = ActiveWorkbook.Sheets("Ranking (alle)").Range("A:A"). _
Find(blz, LookIn:=xlValues).Offset(0, 1)
quote = ActiveWorkbook.Sheets("Ranking (alle)").Range("A:A"). _
Find(blz, LookIn:=xlValues).Offset(0, 5)
nutzerzahl = ActiveWorkbook.Sheets("Ranking (alle)").Range("A:A"). _
Find(blz, LookIn:=xlValues).Offset(0, 4)
bilanzsumme = ActiveWorkbook.Sheets("Ranking (alle)").Range("A:A"). _
Find(blz, LookIn:=xlValues).Offset(0, 2)
verbandname = ActiveWorkbook.Sheets("Ranking (alle)").Range("A:A"). _
Find(blz, LookIn:=xlValues).Offset(0, 3)
Set PPApp = CreateObject("Powerpoint.Application")
Set PPPres = PPApp.Presentations.Open("........")
Set pptLayout = PPPres.SlideMaster.CustomLayouts(3)
filepath = PPPres.Path & "\Export\" & "\" & blz & "_" & spkname & "_" & _
Format(DateAdd("M", -1, Now), "MMMM") & " " & Year(Now) & ".pdf"
For Each sht In ActiveWorkbook.Worksheets
For Each cht In sht.ChartObjects
cht.Activate
i = i + 1
' Reference existing instance of PowerPoint
PPApp.ActiveWindow.ViewType = ppViewSlide
' Reference active slide
Set PPSlide = PPPres.Slides.AddSlide(i, pptLayout)
' Copy chart as a picture
ActiveChart.ChartArea.Copy
' Paste chart
Set oSh = PPSlide.Shapes.PasteSpecial(ppPasteBitmap, msoFalse)
With oSh
.LockAspectRatio = msoFalse
.Left = (6.51 * 28.34646)
.Top = (3.15 * 28.34646)
.Height = (12.04 * 28.34646)
.Width = (17.97 * 28.34646)
End With
With PPSlide.Shapes("Inhaltsplatzhalter 4")
If i = 2 Then
.TextFrame.TextRange.Text = vbCrLf & spkname & vbCrLf & _
vbCrLf & "BLZ: " & blz & vbCrLf & vbCrLf & vbCrLf & _
sht.Name & vbCrLf & "(App - Downloads, kum.)" & vbCrLf & _
vbCrLf & "Quote(User/Mrd. BS):" & vbNewLine & _
Round(quote, 0) & " User pro Mrd. BS"
.TextFrame.TextRange.Font.Size = 12
.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
.TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
.TextFrame.TextRange.Font.Name = "Sparkasse rg"
ElseIf i = 3 Then
.TextFrame.TextRange.Text = vbCrLf & spkname & vbCrLf & _
vbCrLf & "BLZ: " & blz & vbCrLf & vbCrLf & vbCrLf & _
vbCrLf & vbCrLf & vbCrLf & sht.Name & vbCrLf & _
"N = " & ActiveWorkbook.Sheets(sht.Name).Range("A:A") _
.Cells.SpecialCells(xlCellTypeConstants).Count - 1
.TextFrame.TextRange.Font.Size = 12
.TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
.TextFrame.TextRange.Font.Name = "Sparkasse rg"
ElseIf i = 4 Then
.TextFrame.TextRange.Text = vbCrLf & spkname & vbCrLf & _
vbCrLf & "BLZ: " & blz & vbCrLf & vbCrLf & _
vbCrLf & "Bilanzsumme: " & Round(bilanzsumme, 1) _
& " Mrd." & vbCrLf & vbCrLf & vbCrLf & sht.Name _
& vbCrLf & "N = " & ActiveWorkbook.Sheets(sht.Name) _
.Range("A:A").Cells. _
SpecialCells(xlCellTypeConstants).Count - 1
.TextFrame.TextRange.Font.Size = 12
.TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
.TextFrame.TextRange.Font.Name = "Sparkasse rg"
Else
.TextFrame.TextRange.Text = vbCrLf & spkname & vbCrLf & _
vbCrLf & "BLZ: " & blz & vbCrLf & vbCrLf & _
vbCrLf & vbCrLf & vbCrLf & vbCrLf & "Ranking (" _
& verbandname & ")" & vbCrLf & "N = " & _
ActiveWorkbook.Sheets(sht.Name).Range("A:A"). _
Cells.SpecialCells(xlCellTypeConstants).Count - 1
.TextFrame.TextRange.Font.Size = 12
.TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
.TextFrame.TextRange.Font.Name = "Sparkasse rg"
End If
End With
Next cht
Next sht
With PPPres.Slides(1).Shapes("Rechteck 3")
.TextFrame.TextRange.Text = vbCrLf & vbCrLf & spkname & vbCrLf _
& vbCrLf & "Bankleitzahl: " & blz
.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
.TextFrame.TextRange.Font.Size = 16
.TextFrame.TextRange.Font.Bold = msoCTrue
End With
PPPres.ExportAsFixedFormat PPPres.Path & "\Export\" & "\" & blz & _
"_" & spkname & "_" & Format(DateAdd("M", -1, _
Now), "MMMM") & " " & Year(Now) & ".pdf", _
ppFixedFormatTypePDF, ppFixedFormatIntentPrint
PPPres.Close
PPApp.Quit
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
解决方案
除了按照 ashleedawg 和 Profex 的建议尝试使代码更高效并添加 DoEvents 之外,还尝试添加一个循环以帮助确保为创建形状提供足够的时间。换个试试...
' Paste chart
Set oSh = PPSlide.Shapes.PasteSpecial(ppPasteBitmap, msoFalse)
和
' Paste chart
PPSlide.Shapes.PasteSpecial ppPasteBitmap, msoFalse
On Error Resume Next
counter = 0
Do
DoEvents
counter = counter + 1
Set oSh = PPSlide.Shapes(PPSlide.Shapes.Count)
If Not oSh Is Nothing Then Exit Do
If counter > 100 Then Exit Do
Loop
On Error GoTo 0
请注意,counter
应在代码开头与其他变量一起声明。您可以将其声明为 type Long
。另外,请注意,目前它最多循环 100 个循环。如有必要,更改此设置以留出更多时间。
推荐阅读
- c# - 使用 C# 在字符串中使用双精度时如何删除尾随零?
- cldr - 为什么 CLDR 有上标两个尾随一些细分名称?
- teamcity - 在 Octopus 部署步骤之后 TeamCity 自动合并不起作用
- c# - 如何使用 WithAllProperties 等方法扩展 epplus 数据提取器
- windows - 通过bat文件执行时文件路径中的转义空格
- javascript - 仅过滤 jquery 过滤器中的特定列
- javascript - 数据在 Chart.js 折线图中未正确显示
- traversal - 在循环中运行遍历后,V8 因内存而崩溃
- java - 尝试访问 Web 的某些部分而不是重定向到登录页面时提供简单的 HTTP 401
- java - 使用 Docker 运行 Gradle integrationTest 任务时如何修复“:integrationTest NO-SOURCE”