Export several graphics to ppt

[Anonymous]

Good day!

Colleagues, tell me please, has QV ability to export few objects to ppt to one slide?

In community i've found several solutions, but they export one object per one slide in presentation.

My necessary result in attached ppt file.

Thanks.

[m_woolf]

The following code will place 4 charts on each slide:

Sub SendToPPT 

  dim SourceName(400)

  dim SourceNameSlides(100)

  rem ** show each possible value in list box **

  set LB = ActiveDocument.GetSheetObject("LB29")

  boxvalues=LB.GetPossibleValues    'GetPossibleValues

  for i = lbound(boxvalues) to ubound(boxvalues) 

  SourceName(i) = boxvalues(i)

  next

  intSourceNameCount = i-1

  intNoCharts = (intSourceNameCount+1)

  intNoSlides = intNoCharts/4

  if intNoSlides <> int(intNoSlides) then intNoSlides = int(intNoSlides)+1

  Response = msgbox("There are " & intSourceNameCount+1 & " Sources ." & chr(13) _

  & "This will result in " & intNoCharts & " charts on " & intNoSlides & " slides." & chr(13) _

  & "Do you want to continue?",4,"Send All to PPT?")

  if Response = 7 then   'vbCancel

  msgbox("Send All to PPT cancelled by user.")

  exit sub

  end if

  strCH = "CH04"

  Set PPApp = CreateObject("Powerpoint.Application")

  PPApp.Visible = True ' Create a presentation

  Set PPPres = PPApp.Presentations.Add

  intSlideCount = 0

  intSlideWidth=720

  do while c <= intSourceNameCount

  Call AddSlide(PPApp,PPPres,PPSlide,strSourceName)

  SourceNameSlides(c) = SourceNameSlides(c)+1

  blnHasChart = False

  blnNewSlide=false

  intChartCount = 0

  intRowCount = 0

  For p = 0 to 3

  Activedocument.Fields("D_SourceName").select SourceName(c)

  ActiveDocument.GetApplication.WaitForIdle

  strSourceName = SourceName(c)

  c = c + 1

  set val=ActiveDocument.Fields("D_SourceName").GetSelectedValues

  if val.count=0 then

  else

  blnNewSlide = False

  ActiveDocument.GetApplication.WaitForIdle     ' attempt to fix chart not updating

     ActiveDocument.GetSheetObject(strCH).CopyBitmapToClipboard

     PPSlide.Shapes.Paste.Select   

     blnHasChart = True

     PPApp.ActiveWindow.Selection.ShapeRange.Top = 60 +intRowCount*45+intRowCount*189

     PPApp.ActiveWindow.Selection.ShapeRange.Left = 10+intChartCount*10+intChartCount*345

     PPApp.ActiveWindow.Selection.ShapeRange.Width = 345

  PPApp.ActiveWindow.Selection.Unselect

     intChartCount=intChartCount + 1

  if intChartCount = 2  and intRowCount = 0 then

  intRowCount = intRowCount+1

  intChartCount = 0

  end if

  If intChartCount = 2 and intRowCount = 1 then           ' last in group of 4 charts - start new slide

  intRowCount = 0

  intChartCount = 0

  blnNewSlide = True

  end if

  end if    'val.count = 0

  next   'p

  loop  'c

  if blnHasChart = False then PPSlide.Delete

  SourceNameSlides(c) = SourceNameSlides(c) -1   ' maybe c-1

' end if

  Activedocument.Fields("D_SourceName").Clear

  Activedocument.Fields("D_Date").Clear

  PPPres.Slides(1).Select

' PPPres.Close

' PPApp.Quit

  Set PPSlide = Nothing

  Set PPPres = Nothing

  Set PPApp = Nothing

End sub

[Anonymous]

Thanks.

Could you try it's work?

In my model it doesn't work(