Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Advice & Error Trapping
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Advice & Error Trapping
Comments in-line
"michael.beckinsale" wrote in message 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) One way - Dim s as string On error resume next s = PPApp.Presentations(NewFilename).Name On error goto 0 If Len(s) Then ' NewFileName is same as an open doc Of course this doesn't test for the possibility of a closed same name file in same location. 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? In theory yes, until someone takes it home, saves it on their earlier version, then brings it back to the office! If in doubt convert to Late Binding and remove the reference. 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. To convert, change all PP type declarations to "As Object" and change any named constants to their intrinsic values (not that you have any in your code). 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'? If the image in PP will be the same size as original the bitmap should be perfect, otherwise experiement with both arguments in CopyPicture. In passing - Set PPApp = Nothing Set PPPres = Nothing Set PPSlide = Nothing Set PPShape = Nothing Always release object references in the reverse order to which they were created. However no need to bother with these at all as they will automatically go out of scope when the sub ends. Regards, Peter T |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Advice & Error Trapping
Lots of questions here. In general when it comes to errors the first line of
defense is to avoid creating the error in the first place. That is the case here for the most part... Question 1 - avoid overwriting. If you use the Dir function you will be able to determine if a file by that name already exists. If you do this prior to saving then you will know if you can just save directly or if you need to get a bit more fancy to avoid overwriting. Question 2&3 - if you can not guarantee the references on the end user computers then you will want to use late binding. In your case that is almost certainly the route you will want to follow. The change is realtively easy. Change your Powerpoint objects to just plain objects. I notice that you are already using the create object method so there is no change required there. The final step is to change any constants from their constant to their underlying value. For example xlUp is a constant that only mkaes sense if you have a reference to XL. Without that reference you need to use the underlying value. To get teh value with the reference still in place just use... Debug.Print xlUp or a message box. As for question 4 I have no idea. Best of luck on that one... -- HTH... Jim Thomlinson "michael.beckinsale" wrote: 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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Advice & Error Trapping
Hi All,
Thank you for your advice & guidance. As l suspected you have confirmed that l really need to go the late binding route. I dont know much about binding in general and will repost as aseperate subject if l have any questions / problems. I will investigate the DIR method as an error trapping solution. Again many thanks Michael |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Error Trapping | Excel Discussion (Misc queries) | |||
while deleting rows it finds an error - error trapping | Excel Programming | |||
Error Trapping | Excel Programming | |||
trapping error | Excel Programming | |||
Error Trapping | Excel Programming |