Check Box

[mks]

Hi ,

I have following macros for check box, but I need your help to modified this macros to suit my requirement. Is this possible if I check the box it show "Attached" in check box caption, but if it is black or cross than caption should be " Requested". Thanks for help.

Macors as follows -

Sub AddCheckBox()
Dim cell As Range
DelCheckBox 'Do the delete macro
'or delete all checkboxes in the worksheet
'ActiveSheet.CheckBoxes.Delete
For Each cell In Range("F15:F21,F24:F25")
With ActiveSheet.CheckBoxes.Add(cell.Left, _
cell.Top, cell.Width, cell.Height)

.LinkedCell = cell.Offset(, 0).Address(External:="")
.Interior.ColorIndex = xlAutomatic 'or xlNone or xlAutomatic
.Caption = "Attached"
.Border.Weight = xlThin
End With
Next
With Range("F15:F21,F24:F25")
'.Rows.RowHeight = xlAutomatic
End With
End Sub
-------------------------------

Sub DelCheckBox()
For Each cell In Range("F15:F21,F24:F25")
Worksheets("Check List").CheckBoxes.Delete
Next
End Sub

 

[AlphaFrog]

Sub AddCheckBox()
    Dim cell   As Range
    DelCheckBox    'Do the delete macro
    'or delete all checkboxes in the worksheet
    'ActiveSheet.CheckBoxes.Delete
    For Each cell In Range("F15:F21,F24:F25")
        With ActiveSheet.CheckBoxes.Add(cell.Left, _
                                        cell.Top, cell.Width, cell.Height)

            .LinkedCell = cell.Offset(, 0).Address(External:="")
            .Interior.ColorIndex = xlAutomatic    'or xlNone or xlAutomatic
            .Caption = "Attached"
            .Border.Weight = xlThin
            [COLOR="Red"].OnAction = "CB_Toggle"[/COLOR]
        End With
    Next
    With Range("F15:F21,F24:F25")
        '.Rows.RowHeight = xlAutomatic
    End With
End Sub

Sub DelCheckBox()
    For Each cell In Range("F15:F21,F24:F25")
        Worksheets("Check List").CheckBoxes.Delete
    Next
End Sub

[COLOR="Red"]Private Sub CB_Toggle()
    Dim CB As CheckBox
    Set CB = Worksheets("Check List").CheckBoxes(Application.Caller)
    If CB.Value = 1 Then
        CB.Caption = "Requested"
    Else
        CB.Caption = "Attached"
    End If
End Sub[/COLOR]

 

[mks]

Thanks,

Work Perfect, Can we increase the font size of caption as it very small at present.

Thanks

 

[AlphaFrog]

Other than changing the zoom setting for the worksheet, I don't think you can change the font size of a Forms control checkbox.

 

[AlphaFrog]

You could use the ActiveX type checkbox from the Control Toolbox toolbar instead of the Forms Control type checkbox. You could set the font size of an ActiveX type checkbox. However, you cant assign a macro to an ActiveX checkbox. You would have to do something like this to get each ActiveX checkbox to run the one toggle procedure.

As an alternative, the code below adds the Form control checkboxes as before, but without any captions. It also adds Forms control Textboxes behind each checkbox to act as the caption of the checkbox. You can change the font of the Textboxes. It's a bit of a kludge but it seems to work.

Sub AddCheckBox()
    Dim cell   As Range
    DelCheckBox    'Do the delete macro
    'or delete all checkboxes in the worksheet
    'ActiveSheet.CheckBoxes.Delete
    For Each cell In Range("F15:F21,F24:F25")

        With ActiveSheet.TextBoxes.Add(cell.Left, _
                                       cell.Top, cell.Width, cell.Height)
              .Caption = "    Attached"
              .Font.Size = 10
              .VerticalAlignment = xlCenter
              .Name = "TB" & cell.Address(0, 0)
        End With
        With ActiveSheet.CheckBoxes.Add(cell.Left, _
                                        cell.Top, cell.Width, cell.Height)
        
            .LinkedCell = cell.Offset(, 0).Address(External:="")
            .Interior.ColorIndex = xlNone    'or xlNone or xlAutomatic
            '.Caption = "Attached"
            .Caption = ""
            .Border.Weight = xlThin
            .Name = "CB" & cell.Address(0, 0)
            .OnAction = "CB_Toggle"
        End With
    Next
    With Range("F15:F21,F24:F25")
        '.Rows.RowHeight = xlAutomatic
    End With
End Sub

Sub DelCheckBox()
    Dim cell As Range
    On Error Resume Next
    With Worksheets("Check List")
        For Each cell In .Range("F15:F21,F24:F25")
            .CheckBoxes("CB" & cell.Address(0, 0)).Delete
            .TextBoxes("TB" & cell.Address(0, 0)).Delete
        Next
    End With
End Sub

Private Sub CB_Toggle()
    Dim CB As CheckBox, TB As TextBox
    Set CB = Worksheets("Check List").CheckBoxes(Application.Caller)
    Set TB = Worksheets("Check List").TextBoxes(Replace(Application.Caller, "CB", "TB"))
    If CB.Value = 1 Then
        TB.Caption = "    Requested"
    Else
        TB.Caption = "    Attached"
    End If
End Sub