Toggle button code to add shape and hide shape

woodportaj

New Member
Joined
Jan 22, 2021
Messages
5
Office Version
  1. 2016
Platform
  1. Windows
I am trying to create a code for a toggle button. I want a circle to appear around the button when it is clicked, and I want the circle to be deleted or hidden when the button is clicked again. I'm VERY VERY new to this. I thought I had it but I keep getting an error. This is what I have so far.....

Private Sub ToggleButton1_Click()

If ToggleButton1.Value = True Then
'when the toggle button is not depressed
ActiveSheet.Shapes.AddShape(msoShapeOval, 3, 364.5, 90.75, 40.5).Select
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 2.25
End With
Selection.ShapeRange.ZOrder msoBringToFront
Else
'when the toggle button is depressed
Dim Sh As Shape
For Each Sh In ActiveSheet.Shapes
If Not Application.Intersect(Sh.TopLeftCell, Range("C6:D7")) Is Nothing Then
Sh.Delete

End If


End Sub
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Try this code. The toggle button can be placed anywhere on the sheet and the circle is centred over it with its radius is dependent on the size of the toggle button.
VBA Code:
Private Sub ToggleButton1_Click()

    Dim x As Single, y As Single, r As Single
    Dim shCircle As Shape
    
    'Get x,y centre and radius for circle shape
    With ToggleButton1
        x = .Left + .Width / 2
        y = .Top + .Height / 2
        r = Sqr((.Width / 2) ^ 2 + (.Height / 2) ^ 2) 'hypotenuse of right-angled triangle
    End With
    
    'Find Circle
    Set shCircle = Nothing
    On Error Resume Next
    Set shCircle = ActiveSheet.Shapes("Circle")
    On Error GoTo 0
    
    If ToggleButton1.Value = True Then
        'when the toggle button is not depressed
        If shCircle Is Nothing Then
            'Circle doesn't exist so add new shape
            '                                .AddShape(type,left,top,width,height)
            Set shCircle = ActiveSheet.Shapes.AddShape(msoShapeOval, x - r, y - r, r * 2, r * 2)
            shCircle.Name = "Circle"
            With shCircle.Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Weight = 2.25
                .Transparency = 0
            End With
            shCircle.Fill.Visible = msoFalse
            shCircle.ZOrder msoBringToFront
        Else
            'Position and show existing circle
            With shCircle
                .Left = x - r
                .Top = y - r
                .Width = r * 2
                .Height = r * 2
                .Visible = msoTrue
            End With
        End If
    Else
        'when the toggle button is depressed
        If Not shCircle Is Nothing Then
            'Position and hide existing circle
            With shCircle
                .Left = x - r
                .Top = y - r
                .Width = r * 2
                .Height = r * 2
                .Visible = msoFalse
            End With
        End If
    End If

End Sub
 
Upvote 0
Try this code. The toggle button can be placed anywhere on the sheet and the circle is centred over it with its radius is dependent on the size of the toggle button.
VBA Code:
Private Sub ToggleButton1_Click()

    Dim x As Single, y As Single, r As Single
    Dim shCircle As Shape
   
    'Get x,y centre and radius for circle shape
    With ToggleButton1
        x = .Left + .Width / 2
        y = .Top + .Height / 2
        r = Sqr((.Width / 2) ^ 2 + (.Height / 2) ^ 2) 'hypotenuse of right-angled triangle
    End With
   
    'Find Circle
    Set shCircle = Nothing
    On Error Resume Next
    Set shCircle = ActiveSheet.Shapes("Circle")
    On Error GoTo 0
   
    If ToggleButton1.Value = True Then
        'when the toggle button is not depressed
        If shCircle Is Nothing Then
            'Circle doesn't exist so add new shape
            '                                .AddShape(type,left,top,width,height)
            Set shCircle = ActiveSheet.Shapes.AddShape(msoShapeOval, x - r, y - r, r * 2, r * 2)
            shCircle.Name = "Circle"
            With shCircle.Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Weight = 2.25
                .Transparency = 0
            End With
            shCircle.Fill.Visible = msoFalse
            shCircle.ZOrder msoBringToFront
        Else
            'Position and show existing circle
            With shCircle
                .Left = x - r
                .Top = y - r
                .Width = r * 2
                .Height = r * 2
                .Visible = msoTrue
            End With
        End If
    Else
        'when the toggle button is depressed
        If Not shCircle Is Nothing Then
            'Position and hide existing circle
            With shCircle
                .Left = x - r
                .Top = y - r
                .Width = r * 2
                .Height = r * 2
                .Visible = msoFalse
            End With
        End If
    End If

End Sub
PERFECT!!

