Hi All,
I have 'borrowed' some of code examples from other posters here to
export ranges to powerpoint.
The code has been modified to loop through each sheet and export the
print_area as XLbitmaps to individual slides in Powerpoint (PP), make
the bitmap fit the slide, save the file etc. All is working OK but l
have a few questions as follows:
1) How can l trap the error that occurs when saving a file that has
the same name as one already open in PP? I expected the standard
system generated warning "A file with that name is already
open.......etc)
2) This file is to be distributed around the company. Everybody is on
the same version of Excel. Will the reference to 'Microsoft Powerpoint
11.0 Object Library' remain intact?
3) If the reference to PP does not remain intact / is not robust then
should l change to late binding? Not sure exactly what this or what
code changes are necessary.
4) I have used xlBitmap rather xlPicture as the picture type as it
seems to give a more consistent look in PP. Are there any drawbacks to
this? Can pictures be 'sharpened'?
All contributions gratefully received
Please beware wordwrap.......many comments!
Sub PrintAreaToNewPowerpoint()
'REMEMBER: Set VBE reference to Microsoft PowerPoint 11.0 Object
'OUTPUT : xlBitmap appears to give more consistent quality, xlPicture
is the alternative
'SAVE AS : Error trapping required when existing file is open in
Powerpoint
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PPShape As PowerPoint.Shape
Dim PPFileName As String
Dim CurrentTitle As String
Dim SlideCount As Long
Dim Filename As String
Dim PicRange As String
Dim NewFilename As String
Dim PPActive As String
' Activate Powerpoint or create new instance of Powerpoint
On Error Resume Next
Set PPApp = GetObject(, "PowerPoint.Application")
PPActive = "Yes"
If PPApp Is Nothing Then
Set PPApp = CreateObject("PowerPoint.Application")
'PPApp.Visible = True
PPActive = "No"
End If
On Error GoTo 0
' Create new presentation
Set PPPres = PPApp.Presentations.Add
' Set variables
CurrentTitle = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
PPFileName = ThisWorkbook.Path & "\" & CurrentTitle & ".ppt"
SlideCount = PPPres.Slides.Count
Filename = ThisWorkbook.Name
'Loop through each sheet
For Each Sht1 In Workbooks(Filename).Worksheets
PicRange = ""
On Error Resume Next
PicRange = Sht1.Range("Print_Area").Address
On Error GoTo 0
If PicRange = "" Then
MsgBox ("The worksheet '" & Sht1.Name & "' has no print
area set and will not be created in Powerpoint")
Else
Sht1.Range("Print_Area").CopyPicture xlScreen, xlBitmap
' Paste picture into PP
Set PPSlide = PPPres.Slides.Add(SlideCount + 1,
ppLayoutBlank)
With PPSlide
.Shapes.Paste
'//....add code to size to fit
Set PPShape = .Shapes(.Shapes.Count)
PPwidth = PPShape.Width
PPheight = PPShape.Height
If PPwidth < 680 And PPheight < 584 Then
PPwidth = PPwidth
PPheight = PPheight
Else
PPwidth = 680 / PPwidth
PPheight = 584 / PPheight
If PPwidth < PPheight Then
PPsize = PPwidth
PPShape.ScaleWidth PPsize, msoFalse,
msoScaleFromTopLeft
Else
If PPheight < PPwidth Then
PPsize = PPheight
PPShape.ScaleHeight PPsize, msoFalse,
msoScaleFromTopLeft
End If
End If
End If
PPShape.Left = 22
PPShape.Top = 22
'//....end of added code
End With
SlideCount = SlideCount + 1
End If
Next Sht1
' Save PP file in same directory & with same name as source file
or choice of name
With PPPres
NewFilename = InputBox("The Powerpoint file will be saved as :
" _
& vbCrLf _
& vbCrLf _
& CurrentTitle _
& vbCrLf _
& vbCrLf _
& "Please enter a new name if required.",
"Powerpoint File Information", CurrentTitle)
If NewFilename = "" Then
MsgBox ("The Powerpoint file has not been saved.")
If PPActive = "No" Then
.Close
End If
Else
NewFilename = ThisWorkbook.Path & "\" & NewFilename &
".ppt"
.SaveAs NewFilename
If PPActive = "No" Then
.Close
End If
End If
End With
' Tidy up & exit
If PPActive = "No" Then
PPApp.Quit
End If
Set PPApp = Nothing
Set PPPres = Nothing
Set PPSlide = Nothing
Set PPShape = Nothing
End Sub
Regards
Michael
|
Similar Threads
