Consulting

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

Thread: Change Fill color using VBA in PowerPoint

  1. #1

    Change Fill color using VBA in PowerPoint

    I have 10 hexagon shape(having other shape also ie rectangle, square) & having four animation(Entrance:Appear, Motion paths : down, Emphasis:Fill color(given Blue color), Motion paths:Left) with fixed delay.
    During starting animation(during entrance) hexagon color is Red & when meet emphasis animation it become Blue color & remain Blue for remaining animations.
    Now I want to change both color through VBA code. I am abale to change only entrance color(ie Red to my coustom color) through below code:




    Sub addColorhexagon()
    
    
     Dim hshp As Shape
     Dim osld As Slide
     Dim r As Long
     Dim g As Long
     Dim b As Long
     On Error Resume Next
    
    
    r = InputBox("Please enter Red number in: RGB(red,green,blue)", "Change Top Shape Color", "068")
    g = InputBox("Please enter Green number in: RGB(red,green,blue)", "Change Top Shape Color", "114")
    b = InputBox("Please enter Blue number in: RGB(red,green,blue)", "Change Top Shape Color", "196")
    
    
     Set osld = ActivePresentation.Slides(1)
    
    
     For j = 1 To 10
    
    
     Set hshp = osld.Shapes("hexagon" & j)
     hshp.Fill.ForeColor.RGB = RGB(r, g, b)
     hshp.Fill.Solid
     Next j
     On Error GoTo errhandler
    Exit Sub
    errhandler:
    MsgBox "Opps!"
    
    
    End Sub
    So How can I change the Blue color (Emphasis:Fill color ie Blue) to my custom color?
    Please help

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Posts
    7,825
    Location
    1. Don't put On Error Resume Next as the first thing. You need to see the error to correct them
    Only use it in specific places where you KNOW it's OK to ignore an error

    2. The shape's default name is "Hexagon<space>3", etc.
    Unless you renamed them, no shape would match

    3. If you just want to make all the hexagons blue, there's better, more robust ways to to it that doesn't require match names, etc.
    See the second version


    Option Explicit
    
    
    Sub addColorhexagon()
        Dim hshp As Shape
        Dim osld As Slide
        Dim j As Long
        Dim r As Long
        Dim g As Long
        Dim b As Long
    
    
        r = InputBox("Please enter Red number in: RGB(red,green,blue)", "Change Top Shape Color", "068")
        g = InputBox("Please enter Green number in: RGB(red,green,blue)", "Change Top Shape Color", "114")
        b = InputBox("Please enter Blue number in: RGB(red,green,blue)", "Change Top Shape Color", "196")
    
    
        Set osld = ActivePresentation.Slides(1)
    
    
        'testing
        osld.Shapes("Hexagon 3").Fill.ForeColor.RGB = RGB(r, g, b)
     
    '    On Error Resume Next
    '    For j = 1 To 10
    '        Set hshp = osld.Shapes("hexagon" & j)
    '        hshp.Fill.ForeColor.RGB = RGB(r, g, b)
    '        hshp.Fill.Solid
    '    Next j
    '    On Error GoTo 0
    
    
    End Sub


    
    Sub addColorhexagon_1()
        Dim oPres As Presentation
        Dim oShape As Shape
        Dim oSlide As Slide
        Dim j As Long
        Dim r As Long
        Dim g As Long
        Dim b As Long
    
    
        r = InputBox("Please enter Red number in: RGB(red,green,blue)", "Change Top Shape Color", "068")
        g = InputBox("Please enter Green number in: RGB(red,green,blue)", "Change Top Shape Color", "114")
        b = InputBox("Please enter Blue number in: RGB(red,green,blue)", "Change Top Shape Color", "196")
    
    
    
    
        Set oPres = ActivePresentation
            
        For Each oSlide In oPres.Slides
            For Each oShape In oSlide.Shapes
                If oShape.Type = msoAutoShape Then
                    If oShape.AutoShapeType = msoShapeHexagon Then
                        oShape.Fill.ForeColor.RGB = RGB(r, g, b)
                    End If
                End If
            Next
        Next
    
    
    End Sub
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    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) / 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

  3. #3
    Thanks Sir @Paul_Hossler
    The above both codes are working fine to make the Hexagon shape(red color) to any custom color before the start of Emphasis:Fill color(given Blue color) animation.
    So when the Emphasis:Fill color animation starts it changes to its original Blue color & remain blue for the end. Actually I wanted to change that fill color (blue) to any custom color.
    Thanks again sir to make an interest to solve my problem

  4. #4
    VBAX Sage
    Joined
    Apr 2007
    Posts
    7,825
    Location
    If the above doesn't work for you, then I'm not understanding

    Attach a small presentation and add detailed instructions/examples, then I'll look again
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    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) / 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

  5. #5
    Thanks Sir @Paul_Hossler
    I am attached a small presentation where I want to change Blue color to any custom color.
    With the help of above two code which u provided Red color changes to any custom color(solved).

    Note: I name shape "hexagon1" to "
    Heptagon1", "Heptagon2" "Heptagon3".....in PowerPoint presentation ie in example.pptx

    Attached Files Attached Files

  6. #6
    VBAX Sage
    Joined
    Apr 2007
    Posts
    7,825
    Location
    This is what you requested, but I'm not sure it's what you need

    where I want to change Blue color to any custom color.
    There were no blue shapes in your example, so I made them blue

    Capture.JPG

    Option Explicit
    
    
    Sub test()
        Dim hshp As Shape
        Dim osld As Slide
        Dim j As Long
        Dim r As Long
        Dim g As Long
        Dim b As Long
    
    
    
    
        r = InputBox("Please enter Red number in: RGB(red,green,blue)", "Change Top Shape Color", "068")
        g = InputBox("Please enter Green number in: RGB(red,green,blue)", "Change Top Shape Color", "114")
        b = InputBox("Please enter Blue number in: RGB(red,green,blue)", "Change Top Shape Color", "196")
    
    
    
    
        Set osld = ActivePresentation.Slides(1)
        On Error Resume Next
        For j = 1 To 10
            Set hshp = osld.Shapes("Heptagon" & j)
            If hshp.Fill.ForeColor.RGB = RGB(0, 0, 255) Then
                hshp.Fill.ForeColor.RGB = RGB(r, g, b)
                hshp.Fill.Solid
            End If
        Next j
        On Error GoTo 0
    
    
    End Sub
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    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) / 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

  7. #7
    Thanks Sir @Paul_Hossler
    Sir run the presentation this red shape turn into blue & remains blue till the end.I want to change that blue color.
    Thanks again sir.

  8. #8
    VBAX Sage
    Joined
    Apr 2007
    Posts
    7,825
    Location
    Sorry, when I started the slide show, all I saw was the background. When I clicked, it ended. I did not wait long enough

    Option Explicit
    Sub test()
        Dim j As Long
        Dim r As Long
        Dim g As Long
        Dim b As Long
        Dim oMainSeq As Sequence
    
    
        r = InputBox("Please enter Red number in: RGB(red,green,blue)", "Change Top Shape Color", "068")
        g = InputBox("Please enter Green number in: RGB(red,green,blue)", "Change Top Shape Color", "114")
        b = InputBox("Please enter Blue number in: RGB(red,green,blue)", "Change Top Shape Color", "196")
    
    
        Set oMainSeq = ActivePresentation.Slides(1).TimeLine.MainSequence
        
        For j = 1 To oMainSeq.Count
            With oMainSeq(j)
                If .EffectType = msoAnimEffectChangeFillColor Then
                    If .Shape.Type = msoAutoShape Then
                        If .Shape.AutoShapeType = msoShapeHeptagon Then
                            .Behaviors(3).SetEffect.Property = msoAnimShapeFillColor
                            .Behaviors(3).SetEffect.To = RGB(r, g, b)
                        End If
                            
                    End If
                    
                End If
            End With
        Next j
    
    
        MsgBox "Done"
    
    
    End Sub

    See if I'm understanding better with this one
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    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) / 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

  9. #9
    Thanks Sir @Paul_Hossler
    Now it is perfectly working as i wanted. In this universe there are few people having knowledge of PowerPoint vba you are one of them. Thanks again sir to save me lot of time.
    Sir one last request to you , How can i replace heptagonal shape to another shape like hexagon, octagon which is keep in other PowerPoint presentation & import to this slide without affecting the animation.
    Last edited by dibyendu2280; 05-13-2021 at 01:56 AM.

  10. #10
    VBAX Sage
    Joined
    Apr 2007
    Posts
    7,825
    Location
    1. Temporarily insert a sample of the shape that you want to change to

    2. Select it

    3. Run test2()

    4. All AutoShapes on all slides will be changed to that (#1 above) shape (you can change to just Slide(1) )

    5. The temp shape will be deleted


    The original names and original sizes of the shapes don't change, so they're still called "Heptagon1" and the new shape fits into the old shape's box

    Sub test2()
        Dim oPres As Presentation
        Dim oSlide As Slide
        Dim oShape As Shape, oNewShape As Shape
        
        
        Set oNewShape = Nothing
        On Error Resume Next
        Set oNewShape = ActiveWindow.Selection.ShapeRange(1)
        On Error GoTo 0
        
        If oNewShape Is Nothing Then
            Call MsgBox("You must select an AutoShape", vbCritical + vbOKOnly, "Change Shapes")
            Exit Sub
        End If
        
        If oNewShape.Type <> msoAutoShape Then
            Call MsgBox("The selected Shape must be an AutoShape", vbCritical + vbOKOnly, "Change Shapes")
            Exit Sub
        End If
        
        Set oPres = ActivePresentation
        
        For Each oSlide In oPres.Slides
            For Each oShape In oSlide.Shapes
                If oShape.Type = msoAutoShape Then oShape.AutoShapeType = oNewShape.AutoShapeType
            Next
        Next
    
    
        oNewShape.Delete
        
    
    
    End Sub
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    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) / 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

  11. #11
    Thanks Sir @Paul_Hossler
    Working great. Sir i am asking too much question to you & you are giving all solution to my problem. now I implemented above code in my project & it changes all shapes(including all rectangle shape) to hexagon shape. So how to select particular shape(in my case heptagon) to change to hexagon shape.(do not want to change other shape like rectangle shape to hexagon shape).

  12. #12
    VBAX Sage
    Joined
    Apr 2007
    Posts
    7,825
    Location
    Best I can come up with

    1. Insert hexagon shape on slide
    2. Select it
    3. Run macro Step1

    4. Select a heptagon shape
    5. Run macro Step2



    Option Explicit
    
    
    Dim oNewShape As Shape
    
    
    Sub Step1()
        If MsgBox("This is Step1 of a two step process" & vbCrLf & vbCrLf & _
            "1. You must already have inserted and selected a new Shape to change to" & vbCrLf & _
            "2. After running, Step1 will remember the new type of shape" & vbCrLf & _
            "3. Select one of the shapes to be changed" & vbCrLf & _
            "4. Run the Step2 Macro", vbOKCancel + vbInformation, "Change Shapes") = vbCancel Then Exit Sub
        
        
        
        Set oNewShape = Nothing
        On Error Resume Next
        Set oNewShape = ActiveWindow.Selection.ShapeRange(1)
        On Error GoTo 0
        
        If oNewShape Is Nothing Then
            Call MsgBox("You must select an AutoShape", vbCritical + vbOKOnly, "Change Shapes")
            Exit Sub
        End If
        
        If oNewShape.Type <> msoAutoShape Then
            Call MsgBox("The selected Shape must be an AutoShape", vbCritical + vbOKOnly, "Change Shapes")
            Exit Sub
        End If
    
    
        Call MsgBox("Destination Shape type memorized", vbOK + vbInformation, "Change Shapes")
    
    
    
    
    End Sub
    
    
    Sub Step2()
        Dim oPres As Presentation
        Dim oSlide As Slide
        Dim oShape As Shape, oChangeShape As Shape
        Dim oChangeShapeType As MsoAutoShapeType
        
        If MsgBox("This is Step2 of a two step process" & vbCrLf & vbCrLf & _
            "1. You must already have selected an instance of a Shape to change" & vbCrLf & _
            "2. All instances on all slides of that type of Shape will be changes", vbOKCancel + vbInformation, "Change Shapes") = vbCancel Then Exit Sub
        
        If oNewShape Is Nothing Then
            Call MsgBox("1. You must select an example of a new AutoShape to change the shapes to" & vbCrLf & _
                "2. Re-run Step1", vbCritical + vbOKOnly, "Change Shapes")
            Exit Sub
        End If
        
        
        Set oChangeShape = Nothing
        On Error Resume Next
        Set oChangeShape = ActiveWindow.Selection.ShapeRange(1)
        On Error GoTo 0
        
        If oChangeShape Is Nothing Then
            Call MsgBox("You must select an AutoShape of the type to be changed", vbCritical + vbOKOnly, "Change Shapes")
            Exit Sub
        End If
        
        If oChangeShape.Type <> msoAutoShape Then
            Call MsgBox("The selected Shape must be an AutoShape", vbCritical + vbOKOnly, "Change Shapes")
            Exit Sub
        End If
        
        oChangeShapeType = oChangeShape.AutoShapeType
        
        Set oPres = ActivePresentation
        
        For Each oSlide In oPres.Slides
            For Each oShape In oSlide.Shapes
                If oShape.Type = msoAutoShape Then
                    If oShape.AutoShapeType = oChangeShapeType Then
                        oShape.AutoShapeType = oNewShape.AutoShapeType
                    End If
                End If
            Next
        Next
    
        Call MsgBox("Destination Shape type(s) Changed", vbOK + vbInformation, "Change Shapes")
        
        oNewShape.Delete
    
    End Sub
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    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) / 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

  13. #13
    Thanks Sir @Paul_Hossler
    Working perfectly. I have no words to appreciate you. May god bless you.

  14. #14
    VBAX Sage
    Joined
    Apr 2007
    Posts
    7,825
    Location
    There are more elegant (and less confusing) ways to do it using a UserForm and some lists

    Let me know if youwant/need to upgrade the macros
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    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) / 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
    Quote Originally Posted by Paul_Hossler View Post
    There are more elegant (and less confusing) ways to do it using a UserForm and some lists

    Let me know if youwant/need to upgrade the macros
    Thanks Sir @Paul_Hossler
    Yes I need the upgrade micros.
    Sir want to implement above micros in my other project where hexagon shape is inside a group & wanted to change it to heptagon shape(there are other shape also ie rectangular shape) but gets error message "Selected Shape must be an AutoShape"
    I uploaded the presentation. please look if possible. Thanks again.
    Attached Files Attached Files
    Last edited by dibyendu2280; 05-14-2021 at 11:29 AM.

  16. #16
    VBAX Sage
    Joined
    Apr 2007
    Posts
    7,825
    Location
    Some changes to Step2

    Slide 2 has a Group


    Option Explicit
    
    
    Dim oNewShape As Shape
    Dim tNewType As MsoAutoShapeType
    
    
    Sub Step1()
        If MsgBox("This is Step1 of a two step process" & vbCrLf & vbCrLf & _
            "1. You must already have inserted and selected a new Shape to change to" & vbCrLf & _
            "2. After running, Step1 will remember the new type of shape" & vbCrLf & _
            "3. Select one of the shapes to be changed" & vbCrLf & _
            "4. Run the Step2 Macro", vbOKCancel + vbInformation, "Change Shapes") = vbCancel Then Exit Sub
        
        
        
        Set oNewShape = Nothing
        On Error Resume Next
        Set oNewShape = ActiveWindow.Selection.ShapeRange(1)
        tNewType = oNewShape.AutoShapeType
        On Error GoTo 0
        
        If oNewShape Is Nothing Then
            Call MsgBox("You must select an AutoShape", vbCritical + vbOKOnly, "Change Shapes")
            Exit Sub
        End If
        
        If oNewShape.Type <> msoAutoShape Then
            Call MsgBox("The selected Shape must be an AutoShape", vbCritical + vbOKOnly, "Change Shapes")
            Exit Sub
        End If
    
    
        Call MsgBox("Destination Shape type memorized", vbOK + vbInformation, "Change Shapes")
    
    
    
    
    End Sub
    
    
    Sub Step2()
        Dim oPres As Presentation
        Dim oSlide As Slide
        Dim oShape As Shape, oChangeShape As Shape, oShapeInGroup As Shape
        Dim tCurrentType As MsoAutoShapeType
        
        If MsgBox("This is Step2 of a two step process" & vbCrLf & vbCrLf & _
            "1. You must already have selected an instance of a Shape to change" & vbCrLf & _
            "2. All instances on all slides of that type of Shape will be changes", vbOKCancel + vbInformation, "Change Shapes") = vbCancel Then Exit Sub
        
        If oNewShape Is Nothing Then
            Call MsgBox("1. You must select an example of a new AutoShape to change the shapes to" & vbCrLf & _
                "2. Re-run Step1", vbCritical + vbOKOnly, "Change Shapes")
            Exit Sub
        End If
        
        
        Set oChangeShape = Nothing
        On Error Resume Next
        Set oChangeShape = ActiveWindow.Selection.ShapeRange(1)
        On Error GoTo 0
        
        If oChangeShape Is Nothing Then
            Call MsgBox("You must select an AutoShape of the type to be changed", vbCritical + vbOKOnly, "Change Shapes")
            Exit Sub
        End If
        
        If oChangeShape.Type <> msoAutoShape Then
            Call MsgBox("The selected Shape must be an AutoShape", vbCritical + vbOKOnly, "Change Shapes")
            Exit Sub
        End If
        
        tCurrentType = oChangeShape.AutoShapeType
        
        Set oPres = ActivePresentation
        
        For Each oSlide In oPres.Slides
            For Each oShape In oSlide.Shapes
                If oShape.Type = msoGroup Then
                    For Each oShapeInGroup In oShape.GroupItems
                        Call pvtChangeAutoShapeType(oShapeInGroup, tCurrentType, tNewType)
                    Next
                
                Else
                    Call pvtChangeAutoShapeType(oShape, tCurrentType, tNewType)
                End If
            Next
        Next
    
    
        oNewShape.Delete
    End Sub
    
    
    
    
    Private Sub pvtChangeAutoShapeType(o As Shape, tCurrent As MsoAutoShapeType, tNew As MsoAutoShapeType)
        With o
            If .Type <> msoAutoShape Then Exit Sub
            If .AutoShapeType <> tCurrent Then Exit Sub
    
    
            .AutoShapeType = tNew
        End With
    End Sub
    Attached Files Attached Files
    Last edited by Paul_Hossler; 05-14-2021 at 01:46 PM.
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    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) / 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

  17. #17
    Thanks Sir @Paul_Hossler
    Working like
    a charm. You are the most helpful person in this forum. May god bless you.

  18. #18
    Thanks Sir @Paul_Hossler
    Shape is exactly change to my desire custom shape which i inserted in presentation but not the size(ie length, width, height). As a example, I want to change hexagon shape to heptagon shape so I inserted a heptagonal shape & run micros it changes all hexagonal shape to heptagonal shape . It changes only shape but not the exact size of heptagon which I inserted. Is it possible to change the size of hexagonal to the size of heptagonal shape. Sir please look into if some modification in above micros doe the job.

  19. #19
    VBAX Sage
    Joined
    Apr 2007
    Posts
    7,825
    Location
    Sure
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    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) / 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

  20. #20
    Thanks Sir @Paul_Hossler,
    Working nice. Now I customize my shape size. I have no words to appreciates you. May god bless you. Sir I implement above micro in my project & shape size changes as I wanted but not replacing shape center to center(ie not align center/concentric both shape) & final shape not align to center of the previous shape. Please see the presentation. I try adding .Top & .Left in below code but no luck. Please advice sir

    Private Sub pvtChangeAutoShapeType(o As Shape)
    With o
    If .Type <> msoAutoShape Then Exit Sub
    If .AutoShapeType <> tShapeToChange Then Exit Sub


    .AutoShapeType = tShapeAfterChange

    .Height = oShapeAfterChange.Height
    .Width = oShapeAfterChange.Width

    .Top =
    oShapeAfterChange.Width.Top
    .Left = oShapeAfterChange.Left



    End With
    End Sub
    Attached Files Attached Files

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
  •