Никак не получается. Как только ввожу первую цифру в этот КомбоБокс, появляется окошко Rin-time error 450: wrong number of arguments or invalid property assigment
Ну и в коде желтым заливается выделенная полужирным строка
Код
Private Sub ComboBox4_Change()
Dim DatBox As Object
Set DatBox = Me.ActiveControl
[B] If Len(DatBox) = 2 And Right$(DatBox, 1) = "." [/B]Then DatBox = "0" & DatBox
If Len(DatBox) = 5 And Right$(DatBox, 1) = "." Then _
DatBox = Left$(DatBox, 3) & "0" & Right$(DatBox, 2)
If (Len(DatBox) = 3 Or Len(DatBox) = 6) And Right$(DatBox, 1) <> "." Then
DatBox = Left$(DatBox, Len(DatBox) - 1) & "." & Right$(DatBox, 1)
End If
Set DatBox = Nothing
'
Call CheckCombo1
'
End Sub
Пример после максимального урезания весит 215КБ. Попробую вложить. Может пройдёт... Подскажите, пожалуйста, в чем может быть проблема?
Не прошло. В следующем посте выложу полный код на форму.
Private Sub ComboBox1_Change() Call CheckCombo1 End Sub Private Sub ComboBox11_Change() End Sub Private Sub ComboBox13_Change() End Sub Private Sub ComboBox14_Change() End Sub Private Sub ComboBox2_Change() Call CheckCombo1 End Sub
'Дальше идут 4 команды для дати народження в СВ4 (ввод даты без разделителя с предупреждением о не верном вводе). ОСТОРОЖНО, не вводить повтороно здесь Function DatBox_KeyPress(ByVal KeyAsci As Integer) Private Sub ComboBox4_Change() Dim DatBox As Object Set DatBox = Me.ActiveControl If Len(DatBox) = 2 And Right$(DatBox, 1) = "." Then DatBox = "0" & DatBox If Len(DatBox) = 5 And Right$(DatBox, 1) = "." Then _ DatBox = Left$(DatBox, 3) & "0" & Right$(DatBox, 2) If (Len(DatBox) = 3 Or Len(DatBox) = 6) And Right$(DatBox, 1) <> "." Then DatBox = Left$(DatBox, Len(DatBox) - 1) & "." & Right$(DatBox, 1) End If Set DatBox = Nothing ' Call CheckCombo1 ' End Sub Private Sub ComboBox4_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) ComboBox4.MaxLength = 10 KeyAscii = DatBox_KeyPress(KeyAscii) End Sub Function DatBox_KeyPress(ByVal KeyAsci As Integer) Select Case KeyAsci Case 48 To 57: DatBox_KeyPress = KeyAsci Case 44 To 47, 58: DatBox_KeyPress = 46 Case Else: DatBox_KeyPress = 0 End Select End Function Private Sub ComboBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean) Dim Cancl As Boolean, datText$ Dim fUsFr As Object: Set fUsFr = Me Dim DatBox As Object: Set DatBox = Me.ActiveControl If Len(DatBox) Then Else GoTo Cancel_ datText = Left$(DatBox.Text, 5) If Len(datText) = 4 Then datText = Left$(datText, 3) & "0" & Right$(datText, 1) If Len(DatBox) = 6 Then DatBox = datText If IsDate(DatBox) Then If datText <> Format(DatBox, "DD.MM" ;) Then GoTo err_ DatBox = Format(DatBox, "DD.MM.YYYY" ;) : GoTo Cancel_ End If err_: MsgBox "Не вірно введена дата!", vbExclamation, "Перевірте, будь ласка, дату" With fUsFr.Controls(DatBox.Name) .SelStart = 0: .SelLength = Len(DatBox.Text) End With Cancl = True Cancel_: Set DatBox = Nothing: Set fUsFr = Nothing Cancel = Cancl End Sub
Private Sub ComboBox5_Change() Call CheckCombo1 End Sub Private Sub ComboBox8_Change() End Sub Private Sub ComboBox9_Change() End Sub Private Sub CheckBox1_Click() 'Это условие для CheckBox1. Если галка есть, то значение ComboBox7 = Me.ComboBox13. Или пусто. If Me.CheckBox1 = True Then Me.ComboBox7 = Me.ComboBox13 Else Me.ComboBox7 = "" End If End Sub
Private Sub Frame1_Click1() End Sub Private Sub Frame3_Click1() End Sub Private Sub Label10_Click1() End Sub Private Sub Label13_Click1() End Sub Private Sub Label19_Click1() End Sub Private Sub Label4_Click1() End Sub
Private Sub Label9_Click1()
End Sub
Private Sub Label17_Click()
End Sub
Private Sub TextBox6_Change() End Sub
Далее в модуле '
Public Counter1 As Integer
Public Sub show1() U1.show End Sub
Sub CheckCombo1() Dim x As Control Counter = 0 With U1 'на U1 For Each x In .Controls If TypeOf x Is MSForms.ComboBox Then If x.Tag = "w" Then If x.Value <> "" Then Counter = Counter + 1 End If End If Next End With If Counter = 5 Then Call Finder1 '"Звонок" после заполнения 4 поля с тэгом "w". End Sub
Sub Finder1() Dim rw As Long, i As Long, x rw = Cells(Rows.Count, "d" ;) .End(xlUp).Row x = 0 With U1 'на U1 For i = 2 To rw If Cells(i, 4) = .ComboBox1 Then If Cells(i, 5) = .ComboBox2 Then If Cells(i, 6) = .ComboBox5 Then If Cells(i, 7) = CDate(.ComboBox4) Then .ListBox1.AddItem "" .ListBox1.List(x, 0) = i .ListBox1.List(x, 1) = Cells(i, 69) '69--номер столбца, для выведения в ListBox1 (серия +номер). x = x + 1 End If End If End If End If Next End With End Sub
iam1968, вот странные вы люди(день дурака завтра будет, напоминаю)! Нафиг выкладывать пятистраничный листинг без файла? Нам за Вас нарисовать файл, форму, контролы, чтоб проверить, Вам помочь? Не проще ли Вам выложить файл-пример с указанием строки, где ошибка? Нам это не надо - надо Вам.
Если уж и показывать код, то ведь можно его прицепить в txt-файле... А файл почему большой? - скорее всего пытаетесь прикрепить свой рабочий файл, вместо того, чтобы создать МАЛЕНЬКИЙ файл-пример с аналогичной задачей.
Понятно, что Вам НЕ понятно )) Попробую ещё раз: у Вас есть проблема всего с одним контролом (кстати, почему КомбоБокс, а не ТекстБокс?) - не получается ввести в него дату в нужном формате. Попробуйте мне объяснить - зачем всем тем, кто захочет Вам помочь, все остальные поля ввода? Почему бы не создать действительно маленький файл с маленькой формой и показать в ней неработающий код? Не цеплять рабочую форму, а только необходимое?
Я очень слабо разбираюсь в VBA, и мне не хотелось бы создать ситуацию, когда я чрезмерно урежу пример, кто-то потратит время на урезанный пример, даст ответ на мой вопрос на этом примере, а потом окажется, что пример ЧРЕЗМЕРНО сокращён и в нём не хватает какой-то существенной "мелочи". И придется вновь разворачивать тему и проходить всё заново.
Затрудняюсь сказать, откуда этот код в таком виде вылез, но поясняю. Данный код не предназначен для работы с контролами на фреймах.
Код
Set DatBox = Me.ActiveControl
было введено для оформления кода в виде функций с вызовом данной функции по нажатию любой кнопки. У вас ActiveControl - это Frame1. Соответственно код не работает. Более того, этот код предназначался для TextBox, и с комбо не тестировался. Часть процедур вытащена из общего модуля в модуль формы. Замените в оригинале все DatBox на нужный контрол и удалите
Код
Set DatBox = Me.ActiveControl
Должно заработать. Для каждого контрола должно быть три процедуры Change, Exit и KeyPress. Вариант 1 - под форму, без общего модуля.
В форме и коде заменил СВ4 на TextBox7. В коде заменил DatBox на TextBox7. Убрал (в одном месте) Set DatBox = Me.ActiveControl.
Получилось:
Скрытый текст
Private Sub TextBox7_Change() Dim TextBox7 As Object 'Set DatBox = Me.ActiveControl If Len(TextBox7) = 2 And Right$(DatBox, 1) = "." Then TextBox7 = "0" & DatBox If Len(TextBox7) = 5 And Right$(DatBox, 1) = "." Then _ TextBox7 = Left$(DatBox, 3) & "0" & Right$(TextBox7, 2) If (Len(TextBox7) = 3 Or Len(TextBox7) = 6) And Right$(TextBox7, 1) <> "." Then TextBox7 = Left$(TextBox7, Len(DatBox) - 1) & "." & Right$(TextBox7, 1) End If Set TextBox7 = Nothing ' Call CheckCombo1 ' End Sub Private Sub TextBox7_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) TextBox7.MaxLength = 10 KeyAscii = TextBox7_KeyPress(KeyAscii) End Sub Function TextBox7_KeyPress(ByVal KeyAsci As Integer) Select Case KeyAsci Case 48 To 57: TextBox7_KeyPress = KeyAsci Case 44 To 47, 58: TextBox7_KeyPress = 46 Case Else: TextBox7_KeyPress = 0 End Select End Function Private Sub TextBox7_Exit(ByVal Cancel As MSForms.ReturnBoolean) Dim Cancl As Boolean, datText$ Dim fUsFr As Object: Set fUsFr = Me Dim TextBox7 As Object: Set TextBox7 = Me.ActiveControl If Len(TextBox7) Then Else GoTo Cancel_ datText = Left$(TextBox7.Text, 5) If Len(datText) = 4 Then datText = Left$(datText, 3) & "0" & Right$(datText, 1) If Len(TextBox7) = 6 Then TextBox7 = datText If IsDate(TextBox7) Then If datText <> Format(TextBox7, "DD.MM" ;) Then GoTo err_ TextBox7 = Format(TextBox7, "DD.MM.YYYY" ;) : GoTo Cancel_ End If err_: MsgBox "Íå â³ðíî ââåäåíà äàòà!", vbExclamation, "Ïåðåâ³ðòå, áóäü ëàñêà, äàòó" With fUsFr.Controls(DatBox.Name) .SelStart = 0: .SelLength = Len(DatBox.Text) End With Cancl = True Cancel_: Set DatBox = Nothing: Set fUsFr = Nothing Cancel = Cancl End Sub
При открытии формы complite error ambiguus name defected: TextBox7_KeyPress
Собственно вот они: Private Sub TextBox7_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) TextBox7.MaxLength = 10 KeyAscii = TextBox7_KeyPress(KeyAscii) End Sub Function TextBox7_KeyPress(ByVal KeyAsci As Integer) Select Case KeyAsci Case 48 To 57: TextBox7_KeyPress = KeyAsci Case 44 To 47, 58: TextBox7_KeyPress = 46 Case Else: TextBox7_KeyPress = 0 End Select End Function
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Комбобокс в форме был заменен на TextBox7. Далее в коде DatBox был заменен на TextBox7 (не везде). Сейчас нет времени. Наверное замену DatBox на TextBox7 надо будет продолжить.
Скрытый текст
Private Sub TextBox7_Change() Dim DatBox As Object 'Set DatBox = Me.ActiveControl.ActiveControl If Len(TextBox7) = 2 And Right$(TextBox7, 1) = "." Then TextBox7 = "0" & TextBox7 If Len(TextBox7) = 5 And Right$(TextBox7, 1) = "." Then _ TextBox7 = Left$(TextBox7, 3) & "0" & Right$(TextBox7, 2) If (Len(TextBox7) = 3 Or Len(TextBox7) = 6) And Right$(TextBox7, 1) <> "." Then TextBox7 = Left$(TextBox7, Len(TextBox7) - 1) & "." & Right$(TextBox7, 1) End If Set DatBox = Nothing ' Call CheckCombo1 'Это было включено для поиска формой. Если не нужно--отключить. ' End Sub Private Sub TextBox7_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) TextBox7.MaxLength = 10 KeyAscii = DatBox_KeyPress(KeyAscii) End Sub Function DatBox_KeyPress(ByVal KeyAsci As Integer) Select Case KeyAsci Case 48 To 57: DatBox_KeyPress = KeyAsci Case 44 To 47, 58: DatBox_KeyPress = 46 Case Else: DatBox_KeyPress = 0 End Select End Function Private Sub TextBox7_Exit(ByVal Cancel As MSForms.ReturnBoolean) Dim Cancl As Boolean, datText$ Dim fUsFr As Object: Set fUsFr = Me Dim DatBox As Object: Set DatBox = Me.ActiveControl If Len(TextBox7) Then Else GoTo Cancel_ datText = Left$(DatBox.Text, 5) If Len(datText) = 4 Then datText = Left$(datText, 3) & "0" & Right$(datText, 1) If Len(DatBox) = 6 Then DatBox = datText If IsDate(DatBox) Then If datText <> Format(DatBox, "DD.MM" Then GoTo err_ DatBox = Format(DatBox, "DD.MM.YYYY" : GoTo Cancel_ End If err_: MsgBox "Не верно введена дата", vbExclamation, "Проверьте дату" With fUsFr.Controls(DatBox.Name) .SelStart = 0: .SelLength = Len(DatBox.Text) End With Cancl = True Cancel_: Set DatBox = Nothing: Set fUsFr = Nothing Cancel = Cancl End Sub
iam1968, в следующий раз код будет удален. Вместе с сообщениями! Вас предупреждали, что большие листинги лучше выкладывать в текстовом файле, если не хотите Excel показывать.