When VBA Fails It Kills PowerPoint 2016

[nullpointer]

I use the following VBA and works perfectly UNTIL I do something that causes it to fail, at which point it kills PowerPoint 2016 and I need to restart.


Sub Finished_600x400() Dim opic As Shape
Dim sngW_Rat As Single
Dim sngH_Rat As Single
Dim Path As String
Dim x As Integer
Const pix_W As Long = 600
Const pix_H As Long = 400
Set opic = ActiveWindow.Selection.ShapeRange(1)
sngW_Rat = (ActivePresentation.PageSetup.SlideWidth / (opic.Width + opic.Line.Weight)) * pix_W
sngH_Rat = (ActivePresentation.PageSetup.SlideHeight / (opic.Height + opic.Line.Weight)) * pix_H
If Val(Application.Version) > 14 Then
sngW_Rat = sngW_Rat * 0.75
sngH_Rat = sngH_Rat * 0.75
End If
Path = "C:\Graphics_ppt\Test_600x400.png"
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
redo:
While checkSize(pix_H, 1) <> "Just Right" Or x > 100 'redoes with lower value if larger than spec
If checkSize(pix_H, 1) = "Too Hot" Then sngH_Rat = sngH_Rat - 1 Else sngH_Rat = sngH_Rat + 1
x = x + 1
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
Wend
x = 0
While checkSize(pix_W, 0) <> "Just Right" Or x > 100 'redoes with lower value if larger than spec
x = x + 1
If checkSize(pix_W, 0) = "Too Hot" Then sngW_Rat = sngW_Rat - 1 Else sngW_Rat = sngW_Rat + 1
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
Wend
End Sub
Function checkSize(lngTarget As Long, dimension As Long) As String
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Dim strSize As String
Dim rayw() As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("C:\Graphics_ppt")
Set objFile = objFolder.ParseName("Test_600x400.png")
strSize = objFile.ExtendedProperty("Dimensions")
strSize = Mid(strSize, 2, Len(strSize) - 2)
rayw = Split(strSize, "x")
Select Case Val(rayw(dimension))
Case Is < lngTarget
checkSize = "Too Cold"
Case Is > lngTarget
checkSize = "Too Hot"
Case Is = lngTarget
checkSize = "Just Right"
End Select
End Function


What can be done so if it does fail it does not kill PowerPoint 2016 - I would prefer it to just throw an error message.

Suggestions

[John Wilson]

Usually something like this but what are you doing to make it fail. It will not be happy with textboxes because they do not return correct values for line weight in some case.


Sub Finished_600x400()

Dim opic As Shape
Dim sngW_Rat As Single
Dim sngH_Rat As Single
Dim Path As String
Dim x As Integer
Const pix_W As Long = 600
Const pix_H As Long = 400
On Error GoTo Err
Set opic = ActiveWindow.Selection.ShapeRange(1)
sngW_Rat = (ActivePresentation.PageSetup.SlideWidth / (opic.Width + opic.Line.Weight)) * pix_W
sngH_Rat = (ActivePresentation.PageSetup.SlideHeight / (opic.Height + opic.Line.Weight)) * pix_H
If Val(Application.Version) > 14 Then
sngW_Rat = sngW_Rat * 0.75
sngH_Rat = sngH_Rat * 0.75
End If
Path = "C:\Graphics_ppt\Test_600x400.png"
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
redo:
While checkSize(pix_H, 1) <> "Just Right" Or x > 100 'redoes with lower value if larger than spec
If checkSize(pix_H, 1) = "Too Hot" Then sngH_Rat = sngH_Rat - 1 Else sngH_Rat = sngH_Rat + 1
x = x + 1
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
Wend
x = 0
While checkSize(pix_W, 0) <> "Just Right" Or x > 100 'redoes with lower value if larger than spec
x = x + 1
If checkSize(pix_W, 0) = "Too Hot" Then sngW_Rat = sngW_Rat - 1 Else sngW_Rat = sngW_Rat + 1
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
Wend
Exit Sub 'Normal Exit
Err: 'Error exit
MsgBox "Error " & Err.Description
End Sub
Function checkSize(lngTarget As Long, dimension As Long) As String
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Dim strSize As String
Dim rayw() As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("C:\Graphics_ppt")
Set objFile = objFolder.ParseName("Test_600x400.png")
strSize = objFile.ExtendedProperty("Dimensions")
strSize = Mid(strSize, 2, Len(strSize) - 2)
rayw = Split(strSize, "x")
Select Case Val(rayw(dimension))
Case Is < lngTarget
checkSize = "Too Cold"
Case Is > lngTarget
checkSize = "Too Hot"
Case Is = lngTarget
checkSize = "Just Right"
End Select
End Function

