Consulting

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 23

Thread: When VBA Fails It Kills PowerPoint 2016

  1. #1

    When VBA Fails It Kills PowerPoint 2016

    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

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,815
    Location
    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,497
    Location
    One thing I did notice was that if the picture does not have an outline, the .Line.Weight has garbage in it

    Capture.JPG
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  4. #4
    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.

  5. #5
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,815
    Location
    You definitely need to check

    If oshp.Line.Visible and only use the Line weight if true
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  6. #6
    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"



  7. #7
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,497
    Location
    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
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  8. #8
    Thanks Paul

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

  9. #9
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,497
    Location
    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
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  10. #10
    Thanks - I'll give it a go!

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

  12. #12
    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!!!

  13. #13
    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.

  14. #14
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,497
    Location
    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
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  15. #15
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,815
    Location
    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  16. #16
    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!!!

  17. #17
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,815
    Location
    I don't understand why placing close to the edge causes problems though. No reason I can imagine (yet)
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  18. #18
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,815
    Location
    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  19. #19

    Here's a Small Presentation Where it Fails

    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.
    Attached Files Attached Files

  20. #20
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,815
    Location
    No it will not work for grouped shapes properly especially when there are larger than the slide.

    I can't fix that!
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •