Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Attribute VB_Name = "CheckedRange"
- Attribute VB_PredeclaredId = True
- Option Explicit
- Public Enum WingdingsCharCode
- CheckBoxChecked = 254
- CheckBoxUnchecked = 168
- XMark = 251
- CheckMark = 252
- End Enum
- Public Enum CheckedRangeTheme
- ctCheckBoxes
- ctCheckmarks
- ctTrueFalse
- ctYesNo
- End Enum
- Private Type Members
- CheckedCode As Long
- CheckedColor As String
- CheckedString As String
- EditMode As Boolean
- FontName As String
- PrevAddress As String
- RangeFormula As String
- Theme As CheckedRangeTheme
- TrueFalse As Boolean
- UnCheckedCode As Long
- UnCheckedColor As String
- UnCheckedString As String
- YesNo As Boolean
- End Type
- Private this As Members
- Public Event Clicked(Target As Range)
- Public WithEvents Worksheet As Worksheet
- Attribute Worksheet.VB_VarHelpID = -1
- Private m_bUseYesNo As Boolean
- Private m_sCheckedString As String
- Private m_sUnCheckedString As String
- Private m_bEditMode As Boolean
- Private Sub Class_Initialize()
- EditMode = True
- Me.Theme = CheckedRangeTheme.ctCheckBoxes
- EditMode = False
- End Sub
- Public Property Get CheckedCode() As WingdingsCharCode
- CheckedCode = this.CheckedCode
- End Property
- Public Property Let CheckedCode(ByVal Value As WingdingsCharCode)
- CheckedString = Chr(Value)
- this.CheckedCode = Value
- End Property
- Public Property Get CheckedColor() As String
- CheckedColor = this.CheckedColor
- End Property
- Public Property Let CheckedColor(ByVal Value As String)
- this.CheckedColor = Value
- End Property
- Public Property Get CheckedString() As String
- CheckedString = this.CheckedString
- End Property
- Public Property Let CheckedString(ByVal Value As String)
- this.CheckedString = Value
- End Property
- Public Property Get FontName() As String
- FontName = this.FontName
- End Property
- Public Property Let FontName(ByVal Value As String)
- this.FontName = Value
- End Property
- Public Property Get NumberFormat() As String
- Dim CheckedColor As String, UnCheckedColor As String
- CheckedColor = IIf(Len(this.CheckedColor) > 0, "[" & this.CheckedColor & "]", "")
- UnCheckedColor = IIf(Len(this.UnCheckedColor) > 0, "[" & this.UnCheckedColor & "]", "")
- NumberFormat = ";" & CheckedColor & Chr(34) & this.CheckedString & Chr(34) & _
- ";" & UnCheckedColor & Chr(34) & this.UnCheckedString & Chr(34)
- End Property
- Public Property Get RangeFormula() As String
- RangeFormula = this.RangeFormula
- End Property
- Public Property Let RangeFormula(ByVal Value As String)
- this.RangeFormula = Value
- End Property
- Public Property Get Self() As CheckedRange
- Set Self = Me
- End Property
- Public Property Get Theme() As CheckedRangeTheme
- Theme = this.Theme
- End Property
- Public Property Let Theme(ByVal Value As CheckedRangeTheme)
- this.Theme = Value
- Select Case this.Theme
- Case CheckedRangeTheme.ctCheckBoxes
- this.FontName = "Wingdings"
- CheckedCode = WingdingsCharCode.CheckBoxChecked
- UnCheckedCode = WingdingsCharCode.CheckBoxUnchecked
- Case CheckedRangeTheme.ctCheckmarks
- this.FontName = "Wingdings"
- CheckedCode = WingdingsCharCode.CheckMark
- UnCheckedCode = WingdingsCharCode.XMark
- Case CheckedRangeTheme.ctTrueFalse
- TrueFalse = True
- Case CheckedRangeTheme.ctYesNo
- YesNo = True
- End Select
- Me.Apply
- End Property
- Public Property Get TrueFalse() As Boolean
- TrueFalse = this.TrueFalse
- End Property
- Public Property Let TrueFalse(ByVal Value As Boolean)
- CheckedString = "True"
- UnCheckedString = "False"
- Me.FontName = "Calibri"
- this.TrueFalse = Value
- Me.Apply
- End Property
- Public Property Get UnCheckedCode() As WingdingsCharCode
- UnCheckedCode = this.UnCheckedCode
- End Property
- Public Property Let UnCheckedCode(ByVal Value As WingdingsCharCode)
- UnCheckedString = Chr(Value)
- this.UnCheckedCode = Value
- Me.Apply
- End Property
- Public Property Get UnCheckedColor() As String
- UnCheckedColor = this.UnCheckedColor
- End Property
- Public Property Let UnCheckedColor(ByVal Value As String)
- this.UnCheckedColor = Value
- Me.Apply
- End Property
- Public Property Get UnCheckedString() As String
- UnCheckedString = this.UnCheckedString
- End Property
- Public Property Let UnCheckedString(ByVal Value As String)
- this.UnCheckedString = Value
- Me.Apply
- End Property
- Public Property Let YesNo(ByVal Value As Boolean)
- CheckedString = "Yes"
- UnCheckedString = "No"
- Me.FontName = "Calibri"
- this.YesNo = Value
- Me.Apply
- End Property
- Public Property Get YesNo() As Boolean
- YesNo = this.YesNo
- End Property
- Public Function Create(TargetWorksheet As Worksheet, RangeFormula As String, Optional Theme As CheckedRangeTheme = CheckedRangeTheme.ctCheckBoxes) As CheckedRange
- With New CheckedRange
- .EditMode = True
- .Theme = Theme
- .RangeFormula = RangeFormula
- Set .Worksheet = TargetWorksheet
- .EditMode = False
- .Apply
- Set Create = .Self
- End With
- End Function
- Public Property Get EditMode() As Boolean
- EditMode = this.EditMode
- End Property
- Public Property Let EditMode(ByVal Value As Boolean)
- this.EditMode = Value
- End Property
- Public Sub Apply()
- If Me.EditMode Then Exit Sub
- Dim Target As Range
- Set Target = Me.Range
- If Target Is Nothing Then Exit Sub
- this.PrevAddress = Target.Address
- With Target
- .Font.Name = FontName
- .NumberFormat = NumberFormat
- If .Count = 1 Then
- If Len(.Value) = 0 Or .Value = 0 Then
- .Value = 0
- Else
- .Value = -1
- End If
- Else
- Dim result() As Variant
- result = .Value
- Dim r As Long, c As Long
- For r = 1 To UBound(result)
- For c = 1 To UBound(result, 2)
- If Len(result(r, c)) = 0 Or result(r, c) = 0 Then
- result(r, c) = 0
- Else
- result(r, c) = -1
- End If
- Next
- Next
- .Value = result
- End If
- End With
- End Sub
- Public Property Get Range() As Range
- On Error Resume Next
- Set Range = Worksheet.Range(this.RangeFormula)
- End Property
- Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
- Dim MyRange As Range
- Set MyRange = Me.Range
- If MyRange Is Nothing Then Exit Sub
- If Not Intersect(Target, MyRange) Is Nothing Then
- Cancel = True
- End If
- End Sub
- Private Sub Worksheet_SelectionChange(ByVal Target As Range)
- Dim MyRange As Range
- Set MyRange = Me.Range
- If MyRange Is Nothing Then Exit Sub
- If Target.CountLarge > 1 Then Exit Sub
- If Not Intersect(Target, MyRange) Is Nothing Then
- Application.EnableEvents = False
- Target.Value = IIf(Target.Value = -1, 0, -1)
- Application.EnableEvents = True
- RaiseEvent Clicked(Target)
- End If
- If MyRange.Address <> this.PrevAddress Then Me.Apply
- End Sub
- Option Explicit
- Private WithEvents CheckedRange1 As CheckedRange
- Private WithEvents CheckedRange2 As CheckedRange
- Private WithEvents CheckedRange3 As CheckedRange
- Private WithEvents CheckedRange4 As CheckedRange
- Private WithEvents CheckedRange5 As CheckedRange
- Private Sub Worksheet_Activate()
- Set CheckedRange1 = CheckedRange.Create(Me, "OFFSET(G1,1,-6,COUNTA(G:G)-1,1)")
- Set CheckedRange2 = CheckedRange.Create(Me, "OFFSET(G1,1,-5,COUNTA(G:G)-1,1)", CheckedRangeTheme.ctCheckmarks)
- Set CheckedRange3 = CheckedRange.Create(Me, "OFFSET(G1,1,-4,COUNTA(G:G)-1,1)", CheckedRangeTheme.ctTrueFalse)
- Set CheckedRange4 = CheckedRange.Create(Me, "OFFSET(G1,1,-3,COUNTA(G:G)-1,1)", CheckedRangeTheme.ctYesNo)
- Set CheckedRange5 = CheckedRange.Create(Me, "OFFSET(G1,1,-2,COUNTA(G:G)-1,2)")
- With CheckedRange5
- .EditMode = True
- .CheckedCode = 253
- .UnCheckedCode = 168
- .CheckedColor = "Blue"
- .UnCheckedColor = "Magenta"
- .EditMode = False
- .Apply
- End With
- End Sub
- Private Sub CheckedRange1_Clicked(Target As Range)
- setLabelCaption "CheckedRange1", Target
- End Sub
- Private Sub CheckedRange2_Clicked(Target As Range)
- setLabelCaption "CheckedRange2", Target
- End Sub
- Private Sub CheckedRange3_Clicked(Target As Range)
- setLabelCaption "CheckedRange3", Target
- End Sub
- Private Sub CheckedRange4_Clicked(Target As Range)
- setLabelCaption "CheckedRange4", Target
- End Sub
- Private Sub CheckedRange5_Clicked(Target As Range)
- setLabelCaption "CheckedRange5", Target
- End Sub
- Private Sub setLabelCaption(CheckedRangeName As String, Target As Range)
- Me.Label1.Caption = CheckedRangeName & ": Clicked" & vbNewLine & _
- "Range: " & Target.Address & vbNewLine & _
- "Value: " & Target.Value
- End Sub
Add Comment
Please, Sign In to add comment