[Paul_Hossler]

One thing I did notice was that if the picture does not have an outline, the .Line.Weight has garbage in it

16732

[nullpointer]

If I do something like place a WordArt box too close to the edge it fails and requires me to restart PPT. Or, if I have a shape that is outside the slide boundaries, same impact, restart PPT.

[John Wilson]

You definitely need to check

If oshp.Line.Visible and only use the Line weight if true

[nullpointer]

I'm going to admit my ignorance here.

Not what you mean by "If oshp.Line.Visible and only use the Line weight if true"

[Paul_Hossler]

I think maybe something like this




Set opic = ActiveWindow.Selection.ShapeRange(1)

If opic.Line.Visible then
sngW_Rat = (ActivePresentation.PageSetup.SlideWidth / (opic.Width + opic.Line.Weight)) * pix_W
sngH_Rat = (ActivePresentation.PageSetup.SlideHeight / (opic.Height + opic.Line.Weight)) * pix_H

Else
sngW_Rat = (ActivePresentation.PageSetup.SlideWidth / (opic.Width)) * pix_W
sngH_Rat = (ActivePresentation.PageSetup.SlideHeight / (opic.Height)) * pix_H
End If

[nullpointer]

Thanks Paul

I'm unsure as to where I should place your code.

[Paul_Hossler]

Set opic = ActiveWindow.Selection.ShapeRange(1)

replace the 2 lines below that one in John's code in post #2 with the 7 lines I suggested

[nullpointer]

Thanks - I'll give it a go!

[nullpointer]

I was doing pretty good then I moved a WordArt box over the edge if a slide and got a PowerPoint (Not Responding) message.

[nullpointer]

You know what - I think it's good to go. I've been hammering on it and you have to really try to get it to fail.

I super appreciate John and Paul's code corrections and additions.

Thanks guys!!!

[nullpointer]

Wow - I blew it!

You guys helped me with this VBA


Sub Finish_Size_Transparent_600x400()
Dim opic As Shape
Dim sngW_Rat As Single
Dim sngH_Rat As Single
Dim Path As String
Dim x As Integer
Const pix_W As Long = 600
Const pix_H As Long = 400
On Error GoTo Err
Set opic = ActiveWindow.Selection.ShapeRange(1)
If opic.Line.Visible Then
sngW_Rat = (ActivePresentation.PageSetup.SlideWidth / (opic.Width + opic.Line.Weight)) * pix_W
sngH_Rat = (ActivePresentation.PageSetup.SlideHeight / (opic.Height + opic.Line.Weight)) * pix_H

Else
sngW_Rat = (ActivePresentation.PageSetup.SlideWidth / (opic.Width)) * pix_W
sngH_Rat = (ActivePresentation.PageSetup.SlideHeight / (opic.Height)) * pix_H
End If
If Val(Application.Version) > 14 Then
sngW_Rat = sngW_Rat * 0.75
sngH_Rat = sngH_Rat * 0.75
End If
Path = "C:\Graphics_ppt\Test_600x400.png"
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
redo:
While checkSize(pix_H, 1) <> "Just Right" Or x > 100 'redoes with lower value if larger than spec
If checkSize(pix_H, 1) = "Too Hot" Then sngH_Rat = sngH_Rat - 1 Else sngH_Rat = sngH_Rat + 1
x = x + 1
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
Wend
x = 0
While checkSize(pix_W, 0) <> "Just Right" Or x > 100 'redoes with lower value if larger than spec
x = x + 1
If checkSize(pix_W, 0) = "Too Hot" Then sngW_Rat = sngW_Rat - 1 Else sngW_Rat = sngW_Rat + 1
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
Wend
Exit Sub 'Normal Exit
Err: 'Error exit
MsgBox "Error " & Err.Description
End Sub
Function checkSize(lngTarget As Long, dimension As Long) As String
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Dim strSize As String
Dim rayw() As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("C:\Graphics_ppt")
Set objFile = objFolder.ParseName("Test_600x400.png")
strSize = objFile.ExtendedProperty("Dimensions")
strSize = Mid(strSize, 2, Len(strSize) - 2)
rayw = Split(strSize, "x")
Select Case Val(rayw(dimension))
Case Is < lngTarget
checkSize = "Too Cold"
Case Is > lngTarget
checkSize = "Too Hot"
Case Is = lngTarget
checkSize = "Just Right"
End Select
End Function

