Sheet CommandButton (ActiveX) Reset to Avoid Resize Issue

breynolds0431

Active Member
Joined
Feb 15, 2013
Messages
303
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have a sheet that includes multiple sign off buttons. My initial problem was that the buttons would resize and move on the sheet. I found a solution over at stackoverflow that seems to do the trick. However, depending on the number of buttons that are on a sheet, the sub can take a considerable amount of time to complete as it needs to go through each button. I'm wondering if this can be made into a function and run on the button clicked rather than loop through all the sheet buttons.

Here is the code that calls the Shared_ObjectReset routine after a button is clicked:

VBA Code:
Private Sub cbC1AL1_Click()

Call pubvariables

If modu.Range("PROV").value = 0 Then
    MsgBox "Error! " & vbCrLf & vbCrLf & "Signoff not allowed as there is nothing selected." _
        , vbCritical, "Make a Selection"
    Call Shared_ObjectReset
    Exit Sub
End If

If cbC1AL1.BackColor = vbRed Then
Else
    If Left(cbC1AL1.Caption, 7) = user Then 'user is in pubvariables as Environ("username")
        Dim ans As Integer
        ans = MsgBox("Would you like to undo the current signoff?", vbYesNo, "Signoff Options")
            If ans = vbYes Then
                With cbC1AL1
                    .BackColor = &HFFFFFF
                    .Font.Bold = False
                    .Height = 30
                    .Height = 24
                    .ForeColor = &H464646
                    .Caption = "SIGN"
                End With
                Call Shared_ObjectReset
                Exit Sub
            End If
    End If
End If

If Left(cbC1AL2.Caption, 7) = user Then 'This checks another button that a supervisor would use to validate the first signoff
    MsgBox "Error! " & vbCrLf & vbCrLf & "You cannot signoff as both the L1 and L2." _
        , vbCritical, "Unable to Sign"
Else 'If not the same person, the button changes colors and records user and date in button's caption
    With cbC1AL1
        .Caption = user & " " & Format(Date, "m/d/yy")
        .BackColor = &H996500
        .ForeColor = vbWhite
        .Font.Bold = True
    End With
    Call UpdateSigList 'Maintains a history of signoffs
End If

Call Shared_ObjectReset

End Sub

Original credit for this goes to user6645884 from the above stackoverflow link. Not sure what the rules are here for posting this, but the post was from 2016.
VBA Code:
Sub Shared_ObjectReset()

Dim MyShapes As OLEObjects
Dim ObjectSelected As OLEObject
Dim ObjectSelected_Height As Double
Dim ObjectSelected_Top As Double
Dim ObjectSelected_Left As Double
Dim ObjectSelected_Width As Double
Dim ObjectSelected_FontSize As Single

ActiveWindow.Zoom = 90

'OLE Programmatic Identifiers for Commandbuttons = Forms.CommandButton.1
Set MyShapes = ActiveSheet.OLEObjects
For Each ObjectSelected In MyShapes
    'Remove this line if fixing active object other than buttons
    If ObjectSelected.progID = "Forms.CommandButton.1" Then
        ObjectSelected_Height = ObjectSelected.Height
        ObjectSelected_Top = ObjectSelected.Top
        ObjectSelected_Left = ObjectSelected.Left
        ObjectSelected_Width = ObjectSelected.Width
        ObjectSelected_FontSize = ObjectSelected.Object.FontSize

        ObjectSelected.Placement = 3

        ObjectSelected.Height = ObjectSelected_Height + 1
        ObjectSelected.Top = ObjectSelected_Top + 1
        ObjectSelected.Left = ObjectSelected_Left + 1
        ObjectSelected.Width = ObjectSelected_Width + 1
        ObjectSelected.Object.FontSize = ObjectSelected_FontSize + 1

        ObjectSelected.Height = ObjectSelected_Height
        ObjectSelected.Top = ObjectSelected_Top
        ObjectSelected.Left = ObjectSelected_Left
        ObjectSelected.Width = ObjectSelected_Width
        ObjectSelected.Object.FontSize = ObjectSelected_FontSize

    End If
Next

'The below was added by me to circumvent another issue when rows are added
Dim obj As OLEObject
For Each obj In ActiveSheet.OLEObjects
    If TypeOf obj.Object Is MSForms.CommandButton Then
        obj.Placement = xlMove
    End If
Next
End Sub
VBA Code:
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

Forum statistics

Threads
1,213,560
Messages
6,114,306
Members
448,564
Latest member
ED38

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