Структура: Вывод на экран информации о человеке, номер телефона которого введен с клавиатуры

Option Explicit
Option Compare Text
 
Private Type TRecord
    Title As String
    Address  As String
    Login As String
    Password As String
    Phone As String
    Mail As String
    id As Long
End Type
 
Private Type TRec
    Ubound As Long
    CurInd  As Long
    NewId  As Long
    Records() As TRecord
End Type
 
Private Const rr = vbLf & vbCrLf
 
Dim mRec As TRec, FileRec$, v
Dim i&, j&, ff&, s$, DataChanges As Boolean
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
 
Private m_hMod As Long
 
Private Sub SavingAccounts()
    'Сохранение всех записей
    Dim Rec2() As TRecord, i&, j&
    If ActiveControl.Name = "Text1" Then Text1_Validate ActiveControl.Index, 0
    Rec2 = mRec.Records
    For i = 0 To List1(0).ListCount - 1: For j = 0 To UBound(Rec2)
        With Rec2(j)
            If .id = List1(0).ItemData(i) Then
                mRec.Records(i) = Rec2(j)
            End If
        End With
    Next: Next
    On Error Resume Next
    Kill FileRec
    ff = FreeFile
    Open FileRec For Binary As #ff
    Put #ff, 1, mRec
    Close #ff
    DataChanges = 0 ' Сброс изменений
End Sub
 
 
Private Sub Text1_Change(Index As Integer)
    Dim i&, j&, s$, a$(), fnd&
    Static ar$(), b As Boolean
    DataChanges = True 'Изменения в режиме выполнения
    With Text1(Index)
        Select Case Index
        Case 1
            s = Trim(.Text)
            .FontUnderline = IIf(Left$(s, 6) = "ftp://", 1, 0)
            .FontUnderline = IIf(Left$(s, 7) = "http://", 1, .FontUnderline)
            .FontUnderline = IIf(Left$(s, 8) = "https://", 1, .FontUnderline)
            .FontUnderline = IIf(InStr(1, s, " ") = 0, .FontUnderline, 0)
            .ForeColor = IIf(.FontUnderline, vbBlue, vbBlack)
        Case 6
            With List1(0)
                If b = False Then
                    b = True
                    ReDim Preserve ar(.ListCount - 1)
                    For i = 0 To UBound(ar)
                        ar(i) = .List(i) & rr & .ItemData(i)
                    Next
                End If
            End With
            ControlsEnabled Me, .Text = "", "Command1(20,21,30 to 33)"
            If .Text = "" Then b = False
            List1(0).Clear
            For i = 0 To UBound(ar)
                a = Split(ar(i), rr)
                If InStr(1, a(0), .Text, 1) > 0 Or .Text = "" Then
                    List1(0).AddItem a(0), j
                    List1(0).ItemData(j) = a(1)
                    If a(1) = mRec.Records(mRec.CurInd).id Then fnd& = j
                    j = j + 1
                End If
            Next
            With List1(0)
                ControlsEnabled Me, .ListCount > 0, "List1(0)", "Label1(0 to 5)", "Text1(0 to 5)", "Command1(10 to 15)"
                If .ListCount > 0 Then .ListIndex = fnd
            End With
        End Select
    End With
End Sub
 
Private Sub SubMenu_Click(Index As Integer)
    Select Case NameIndex(ActiveControl)
    Case "command1(11)"
        Select Case Index
        Case 0: With Clipboard: .Clear: .SetText (Text1(1).Text): End With
        Case 1: ShellApp.Open Text1(1).Text
        End Select
    End Select
End Sub
 
Private Sub LoadAccounts()
    On Error Resume Next
    ff = FreeFile
    Open FileRec For Binary As #ff
    If LOF(ff) < 1 Then
        mRec.Ubound = -1
    Else
        Get #ff, 1, mRec
    End If
    Close #ff
    List1(0).Clear
    For i = 0 To mRec.Ubound
        With mRec.Records(i)
            List1(0).AddItem .Title, i
            List1(0).ItemData(i) = .id
        End With
    Next
    List1(0).ListIndex = 0
    DataChanges = 0 'Сброс изменений
