This site is developed to XHTML and CSS2 W3C standards.
If you see this paragraph, your browser does not support those standards and you
need to upgrade. Visit WaSP
for a variety of options.
Paste #530
Posted by:
Posted on: 2026-02-20 23:28:08
Age: 5 hrs ago
Views: 2
Option Explicit
' --- Глобальные ---
Public OpenChats As Collection
Private ServerChat As FormChat
Private RightClickedNode As Node
Private BlinkContacts As Collection ' коллекция контактов, которые мигают
Private BlinkState As Boolean ' текущий цвет мигания (True = красный, False = черный)
Public WaitingForLogin As Boolean
Public ServerChatWindow As formChat
Private AutoConnectChecked As Boolean
' ===== Автологин и текущий пользователь =====
Public LoginUser As String
Public LoginPass As String
Public LoggedUser As String
' ======== Form Load ========
Private Sub Form_Load()
Set tvContacts.ImageList = ImageList1
LoginUser = "a"
LoginPass = "a"
LoggedUser = ""
Set OpenChats = New Collection
Me.Caption = "Messenger"
tvContacts.LineStyle = 0
tvContacts.Indentation = 150
' ==== Загружаем контакты или создаём категорию General ====
If Dir(App.Path & "\contacts.dat") <> "" Then
LoadContacts
Else
Dim grpGeneral As Node
Set grpGeneral = tvContacts.Nodes.Add(, , "general", "General (0)")
grpGeneral.Bold = True
grpGeneral.Expanded = True
grpGeneral.Image = 1
grpGeneral.SelectedImage = 1
End If
' ==== Инициализация коллекции для мигающих контактов ====
Set BlinkContacts = New Collection
' ==== Настройка таймера для мигания ====
tmrBlink.Interval = 400 ' интервал мигания в миллисекундах
tmrBlink.Enabled = True
Dim autoConnect As Boolean
LoadSettings autoConnect
AutoConnectChecked = autoConnect
End Sub
Private Sub Form_Activate()
Static AlreadyRun As Boolean
If AlreadyRun Then Exit Sub
AlreadyRun = True
If AutoConnectChecked Then
With frmLogin
.Left = Me.Left + (Me.Width - .Width) / 2
.Top = Me.Top + (Me.Height - .Height) / 2
.Show vbModal
End With
End If
End Sub
Private Sub JoinConferenceAction()
' ===== Проверка авторизации =====
If LoggedUser = "" Then
With frmLogin
.Left = Me.Left + (Me.Width - .Width) / 2
.Top = Me.Top + (Me.Height - .Height) / 2
.Show vbModal
End With
Else
frmJoinConference.Show vbModal
End If
End Sub
Private Sub mnuJoinConference_Click()
JoinConferenceAction
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
' Если нажата вторая кнопка
If Button.Index = 2 Then
Call mnuAddContact_Click
End If
' Если нажата четвёртая кнопка
If Button.Index = 4 Then
JoinConferenceAction
End If
End Sub
' ======== Connect / Disconnect ========
Private Sub mnuConnect_Click()
If Winsock1.State = sckClosed Then
' Центрируем форму frmLogin относительно Form1
With frmLogin
.Left = Form1.Left + (Form1.Width - .Width) / 2
.Top = Form1.Top + (Form1.Height - .Height) / 2
.Show vbModal
End With
Else
Winsock1.Close
mnuConnect.Caption = "Connect..."
lblConnectionState.Caption = "Disconnected!"
End If
End Sub
Private Sub mnuSettings_Click()
frmSettings.Show vbModal
End Sub
' ==== Инициализация категорий при загрузке ====
Dim cat As Node
For Each cat In tvContacts.Nodes
If cat.Parent Is Nothing Then
cat.Bold = True
cat.Expanded = True ' раскрыта сразу
cat.Image = 2 ' картинка для открытой категории
cat.SelectedImage = 2
End If
Next
Private Sub UpdateCategoryIcon(n As Node)
If n Is Nothing Then Exit Sub
If Not n.Parent Is Nothing Then Exit Sub
If n.Expanded Then
n.Image = 2 ' открытая папка
n.SelectedImage = 2
Else
n.Image = 1 ' закрытая папка
n.SelectedImage = 1
End If
End Sub
' ===== Принудительное обновление картинки при разворачивании/сворачивании =====
Private Sub tvContacts_NodeExpand(ByVal Node As MSComctlLib.Node)
UpdateCategoryIcon Node
End Sub
Private Sub tvContacts_NodeCollapse(ByVal Node As MSComctlLib.Node)
UpdateCategoryIcon Node
End Sub
Private Sub UpdateCategoryCounts()
Dim n As Node
Dim childCount As Long
For Each n In tvContacts.Nodes
' Только верхние узлы (категории)
If n.Parent Is Nothing Then
childCount = n.Children
' Убираем старые скобки
If InStr(n.Text, "(") > 0 Then
n.Text = Left$(n.Text, InStr(n.Text, "(") - 2)
End If
' Добавляем новое количество
n.Text = n.Text & " (" & childCount & ")"
End If
Next
End Sub
Private Sub tvContacts_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> vbLeftButton Then Exit Sub
Dim n As Node
Set n = tvContacts.SelectedItem
If n Is Nothing Then Exit Sub
' Только категории
If n.Parent Is Nothing Then
' Даём TreeView завершить разворот
DoEvents
If n.Expanded Then
n.Image = 2
n.SelectedImage = 2
Else
n.Image = 1
n.SelectedImage = 1
End If
End If
End Sub
Private Sub tvContacts_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbRightButton Then
' Берём уже выбранный элемент
Set RightClickedNode = tvContacts.SelectedItem
If RightClickedNode Is Nothing Then Exit Sub
' ===== ЕСЛИ ЭТО КОНТАКТ =====
If InStr(1, RightClickedNode.Key, "_contact_", vbTextCompare) > 0 Then
mnuDeleteContact.Enabled = True
mnuDeleteCategory.Enabled = False
mnuAddCategory.Enabled = False
mnuAddContact.Enabled = False
Else
' ===== ЭТО КАТЕГОРИЯ =====
mnuDeleteContact.Enabled = False
mnuAddCategory.Enabled = True
mnuAddContact.Enabled = True
If RightClickedNode.Key <> "general" Then
mnuDeleteCategory.Enabled = True
Else
mnuDeleteCategory.Enabled = False
End If
End If
PopupMenu mnuContactsPopup
End If
End Sub
Private Sub tvContacts_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then ' Enter
KeyAscii = 0
End If
End Sub
Private Sub tvContacts_KeyDown(KeyCode As Integer, Shift As Integer)
Dim n As Node
Set n = tvContacts.SelectedItem
If n Is Nothing Then Exit Sub
Select Case KeyCode
' ===== ENTER =====
Case vbKeyReturn
' ===== КОНТАКТ =====
If Not n.Parent Is Nothing Then
If InStr(1, n.Key, "_contact_", vbTextCompare) > 0 Then
KeyCode = 0
If Form1.LoggedUser = "" Then
With frmLogin
.Left = Form1.Left + (Form1.Width - .Width) / 2
.Top = Form1.Top + (Form1.Height - .Height) / 2
.Show vbModal
End With
Exit Sub
End If
OpenPrivateChat n.Text
End If
Else
' ===== КАТЕГОРИЯ =====
' Даем TreeView выполнить стандартное раскрытие
DoEvents
' Принудительно обновляем иконку
If n.Expanded Then
n.Image = 2
n.SelectedImage = 2
Else
n.Image = 1
n.SelectedImage = 1
End If
End If
' ===== DELETE =====
Case vbKeyDelete
' ----- КОНТАКТ -----
If Not n.Parent Is Nothing Then
If MsgBox("Delete contact '" & n.Text & "' ?", _
vbYesNo + vbQuestion) = vbYes Then
tvContacts.Nodes.Remove n.Key
UpdateCategoryCounts
SaveContacts
End If
' ----- КАТЕГОРИЯ -----
Else
If n.Key = "general" Then
MsgBox "You cannot delete the General category!", vbExclamation
Exit Sub
End If
If MsgBox("Delete category '" & n.Text & "' ?", _
vbYesNo + vbQuestion) = vbYes Then
tvContacts.Nodes.Remove n.Key
UpdateCategoryCounts
SaveContacts
End If
End If
KeyCode = 0
End Select
End Sub
Private Sub tvContacts_DblClick()
Dim n As Node
Set n = tvContacts.SelectedItem
If n Is Nothing Then Exit Sub
' Если категория — ничего
If n.Parent Is Nothing Then Exit Sub
' Если контакт
If InStr(1, n.Key, "_contact_", vbTextCompare) > 0 Then
OpenPrivateChat n.Text
End If
End Sub
Private Sub OpenPrivateChat(ByVal username As String)
Dim frm As FormChat
' ===== Проверяем, открыт ли уже чат =====
On Error Resume Next
Set frm = OpenChats(username)
On Error GoTo 0
If Not frm Is Nothing Then
frm.Show
frm.SetFocus
Exit Sub
End If
' ===== Если не открыт — создаём =====
Set frm = New FormChat
frm.SetContact username
OpenChats.Add frm, username
frm.Show
End Sub
Private Sub mnuDeleteContact_Click()
If RightClickedNode Is Nothing Then Exit Sub
' Убеждаемся что это контакт
If RightClickedNode.Parent Is Nothing Then Exit Sub
If MsgBox("Delete contact '" & RightClickedNode.Text & "' ?", _
vbYesNo + vbQuestion) = vbYes Then
tvContacts.Nodes.Remove RightClickedNode.Key
UpdateCategoryCounts
Set RightClickedNode = Nothing
End If
SaveContacts
End Sub
Private Sub mnuDeleteCategory_Click()
If tvContacts.SelectedItem Is Nothing Then Exit Sub
Dim n As Node
Set n = tvContacts.SelectedItem
' Нельзя удалить general
If n.Key = "general" Then
MsgBox "You cannot delete the General category!", vbExclamation
Exit Sub
End If
' Проверяем что это категория (верхний уровень)
If Not n.Parent Is Nothing Then Exit Sub
If MsgBox("Delete category '" & n.Text & "' ?", _
vbYesNo + vbQuestion) = vbNo Then Exit Sub
tvContacts.Nodes.Remove n.Key
UpdateCategoryCounts
SaveContacts
End Sub
Private Sub mnuAddAContact_Click()
mnuAddContact_Click
End Sub
Private Sub mnuAddContact_Click()
Dim frm As frmSelectCategory
Dim parentNode As Node
Dim newKey As String
Dim n As Node, childNode As Node
Dim exists As Boolean
' --- Создаем форму выбора категории ---
Set frm = New frmSelectCategory
frm.FillCategories tvContacts
frm.Show vbModal
' --- Если пользователь отменил ---
If Not frm.Confirmed Then
Unload frm
Set frm = Nothing
Exit Sub
End If
' --- Проверка глобально, чтобы контакт с таким именем не существовал ---
exists = False
For Each n In tvContacts.Nodes
If n.Parent Is Nothing Then ' категория
Set childNode = n.Child
Do While Not childNode Is Nothing
If StrComp(childNode.Text, frm.ContactName, vbTextCompare) = 0 Then
exists = True
Exit Do
End If
Set childNode = childNode.Next
Loop
End If
If exists Then Exit For
Next
If exists Then
MsgBox "A contact with this name already exists!", vbExclamation
Unload frm
Set frm = Nothing
Exit Sub
End If
' --- Получаем выбранную категорию по ключу ---
Set parentNode = tvContacts.Nodes(frm.SelectedCategoryKey)
' --- Создаем уникальный ключ ---
newKey = parentNode.Key & "_contact_" & frm.ContactName
Dim counter As Long
counter = 1
Do While NodeExists(newKey)
newKey = parentNode.Key & "_contact_" & frm.ContactName & "_" & counter
counter = counter + 1
Loop
' --- Добавляем контакт ---
tvContacts.Nodes.Add parentNode, tvwChild, newKey, frm.ContactName
' --- Обновляем счетчик контактов в категории ---
UpdateCategoryCounts
' --- Сохраняем контакты ---
SaveContacts
' --- Завершение ---
Unload frm
Set frm = Nothing
End Sub
Private Function NodeExists(key As String) As Boolean
On Error Resume Next
NodeExists = Not tvContacts.Nodes(key) Is Nothing
On Error GoTo 0
End Function
' ===== Категории =====
Private Sub mnuAddCategory_Click()
Dim frm As frmAddCategory
Dim baseKey As String, newKey As String, counter As Long, newCat As Node
' --- Открываем форму добавления категории ---
Set frm = New frmAddCategory
frm.Show vbModal
If Not frm.Confirmed Then
Unload frm
Set frm = Nothing
Exit Sub
End If
' --- Генерация уникального ключа ---
baseKey = "category_" & frm.CategoryName
newKey = baseKey
counter = 1
Do While NodeExists(newKey)
newKey = baseKey & "_" & counter
counter = counter + 1
Loop
' --- Добавляем новую категорию ---
Set newCat = tvContacts.Nodes.Add(, tvwFirst, newKey, frm.CategoryName & " (0)")
With newCat
.Bold = True
.Expanded = True ' категория сразу раскрыта
.Image = 2 ' картинка для открытой категории
.SelectedImage = 2
End With
' --- Обновляем счётчики и сохраняем ---
UpdateCategoryCounts
SaveContacts
Unload frm
Set frm = Nothing
End Sub
Private Function ContactExists(ByVal username As String) As Boolean
Dim n As Node
Dim childNode As Node
For Each n In tvContacts.Nodes
If n.Parent Is Nothing Then
Set childNode = n.Child
Do While Not childNode Is Nothing
If StrComp(childNode.Text, username, vbTextCompare) = 0 Then
ContactExists = True
Exit Function
End If
Set childNode = childNode.Next
Loop
End If
Next
ContactExists = False
End Function
Private Function ContactExistsNode(ByVal username As String) As Node
Dim n As Node, childNode As Node
For Each n In tvContacts.Nodes
If n.Parent Is Nothing Then
Set childNode = n.Child
Do While Not childNode Is Nothing
If StrComp(childNode.Text, username, vbTextCompare) = 0 Then
Set ContactExistsNode = childNode
Exit Function
End If
Set childNode = childNode.Next
Loop
End If
Next
Set ContactExistsNode = Nothing
End Function
Public Sub StartBlinkContact(n As Node)
Dim i As Long
Dim key As String
key = n.Key
' Проверяем, есть ли уже в списке
For i = 1 To BlinkContacts.Count
If BlinkContacts(i)(0).Key = key Then
' Сбрасываем время окончания мигания на 3 секунды от Now
BlinkContacts(i)(1) = DateAdd("s", 3, Now)
Exit Sub
End If
Next i
' Добавляем Node и время окончания мигания
Dim item(1) As Variant
Set item(0) = n
item(1) = DateAdd("s", 3, Now) ' мигаем 3 секунды
BlinkContacts.Add item
End Sub
' ==== Таймер мигания ====
Private Sub tmrBlink_Timer()
Dim i As Long
If BlinkContacts.Count = 0 Then Exit Sub
BlinkState = Not BlinkState
For i = BlinkContacts.Count To 1 Step -1
Dim node As Node
Dim endTime As Date
Set node = BlinkContacts(i)(0)
endTime = BlinkContacts(i)(1)
' Мигаем только если время еще не прошло
If Now < endTime Then
node.Bold = BlinkState
If BlinkState Then
node.ForeColor = vbRed ' красный текст на "включённом" мигании
Else
node.ForeColor = vbBlack ' черный текст на "выключенном" мигании
End If
Else
' Время вышло — убираем жирность и цвет, удаляем из списка
node.Bold = False
node.ForeColor = vbBlack
BlinkContacts.Remove i
End If
Next i
End Sub
' ======== Connected ========
Private Sub Winsock1_Connect()
mnuConnect.Caption = "Disconnect"
' ===== ОБНОВЛЯЕМ СТАТУС =====
lblConnectionState.Caption = "Connected!"
' ===== ЛОГИН =====
Dim loginCmd As String
loginCmd = "/login " & LoginUser & " " & LoginPass
Winsock1.SendData StringToUTF8(loginCmd & vbCrLf)
LoggedUser = LoginUser
End Sub
' ======== Closed ========
Private Sub Winsock1_Close()
mnuConnect.Caption = "Connect..."
lblConnectionState.Caption = "Disconnected!"
End Sub
' ======== Data Arrival ========
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim data() As Byte
Winsock1.GetData data, vbByte
Dim msg As String
msg = UTF8ToString(data)
' ===== НОРМАЛИЗАЦИЯ =====
msg = Replace(msg, Chr(0), "")
msg = Replace(msg, vbCrLf, vbLf)
msg = Replace(msg, vbCr, vbLf)
msg = Replace(msg, vbLf, vbCrLf)
msg = Trim(msg)
' ===== Убираем лишние пустые строки в конце =====
Do While Right$(msg, 2) = vbCrLf
msg = Left$(msg, Len(msg) - 2)
Loop
msg = Trim(msg)
If msg = "" Then Exit Sub
' ===== ПРОВЕРКА ЛОГИНА =====
If WaitingForLogin Then
If InStr(msg, "Invalid username or password.") > 0 Then
MsgBox "Invalid username or password!", vbExclamation, "Login Error"
frmLogin.txtPassword.Text = ""
frmLogin.txtPassword.SetFocus
frmLogin.cmdOK.Enabled = True
WaitingForLogin = False
Exit Sub
ElseIf InStr(msg, "Login successful.") > 0 Then
LoggedUser = frmLogin.txtUsername.Text
Unload frmLogin
WaitingForLogin = False
' Теперь можно открывать серверный чат
Exit Sub
End If
End If
' ===== ОТВЕТЫ НА /PM =====
If InStr(msg, "User does not exist.") > 0 Then
MsgBox "User does not exist.", vbExclamation, "Private Message Error"
Exit Sub
End If
If InStr(msg, "You cannot send private messages to yourself.") > 0 Then
MsgBox "You cannot send private messages to yourself.", vbExclamation, "Private Message Error"
Exit Sub
End If
If InStr(msg, " is banned.") > 0 Then
MsgBox "Receiver is banned.", vbExclamation, "Private Message Error"
Exit Sub
End If
If StrComp(Left$(msg, 34), "Failed to send private message to ", vbTextCompare) = 0 Then
Dim failedUser As String
failedUser = Mid$(msg, 35) ' всё после "to "
failedUser = Replace(failedUser, ".", "")
failedUser = Trim$(failedUser)
MsgBox "Failed to send private message to " & failedUser & ".", _
vbExclamation, "Private Message Error"
Exit Sub
End If
If StrComp(Left$(msg, 24), "Private message sent to ", vbTextCompare) = 0 Then
Exit Sub
End If
Dim username As String
Dim messageBody As String
Dim pos As Long
' ===== PRIVATE MESSAGE =====
If Left$(msg, 10) = "(Private) " Then
Dim tmp As String
tmp = Mid$(msg, 11)
Dim p As Long
p = InStr(tmp, ":")
If p > 0 Then
username = Left$(tmp, p - 1)
messageBody = Mid$(tmp, p + 1)
messageBody = Trim$(messageBody)
' Проверяем есть ли контакт
Dim nNode As Node
Set nNode = ContactExistsNode(username)
If Not nNode Is Nothing Then
OpenPrivateChat username
Dim frm As FormChat
Set frm = OpenChats(username)
frm.ReceiveMessage username, messageBody
frm.Show
frm.SetFocus
' Добавляем в мигающие
StartBlinkContact nNode
End If
End If
End If
pos = InStr(msg, ":")
' ===== ТАЙМШТАМП =====
Dim ts As String
ts = "[" & Format$(Now, "hh:nn:ss") & "] "
' ===== Проверка формата НИК: =====
If pos > 0 Then
username = Left$(msg, pos - 1)
messageBody = Mid$(msg, pos + 1)
messageBody = Trim(messageBody)
End If
If Not ServerChatWindow Is Nothing Then
' ===== Пропускаем приватные сообщения =====
If Left$(msg, 10) = "(Private) " Then Exit Sub
' ===== Системные сообщения =====
If Left$(msg, 4) = "*** " Then
With ServerChatWindow.txtChat
.SelStart = Len(.Text)
.SelLength = 0
' Таймштамп
.SelColor = RGB(150, 150, 150)
.SelBold = False
.SelText = ts
' Сообщение жирным черным
.SelColor = vbBlack
.SelBold = True
.SelText = msg & vbCrLf
.SelBold = False
' Скролл вниз
.SelStart = Len(.Text)
.SelLength = 0
End With
Exit Sub ' больше не обрабатываем
End If
If pos > 0 Then
Dim nick As String, body As String
nick = Left$(msg, pos - 1)
body = Mid$(msg, pos + 1)
body = Trim(body)
' ===== Ник без пробелов =====
If InStr(nick, " ") = 0 And nick <> "" Then
With ServerChatWindow.txtChat
.SelStart = Len(.Text)
.SelLength = 0
' Таймштамп
.SelColor = RGB(150, 150, 150)
.SelBold = False
.SelText = ts
' Ник: синий, если наш, иначе красный
If nick = Form1.LoggedUser Then
.SelColor = vbBlue
Else
.SelColor = vbRed
End If
.SelBold = False
.SelText = "<" & nick & "> "
' Сообщение чёрным
.SelColor = vbBlack
.SelText = body & vbCrLf
' Скролл вниз
.SelStart = Len(.Text)
.SelLength = 0
End With
Else
' ===== Обычное серверное сообщение =====
With ServerChatWindow.txtChat
.SelStart = Len(.Text)
.SelLength = 0
' Таймштамп
.SelColor = RGB(150, 150, 150)
.SelBold = False
.SelText = ts
' Текст чёрным
.SelColor = vbBlack
.SelBold = False
.SelText = msg & vbCrLf
' Скролл вниз
.SelStart = Len(.Text)
.SelLength = 0
End With
End If
Else
' ===== Обычное серверное сообщение =====
With ServerChatWindow.txtChat
.SelStart = Len(.Text)
.SelLength = 0
' Таймштамп
.SelColor = RGB(150, 150, 150)
.SelBold = False
.SelText = ts
' Текст чёрным
.SelColor = vbBlack
.SelBold = False
.SelText = msg & vbCrLf
' Скролл вниз
.SelStart = Len(.Text)
.SelLength = 0
End With
End If
End If
End Sub
' ======== Отправка сообщений ========
Public Sub SendMessageToUser(ByVal username As String, ByVal message As String)
If Winsock1.State = sckConnected Then
Winsock1.SendData StringToUTF8(message & vbCrLf)
End If
End Sub
' ======== UTF8 БЕЗ BOM ========
Public Function StringToUTF8(ByVal text As String) As Byte()
Dim stm As Object
Set stm = CreateObject("ADODB.Stream")
stm.Type = 2
stm.Charset = "utf-8"
stm.Open
stm.WriteText text
stm.Position = 0
stm.Type = 1
Dim bytes() As Byte
bytes = stm.Read
stm.Close
Set stm = Nothing
' --- Убираем BOM ---
If UBound(bytes) >= 2 Then
If bytes(0) = &HEF And bytes(1) = &HBB And bytes(2) = &HBF Then
Dim tmp() As Byte
ReDim tmp(UBound(bytes) - 3)
Dim i As Long
For i = 3 To UBound(bytes)
tmp(i - 3) = bytes(i)
Next
StringToUTF8 = tmp
Exit Function
End If
End If
StringToUTF8 = bytes
End Function
Public Function UTF8ToString(ByRef bytes() As Byte) As String
Dim stm As Object
Set stm = CreateObject("ADODB.Stream")
stm.Type = 1
stm.Open
stm.Write bytes
stm.Position = 0
stm.Type = 2
stm.Charset = "utf-8"
UTF8ToString = stm.ReadText
stm.Close
Set stm = Nothing
End Function
' ===========================
' ===== СОХРАНЕНИЕ ==========
' ===========================
Private Sub SaveContacts()
Dim f As Integer
f = FreeFile
Open App.Path & "\contacts.dat" For Output As #f
Dim n As Node
For Each n In tvContacts.Nodes
If n.Parent Is Nothing Then
' Категория
Print #f, "C|" & n.Key & "|" & n.Text & "|"
Else
' Контакт
Print #f, "U|" & n.Key & "|" & n.Text & "|" & n.Parent.Key
End If
Next
Close #f
End Sub
' ===========================
' ===== ЗАГРУЗКА ============
' ===========================
Private Sub LoadContacts()
Dim path As String
path = App.Path & "\contacts.dat"
If Dir(path) = "" Then Exit Sub
tvContacts.Nodes.Clear
Dim f As Integer
f = FreeFile
Open path For Input As #f
Dim line As String
Dim parts() As String
Do Until EOF(f)
Line Input #f, line
parts = Split(line, "|")
If UBound(parts) < 2 Then GoTo ContinueLoop
Dim typeNode As String
Dim key As String
Dim txt As String
Dim parentKey As String
typeNode = parts(0)
key = parts(1)
txt = parts(2)
If typeNode = "C" Then
Dim cat As Node
Set cat = tvContacts.Nodes.Add(, tvwLast, key, txt)
cat.Bold = True
cat.Expanded = True
cat.Image = 2 ' картинка для открытой категории
cat.SelectedImage = 2
ElseIf typeNode = "U" Then
parentKey = parts(3)
If NodeExists(parentKey) Then
tvContacts.Nodes.Add parentKey, tvwChild, key, txt
End If
End If
ContinueLoop:
Loop
Close #f
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim f As Form
For Each f In Forms
If TypeOf f Is FormChat Then
Unload f
End If
Next
End Sub
Private Sub mnuExit_Click()
If MsgBox("Do you really want to exit?", vbYesNo + vbQuestion) = vbYes Then
Unload Me
End
End If
End Sub
Private Sub mnuAutoConnect_Click()
' Переключаем галочку
mnuAutoConnect.Checked = Not mnuAutoConnect.Checked
' Сохраняем состояние
SaveSettings mnuAutoConnect.Checked
End Sub
Private Sub SaveSettings(ByVal autoConnect As Boolean)
Dim f As Integer
f = FreeFile
Open App.Path & "\settings.dat" For Output As #f
Print #f, CStr(autoConnect)
Close #f
End Sub
' ===== ЗАГРУЗКА AUTOCONNECT =====
Private Sub LoadSettings(ByRef autoConnect As Boolean)
Dim f As Integer
Dim value As String
If Dir(App.Path & "\settings.dat") = "" Then Exit Sub
f = FreeFile
Open App.Path & "\settings.dat" For Input As #f
Line Input #f, value
Close #f
autoConnect = (LCase(value) = "true")
End Sub
Download raw |
Create new paste
