Unlock a world of possibilities! Login now and discover the exclusive benefits awaiting you.
Hi.
Finally i have created ppt useing macro but all charts comes in diifrent slide, i need two particaluer silde only..like mainsheet in one slide sheet1 in slide 2
pls can any guide me where im worng.and find attached test application...
you need to move
Set PPSlide = PPPres.Slides.Add(1, 1)
PPSlide.Shapes(1).Delete ' removes the title
PPSlide.Shapes(1).Delete ' removes the text box
before your loop
whole script should be like:
sub ppt1
Set PPApp = CreateObject("Powerpoint.Application")
MsgBox("Hello")
PPApp.Visible = True ' Create a presentation
Set PPPres = PPApp.Presentations.Add
'''''''''' For All Sheets '''''''''
for j = 0 to ActiveDocument.NoOfSheets - 1
ActiveDocument.Sheets(j).Activate
set ss= ActiveDocument.GetSheet(j)
shID =ucase(mid(ss.GetProperties.SheetID,10))
shName=ss.GetProperties.Name
ActiveDocument.GetApplication.WaitForIdle
'ActiveDocument.GetApplication.Sleep 5000
'msgbox shName & "--" & shID
''''''''''''''''''''''''''''''''''''''''''
ActiveDocument.Sheets(shName).Activate
ActiveDocument.Sheets(j).Activate
set s=ActiveDocument.ActiveSheet
charts=s.GetSheetObjects
Set PPSlide = PPPres.Slides.Add(1, 1)
PPSlide.Shapes(1).Delete ' removes the title
PPSlide.Shapes(1).Delete ' removes the text box
for i=lbound(charts) to ubound(charts)
if(UCASE(mid(charts(i).getobjectid,10,2)))="CH" then
ActiveDocument.GetSheetObject(charts(i).getobjectid).CopyBitmapToClipboard
PPSlide.Shapes.Paste
'ActiveDocument.GetApplication.Sleep 1000
end if
next
next ''for sheets next move
PPPres.SaveAs "C:\temp\MyPresentationPPT.ppt"
PPPres.Close
PPApp.Quit
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
end sub
sub sheets
MsgBox("Hello")
for i = 0 to ActiveDocument.NoOfSheets - 1
set ss= ActiveDocument.GetSheet(i)
msgbox(ss.GetProperties.Name)
next
end sub
'sub Trends
'Set PPApp = CreateObject("Powerpoint.Application")
'PPApp.Visible = True ' Create a presentation
'Set PPPres = PPApp.Presentations.Add
'set s=ActiveDocument.Sheets("Trends")
'charts2=s.GetGraphs
''charts3=s.GetPivotTableBoxes
'charts=s.GetStraightTableBoxes
'Set PPSlide = PPPres.Slides.Add(1, 1)
'PPSlide.Shapes(1).Delete ' removes the title
'PPSlide.Shapes(1).Delete ' removes the text box
'vPosition=50
'
'for i=lbound(charts) to ubound(charts)
'ActiveDocument.GetSheetObject(charts(i).getobjectid).CopyBitmapToClipboard
'PPSlide.Shapes.Paste.Select
'next
'
'for j=lbound(charts2) to ubound(charts2)
'ActiveDocument.GetSheetObject(charts2(j).getobjectid).CopyBitmapToClipboard
'PPSlide.Shapes.Paste.Select
'next
'
'for k=lbound(charts3) to ubound(charts3)
'ActiveDocument.GetSheetObject(charts3(k).getobjectid).CopyBitmapToClipboard
'PPSlide.Shapes.Paste.Select
'next
'
'PPPres.SaveAs "C:\Temp\MyPresentation.ppt"
'PPPres.Close
'PPApp.Quit
'Set PPSlide = Nothing
'Set PPPres = Nothing
'Set PPApp = Nothing
you need to move
Set PPSlide = PPPres.Slides.Add(1, 1)
PPSlide.Shapes(1).Delete ' removes the title
PPSlide.Shapes(1).Delete ' removes the text box
before your loop
whole script should be like:
sub ppt1
Set PPApp = CreateObject("Powerpoint.Application")
MsgBox("Hello")
PPApp.Visible = True ' Create a presentation
Set PPPres = PPApp.Presentations.Add
'''''''''' For All Sheets '''''''''
for j = 0 to ActiveDocument.NoOfSheets - 1
ActiveDocument.Sheets(j).Activate
set ss= ActiveDocument.GetSheet(j)
shID =ucase(mid(ss.GetProperties.SheetID,10))
shName=ss.GetProperties.Name
ActiveDocument.GetApplication.WaitForIdle
'ActiveDocument.GetApplication.Sleep 5000
'msgbox shName & "--" & shID
''''''''''''''''''''''''''''''''''''''''''
ActiveDocument.Sheets(shName).Activate
ActiveDocument.Sheets(j).Activate
set s=ActiveDocument.ActiveSheet
charts=s.GetSheetObjects
Set PPSlide = PPPres.Slides.Add(1, 1)
PPSlide.Shapes(1).Delete ' removes the title
PPSlide.Shapes(1).Delete ' removes the text box
for i=lbound(charts) to ubound(charts)
if(UCASE(mid(charts(i).getobjectid,10,2)))="CH" then
ActiveDocument.GetSheetObject(charts(i).getobjectid).CopyBitmapToClipboard
PPSlide.Shapes.Paste
'ActiveDocument.GetApplication.Sleep 1000
end if
next
next ''for sheets next move
PPPres.SaveAs "C:\temp\MyPresentationPPT.ppt"
PPPres.Close
PPApp.Quit
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
end sub
sub sheets
MsgBox("Hello")
for i = 0 to ActiveDocument.NoOfSheets - 1
set ss= ActiveDocument.GetSheet(i)
msgbox(ss.GetProperties.Name)
next
end sub
'sub Trends
'Set PPApp = CreateObject("Powerpoint.Application")
'PPApp.Visible = True ' Create a presentation
'Set PPPres = PPApp.Presentations.Add
'set s=ActiveDocument.Sheets("Trends")
'charts2=s.GetGraphs
''charts3=s.GetPivotTableBoxes
'charts=s.GetStraightTableBoxes
'Set PPSlide = PPPres.Slides.Add(1, 1)
'PPSlide.Shapes(1).Delete ' removes the title
'PPSlide.Shapes(1).Delete ' removes the text box
'vPosition=50
'
'for i=lbound(charts) to ubound(charts)
'ActiveDocument.GetSheetObject(charts(i).getobjectid).CopyBitmapToClipboard
'PPSlide.Shapes.Paste.Select
'next
'
'for j=lbound(charts2) to ubound(charts2)
'ActiveDocument.GetSheetObject(charts2(j).getobjectid).CopyBitmapToClipboard
'PPSlide.Shapes.Paste.Select
'next
'
'for k=lbound(charts3) to ubound(charts3)
'ActiveDocument.GetSheetObject(charts3(k).getobjectid).CopyBitmapToClipboard
'PPSlide.Shapes.Paste.Select
'next
'
'PPPres.SaveAs "C:\Temp\MyPresentation.ppt"
'PPPres.Close
'PPApp.Quit
'Set PPSlide = Nothing
'Set PPPres = Nothing
'Set PPApp = Nothing
Hey Thanks its working.you have saved my time..i thought about it, but i got confuse after debugging lot.
Thanks again
Hi Pari,
Just clear me on think in this why sheet 2 added in slide1..its not add in Sequence?
Thanks