And, I knew as long as I followed certain guidelines (no text boxes near the edges or otherwise it would kill PPT) everything would be great.

Well, yesterday I shared the VBA with a group of grad students and today I had most of them complain to me the VBA kills PPT. And yes, I told them about the text box near the edge issue. But like most people they just marched ahead and ignored my warnings.

So I'm here again asking if there is any way to stop PPT from dying if a text box is used near the edge of a slide with this VBA?

I would like to use it with more of my students but if I do, in it's current state, I'm afraid of being drug thru the streets and hung in the center of the university.

Any help would be incredibly appreciated.

[Paul_Hossler]

I had a picture on a slide (selected) and a TB half off the slide and I didn't have any crashes (using 2016)

Can you post a small presentation that you can get to crash?


1. BTW, you do make some assumptions about folders being there.:

"C:\Graphics_ppt\Test_600x400.png"

Could that be the problem, or maybe security isses by writing to a root folder???????



2. Also, the picture dimensions do not include any border, so if you want just the picture, you can probably delete the border logic


3. I'm guessing that the x > 100 is an infinite loop counter in


While checkSize(pix_W, 0) <> "Just Right" Or x > 100


but I'd think


While checkSize(pix_W, 0) <> "Just Right" And x < 100

would be better

[John Wilson]

The problem is that for textboxes the check never comes out "Just right" and the x>100 which is meant to stop the loop if it gets to 100 doesn't work so the loop just goes on forever.