End Sub
 
 
Private Sub Text1_Validate(Index As Integer, Cancel As Boolean)
    On Error Resume Next
    With mRec.Records(mRec.CurInd)
        
        Select Case Index
        Case 0
            If Trim(Text1(Index).Text) = "" Then
                MsgBox Label1(Index) & " не должен быть пустым", vbExclamation, Me.Caption
                Text1(Index).Text = .Title
                Cancel = 1: Exit Sub
            End If
            .Title = Text1(Index)
            With List1(0)
                .List(.ListIndex) = Text1(Index)
            End With
            
        Case 1
            .Address = Text1(Index)
        Case 2
            .Login = Text1(Index)
        Case 3
            .Password = Text1(Index)
        Case 4
            With Text1(Index)
                s = "" 'Форматируем номер телефона
                For i = 1 To Len(.Text): If Mid$(.Text, i, 1) Like "#" Then s = s & Mid$(.Text, i, 1)
                Next: s = Format(s, IIf(Len(s) < 8, "###-##-##", "# (###) ###-##-##"))
                While Left$(s, 1) = "-": s = Mid$(s, 2): Wend: .Text = s
            End With
            .Phone = Text1(Index)
        Case 5
            .Mail = Text1(Index)
        End Select
    End With
End Sub
 
Private Sub List1_Click(Index As Integer)
    Dim i&
    With mRec
        On Error Resume Next
        For i = 0 To mRec.Ubound
            With .Records(i)
                If .id = List1(Index).ItemData(List1(Index).ListIndex) Then
                    mRec.CurInd = i
                    Text1(0) = .Title
                    Text1(1) = .Address
                    Text1(2) = .Login
                    Text1(3) = .Password
                    Text1(4) = .Phone
                    Text1(5) = .Mail
                    Exit For
                End If
            End With
        Next
    End With
End Sub
 
 
Private Sub Command1_Click(Index As Integer)
    Dim i&, j&, a$(), aa$()
    
    Select Case Index
    Case -1 'Если кнопка не выбранна, и нужно попасть в конец процедуры
    Case 34:  LoadAccounts 'Перезагрузка
        Command1_Click 16 'Стирание поля над списком
        
    Case 33:  SavingAccounts 'Сохранение всех записей
 
    Case 16: Text1(Index - 10).Text = "" 'Стирание поля над списком
    Case 14 'Копировать телефон
        With Text1(Index - 10): s = ""
            For i = 1 To Len(.Text): If Mid$(.Text, i, 1) Like "#" Then s = s & Mid$(.Text, i, 1)
        Next: End With: With Clipboard: .Clear: .SetText s: End With
    Case 11
        With Text1(1)
            LoadAction -1, SubMenu, "enabled=1//" & Abs(.FontUnderline), "caption=Копировать//Перейти по ссылке"
        End With
 
        With Command1(Index): PopupMenu Menu, , .Left, .Top: End With
    Case 10 To 15 'Копировать поля
        With Clipboard: .Clear: .SetText (Text1(Index - 10).Text): End With
    Case 32 'Сортировка
        With List1(0)
            qSortList List1(0), 0, .ListCount - 1
            .ListIndex = 0
        End With
        DataChanges = 1
    Case 20, 21 'Перемещение в списке
        With List1(0)
            i = IIf(Index = 20, -1, 1)
            j = i + .ListIndex
            If j >= .ListCount Or j < 0 Then Exit Sub
            v = Array(.List(j), .ItemData(j))
            .RemoveItem (.ListIndex + i)
            j = .ListIndex + Abs(i < 0)
            .AddItem v(0), (j)
            .ItemData(j) = v(1)
        End With
        DataChanges = 1
    Case 31 'Удалить
        With mRec
            .Ubound = .Ubound - 1
            If .Ubound < 0 Then
                Erase .Records
                List1(0).Clear
                For i = 0 To Text1.Count - 1: Text1(i).Text = "": Next
                .Ubound = -1
                .NewId = 0
            Else
                ReDim Rec2(.Ubound) As TRecord
                For i = 0 To .Ubound
                    With .Records(i)
                        If .id <> List1(0).ItemData(List1(0).ListIndex) Then
                            Rec2(j) = mRec.Records(i): j = j + 1
                        End If
                    End With
                Next
                .Records = Rec2
                With List1(0)
                    j = .ListIndex
                    .RemoveItem .ListIndex
                    .ListIndex = j - Abs(j = .ListCount)
                End With
            End If
        End With
    Case 30 'Добавить
        With mRec
            .Ubound = .Ubound + 1
            ReDim Preserve .Records(.Ubound)
            With .Records(.Ubound)
                mRec.NewId = mRec.NewId + 1
                .id = mRec.NewId
                .Title = "Новая запись " & .id
                List1(0).AddItem .Title, 0
                List1(0).ItemData(0) = .id
            End With
            List1(0).ListIndex = 0
        End With
    Case Else 'Если это непроработанная кнопка выход здесь
        Exit Sub
    End Select
    
    ControlsEnabled Me, List1(0).ListCount > 0, "List1(0)", "Label1(0 to 5)", "Text1(0 to 6)", "Command1(10 to 16, 20,21 , 31 to 32)"
    
