M
Mieds
I am trying to create PowerPoint slides from an access database,
basically the data is queried in access, pasted and formatted into
Excel and then copied into PowerPoint. The program loops through
different data (cities) and create a series of slides based on the
results for each city. When I had a small number of cities (35) the
program worked fine, now that I increased the number of cities (160)
the program fails, I get a run-time error '-2147417851 (80010105)';
Method 'PasteSpecial' of obejct 'Shapes' failed
Here is a snippet of the code and where it is failing, after looping
through about 90 times the program fails on the last section,
objPPTSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Name =
"SummaryTableOne". Any ideas or advice would be greatly appreciated.
Option Compare Database
Option Explicit
Sub CreateSlides()
Dim datDate0, datDate1, datDate2, datDate3 As Date
Dim intCurrentSheet, intDMACount, intStartCopy, intEndCopy As
Integer
Dim db As DAO.Database
DoCmd.SetWarnings False
gstrPath = "C:\USER\Data\"
'Create Application Variables
'*Excel
Dim xlApp As Excel.Application
Dim xlWorkbookC As Excel.Workbook
Dim xlWorkbookTemp As Excel.Workbook
Dim xlSheetSlide0, xlSheetSlide1, xlSheetSlide2, xlSheetSlide2U,
xlSheetSlide3, xlSheetSlideTemp As Excel.Worksheet
'*Powerpoint
Dim objPPTApp As PowerPoint.Application
Dim objPPTPresen As PowerPoint.Presentation
Dim objPPTSlide As PowerPoint.Slide
Dim objPPTShape As PowerPoint.Shape
'Open Excel Application
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkbookC = xlApp.Workbooks.Open(gstrPath &
"DMATemplate.xlsm")
Set xlSheetSlide0 = xlWorkbookC.Sheets("Page_01")
Set xlSheetSlide1 = xlWorkbookC.Sheets("Slides")
Set xlSheetSlide2 = xlWorkbookC.Sheets("Slide2A")
Set xlSheetSlide2U = xlWorkbookC.Sheets("Slide2B")
Set xlSheetSlide3 = xlWorkbookC.Sheets("Page_99")
'Open Powerpoint Application
Set objPPTApp = CreateObject("Powerpoint.Application")
objPPTApp.Visible = True
Set objPPTPresen = objPPTApp.Presentations.Open(gstrPath &
"Template.pptm")
With objPPTPresen.Slides
Set objPPTSlide = .Item(1)
End With
'Create Slide 1
With objPPTPresen.Slides
s = objPPTPresen.Slides.Count
Set objPPTSlide = .Add(s, ppLayoutBlank)
End With
'Create Slide1
Set objPPTShape =
objPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=18, Top:=18, Width:=600, Height:=50)
With objPPTShape
.TextFrame.TextRange.Font.Name = "Verdana"
.TextFrame.TextRange.Font.Bold = msoTrue
.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
.TextFrame.TextRange.Text = "Advance 12M Sales Growth vs.
Remaining Market"
.TextFrame.TextRange.Lines(1).Font.Size = 18
End With
With objPPTPresen.Slides
s = objPPTPresen.Slides.Count
Set objPPTSlide = .Add(s, ppLayoutBlank)
End With
Set objPPTShape =
objPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=18, Top:=18, Width:=600, Height:=50)
With objPPTShape
.TextFrame.TextRange.Font.Name = "Verdana"
.TextFrame.TextRange.Font.Bold = msoTrue
.TextFrame.TextRange.ParagraphFormat.Alignment =
ppAlignLeft
.TextFrame.TextRange.Text = "Advance 12M Sales Growth vs.
Remaining Market"
.TextFrame.TextRange.Lines(1).Font.Size = 18
End With
xlSheetSlide0.Select
xlSheetSlide0.Range(strCopyRange).Copy
objPPTSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Name
= "SummaryTableOne"
With objPPTShape
.ScaleHeight 0.4, msoTrue, msoScaleFromMiddle
.ScaleWidth 0.8, msoTrue, msoScaleFromMiddle
.Top = 75
.Left = 18
End With
basically the data is queried in access, pasted and formatted into
Excel and then copied into PowerPoint. The program loops through
different data (cities) and create a series of slides based on the
results for each city. When I had a small number of cities (35) the
program worked fine, now that I increased the number of cities (160)
the program fails, I get a run-time error '-2147417851 (80010105)';
Method 'PasteSpecial' of obejct 'Shapes' failed
Here is a snippet of the code and where it is failing, after looping
through about 90 times the program fails on the last section,
objPPTSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Name =
"SummaryTableOne". Any ideas or advice would be greatly appreciated.
Option Compare Database
Option Explicit
Sub CreateSlides()
Dim datDate0, datDate1, datDate2, datDate3 As Date
Dim intCurrentSheet, intDMACount, intStartCopy, intEndCopy As
Integer
Dim db As DAO.Database
DoCmd.SetWarnings False
gstrPath = "C:\USER\Data\"
'Create Application Variables
'*Excel
Dim xlApp As Excel.Application
Dim xlWorkbookC As Excel.Workbook
Dim xlWorkbookTemp As Excel.Workbook
Dim xlSheetSlide0, xlSheetSlide1, xlSheetSlide2, xlSheetSlide2U,
xlSheetSlide3, xlSheetSlideTemp As Excel.Worksheet
'*Powerpoint
Dim objPPTApp As PowerPoint.Application
Dim objPPTPresen As PowerPoint.Presentation
Dim objPPTSlide As PowerPoint.Slide
Dim objPPTShape As PowerPoint.Shape
'Open Excel Application
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkbookC = xlApp.Workbooks.Open(gstrPath &
"DMATemplate.xlsm")
Set xlSheetSlide0 = xlWorkbookC.Sheets("Page_01")
Set xlSheetSlide1 = xlWorkbookC.Sheets("Slides")
Set xlSheetSlide2 = xlWorkbookC.Sheets("Slide2A")
Set xlSheetSlide2U = xlWorkbookC.Sheets("Slide2B")
Set xlSheetSlide3 = xlWorkbookC.Sheets("Page_99")
'Open Powerpoint Application
Set objPPTApp = CreateObject("Powerpoint.Application")
objPPTApp.Visible = True
Set objPPTPresen = objPPTApp.Presentations.Open(gstrPath &
"Template.pptm")
With objPPTPresen.Slides
Set objPPTSlide = .Item(1)
End With
'Create Slide 1
With objPPTPresen.Slides
s = objPPTPresen.Slides.Count
Set objPPTSlide = .Add(s, ppLayoutBlank)
End With
'Create Slide1
Set objPPTShape =
objPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=18, Top:=18, Width:=600, Height:=50)
With objPPTShape
.TextFrame.TextRange.Font.Name = "Verdana"
.TextFrame.TextRange.Font.Bold = msoTrue
.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
.TextFrame.TextRange.Text = "Advance 12M Sales Growth vs.
Remaining Market"
.TextFrame.TextRange.Lines(1).Font.Size = 18
End With
With objPPTPresen.Slides
s = objPPTPresen.Slides.Count
Set objPPTSlide = .Add(s, ppLayoutBlank)
End With
Set objPPTShape =
objPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=18, Top:=18, Width:=600, Height:=50)
With objPPTShape
.TextFrame.TextRange.Font.Name = "Verdana"
.TextFrame.TextRange.Font.Bold = msoTrue
.TextFrame.TextRange.ParagraphFormat.Alignment =
ppAlignLeft
.TextFrame.TextRange.Text = "Advance 12M Sales Growth vs.
Remaining Market"
.TextFrame.TextRange.Lines(1).Font.Size = 18
End With
xlSheetSlide0.Select
xlSheetSlide0.Range(strCopyRange).Copy
objPPTSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Name
= "SummaryTableOne"
With objPPTShape
.ScaleHeight 0.4, msoTrue, msoScaleFromMiddle
.ScaleWidth 0.8, msoTrue, msoScaleFromMiddle
.Top = 75
.Left = 18
End With