Hi
I have this VBA code,I Have a button that copy charts to power point, everything works fine, except when i pick to copy Quarter page(4 Charts in 1 slide) it copy just three of them with a good size except the fourth one it copy it large, and when i pick 5 charts, it do samething, 1 slide has 3 small charts, the fourth one is taking all the page, and the next slide has only one big chart, I dont know whats wrong, I check it many time.
Please this is a very sensitvie project
let me know if anybody can help in this
This is the code
Sub Form_CopyCharts()
If DBUG Then MsgBox ("Running Form_CopyCharts" & procedure)
arrParms = Range("ParameterList").Value
'Initialize the list box
CopyChartsForm.LB_Parms2Copy.List() = Range("ParameterList").Value
CopyChartsForm.LB_Parms2Copy.ListIndex = 0
'Turn on first page of multipage Form
CopyChartsForm.MultiPage1.Value = 0
'Default to QuarterPage output
CopyChartsForm.Quarterpage.Value = 1
' Set the default Set of charts
If ActiveSheet.Name = "Compare" Then
CopyChartsForm.CB_Comp.Value = 1
ElseIf ActiveSheet.Name = "Pop01_chart" Then
CopyChartsForm.CB_Pop01.Value = 1
ElseIf ActiveSheet.Name = "Pop02_chart" Then
CopyChartsForm.CB_Pop02.Value = 1
End If
CopyChartsForm.Show
Call CopyChartsForm.UpdateProgress(0)
End Sub
Sub copy_charts(arrCopy() As Integer, arrPop() As Integer, fname As String, perpage As Integer)
If DBUG Then MsgBox ("Running copy_charts(arrCopy() As Integer, arrPop() As Integer, fname As String, perpage As Integer)" & procedure)
'
' status_gen_report
' This module generates a simple PowerPoint report.
' The first slide is the Summary Table
' The remaining slides are the plots of each Task/Project, four-plots per page
'
' Note: For positioning, there are 72 units per inch on a page
'
Dim oppt As PowerPoint.Application
Dim pptpres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pgindex As Integer
Dim initfile As String
Dim Picfile As String
Dim PicTitle As String
Dim Fnd As Integer
Dim Fnd2 As Integer
Dim ppHeader As String
Dim Cntr As Integer
Dim lheight As Single
Dim lwidth As Single
Dim Taskcnt As Integer
Dim PH As Single
Dim PW As Single
Dim i As Integer
Dim p As Integer
Dim iplot As Integer
Dim PlotPos As Integer
Dim PctDone As Single
Dim pname As String
Dim shName As String
Dim copyName As String
Dim Title As String
Dim pres() As String
Dim AddedSheets As Integer
'Dim APPEND As Boolean
'Dim PPT_OPEN As Boolean
BATCHPLOT = True
nonplots = 0
'Turnoff the Manual Bin Reset in case it was left on:
Range("ManBinReset").Value = False
For p = 0 To 2
numPops = numPops + (arrPop(p))
Next p
numParms = UBound(arrCopy, 1)
Taskcnt = numParms * numPops 'Number of charts to import is the number of parameters * number of populations
'
' Getting the PowerPoint output filename
'
PPTFile = Left(fname, Len(fname) - 4) & ".ppt"
' Start the PowerPoint Application, get Page height and width, save file and set Path
'ActiveSheet.Activate
If PPTFile <> "False" Then
'Look for existing instance
On Error Resume Next
Set oppt = GetObject(, "PowerPoint.Application")
' Set oppt = GetObject(, "PowerPoint.Application")
' On Error GoTo 0
'Create new instance if no instance exists
AppendFile = ""
PPT_APPEND = False
If oppt Is Nothing Then
Set oppt = New PowerPoint.Application
Set pptpres = oppt.Presentations.Add
oppt.Visible = msoTrue
Else
'Get the number of open presentations
prescount = oppt.Presentations.Count
ReDim pres(prescount)
If prescount > 0 Then
For i = 1 To prescount
'Intialize the user form for which presentations are open
pres(i - 1) = oppt.Presentations(i).Name
Next i
PPTOpenForm.LB_PPTOpen.List() = pres()
' Show a dialog on whether to append an open presentation or not
PPTOpenForm.Show
ElseIf prescount = 0 Then
Set oppt = PowerPoint.Application
End If
End If
End If
FileSaveAs:
' If you have not chosen to append or overwrite on file already open in powerpoint, then prompt user for a new name
If Not PPT_APPEND And Not PPT_OVERWRITE Then
' PPT_RENAME = True
PPTFile = Application _
.GetSaveAsFilename(PPTFile, "Presentation (*.ppt), *.ppt", , "Enter PowerPoint Output Filename")
'Check to see if the proposed filename already exists if so, open the PPTExists form to find out what to do
If Dir(PPTFile) > "" Then
PPTExistsForm.Label_filename.Caption = PPTFile
PPTExistsForm.Show
If PPT_RENAME Then GoTo FileSaveAs
End If
ElseIf PPT_OVERWRITE = True Then
PPT_APPEND = False
ElseIf PPT_APPEND Then
PPT_OVERWRITE = False
End If
oppt.Visible = True
'Stop
If PPT_APPEND Or PPT_OVERWRITE Or PPT_RENAME Then
If prescount > 0 Then
For i = 1 To prescount
If oppt.Presentations(i).Name = PPTFile Then
'if it is open, set the values needed
PPT_OPEN = True
GoTo PPTO
Else
PPT_OPEN = False
End If
Next i
End If
End If
' set the presentation
PPTO:
'Stop
If Not PPT_OPEN And PPT_OVERWRITE Then
Set pptpres = oppt.Presentations.Add
ElseIf PPT_OPEN Then
Set pptpres = oppt.Presentations(PPTFile)
If PPT_OVERWRITE Then
slidecount = pptpres.Slides.Count
For i = 0 To pptpres.Slides.Count - 1
pptpres.Slides(slidecount - i).Delete
MsgBox ("Deleted one slide i = " & i)
Stop
Next i
End If
Else
Set pptpres = oppt.Presentations.Add
End If
With pptpres.Slides
lheight = pptpres.PageSetup.SlideHeight
lwidth = pptpres.PageSetup.SlideWidth
End With
'oppt.ScreenUpdating = False
For p = 0 To 2
If arrPop(p) = 1 Then
If p = 0 Then
pname = "Compare"
shName = "Compare"
copyName = shName & "_copy"
ElseIf p = 1 Then
pname = "Pop01"
shName = "Pop01_chart"
copyName = shName & "_copy"
ElseIf p = 2 Then
pname = "Pop02"
shName = "Pop02_chart"
copyName = shName & "_copy"
End If
Else
GoTo NextP
End If
'
' Now make each plot and copy it to PowerPoint
'
'SCREEN = False
For i = 1 To numParms
NONPLOT = False
' Set the Parameter Column Value
Range("_084_").Value = arrCopy(i)
' Generate the plot
'Application.ScreenUpdating = True
Application.Run ("PopParamSelect")
If NONPLOT Then
GoTo NextI
End If
iplot = i - nonplots
'Select and copy the plot into PowerPoint
Sheets(shName).Activate
Range(copyName).Select
Selection.CopyPicture _
Appearance:=xlScreen, Format:=xlBitmap ' Added by Qa
' Appearance:=xlPrinter, Format:=xlPicture
' Appearance:=xlScreen, Format:=xlBitmap
If perpage = 1 Then
' Set the Page Index
PlotPos = 1
If iplot = 1 Then
If PPT_APPEND Then
pgindex = pptpres.Slides.Count + 1
Else
pgindex = 1
End If
Else
pgindex = pgindex + 1
End If
Title = pname & " " & Range("_073_").Value
Set pptSlide = pptpres.Slides.Add(pgindex, ppLayoutTitleOnly)
AddedSheets = AddedSheets + 1
oppt.ActiveWindow.View.GotoSlide Index:=pgindex
pptSlide.Shapes.Paste
oppt.ActiveWindow.Selection.SlideRange.Shapes("Picture 3").Select
'
' Initial: 0.92" from top, centered 5/8 from edges
'
With oppt.ActiveWindow.Selection.ShapeRange
.Width = 630#
.Left = 45#
.Top = 66#
End With
' Check to see if bottom of table leaves 3/4 margin, if not, size by height and re-center
With oppt.ActiveWindow.Selection.ShapeRange
PH = .Height
PW = .Width
If PH > 420# Then
.Height = 420#
.Left = (720 - PW) / 2#
End If
End With
Range("A1").Select
ElseIf perpage = 4 Then
' Determine the plot position
If iplot = 1 Then
If PPT_APPEND Then
pgindex = pptpres.Slides.Count + 1
Else
pgindex = 1
End If
PlotPos = 1
ElseIf iplot Mod 4 = 1 Then
pgindex = pgindex + 1
PlotPos = 1
ElseIf iplot Mod 4 = 2 Then
PlotPos = 2
ElseIf iplot Mod 4 = 3 Then
PlotPos = 3
ElseIf iplot Mod 4 = 0 Then
PlotPos = 4
End If
'Add the titles to each chart for easy reference entering a carriage return before the 3rd title
If PlotPos = 1 Then
Title = pname & " " & Range("_073_").Value & " / "
ElseIf PlotPos = 3 Then
Title = Title & Chr(13) & pname & " " & Range("_073_").Value & " / "
Else
Title = Title & pname & " " & Range("_073_").Value
End If
If PlotPos = 1 Then
Set pptSlide = pptpres.Slides.Add(pgindex, ppLayoutTitleOnly)
AddedSheets = AddedSheets + 1
End If
oppt.ActiveWindow.View.GotoSlide Index:=pgindex
' Stop
pptSlide.Shapes.PasteSpecial(DataType:=ppPasteBitmap).Select
' Position in Quadrant 1
If PlotPos = 1 Then
' Now select the picture
oppt.ActiveWindow.Selection.SlideRange.Shapes("Picture 3").Select
' Position .25" from Left, 0.92" from Top
With oppt.ActiveWindow.Selection.ShapeRange
.Width = 333# '369=width with 1/4" from left, 1/4" gap in middle, and 1/4" on right
.Height = 216# '254=hieght with 1/4 from top, 1/2" for title, 1/4" below title, 1/4" between and 1/4 from bottom
.Left = 54#
.Top = 72#
End With
' Check to see if chart is too high, reposition by width if it is
' With oppt.ActiveWindow.Selection.ShapeRange
' PH = .Height
' PW = .Width
' If PH > 225# Then '192
' .Height = 225# '192
' .Left = (402 - PW) * 2 / 3# '400=360
' End If
' End With
ElseIf PlotPos = 2 Then
oppt.ActiveWindow.Selection.SlideRange.Shapes("Picture 4").Select
' Position 5.125" from Left, 0.92" from Top
With oppt.ActiveWindow.Selection.ShapeRange
.Width = 333#
.Height = 216#
.Left = 387# '1/4 left margin, 369 for 1/4 middle and 369, 1/4 right
.Top = 72#
End With
' Check to see if chart is too high, reposition by width if it is
' With oppt.ActiveWindow.Selection.ShapeRange
' PH = .Height
' PW = .Width
' If PH > 225# Then
' .Height = 225#
' .Left = 402 + (402 - PW) / 3#
' '.Right = (402 1- PW) * 2 / 3#
' End If
' End With
ElseIf PlotPos = 3 Then
oppt.ActiveWindow.Selection.SlideRange.Shapes("Picture 5").Select
' Position .25" from Left, 4.08" from Top
With oppt.ActiveWindow.Selection.ShapeRange
.Width = 333#
.Height = 216#
.Left = 54#
.Top = 306# '1/4 top 1/2 title 1/4 gap 252 PlotPos1
End With
' Check to see if chart is too high, reposition by width if it is
' With oppt.ActiveWindow.Selection.ShapeRange
' PH = .Height
' PW = .Width
' If PH > 225# Then
' .Height = 225#
' .Left = (402 - PW) * 2 / 3#
' End If
' End With
ElseIf PlotPos = 4 Then
oppt.ActiveWindow.Selection.SlideRange.Shapes("Picture 6").Select
' Position 5.125" from Left, 4.08" from Top
With oppt.ActiveWindow.Selection.ShapeRange
.Width = 333#
.Height = 216#
.Left = 387# '369
.Top = 306#
End With
' Check to see if chart is too high, reposition by width if it is
' With oppt.ActiveWindow.Selection.ShapeRange
' PH = .Height
' PW = .Width
' If PH > 225# Then
' .Height = 225#
' .Left = 402 + (402 - PW) / 3#
' .Left = 280 + (280 - PW) / 3#
' End If
' End With
End If
End If ' Either Page select
'Title work
Application.ScreenUpdating = True
PctDone = iplot / Taskcnt
'MsgBox ("I'm now " & PctDone & "% done")
CopyChartsForm.UpdateProgress (PctDone)
Application.ScreenUpdating = False
'Set the title when you are on the last plot of the page
If PlotPos = perpage Or i Mod numParms = 0 Then
oppt.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Select
' Stop
oppt.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
oppt.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(start:=1, Length:=0).Select
With oppt.ActiveWindow.Selection.TextRange
.text = Title
With .Font
.NameAscii = "Courier New"
.Size = 16
End With
End With
oppt.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Select
With oppt.ActiveWindow.Selection.ShapeRange
.Top = 18#
.Height = 36#
.Width = 600#
End With
oppt.ActiveWindow.Selection.Unselect
' oppt.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Select
' oppt.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").TextRange.Select
' With oppt.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2")
' With .TextFrame.TextRange.Characters(start:=1, Length:=0)
' .text = Title
' .Font.Size = 32
' End With
' .Top = 30#
' .Height = 22#
' .Width = 600#
' End With
'Then Reset title for next page
Title = ""
End If
NextI:
Next i
NextP:
Next p
SCREEN = True
'If there were plots that needed to be skipped, report them out to the user
Application.ScreenUpdating = True
If nonplots > 0 Then
msg = "Could not plot " & nonplots & " parameters" & vbCrLf
For i = 1 To nonplots
msg = msg & Range("ParameterList").Cells(noplot(i), 1) & vbCrLf
Next i
MsgBox ("Could not plot: " & msg & vbCrLf & "These were not exported to power point")
Application.ScreenUpdating = True
' PctDone = i / Taskcnt
' MsgBox ("I'm now " & PctDone*100 & "% done")
PctDone = 1
CopyChartsForm.UpdateProgress (PctDone)
Application.ScreenUpdating = False
End If
'
' Leave PowerPoint on Slide 1
'
'If AddedSheets > 0 Then
' oppt.ActiveWindow.View.GotoSlide Index:=1
'Else
' oppt.ActivePresentation.Close
'End If
'
' Save PowerPoint File
'
pptpres.SaveAs (PPTFile)
'oppt.ScreenUpdating = False
Range("A1").Select
BATCHPLOT = False
End Sub
I have this VBA code,I Have a button that copy charts to power point, everything works fine, except when i pick to copy Quarter page(4 Charts in 1 slide) it copy just three of them with a good size except the fourth one it copy it large, and when i pick 5 charts, it do samething, 1 slide has 3 small charts, the fourth one is taking all the page, and the next slide has only one big chart, I dont know whats wrong, I check it many time.
Please this is a very sensitvie project
let me know if anybody can help in this
This is the code
Sub Form_CopyCharts()
If DBUG Then MsgBox ("Running Form_CopyCharts" & procedure)
arrParms = Range("ParameterList").Value
'Initialize the list box
CopyChartsForm.LB_Parms2Copy.List() = Range("ParameterList").Value
CopyChartsForm.LB_Parms2Copy.ListIndex = 0
'Turn on first page of multipage Form
CopyChartsForm.MultiPage1.Value = 0
'Default to QuarterPage output
CopyChartsForm.Quarterpage.Value = 1
' Set the default Set of charts
If ActiveSheet.Name = "Compare" Then
CopyChartsForm.CB_Comp.Value = 1
ElseIf ActiveSheet.Name = "Pop01_chart" Then
CopyChartsForm.CB_Pop01.Value = 1
ElseIf ActiveSheet.Name = "Pop02_chart" Then
CopyChartsForm.CB_Pop02.Value = 1
End If
CopyChartsForm.Show
Call CopyChartsForm.UpdateProgress(0)
End Sub
Sub copy_charts(arrCopy() As Integer, arrPop() As Integer, fname As String, perpage As Integer)
If DBUG Then MsgBox ("Running copy_charts(arrCopy() As Integer, arrPop() As Integer, fname As String, perpage As Integer)" & procedure)
'
' status_gen_report
' This module generates a simple PowerPoint report.
' The first slide is the Summary Table
' The remaining slides are the plots of each Task/Project, four-plots per page
'
' Note: For positioning, there are 72 units per inch on a page
'
Dim oppt As PowerPoint.Application
Dim pptpres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pgindex As Integer
Dim initfile As String
Dim Picfile As String
Dim PicTitle As String
Dim Fnd As Integer
Dim Fnd2 As Integer
Dim ppHeader As String
Dim Cntr As Integer
Dim lheight As Single
Dim lwidth As Single
Dim Taskcnt As Integer
Dim PH As Single
Dim PW As Single
Dim i As Integer
Dim p As Integer
Dim iplot As Integer
Dim PlotPos As Integer
Dim PctDone As Single
Dim pname As String
Dim shName As String
Dim copyName As String
Dim Title As String
Dim pres() As String
Dim AddedSheets As Integer
'Dim APPEND As Boolean
'Dim PPT_OPEN As Boolean
BATCHPLOT = True
nonplots = 0
'Turnoff the Manual Bin Reset in case it was left on:
Range("ManBinReset").Value = False
For p = 0 To 2
numPops = numPops + (arrPop(p))
Next p
numParms = UBound(arrCopy, 1)
Taskcnt = numParms * numPops 'Number of charts to import is the number of parameters * number of populations
'
' Getting the PowerPoint output filename
'
PPTFile = Left(fname, Len(fname) - 4) & ".ppt"
' Start the PowerPoint Application, get Page height and width, save file and set Path
'ActiveSheet.Activate
If PPTFile <> "False" Then
'Look for existing instance
On Error Resume Next
Set oppt = GetObject(, "PowerPoint.Application")
' Set oppt = GetObject(, "PowerPoint.Application")
' On Error GoTo 0
'Create new instance if no instance exists
AppendFile = ""
PPT_APPEND = False
If oppt Is Nothing Then
Set oppt = New PowerPoint.Application
Set pptpres = oppt.Presentations.Add
oppt.Visible = msoTrue
Else
'Get the number of open presentations
prescount = oppt.Presentations.Count
ReDim pres(prescount)
If prescount > 0 Then
For i = 1 To prescount
'Intialize the user form for which presentations are open
pres(i - 1) = oppt.Presentations(i).Name
Next i
PPTOpenForm.LB_PPTOpen.List() = pres()
' Show a dialog on whether to append an open presentation or not
PPTOpenForm.Show
ElseIf prescount = 0 Then
Set oppt = PowerPoint.Application
End If
End If
End If
FileSaveAs:
' If you have not chosen to append or overwrite on file already open in powerpoint, then prompt user for a new name
If Not PPT_APPEND And Not PPT_OVERWRITE Then
' PPT_RENAME = True
PPTFile = Application _
.GetSaveAsFilename(PPTFile, "Presentation (*.ppt), *.ppt", , "Enter PowerPoint Output Filename")
'Check to see if the proposed filename already exists if so, open the PPTExists form to find out what to do
If Dir(PPTFile) > "" Then
PPTExistsForm.Label_filename.Caption = PPTFile
PPTExistsForm.Show
If PPT_RENAME Then GoTo FileSaveAs
End If
ElseIf PPT_OVERWRITE = True Then
PPT_APPEND = False
ElseIf PPT_APPEND Then
PPT_OVERWRITE = False
End If
oppt.Visible = True
'Stop
If PPT_APPEND Or PPT_OVERWRITE Or PPT_RENAME Then
If prescount > 0 Then
For i = 1 To prescount
If oppt.Presentations(i).Name = PPTFile Then
'if it is open, set the values needed
PPT_OPEN = True
GoTo PPTO
Else
PPT_OPEN = False
End If
Next i
End If
End If
' set the presentation
PPTO:
'Stop
If Not PPT_OPEN And PPT_OVERWRITE Then
Set pptpres = oppt.Presentations.Add
ElseIf PPT_OPEN Then
Set pptpres = oppt.Presentations(PPTFile)
If PPT_OVERWRITE Then
slidecount = pptpres.Slides.Count
For i = 0 To pptpres.Slides.Count - 1
pptpres.Slides(slidecount - i).Delete
MsgBox ("Deleted one slide i = " & i)
Stop
Next i
End If
Else
Set pptpres = oppt.Presentations.Add
End If
With pptpres.Slides
lheight = pptpres.PageSetup.SlideHeight
lwidth = pptpres.PageSetup.SlideWidth
End With
'oppt.ScreenUpdating = False
For p = 0 To 2
If arrPop(p) = 1 Then
If p = 0 Then
pname = "Compare"
shName = "Compare"
copyName = shName & "_copy"
ElseIf p = 1 Then
pname = "Pop01"
shName = "Pop01_chart"
copyName = shName & "_copy"
ElseIf p = 2 Then
pname = "Pop02"
shName = "Pop02_chart"
copyName = shName & "_copy"
End If
Else
GoTo NextP
End If
'
' Now make each plot and copy it to PowerPoint
'
'SCREEN = False
For i = 1 To numParms
NONPLOT = False
' Set the Parameter Column Value
Range("_084_").Value = arrCopy(i)
' Generate the plot
'Application.ScreenUpdating = True
Application.Run ("PopParamSelect")
If NONPLOT Then
GoTo NextI
End If
iplot = i - nonplots
'Select and copy the plot into PowerPoint
Sheets(shName).Activate
Range(copyName).Select
Selection.CopyPicture _
Appearance:=xlScreen, Format:=xlBitmap ' Added by Qa
' Appearance:=xlPrinter, Format:=xlPicture
' Appearance:=xlScreen, Format:=xlBitmap
If perpage = 1 Then
' Set the Page Index
PlotPos = 1
If iplot = 1 Then
If PPT_APPEND Then
pgindex = pptpres.Slides.Count + 1
Else
pgindex = 1
End If
Else
pgindex = pgindex + 1
End If
Title = pname & " " & Range("_073_").Value
Set pptSlide = pptpres.Slides.Add(pgindex, ppLayoutTitleOnly)
AddedSheets = AddedSheets + 1
oppt.ActiveWindow.View.GotoSlide Index:=pgindex
pptSlide.Shapes.Paste
oppt.ActiveWindow.Selection.SlideRange.Shapes("Picture 3").Select
'
' Initial: 0.92" from top, centered 5/8 from edges
'
With oppt.ActiveWindow.Selection.ShapeRange
.Width = 630#
.Left = 45#
.Top = 66#
End With
' Check to see if bottom of table leaves 3/4 margin, if not, size by height and re-center
With oppt.ActiveWindow.Selection.ShapeRange
PH = .Height
PW = .Width
If PH > 420# Then
.Height = 420#
.Left = (720 - PW) / 2#
End If
End With
Range("A1").Select
ElseIf perpage = 4 Then
' Determine the plot position
If iplot = 1 Then
If PPT_APPEND Then
pgindex = pptpres.Slides.Count + 1
Else
pgindex = 1
End If
PlotPos = 1
ElseIf iplot Mod 4 = 1 Then
pgindex = pgindex + 1
PlotPos = 1
ElseIf iplot Mod 4 = 2 Then
PlotPos = 2
ElseIf iplot Mod 4 = 3 Then
PlotPos = 3
ElseIf iplot Mod 4 = 0 Then
PlotPos = 4
End If
'Add the titles to each chart for easy reference entering a carriage return before the 3rd title
If PlotPos = 1 Then
Title = pname & " " & Range("_073_").Value & " / "
ElseIf PlotPos = 3 Then
Title = Title & Chr(13) & pname & " " & Range("_073_").Value & " / "
Else
Title = Title & pname & " " & Range("_073_").Value
End If
If PlotPos = 1 Then
Set pptSlide = pptpres.Slides.Add(pgindex, ppLayoutTitleOnly)
AddedSheets = AddedSheets + 1
End If
oppt.ActiveWindow.View.GotoSlide Index:=pgindex
' Stop
pptSlide.Shapes.PasteSpecial(DataType:=ppPasteBitmap).Select
' Position in Quadrant 1
If PlotPos = 1 Then
' Now select the picture
oppt.ActiveWindow.Selection.SlideRange.Shapes("Picture 3").Select
' Position .25" from Left, 0.92" from Top
With oppt.ActiveWindow.Selection.ShapeRange
.Width = 333# '369=width with 1/4" from left, 1/4" gap in middle, and 1/4" on right
.Height = 216# '254=hieght with 1/4 from top, 1/2" for title, 1/4" below title, 1/4" between and 1/4 from bottom
.Left = 54#
.Top = 72#
End With
' Check to see if chart is too high, reposition by width if it is
' With oppt.ActiveWindow.Selection.ShapeRange
' PH = .Height
' PW = .Width
' If PH > 225# Then '192
' .Height = 225# '192
' .Left = (402 - PW) * 2 / 3# '400=360
' End If
' End With
ElseIf PlotPos = 2 Then
oppt.ActiveWindow.Selection.SlideRange.Shapes("Picture 4").Select
' Position 5.125" from Left, 0.92" from Top
With oppt.ActiveWindow.Selection.ShapeRange
.Width = 333#
.Height = 216#
.Left = 387# '1/4 left margin, 369 for 1/4 middle and 369, 1/4 right
.Top = 72#
End With
' Check to see if chart is too high, reposition by width if it is
' With oppt.ActiveWindow.Selection.ShapeRange
' PH = .Height
' PW = .Width
' If PH > 225# Then
' .Height = 225#
' .Left = 402 + (402 - PW) / 3#
' '.Right = (402 1- PW) * 2 / 3#
' End If
' End With
ElseIf PlotPos = 3 Then
oppt.ActiveWindow.Selection.SlideRange.Shapes("Picture 5").Select
' Position .25" from Left, 4.08" from Top
With oppt.ActiveWindow.Selection.ShapeRange
.Width = 333#
.Height = 216#
.Left = 54#
.Top = 306# '1/4 top 1/2 title 1/4 gap 252 PlotPos1
End With
' Check to see if chart is too high, reposition by width if it is
' With oppt.ActiveWindow.Selection.ShapeRange
' PH = .Height
' PW = .Width
' If PH > 225# Then
' .Height = 225#
' .Left = (402 - PW) * 2 / 3#
' End If
' End With
ElseIf PlotPos = 4 Then
oppt.ActiveWindow.Selection.SlideRange.Shapes("Picture 6").Select
' Position 5.125" from Left, 4.08" from Top
With oppt.ActiveWindow.Selection.ShapeRange
.Width = 333#
.Height = 216#
.Left = 387# '369
.Top = 306#
End With
' Check to see if chart is too high, reposition by width if it is
' With oppt.ActiveWindow.Selection.ShapeRange
' PH = .Height
' PW = .Width
' If PH > 225# Then
' .Height = 225#
' .Left = 402 + (402 - PW) / 3#
' .Left = 280 + (280 - PW) / 3#
' End If
' End With
End If
End If ' Either Page select
'Title work
Application.ScreenUpdating = True
PctDone = iplot / Taskcnt
'MsgBox ("I'm now " & PctDone & "% done")
CopyChartsForm.UpdateProgress (PctDone)
Application.ScreenUpdating = False
'Set the title when you are on the last plot of the page
If PlotPos = perpage Or i Mod numParms = 0 Then
oppt.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Select
' Stop
oppt.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
oppt.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(start:=1, Length:=0).Select
With oppt.ActiveWindow.Selection.TextRange
.text = Title
With .Font
.NameAscii = "Courier New"
.Size = 16
End With
End With
oppt.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Select
With oppt.ActiveWindow.Selection.ShapeRange
.Top = 18#
.Height = 36#
.Width = 600#
End With
oppt.ActiveWindow.Selection.Unselect
' oppt.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Select
' oppt.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").TextRange.Select
' With oppt.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2")
' With .TextFrame.TextRange.Characters(start:=1, Length:=0)
' .text = Title
' .Font.Size = 32
' End With
' .Top = 30#
' .Height = 22#
' .Width = 600#
' End With
'Then Reset title for next page
Title = ""
End If
NextI:
Next i
NextP:
Next p
SCREEN = True
'If there were plots that needed to be skipped, report them out to the user
Application.ScreenUpdating = True
If nonplots > 0 Then
msg = "Could not plot " & nonplots & " parameters" & vbCrLf
For i = 1 To nonplots
msg = msg & Range("ParameterList").Cells(noplot(i), 1) & vbCrLf
Next i
MsgBox ("Could not plot: " & msg & vbCrLf & "These were not exported to power point")
Application.ScreenUpdating = True
' PctDone = i / Taskcnt
' MsgBox ("I'm now " & PctDone*100 & "% done")
PctDone = 1
CopyChartsForm.UpdateProgress (PctDone)
Application.ScreenUpdating = False
End If
'
' Leave PowerPoint on Slide 1
'
'If AddedSheets > 0 Then
' oppt.ActiveWindow.View.GotoSlide Index:=1
'Else
' oppt.ActivePresentation.Close
'End If
'
' Save PowerPoint File
'
pptpres.SaveAs (PPTFile)
'oppt.ScreenUpdating = False
Range("A1").Select
BATCHPLOT = False
End Sub
