Option Explicit
Option Compare Text
Private Sub Comm1_Click()
Dim r As Integer, C As Integer
If ListBox1.ListIndex = -1 Then Exit Sub
If Not ActiveSheet Is iSheetLists Then
If ActiveSheet.ProtectContents = True And ActiveCell.Locked = True Then
MsgBox "Лист защищен! Что бы вставить значение, снимите защиту листа."
Else
ActiveCell.Value = ListBox1.Text
Select Case iShiftOption
Case 0: r = 0: C = 0
Case 1: r = -1: C = 0
Case 2: r = 0: C = 1
Case 4: r = 0: C = -1
Case Else: r = 1: C = 0
End Select
On Error Resume Next
'AppActivate "Microsoft Excel"
ActiveCell.Offset(r, C).Activate
ListBox1.SetFocus
On Error GoTo 0
End If
End If
End Sub
Private Sub HelpButton_Click()
Me.Hide
With HelpForm
.Top = Me.Top
.Left = Me.Left
.Show
End With
Me.Show
End Sub
Private Sub ListBox1_Click()
Call MyControlsState(Not ListBox1.ListIndex = -1)
NewItButton.Enabled = Not TextBoxItems.Text = ""
End Sub
Private Sub ListBoxItems_Click()
Dim arr, i As Long, MainValue As String
If Me.ListBoxItems.ListCount = 0 Then Exit Sub
arr = Worksheets("Список").Range("A1").CurrentRegion.Value
For i = 0 To Me.ListBoxItems.ListCount - 1
If Me.ListBoxItems.Selected(i) Then
MainValue = Me.ListBoxItems.List(i)
Exit For
End If
Next
If MainValue = "" Then Exit Sub
Me.ListBox1.Clear
For i = 1 To UBound(arr)
If arr(i, 1) = MainValue Then Me.ListBox1.AddItem arr(i, 2)
Next i
End Sub
'----------------------------------------------------------
'----------------------------------------------------------
Private Sub UserForm_Initialize()
Me.Tag = 1
Me.Caption = AppName
If iMainFormPosOption = 1 Then Call mySetFormKoord(Me) ' устанавливаем координаты формы
Call AssigningValuesToVariables ' присваиваем значения переменным
Call MyFillDataControlLists(ComboBoxLists) ' заполняем данными комбобокс с названиями списков и устанавливаем в нем текущий єлемент.
If dLists.Count = 0 Then
MsgBox "Нет списков для выбора!" & vbCrLf & "Для продолжения работы добавьте хотя бы один список." _
, vbExclamation + vbOKOnly, AppName
SettingsForm.Show
Call MyFillDataControlLists(ComboBoxLists)
End If
End Sub
Private Sub AssigningValuesToVariables()
Call myGetCustomProperties("NumListColumn", 1, iNumListColumn)
Call myGetCustomProperties("SortingOption", 1, iSortingOption)
Call myGetCustomProperties("ShiftOption", 3, iShiftOption)
Call myGetCustomProperties("DblClickRunOption", 1, iDblClickRunOption)
Call myGetCustomProperties("FindOption", 1, iFindOption)
Call myGetCustomProperties("MainFormPosOption", 1, iMainFormPosOption)
End Sub
Private Sub myGetCustomProperties(prName As String, prValueDefault As Long, prValue As Long)
On Error Resume Next
With ThisWorkbook.CustomDocumentProperties
If Not MyCustomPropertiesExists(prName) Then _
Call MyCreateCustomProperties(prName, prValueDefault)
prValue = CLng(.Item(prName))
If Not Err.Number = 0 Then prValue = prValueDefault
End With
On Error GoTo 0
End Sub
Private Sub ComboBoxLists_Change()
Dim s
TextBoxItems.Text = ""
ListBoxItems.Clear
If ComboBoxLists.Text = "" Then Exit Sub
s = ComboBoxLists.Text
If IsNumeric(s) Then s = Val(s)
iNumListColumn = dLists.Item(s)
Call MyFillDataControlItems(ListBoxItems)
End Sub
Private Sub ListBoxItems_Change()
Call MyControlsState(Not ListBoxItems.ListIndex = -1)
NewItButton.Enabled = Not TextBoxItems.Text = ""
End Sub
Private Sub MyControlsState(ContrlState As Boolean)
OKButton.Enabled = ContrlState
DelItButton.Enabled = ContrlState
NewItButton.Enabled = ContrlState
End Sub
Private Sub MyControlsState22(ContrlState As Boolean)
Comm1.Enabled = ContrlState
DelItButton.Enabled = ContrlState22
NewItButton.Enabled = ContrlState22
End Sub
Private Sub TextBoxItems_Change()
Dim s As String, it
NewItButton.Enabled = Not TextBoxItems.Text = ""
If ComboBoxLists.Text = "" Or _
dLists.Count = 0 Then NewItButton.Enabled = False: Exit Sub
If dItems.Count = 0 Then Exit Sub
ListBoxItems.Clear
If TextBoxItems.Text = "" Then
ListBoxItems.List = dItems.keys
Else
s = "*" & TextBoxItems.Text & "*"
If iFindOption = 2 Then s = Mid(s, 2)
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For Each it In dItems.keys
If it Like s Then .Item(it) = ""
Next it
If .Count = 0 Then Exit Sub
ListBoxItems.List = .keys
End With
End If
ListBoxItems.ListIndex = 0
End Sub
Private Sub CancelButton_Click()
Unload Me
End Sub
Private Sub ComboBoxLists_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = 0
End Sub
Private Sub DelItButton_Click()
Dim r As Range
If MsgBox("Вы действительно хотите удалить" & vbCrLf & "элемент: " & _
ListBoxItems.Text & vbCrLf & "из списка: " & ComboBoxLists.Text & " ?", vbOKCancel + vbExclamation, _
"Удаление элемента списка") = vbOK Then
With iSheetLists.Columns(iNumListColumn)
On Error Resume Next
Set r = .Find(What:=ListBoxItems.Text, LookIn:=xlValues, LookAt:=xlWhole)
If Not r Is Nothing Then r.Delete Shift:=xlUp
End With
dItems.RemoveAll
TextBoxItems.Text = ""
Call MyFillDataControlItems(ListBoxItems)
End If
End Sub
Private Sub ListBoxItems_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Call OKButton_Click
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Call Comm1_Click
End Sub
Private Sub NewItButton_Click()
Dim s
s = TextBoxItems.Text
If IsNumeric(s) Then s = Val(s)
If Len(Trim(s)) = 0 Then Exit Sub
If dItems.Exists(s) Then
MsgBox "Элемент: " & s & vbCrLf & "уже есть в этом списке !"
Exit Sub
End If
With iSheetLists
On Error Resume Next
.Cells(.Rows.Count, iNumListColumn).End(xlUp).Offset(1, 0).Value = s
End With
dItems.RemoveAll
TextBoxItems.Text = ""
Call MyFillDataControlItems(ListBoxItems, s)
End Sub
Private Sub OKButton_Click()
Dim r As Integer, C As Integer
If ListBoxItems.ListIndex = -1 Then Exit Sub
If Not ActiveSheet Is iSheetLists Then
If ActiveSheet.ProtectContents = True And ActiveCell.Locked = True Then
MsgBox "Лист защищен! Что бы вставить значение, снимите защиту листа."
Else
ActiveCell.Value = ListBoxItems.Text
Select Case iShiftOption
Case 0: r = 0: C = 0
Case 1: r = -1: C = 0
Case 2: r = 0: C = 1
Case 4: r = 0: C = -1
Case Else: r = 1: C = 0
End Select
On Error Resume Next
'AppActivate "Microsoft Excel"
ActiveCell.Offset(r, C).Activate
ListBoxItems.SetFocus
On Error GoTo 0
End If
End If
End Sub
Private Sub SettingsButton_Click()
Call MyControlsState(False)
Me.Hide
SettingsForm.Show
ListBoxItems.Clear
Call MyFillDataControlLists(ComboBoxLists)
If Not dLists.Count = 0 Then
Call MyFillDataControlItems(ListBoxItems)
End If
TextBoxItems.Text = ""
Me.Show 0
End Sub
Private Sub UserForm_Terminate()
Call mySetCustomProperties("NumListColumn", iNumListColumn)
Call mySetCustomProperties("SortingOption", iSortingOption)
Call mySetCustomProperties("ShiftOption", iShiftOption)
Call mySetCustomProperties("DblClickRunOption", iDblClickRunOption)
Call mySetCustomProperties("FindOption", iFindOption)
Call mySetCustomProperties("MainFormPosOption", iMainFormPosOption)
Set dLists = Nothing
Set dItems = Nothing
End Sub
Private Sub mySetCustomProperties(prName As String, prValue As Long)
On Error Resume Next
With ThisWorkbook.CustomDocumentProperties
If MyCustomPropertiesExists(prName) Then
.Item(prName).Value = prValue
Else
Call MyCreateCustomProperties(prName, prValue)
End If
End With
On Error GoTo 0
End Sub
|