Guest User

Untitled

a guest
Nov 14th, 2018
111
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 8.72 KB | None | 0 0
  1. Attribute VB_Name = "CheckedRange"
  2. Attribute VB_PredeclaredId = True
  3. Option Explicit
  4. Public Enum WingdingsCharCode
  5. CheckBoxChecked = 254
  6. CheckBoxUnchecked = 168
  7. XMark = 251
  8. CheckMark = 252
  9. End Enum
  10.  
  11. Public Enum CheckedRangeTheme
  12. ctCheckBoxes
  13. ctCheckmarks
  14. ctTrueFalse
  15. ctYesNo
  16. End Enum
  17.  
  18. Private Type Members
  19. CheckedCode As Long
  20. CheckedColor As String
  21. CheckedString As String
  22. EditMode As Boolean
  23. FontName As String
  24. PrevAddress As String
  25. RangeFormula As String
  26. Theme As CheckedRangeTheme
  27. TrueFalse As Boolean
  28. UnCheckedCode As Long
  29. UnCheckedColor As String
  30. UnCheckedString As String
  31. YesNo As Boolean
  32. End Type
  33. Private this As Members
  34.  
  35. Public Event Clicked(Target As Range)
  36. Public WithEvents Worksheet As Worksheet
  37. Attribute Worksheet.VB_VarHelpID = -1
  38.  
  39. Private m_bUseYesNo As Boolean
  40.  
  41. Private m_sCheckedString As String
  42. Private m_sUnCheckedString As String
  43.  
  44. Private m_bEditMode As Boolean
  45.  
  46. Private Sub Class_Initialize()
  47. EditMode = True
  48. Me.Theme = CheckedRangeTheme.ctCheckBoxes
  49. EditMode = False
  50. End Sub
  51.  
  52. Public Property Get CheckedCode() As WingdingsCharCode
  53. CheckedCode = this.CheckedCode
  54. End Property
  55.  
  56. Public Property Let CheckedCode(ByVal Value As WingdingsCharCode)
  57. CheckedString = Chr(Value)
  58. this.CheckedCode = Value
  59. End Property
  60.  
  61. Public Property Get CheckedColor() As String
  62. CheckedColor = this.CheckedColor
  63. End Property
  64.  
  65. Public Property Let CheckedColor(ByVal Value As String)
  66. this.CheckedColor = Value
  67. End Property
  68.  
  69. Public Property Get CheckedString() As String
  70. CheckedString = this.CheckedString
  71. End Property
  72.  
  73. Public Property Let CheckedString(ByVal Value As String)
  74. this.CheckedString = Value
  75. End Property
  76.  
  77. Public Property Get FontName() As String
  78. FontName = this.FontName
  79. End Property
  80.  
  81. Public Property Let FontName(ByVal Value As String)
  82. this.FontName = Value
  83. End Property
  84.  
  85. Public Property Get NumberFormat() As String
  86. Dim CheckedColor As String, UnCheckedColor As String
  87. CheckedColor = IIf(Len(this.CheckedColor) > 0, "[" & this.CheckedColor & "]", "")
  88. UnCheckedColor = IIf(Len(this.UnCheckedColor) > 0, "[" & this.UnCheckedColor & "]", "")
  89.  
  90. NumberFormat = ";" & CheckedColor & Chr(34) & this.CheckedString & Chr(34) & _
  91. ";" & UnCheckedColor & Chr(34) & this.UnCheckedString & Chr(34)
  92.  
  93. End Property
  94.  
  95. Public Property Get RangeFormula() As String
  96. RangeFormula = this.RangeFormula
  97. End Property
  98.  
  99. Public Property Let RangeFormula(ByVal Value As String)
  100. this.RangeFormula = Value
  101. End Property
  102.  
  103. Public Property Get Self() As CheckedRange
  104. Set Self = Me
  105. End Property
  106.  
  107. Public Property Get Theme() As CheckedRangeTheme
  108. Theme = this.Theme
  109. End Property
  110.  
  111. Public Property Let Theme(ByVal Value As CheckedRangeTheme)
  112. this.Theme = Value
  113. Select Case this.Theme
  114. Case CheckedRangeTheme.ctCheckBoxes
  115. this.FontName = "Wingdings"
  116. CheckedCode = WingdingsCharCode.CheckBoxChecked
  117. UnCheckedCode = WingdingsCharCode.CheckBoxUnchecked
  118. Case CheckedRangeTheme.ctCheckmarks
  119. this.FontName = "Wingdings"
  120. CheckedCode = WingdingsCharCode.CheckMark
  121. UnCheckedCode = WingdingsCharCode.XMark
  122. Case CheckedRangeTheme.ctTrueFalse
  123. TrueFalse = True
  124. Case CheckedRangeTheme.ctYesNo
  125. YesNo = True
  126. End Select
  127. Me.Apply
  128. End Property
  129.  
  130. Public Property Get TrueFalse() As Boolean
  131. TrueFalse = this.TrueFalse
  132. End Property
  133.  
  134. Public Property Let TrueFalse(ByVal Value As Boolean)
  135. CheckedString = "True"
  136. UnCheckedString = "False"
  137. Me.FontName = "Calibri"
  138. this.TrueFalse = Value
  139. Me.Apply
  140. End Property
  141.  
  142. Public Property Get UnCheckedCode() As WingdingsCharCode
  143. UnCheckedCode = this.UnCheckedCode
  144. End Property
  145.  
  146. Public Property Let UnCheckedCode(ByVal Value As WingdingsCharCode)
  147. UnCheckedString = Chr(Value)
  148. this.UnCheckedCode = Value
  149. Me.Apply
  150. End Property
  151.  
  152. Public Property Get UnCheckedColor() As String
  153. UnCheckedColor = this.UnCheckedColor
  154. End Property
  155.  
  156. Public Property Let UnCheckedColor(ByVal Value As String)
  157. this.UnCheckedColor = Value
  158. Me.Apply
  159. End Property
  160.  
  161. Public Property Get UnCheckedString() As String
  162. UnCheckedString = this.UnCheckedString
  163. End Property
  164.  
  165. Public Property Let UnCheckedString(ByVal Value As String)
  166. this.UnCheckedString = Value
  167. Me.Apply
  168. End Property
  169.  
  170. Public Property Let YesNo(ByVal Value As Boolean)
  171. CheckedString = "Yes"
  172. UnCheckedString = "No"
  173. Me.FontName = "Calibri"
  174. this.YesNo = Value
  175. Me.Apply
  176. End Property
  177.  
  178. Public Property Get YesNo() As Boolean
  179. YesNo = this.YesNo
  180. End Property
  181.  
  182. Public Function Create(TargetWorksheet As Worksheet, RangeFormula As String, Optional Theme As CheckedRangeTheme = CheckedRangeTheme.ctCheckBoxes) As CheckedRange
  183. With New CheckedRange
  184. .EditMode = True
  185. .Theme = Theme
  186. .RangeFormula = RangeFormula
  187. Set .Worksheet = TargetWorksheet
  188. .EditMode = False
  189. .Apply
  190. Set Create = .Self
  191. End With
  192. End Function
  193.  
  194. Public Property Get EditMode() As Boolean
  195. EditMode = this.EditMode
  196. End Property
  197.  
  198. Public Property Let EditMode(ByVal Value As Boolean)
  199. this.EditMode = Value
  200. End Property
  201.  
  202. Public Sub Apply()
  203. If Me.EditMode Then Exit Sub
  204. Dim Target As Range
  205. Set Target = Me.Range
  206.  
  207. If Target Is Nothing Then Exit Sub
  208.  
  209. this.PrevAddress = Target.Address
  210.  
  211. With Target
  212. .Font.Name = FontName
  213. .NumberFormat = NumberFormat
  214. If .Count = 1 Then
  215. If Len(.Value) = 0 Or .Value = 0 Then
  216. .Value = 0
  217. Else
  218. .Value = -1
  219. End If
  220. Else
  221. Dim result() As Variant
  222. result = .Value
  223. Dim r As Long, c As Long
  224.  
  225. For r = 1 To UBound(result)
  226. For c = 1 To UBound(result, 2)
  227. If Len(result(r, c)) = 0 Or result(r, c) = 0 Then
  228. result(r, c) = 0
  229. Else
  230. result(r, c) = -1
  231. End If
  232. Next
  233. Next
  234. .Value = result
  235. End If
  236. End With
  237. End Sub
  238.  
  239. Public Property Get Range() As Range
  240. On Error Resume Next
  241. Set Range = Worksheet.Range(this.RangeFormula)
  242. End Property
  243.  
  244. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  245. Dim MyRange As Range
  246. Set MyRange = Me.Range
  247.  
  248. If MyRange Is Nothing Then Exit Sub
  249.  
  250. If Not Intersect(Target, MyRange) Is Nothing Then
  251. Cancel = True
  252. End If
  253. End Sub
  254.  
  255. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  256. Dim MyRange As Range
  257. Set MyRange = Me.Range
  258.  
  259. If MyRange Is Nothing Then Exit Sub
  260. If Target.CountLarge > 1 Then Exit Sub
  261.  
  262. If Not Intersect(Target, MyRange) Is Nothing Then
  263. Application.EnableEvents = False
  264. Target.Value = IIf(Target.Value = -1, 0, -1)
  265. Application.EnableEvents = True
  266. RaiseEvent Clicked(Target)
  267. End If
  268.  
  269. If MyRange.Address <> this.PrevAddress Then Me.Apply
  270.  
  271. End Sub
  272.  
  273. Option Explicit
  274. Private WithEvents CheckedRange1 As CheckedRange
  275. Private WithEvents CheckedRange2 As CheckedRange
  276. Private WithEvents CheckedRange3 As CheckedRange
  277. Private WithEvents CheckedRange4 As CheckedRange
  278. Private WithEvents CheckedRange5 As CheckedRange
  279.  
  280. Private Sub Worksheet_Activate()
  281. Set CheckedRange1 = CheckedRange.Create(Me, "OFFSET(G1,1,-6,COUNTA(G:G)-1,1)")
  282. Set CheckedRange2 = CheckedRange.Create(Me, "OFFSET(G1,1,-5,COUNTA(G:G)-1,1)", CheckedRangeTheme.ctCheckmarks)
  283. Set CheckedRange3 = CheckedRange.Create(Me, "OFFSET(G1,1,-4,COUNTA(G:G)-1,1)", CheckedRangeTheme.ctTrueFalse)
  284. Set CheckedRange4 = CheckedRange.Create(Me, "OFFSET(G1,1,-3,COUNTA(G:G)-1,1)", CheckedRangeTheme.ctYesNo)
  285. Set CheckedRange5 = CheckedRange.Create(Me, "OFFSET(G1,1,-2,COUNTA(G:G)-1,2)")
  286. With CheckedRange5
  287. .EditMode = True
  288. .CheckedCode = 253
  289. .UnCheckedCode = 168
  290. .CheckedColor = "Blue"
  291. .UnCheckedColor = "Magenta"
  292. .EditMode = False
  293. .Apply
  294. End With
  295. End Sub
  296.  
  297. Private Sub CheckedRange1_Clicked(Target As Range)
  298. setLabelCaption "CheckedRange1", Target
  299. End Sub
  300.  
  301. Private Sub CheckedRange2_Clicked(Target As Range)
  302. setLabelCaption "CheckedRange2", Target
  303. End Sub
  304.  
  305. Private Sub CheckedRange3_Clicked(Target As Range)
  306. setLabelCaption "CheckedRange3", Target
  307. End Sub
  308.  
  309. Private Sub CheckedRange4_Clicked(Target As Range)
  310. setLabelCaption "CheckedRange4", Target
  311. End Sub
  312.  
  313. Private Sub CheckedRange5_Clicked(Target As Range)
  314. setLabelCaption "CheckedRange5", Target
  315. End Sub
  316.  
  317. Private Sub setLabelCaption(CheckedRangeName As String, Target As Range)
  318. Me.Label1.Caption = CheckedRangeName & ": Clicked" & vbNewLine & _
  319. "Range: " & Target.Address & vbNewLine & _
  320. "Value: " & Target.Value
  321. End Sub
Add Comment
Please, Sign In to add comment