· 6 years ago · Jan 06, 2020, 01:10 AM
1'@Folder("Classes.Controls")
2Option Explicit
3
4'---------------------------------------------------------------------------------------
5' # DOCUMENTATION
6' Toto je jedna varianta, jak vytvoøit vlastní Control, který se bude chovat
7' na základnì nìjakých eventù (kliknutí na nìj, dvojklik, ...)
8'
9' Zadefinují se PRIVÁTNÍ p<var>, které se nastaví funkcí InitializeWithValues
10' V hlavním kódu tedy:
11'
12' # MODULE-LEVEL
13' Public collUserControls As New Scripting.Dictionary
14'
15' # PROCEDURE
16' Public Sub InitControls(ByVal frm As UserForm)
17' Dim frmName As String
18' frmName = TypeName(getCtrlParentForm(frm.Controls(2)))
19' Dim dict As Scripting.Dictionary
20' Dim ctrl As MSForms.Control
21' For Each ctrl In frm.Controls
22' Set dict = strToDict(ctrl.Tag)
23' ...
24' ElseIf TypeName(ctrl) = "ComboBox" And IgnoreTxt = False Then
25' Dim myCbo As clsUserTextBox
26' Set myCbo = New clsUserTextBox
27' myCbo.InitializeWithValues ctrl, parentForm:=frm
28' Set collUserControls(myCbo.collectionName) = myCbo
29' ....
30' End Sub
31'---------------------------------------------------------------------------------------
32
33'@MemberAttribute VB_VarHelpID, -1
34Public WithEvents pMyComboBox As MSForms.ComboBox ' bylo Public
35
36
37'=======================================================================================
38' TYPE DECLARATIONS
39'=======================================================================================
40Private Type TSpecific
41 tableName As String
42 Row As String
43 col As String
44 Cell As Range
45 Value As String
46End Type
47
48Private Type TDict
49 Table As ListObject
50 tableName As String
51 key As String
52' ColumnName As String
53End Type
54
55Private this As TView
56Private Type TView
57 ctrl As MSForms.ComboBox ' control class
58 ctrlRawName As String ' txtID_MAT --> ID_MAT
59 parentForm As UserForm ' parent form class
60 dict As Scripting.Dictionary ' parsed dict of .TAG property
61 parentFormName As String ' name of the parent form
62 collectionName As String ' parentName@txtCtrlName
63 dc As TDict ' sub-type for interal dictionary
64 type As String ' empty, list, tblNAME, tblPARENT < NAME
65 Cell As Range ' table cell where the rawValue is
66 rawValue As String ' what is displayed in the cell (raw string)
67 srcTable As ListObject
68 srcTableName As String
69 srcTableDc As New Scripting.Dictionary ' for holding Tip text
70 valToRawDict As New Scripting.Dictionary ' for holding srcTable VALUE->ID values
71 Value As String ' what is in the control value
72 initValue As String ' initial value loaded into control
73 modified As Boolean ' status if control was modified/edited
74 parentControlName As String
75 parentControlValue As String
76 parentControl As clsUserComboBox
77 parentCollectionName As String
78 childControlName As String
79 childCollectionName As String
80 specific As TSpecific ' for case when '.type = tblNAME: [TBLNAME, ROW, COL]'
81 tipText As String
82 events As Boolean
83 childrenDict As Scripting.Dictionary
84 hasChildren As Boolean
85End Type
86
87
88'=======================================================================================
89' PROPERTIES
90'=======================================================================================
91'--------------------------------------------------------
92' PROPERTY collectionName
93'--------------------------------------------------------
94Public Property Get collectionName() As String
95 collectionName = this.collectionName
96End Property
97'--------------------------------------------------------
98' PROPERTY value
99'--------------------------------------------------------
100Public Property Get Value() As String
101 Value = this.Value
102End Property
103'--------------------------------------------------------
104' PROPERTY parentCollectionName
105'--------------------------------------------------------
106Public Property Get parentCollectionName() As String
107 parentCollectionName = this.parentCollectionName
108End Property
109'--------------------------------------------------------
110' PROPERTY parentControlValue
111'--------------------------------------------------------
112Public Property Let parentControlValue(ByVal item As String)
113 this.parentControlValue = item
114End Property
115Public Property Get parentControlValue() As String
116 parentControlValue = this.parentControlValue
117End Property
118'--------------------------------------------------------
119' PROPERTY childControlName
120'--------------------------------------------------------
121Public Property Let childControlName(ByVal item As String)
122 this.childControlName = item
123End Property
124Public Property Get childControlName() As String
125 childControlName = this.childControlName
126End Property
127'--------------------------------------------------------
128' PROPERTY childCollectionName
129'--------------------------------------------------------
130Public Property Let childCollectionName(ByVal item As String)
131 this.childCollectionName = item
132End Property
133Public Property Get childCollectionName() As String
134 childCollectionName = this.childCollectionName
135End Property
136'--------------------------------------------------------
137' PROPERTY rawValue
138'--------------------------------------------------------
139Public Property Let rawValue(ByVal item As String)
140 this.rawValue = item
141End Property
142Public Property Get rawValue() As String
143 rawValue = this.rawValue
144End Property
145'--------------------------------------------------------
146' PROPERTY srcTableName
147'--------------------------------------------------------
148Public Property Let srcTableName(ByVal item As String)
149 this.srcTableName = item
150End Property
151Public Property Get srcTableName() As String
152 srcTableName = this.srcTableName
153End Property
154
155
156'=======================================================================================
157' INIT AND TERMINATE
158'=======================================================================================
159
160'' Purpose: Class initialization with empty variables (don't need this here but why not)
161''---------------------------------------------------------------------------------------
162'Private Sub Class_Initialize()
163' Set this.Ctrl = Nothing
164' Set this.parentForm = Nothing
165'End Sub
166
167'---------------------------------------------------------------------------------------
168Private Sub Class_Terminate()
169 Set this.ctrl = Nothing
170 Set this.parentForm = Nothing
171' UnhookListBoxScroll
172End Sub
173
174' Purpose: Define initialization with all variables at once
175'---------------------------------------------------------------------------------------
176Public Sub InitializeWithValues(ByVal MyComboBox As MSForms.ComboBox, _
177 ByVal parentForm As MSForms.UserForm)
178 this.modified = False
179 Set pMyComboBox = MyComboBox
180 Set this.ctrl = MyComboBox
181 Set this.parentForm = parentForm
182
183 Set this.dict = strToDict(this.ctrl.Tag)
184 this.parentFormName = TypeName(this.parentForm)
185 this.collectionName = this.parentFormName & "@" & this.ctrl.Name
186 this.ctrlRawName = getCtrlName(this.ctrl)
187
188 Debug.Print "this.collectionName: " & this.collectionName
189
190 FillTDict
191
192 If this.ctrl.Name = "cboCUR_TYPE" Then Stop
193
194 ' CHILDREN INTO DICTIONARY
195 this.hasChildren = False
196 On Error Resume Next
197 Dim childColumnRange As Range
198 Set childColumnRange = this.srcTable.ListColumns("Child").Range
199 On Error GoTo 0
200 If Not childColumnRange Is Nothing Then
201 this.hasChildren = True
202 End If
203 If this.hasChildren = True Then
204 ' working right now
205 End If
206
207 ' If class is reinitializing, keep the old initValue from maybe different srcTable
208 If this.parentControlValue = vbNullString Then
209' If this.initValue = vbNullString Then
210' Debug.Print "Menim this.initValue = this.Value: " & _
211' this.initValue & " --> " & this.Value
212 this.initValue = this.Value
213 End If
214
215 ' TODO tohle nejak posetrit, mozna pri ctrl.disabled = true nastavit init na disable?
216 If this.modified = True And this.ctrl.Enabled <> False Then
217 this.modified = False
218 End If
219 On Error Resume Next
220 this.ctrl.Value = this.Value
221 On Error GoTo 0
222
223 ' What tipBox text should be displayed when onClick
224 this.tipText = GetLbl(this.parentFormName, this.ctrlRawName, info:=True)
225
226End Sub
227
228
229'=======================================================================================
230' METHODS
231'=======================================================================================
232
233'---------------------------------------------------------------------------------------
234Private Sub FillTDict()
235' Debug.Print vbNewLines(2) & "### CBO: " & this.Ctrl.Name & " [" & dictToStr(this.dict) & "] ###"
236
237 ' DEBUG
238 '===============
239' If this.ctrl.Name = "cboT_MEDIUM" Then Stop
240
241 ' TABLE
242 '===============
243' Dim rng As Range
244 On Error Resume Next
245 Set this.dc.Table = Range(this.dict.item("table")).ListObject
246 this.dc.tableName = this.dc.Table.Name
247' Debug.Print "this.dc.TableName: " & this.dc.TableName
248 On Error GoTo 0
249 If this.dc.Table Is Nothing Then
250 MsgBox "table: " & this.dict.item("table") & " not found anywhere... ERROR HANDLING"
251' GoTo ErrHandler
252 Class_Terminate
253 End
254 End If
255
256 ' KEY
257 '===============
258 ' Check for existence of "key" key in Dict. If not found, create it from Ctrl.Name
259 If this.dict.Exists("key") = False Then
260 this.dc.key = getCtrlName(this.ctrl)
261 Else
262 this.dc.key = this.dict.item("key")
263 End If
264 this.dict.item("key") = this.dc.key
265' Debug.Print "this.dc.Key: " & this.dc.Key
266
267' If this.Ctrl.Name = "cboT_PROCESS" Then Stop
268
269 ' TYPE
270 '===============
271 ' Get the type of the value (empty, list, tblName, tblName < Name, tblName | Row)
272 this.type = GetTableVal(this.dc.tableName, rowName:=this.dc.key, colName:="Type")
273' Debug.Print "This.type: " & this.type
274 this.specific.Value = getTypeSpecificValue(this.type)
275
276 ' CELL
277 '===============
278 Set this.Cell = GetCellFromTag(this.dict, this.specific.Value)
279' Debug.Print "this.cell: " & this.Cell.Address
280
281 ' RAW VALUE
282 '===============
283 ' Get raw value from table field
284' this.rawValue = GetValueFromTag(this.dict)
285 this.rawValue = this.Cell.Value2
286
287 ' EXCEPT if the control is already initialized and PARENT cbo is changed...
288 If this.parentControlValue <> vbNullString Then
289 this.rawValue = 0 ' reset to first
290' Debug.Print "Resetting this.rawValue = " & this.rawValue
291 End If
292' Debug.Print "this.rawValue: " & this.rawValue
293' If this.ctrl.Name = "cboCUR_TYPE" Then Stop
294 ' VALUE
295 '===============
296 Select Case True
297
298' Case vbNullString, "-", "type"
299' MsgBox "Something is wrong. " & this.collectionName & " should have Type..."
300
301
302 Case Trim$(LCase$(this.type)) = "type"
303 Debug.Print "Type type of type..."
304 GoTo Exit_Select:
305
306 ' Parent-type, like: tblMAT_SUB < MAT_GROUP ... Child < Parent
307 ' CHILD or PARENT ComboBox
308 '========================================
309 Case InStr(LCase$(this.type), " < ") <> 0
310
311' Debug.Print "TYPE: tbl < name"
312
313 ' Case there is specific value specified: 'tblT_PROCESS < T_TYPE: <TREATMENT>'
314 If InStr(this.type, ":") <> 0 Then
315 this.type = Trim$(Split(this.type, ":")(0))
316 End If
317
318 ' GET ChildTable (left) and ParentTable (right)
319 ' example: splittedColl = ['ChildTable', 'ParentTable']
320 Dim splittedColl As Collection
321 Set splittedColl = splitStringToCollection(this.type, "<", noSpaces:=True)
322
323 Dim childTable As String: childTable = splittedColl.item(1)
324 Dim parentTable As String: parentTable = splittedColl.item(2)
325
326 ' First, found out the value of the parentControl
327 this.parentControlName = parentTable
328 this.parentCollectionName = this.parentFormName & "@cbo" & this.parentControlName
329 Set this.parentControl = collUserControls.item(this.parentCollectionName)
330' Debug.Print "this.parentCollectionName: " & this.parentCollectionName
331' Debug.Print "this.parentControl.value: " & this.parentControl.Value
332' Debug.Print "this.parentControl.rawValue: " & this.parentControl.rawValue
333
334 ' Parse this childControl to the parentControl
335 this.parentControl.childControlName = this.ctrl.Name
336 this.parentControl.childCollectionName = this.collectionName
337
338 ' Inform if I'm parent and have a child of xxx collectionName
339 If this.childCollectionName <> vbNullString Then
340 Debug.Print "I Am parent: " & this.collectionName & " ... child: " & this.childCollectionName
341 End If
342
343 ' Check parent tbl for <rawValue> and <Child> column
344' If this.childCollectionName = vbNullString Then
345' Debug.Print GetTableVal(this.parentControl.srcTableName, _
346' this.parentControl.rawValue, "Child")
347' End If
348 ' Put together the srcTableName from parentControl & ComboBox value (number)
349 ' eg: "tblSEM_TYPE" & "6"
350
351 On Error Resume Next
352 this.srcTableName = GetTableVal(this.parentControl.srcTableName, _
353 this.parentControl.rawValue, colName:="Child", _
354 ignoreColumnNotFound:=True)
355 On Error GoTo 0
356 If this.srcTableName = vbNullString Then
357 this.srcTableName = childTable & this.parentControl.rawValue
358 End If
359' Debug.Print "this.srcTableName : " & this.srcTableName
360
361 ' Try to initialize this control's ListObject table
362 ' If it fails, disable this ComboBox
363 On Error Resume Next
364 Set this.srcTable = Nothing
365 Set this.srcTable = Range(this.srcTableName).ListObject
366 On Error GoTo 0
367 If this.srcTable Is Nothing Then
368 this.ctrl.Clear
369 this.ctrl.BackColor = eColors.White
370 this.ctrl.Enabled = False
371' Debug.Print "this.srcTable not found... Disabling: " & this.srcTableName
372 If this.initValue <> this.ctrl.Value Then
373 this.modified = True
374 End If
375 GoTo Exit_Select
376 Else
377 this.ctrl.Enabled = True
378 End If
379
380 ' Get inside the srcTable and check if "Relations" column exists
381 Dim relations As Boolean
382 relations = tblHeaderExists(this.srcTableName, "Relations")
383' Debug.Print "Relations: " & relations
384 Debug.Print "this.srcTableName: " & this.srcTableName
385 ' If Relations exists, check if parentSrcTable = Relations value
386 ' If not, disable this ComboBox
387 If relations = True Then
388 Dim relationsVal As String
389 relationsVal = this.srcTable.ListColumns.[_Default]("Relations").DataBodyRange.rows.item(1).Value
390 Debug.Print "relationsVal: " & relationsVal
391 Debug.Print "this.parentControl.srcTableName: " & this.parentControl.srcTableName
392
393 If this.parentControl.srcTableName <> relationsVal Then
394' Debug.Print "RELATIONS ... " & relationsVal & " != " & _
395' this.parentControl.srcTableName & ", Disabling ComboBox..."
396 this.ctrl.Clear
397 this.ctrl.BackColor = eColors.White
398 this.ctrl.Enabled = False
399 GoTo Exit_Select
400 End If
401
402 End If
403
404 ' It really is a combobox with a value "0" but in cell, there is ""
405 ' Fix the problem within the sheet
406 If this.rawValue = vbNullString Then
407 this.rawValue = "0"
408 this.Cell.Value2 = "0"
409 End If
410
411 ' Get the active value from srcTable depending on the RawValue
412 this.Value = GetTableVal(this.srcTableName, this.rawValue, colName:="Value")
413 If this.parentControlValue = vbNullString Then
414 this.initValue = this.Value
415 End If
416
417 ' Populate ComboBox
418 PopulateCbo cboCtrl:=this.ctrl, coll:=getComboBoxValues(this.srcTable)
419' this.Ctrl.Enabled = True ' TODO je to tu potrebne?
420
421
422 ' CBO which VALUE depends on the value in some <columnName> of another TABLE
423 '===============================================================================
424 Case InStr(LCase$(this.type), "[") <> 0 And InStr(LCase$(this.type), "]") <> 0
425 Dim splitted As Collection
426 Set splitted = splitStringToCollection(this.type, ":", True)
427 this.srcTableName = splitted.item(1)
428
429 ' Try to initialize this control's ListObject table
430 ' If it fails, disable this ComboBox
431 On Error Resume Next
432 Set this.srcTable = Nothing
433 Set this.srcTable = Range(this.srcTableName).ListObject
434 On Error GoTo 0
435 If this.srcTable Is Nothing Then
436 this.ctrl.Clear
437 this.ctrl.BackColor = eColors.White
438 this.ctrl.Enabled = False
439' Debug.Print "this.srcTable not found... Disabling: " & this.srcTableName
440 GoTo Exit_Select
441 End If
442
443 Dim specificValues As Collection
444 Set specificValues = splitStringToCollection( _
445 LeftRight(splitted.item(2), 1), ";", True)
446 this.specific.tableName = specificValues.item(1)
447 this.specific.Row = specificValues.item(2)
448 this.specific.col = specificValues.item(3)
449 Set this.specific.Cell = GetTblCell(this.specific.tableName, _
450 this.specific.col, this.specific.Row)
451 this.specific.Value = this.specific.Cell.Value2
452' this.specific.Value = GetTableVal(this.specific.TableName, _
453' this.specific.Row, this.specific.Col)
454
455 ' Populate ComboBox
456 PopulateCbo cboCtrl:=this.ctrl, coll:=getComboBoxValues(this.srcTable)
457
458 ' The the active value
459 this.Value = GetTableVal( _
460 this.srcTable, _
461 GetTableVal(this.dc.tableName, this.dc.key, this.specific.Value))
462 Set this.Cell = GetTblCell(this.dc.tableName, this.specific.Value, this.dc.key)
463 this.Cell.Activate
464
465
466 ' NORMAL or PARENT ComboBox
467 '========================================
468 Case InStr(LCase$(this.type), "tbl") <> 0
469
470 ' Case there is specific value specified: 'tblT_ENVIRO: <TREATMENT>'
471 If InStr(this.type, ":") <> 0 Then
472 this.type = Trim$(Split(this.type, ":")(0))
473 End If
474
475' Debug.Print "TYPE: tbl"
476 this.srcTableName = this.type
477
478 ' GET SRC TABLE
479 On Error Resume Next
480 Set this.srcTable = Range(this.srcTableName).ListObject
481' Debug.Print "found this.srcTable: " & this.srcTable
482 On Error GoTo 0
483 If this.srcTable Is Nothing Then
484 MsgBox "SrcTable: " & this.srcTableName & _
485 " not found anywhere..." & vbNewLine & "EROR HANDLING"
486 Class_Terminate
487 End If
488
489 ' TODATE 2019-11-18 Toto nemùže být tak lehké, nejdou teï jiné CBO...
490 this.events = False
491 ' Populate ComboBox
492 PopulateCbo cboCtrl:=this.ctrl, coll:=getComboBoxValues(this.srcTable)
493 this.events = True
494
495 ' Select value only if there is something within this.rawValue
496 If this.rawValue <> vbNullString Then
497 ' Get the active value from srcTable depending on the RawValue
498 this.Value = GetTableVal(this.srcTableName, this.rawValue, colName:="Value")
499 End If
500
501
502 ' ONLY VALUES ComboBox
503 '========================================
504 Case InStr(LCase$(this.type), " | ") <> 0
505
506' Debug.Print "TYPE: OnlyValues"
507' Debug.Print "TODO..." ' TODO dodelat OnlyValues ComboBox
508 Set splitted = splitStringToCollection(this.type, Splitter:="|", noSpaces:=True)
509 this.srcTableName = splitted.item(1)
510
511 ' GET SRC TABLE
512 ' TODO tohle je stale se opakujici, udelat z toho funkci
513 On Error Resume Next
514 Set this.srcTable = Range(this.srcTableName).ListObject
515' Debug.Print "found this.srcTable: " & this.srcTable
516 On Error GoTo 0
517 If this.srcTable Is Nothing Then
518 MsgBox "SrcTable: " & this.srcTableName & "not found anywhere..." & vbNewLine & _
519 "ERROR HANDLING"
520 Class_Terminate
521 End If
522
523 ' TODATE 2019-07-15 Zatim delane jen pro ROW VALUE ne COL VALUE, dodelat
524 Dim colRowVal As String
525 colRowVal = splitStringToCollection(splitted.item(2), ":", True).item(2)
526
527 Dim cboValues As Collection
528 Set cboValues = getTableRowValues(this.srcTable, rowName:=colRowVal)
529
530 this.Value = this.rawValue
531' this.Ctrl.Value = this.Value
532 ' TODO z nejakeho bizardniho duvodu se pri tomto radku smaze this.RawValue
533 ' TODO ... a musi to tedy byt pod temi 2 radky nahore...
534 this.ctrl.list = collectionToArray(cboValues)
535
536 End Select
537
538 ' Fill helper dictionaries
539 Dim rowID As Range
540 For Each rowID In this.srcTable.DataBodyRange.Columns.item(1).Cells
541
542 ' Dict["Value"] = "ID"
543 this.valToRawDict.item(rowID.Offset(0, 1).Value) = rowID.Offset(0, 0).Value
544
545 ' Dict["Value"] = "Tip"
546 this.srcTableDc.item(rowID.Offset(0, 1).Value) = rowID.Offset(0, 2).Value
547
548 Next rowID
549
550 Set rowID = Nothing
551' Set rng = Nothing
552
553Exit_Select:
554
555End Sub
556
557
558'---------------------------------------------------------------------------------------
559Public Sub Save()
560
561' If this.Ctrl.Name = "cboT_PROCESS" Then Stop
562
563 If this.modified = False Then
564' Debug.Print "PRESKAKUJI, nebylo modifikovano..."
565 GoTo ExitNotModified
566 End If
567'
568 Debug.Print "Saving... " & this.collectionName
569 Debug.Print "Value: " & this.Value
570 this.initValue = this.Value
571 Debug.Print "Specific.Value: " & this.specific.Value
572 Debug.Print "Saving to cell: " & this.Cell.Address
573
574 If InStr(LCase$(this.type), " | ") <> 0 Then
575' this.Cell.Value = this.Ctrl.Value2
576' Debug.Print "Value number: " & this.Ctrl.Value2
577 this.Cell.Value = this.Value
578 Debug.Print "Value number: " & this.Value
579 Else
580 Dim numberValue As String
581 numberValue = GetTableVal( _
582 this.srcTableName, this.Value, colName:="ID", srcColNum:=2)
583 Debug.Print "Value number: " & numberValue
584 ' Save the mother f*cker...
585 this.Cell.Value2 = numberValue
586 End If
587
588 ' Reset colors
589 this.ctrl.BackColor = eColors.LightGreen
590 this.modified = False
591
592ExitNotModified:
593
594End Sub
595
596
597'---------------------------------------------------------------------------------------
598Public Sub Reset()
599 On Error Resume Next
600 this.ctrl.Value = this.initValue
601 this.Value = this.initValue
602 On Error GoTo 0
603 this.ctrl.BackColor = eColors.LightGreen
604 this.modified = False
605End Sub
606
607
608'=======================================================================================
609' EVENTS
610'=======================================================================================
611
612'---------------------------------------------------------------------------------------
613Private Sub pMyComboBox_Change()
614' If this.ctrl.Name = "cboT_PROCESS" Then Stop
615' Debug.Print "this.initValue: [" & this.initValue & "] <==> [" & this.Ctrl.Value & "]"
616
617 ' For some reason when 'PopulateCBO' sub is called, it fires 2x _Change event and
618 ' deletes this.rawValue, this.valToRawDict and so on...
619 ' In the code there is: this.events = False; code to run; this.events = True
620' If this.events = False Then Exit Sub
621 Application.EnableEvents = False
622 ' Ctrl.Value and InitValue are the same, update rawValue and value
623 If this.initValue = this.ctrl.Value Then
624 this.modified = False
625 this.ctrl.BackColor = eColors.LightGreen
626' ' Ctrl.Value and InitValue are different, update RawValue, Value and color to Dark
627 Else
628 this.modified = True
629 this.ctrl.BackColor = eColors.DarkGreen
630 End If
631
632 this.Value = this.ctrl.Value
633 this.rawValue = this.valToRawDict.item(this.Value)
634
635 ' If there is Child ComboBox, get it out of collUserControls and reinitialize it
636 If this.childCollectionName <> vbNullString Then
637' Debug.Print "Mam dite...: " & this.childCollectionName
638 Dim childCtrl As clsUserComboBox
639 Set childCtrl = collUserControls.item(this.childCollectionName)
640 childCtrl.parentControlValue = this.Value
641 childCtrl.InitializeWithValues this.parentForm.Controls.item(this.childControlName), _
642 this.parentForm
643 End If
644 Application.EnableEvents = True
645End Sub
646
647
648'---------------------------------------------------------------------------------------
649Private Sub pMyComboBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
650 ByVal x As Single, ByVal y As Single)
651 this.parentForm.Controls.item("edTipBox").text = this.tipText
652End Sub
653
654
655'---------------------------------------------------------------------------------------
656Private Sub pMyComboBox_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
657 ByVal x As Single, ByVal y As Single)
658
659 ' SCROLLING
660' HookListBoxScroll this.parentForm, pMyComboBox
661
662 ' Reset edTipBox.Text back to "Information: "
663 If this.ctrl.TopIndex <= -1 And _
664 (x < 1 Or y < 1 Or x > this.ctrl.Width - 1 Or y > this.ctrl.Height - 1) Then
665 this.parentForm.Controls.item("edTipBox").text = "Information: "
666 End If
667
668 If this.ctrl.TopIndex <= -1 Then Exit Sub
669
670' Debug.Print "Shift: " & Shift & ", X: " & X & ", Y: " & Y
671
672 Dim curIndex As Long
673 curIndex = this.ctrl.TopIndex + Application.WorksheetFunction.RoundDown(y / 9.75, 0)
674
675 ' In case ComboBox width is > 9.75 AND there is only 1 item in list, when mouse
676 ' moves under 9.75, it tries to grab curIndex = 2 which doesn't exist...
677 ' Cant' find how to differentiate MouseMove over opened ComboBoxe's .text and items area
678 If curIndex >= this.ctrl.listCount Then Exit Sub
679
680' On Error GoTo ResolveError
681 Dim selectedItem As String
682 selectedItem = this.ctrl.list(curIndex)
683' Debug.Print "DEBUG curIndex: " & curIndex & ", selectedItem: " & selectedItem
684
685 this.parentForm.Controls.item("edTipBox").text = _
686 "Information: " & this.srcTableDc.item(selectedItem)
687
688' On Error GoTo 0
689' Exit Sub
690'
691'ResolveError:
692' Debug.Print "WARNING: idx[" & curIndex & "]" & _
693' "clsUserComboBox [Sub: pMyComboBox_MouseMove]: " & _
694' "Nejaky Problem s comboboxem, nejspise jmeno, script problem, ne tag"
695' On Error GoTo 0
696' UnhookListBoxScroll
697
698End Sub