End Sub
 
 
 
 
Private Sub Form_Load()
 
''    s = ""
''    For i = 33 To 255
''        s = s & Chr(i)
''        If i Mod 32 = 0 Then s = s & vbLf
''    Next
''    Clipboard.Clear
''    Clipboard.SetText s
''
''    Stop
    On Error Resume Next
    FileRec = Environ("AppData") & "\Accounts"
    MkDir FileRec
    FileRec = FileRec & "\Accounts.dat"
 
    
    Me.Caption = "Аккаунты"
    With SetCtr
    
        .GridHeight = 3: .Gaps = 1
        LoadAction 0, Label1, "Autosize=1", "Caption=Заголовок//Адрес//Логин//Пароль//Телефон//Почта"
        
        .GridWidth = 25
        LoadAction 0, Text1, Label1.Count, "Text="
        
        .GridHeight = 3: .GridWidth = 3: .Gaps = 1
        LoadAction 0, Command1(10), Label1.Count, "caption=}//‚//}", "font.name=Wingdings 3", "ToolTipText=Копировать"
        .GridWidth = 25: .GridHeight = 3
        LoadAction 0, Text1
 
        .GridWidth = 25: .GridHeight = (Label1.Count - 1) * 4
        LoadAction 2, List1
        
        .GridHeight = 3: .GridWidth = 3: .Gaps = 1
        LoadAction 0, Command1, "caption=У", "font.name=Wingdings 2", "font.size=10", "ToolTipText=Очистить поиск"
 
        .GridHeight = 3: .GridWidth = 3: .Gaps = 0
        LoadAction 2, Command1(20), "caption=З//И", "font.name=Wingdings 3", "ToolTipText=Переместить вверх//Переместить вниз"
        
        .GridWidth = 12: .GridHeight = 5: .Gaps = 1
        LoadAction 1, Command1(30), "caption=Добавить запись//Удалить запись//Сортировать записи//Сохранить//Пере запуск"
        
        .GridHeight = 3: .GridWidth = 3: .Gaps = 1
        LoadAction 2, Command1, "caption=‚", "font.name=Wingdings 3", "font.size=10", "ToolTipText=Недоделанно"
 
    End With
    LoadAccounts
    Command1_Click -1
    FrameRePaint Me
End Sub
 
Private Sub Form_Resize()
    If Me.WindowState <> 1 Then Me.WindowState = 0
    ApplyFinalSize Me
End Sub
 
Private Sub Form_Paint()
    'Поверх всех окон
    SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, &H10 Or &H1 Or &H2
End Sub
 
Private Sub Form_Initialize()
    m_hMod = LoadLibrary("shell32.dll")
    InitCommonControls
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    
    If DataChanges Then
        If MsgBox("Сохранить изменения ?", 68, Me.Caption) = vbYes Then
            SavingAccounts
        End If
    End If
    
    FreeLibrary m_hMod
End Sub