I have (hopefully fixed the endless loop and maybe made it more accurate. No guarantees but at least it shouldn't crash as much.


Sub Finish_Size_Transparent_600x400() Dim opic As Shape
Dim sngW_Rat As Single
Dim sngH_Rat As Single
Dim Path As String
Dim x As Integer
Dim origH As Single
Dim origW As Single
Const pix_W As Long = 600
Const pix_H As Long = 400
On Error GoTo Err
Set opic = ActiveWindow.Selection.ShapeRange(1)
origH = opic.Height
origW = opic.Width
If opic.Width <> pix_W Then opic.Width = pix_W
If opic.Height <> pix_H Then opic.Height = pix_H
DoEvents
If opic.Line.Visible Then
sngW_Rat = (ActivePresentation.PageSetup.SlideWidth / (opic.Width + opic.Line.Weight)) * pix_W
sngH_Rat = (ActivePresentation.PageSetup.SlideHeight / (opic.Height + opic.Line.Weight)) * pix_H
Else
sngW_Rat = (ActivePresentation.PageSetup.SlideWidth / (opic.Width)) * pix_W
sngH_Rat = (ActivePresentation.PageSetup.SlideHeight / (opic.Height)) * pix_H
End If
If Val(Application.Version) > 14 Then
sngW_Rat = sngW_Rat * 0.75
sngH_Rat = sngH_Rat * 0.75
End If
Path = "C:\Graphics_ppt\Test_600x400.png"
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
redo:
While checkSize(pix_H, 1) <> "Just Right" And x < 100 'redoes with lower value if larger than spec
If checkSize(pix_H, 1) = "Too Hot" Then sngH_Rat = sngH_Rat - 1 Else sngH_Rat = sngH_Rat + 1
x = x + 1
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
Wend
x = 0
While checkSize(pix_W, 0) <> "Just Right" And x < 100 'redoes with lower value if larger than spec
x = x + 1
If checkSize(pix_W, 0) = "Too Hot" Then sngW_Rat = sngW_Rat - 1 Else sngW_Rat = sngW_Rat + 1
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
Wend
opic.Height = origH
opic.Width = origW
Exit Sub 'Normal Exit
Err: 'Error exit
MsgBox "Error " & Err.Description
End Sub
Function checkSize(lngTarget As Long, dimension As Long) As String
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Dim strSize As String
Dim rayw() As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("C:\Graphics_ppt")
Set objFile = objFolder.ParseName("Test_600x400.png")
strSize = objFile.ExtendedProperty("Dimensions")
strSize = Mid(strSize, 2, Len(strSize) - 2)
rayw = Split(strSize, "x")
Select Case Val(rayw(dimension))
Case Is < lngTarget
checkSize = "Too Cold"
Case Is > lngTarget
checkSize = "Too Hot"
Case Is = lngTarget
checkSize = "Just Right"
End Select
End Function

[nullpointer]

John,

I really appreciate the time you've invested on this!

You're right - it doesn't crash as much.

I thru everything at it and there were times where it gave the appearance of crashing but then settled down and didn't slam PPT down.

Thanks again!!!

[John Wilson]

I don't understand why placing close to the edge causes problems though. No reason I can imagine (yet)

[John Wilson]

I like a challenge though :

Try this with some extra checks


Sub Finish_Size_Transparent_600x400()
Dim opic As Shape
Dim sngW_Rat As Single
Dim sngH_Rat As Single
Dim Path As String
Dim x As Integer
Dim origH As Single
Dim origW As Single
Dim origT As Single
Dim origL As Single
Const pix_W As Long = 600
Const pix_H As Long = 400
On Error GoTo Err
Set opic = ActiveWindow.Selection.ShapeRange(1)
origH = opic.Height
origW = opic.Width
origL = opic.Left
origT = opic.Top
If opic.Width <> pix_W Then opic.Width = pix_W
If opic.Height <> pix_H Then opic.Height = pix_H
opic.Left = 5
opic.Top = 5
DoEvents
If opic.Line.Visible Then
sngW_Rat = (ActivePresentation.PageSetup.SlideWidth / (opic.Width + opic.Line.Weight)) * pix_W
sngH_Rat = (ActivePresentation.PageSetup.SlideHeight / (opic.Height + opic.Line.Weight)) * pix_H
Else
sngW_Rat = (ActivePresentation.PageSetup.SlideWidth / (opic.Width)) * pix_W
sngH_Rat = (ActivePresentation.PageSetup.SlideHeight / (opic.Height)) * pix_H
End If
If Val(Application.Version) > 14 Then
sngW_Rat = sngW_Rat * 0.75
sngH_Rat = sngH_Rat * 0.75
End If
Path = "C:\Graphics_ppt\Test_600x400.png"
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
redo:
While checkSize(pix_H, 1) <> "Just Right" And x < 100 'redoes with lower value if larger than spec
If checkSize(pix_H, 1) = "Too Hot" Then sngH_Rat = sngH_Rat - 0.1 Else sngH_Rat = sngH_Rat + 0.1
x = x + 1
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
Wend
x = 0
While checkSize(pix_W, 0) <> "Just Right" And x < 100 'redoes with lower value if larger than spec
x = x + 1
If checkSize(pix_W, 0) = "Too Hot" Then sngW_Rat = sngW_Rat - 0.1 Else sngW_Rat = sngW_Rat + 0.1
Call opic.Export(Path, ppShapeFormatPNG, sngW_Rat, sngH_Rat)
Wend
opic.Height = origH
opic.Width = origW
opic.Top = origT
opic.Left = origL
Exit Sub 'Normal Exit
Err: 'Error exit
MsgBox "Error " & Err.Description
End Sub
Function checkSize(lngTarget As Long, dimension As Long) As String
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Dim strSize As String
Dim rayw() As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("C:\Graphics_ppt")
Set objFile = objFolder.ParseName("Test_600x400.png")
strSize = objFile.ExtendedProperty("Dimensions")
strSize = Mid(strSize, 2, Len(strSize) - 2)
rayw = Split(strSize, "x")
Select Case Val(rayw(dimension))
Case Is < lngTarget
checkSize = "Too Cold"
Case Is > lngTarget
checkSize = "Too Hot"
Case Is = lngTarget
checkSize = "Just Right"
End Select
End Function

[nullpointer]

John,

You are too funny! You don't let things go! I appreciate that!

I've attached a 1 slide presentation to demonstrate the "PPT Not Responding" situation.

Notice I have an image with a border and then when I place a text box near the left and lower border of the image, run the script, it gives PPT a coronary.

[John Wilson]

No it will not work for grouped shapes properly especially when there are larger than the slide.

I can't fix that!

[nullpointer]

I kind of assumed that's where we were at.

However, thank you for all the time you spent!

[nullpointer]

I kind of figured that's where we were.

However, thank you for all the time you've invested!

[nullpointer]

I kind of assumed that's where we were this.

That being said, I really appreciate all the time you have invested in this!