I have multiple toggle boxes, how can I keep some of the boxes circled? Is that possible to have different functions for each toggle box? Like shown below

 

Attachments

  • Untitled.png
    Untitled.png
    47.4 KB · Views: 17
Upvote 0
The simplest way, without the complication of a class handler for multiple toggle buttons, is this:
VBA Code:
Private Sub ToggleButton1_Click()
    TB_Click ToggleButton1
End Sub

Private Sub ToggleButton2_Click()
    TB_Click ToggleButton2
End Sub

Private Sub ToggleButton3_Click()
    TB_Click ToggleButton3
End Sub

Private Sub TB_Click(tb As ToggleButton)

    Dim x As Single, y As Single, r As Single
    Dim shCircle As Shape
    
    'Get x,y centre and radius for circle shape
    With tb
        x = .Left + .Width / 2
        y = .Top + .Height / 2
        r = Sqr((.Width / 2) ^ 2 + (.Height / 2) ^ 2) 'hypotenuse of right-angled triangle
    End With
    
    'Find Circle for this toggle button
    Set shCircle = Nothing
    On Error Resume Next
    Set shCircle = ActiveSheet.Shapes(tb.Name & "_Circle")
    On Error GoTo 0
    
    If tb.Value = True Then
        'when the toggle button is not depressed
        If shCircle Is Nothing Then
            'Circle doesn't exist so add new shape
            '                                .AddShape(type,left,top,width,height)
            Set shCircle = ActiveSheet.Shapes.AddShape(msoShapeOval, x - r, y - r, r * 2, r * 2)
            shCircle.Name = tb.Name & "_Circle"
            With shCircle.Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Weight = 2.25
                .Transparency = 0
            End With
            shCircle.Fill.Visible = msoFalse
            shCircle.ZOrder msoBringToFront
        Else
            'Position and show existing circle
            With shCircle
                .Left = x - r
                .Top = y - r
                .Width = r * 2
                .Height = r * 2
                .Visible = msoTrue
            End With
        End If
    Else
        'when the toggle button is depressed
        If Not shCircle Is Nothing Then
            'Position and hide existing circle
            With shCircle
                .Left = x - r
                .Top = y - r
                .Width = r * 2
                .Height = r * 2
                .Visible = msoFalse
            End With
        End If
    End If

End Sub
Just add as many Private Sub ToggleButtonX_Click routines as you need.
 
Upvote 0
The simplest way, without the complication of a class handler for multiple toggle buttons, is this:
VBA Code:
Private Sub ToggleButton1_Click()
    TB_Click ToggleButton1
End Sub

Private Sub ToggleButton2_Click()
    TB_Click ToggleButton2
End Sub

Private Sub ToggleButton3_Click()
    TB_Click ToggleButton3
End Sub

Private Sub TB_Click(tb As ToggleButton)

    Dim x As Single, y As Single, r As Single
    Dim shCircle As Shape
   
    'Get x,y centre and radius for circle shape
    With tb
        x = .Left + .Width / 2
        y = .Top + .Height / 2
        r = Sqr((.Width / 2) ^ 2 + (.Height / 2) ^ 2) 'hypotenuse of right-angled triangle
    End With
   
    'Find Circle for this toggle button
    Set shCircle = Nothing
    On Error Resume Next
    Set shCircle = ActiveSheet.Shapes(tb.Name & "_Circle")
    On Error GoTo 0
   
    If tb.Value = True Then
        'when the toggle button is not depressed
        If shCircle Is Nothing Then
            'Circle doesn't exist so add new shape
            '                                .AddShape(type,left,top,width,height)
            Set shCircle = ActiveSheet.Shapes.AddShape(msoShapeOval, x - r, y - r, r * 2, r * 2)
            shCircle.Name = tb.Name & "_Circle"
            With shCircle.Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Weight = 2.25
                .Transparency = 0
            End With
            shCircle.Fill.Visible = msoFalse
            shCircle.ZOrder msoBringToFront
        Else
            'Position and show existing circle
            With shCircle
                .Left = x - r
                .Top = y - r
                .Width = r * 2
                .Height = r * 2
                .Visible = msoTrue
            End With
        End If
    Else
        'when the toggle button is depressed
        If Not shCircle Is Nothing Then
            'Position and hide existing circle
            With shCircle
                .Left = x - r
                .Top = y - r
                .Width = r * 2
                .Height = r * 2
                .Visible = msoFalse
            End With
        End If
    End If

End Sub
Just add as many Private Sub ToggleButtonX_Click routines as you need.
Thank You!!
 
Upvote 0

Forum statistics

Threads
1,213,497
Messages
6,114,002
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top