MyTetra Share
Делитесь знаниями!
Чтиво - программирование на Visual Basic
31.07.2019
22:37
Текстовые метки: vba office
Раздел: !Закладки - VBA

Чтиво - программирование на Visual Basic

    00. Знакомимся с историей языка Бэйсик - Visual Basic
    01. Как перезагрузить или выключить компьютер в Windows XP? - Visual Basic
    02. Узнаем путь к Windows и о функции Environ - Visual Basic
    03. Работа с файлами - Visual Basic
    04. Работа с папками - Visual Basic
    05. Как узнать имя компьютера и имя пользователя? - Visual Basic
    06. Как изменить имя компьютера? - Visual Basic
    07. Работа с числами, шрифтом, текстом, TextBox'om и RichTextBox'om - Visual Basic
    08. Интернет - Visual Basic
    09. Использование Winsock контрола - Visual Basic
    10. Как заставить Winsock работать с несколькими соединениями? - Visual Basic
    11. Узнаем свой IP адрес - Visual Basic
    12. Определение имени или IP-адреса удаленного компьютера - Visual Basic
    13. Как заполнить ComboBox всеми шрифтами, которые установленны в системе? - Visual Basic
    14. Как заполнить ComboBox буквами доступных дисков? - Visual Basic
    15. Изменение высоты ниспадающей части элемента ComboBox - Visual Basic
    16. Cкриншот экрана, формы или контрола - Visual Basic
    17. Выделить кусок картинки - Visual Basic
    18. Изменение фона рабочего стола Windows - Visual Basic
    19. Скопировать содержимое PictureBox в буфер обмена - Visual Basic
    20. Преобразование и форматирования данных (функции) - Visual Basic
    21. Программно переключить клавиатуру с русского на английский и обратно - Visual Basic
    22. Работа с системным треем - Visual Basic
    23. Как извлечь иконку из файла? - Visual Basic
    23. Как сменить курсор на "песочные часы" и обратно? - Visual Basic
    25. Как узнать количество свободной оперативной памяти? - Visual Basic
    26. Как узнать сколько процессоров в компьютере? - Visual Basic
    27. Как узнать сколько работает ваш компьютер? - Visual Basic
    28. Как управлять консолью под vb6? - Visual Basic
    29. Пишем трейнер на Visual Basic - Visual Basic
    30. Зашифрованные пароли - Visual Basic
    31. Как завершить указанный процесс - Visual Basic
    32. Управление событиями в комбоксе - Visual Basic
    33. Как содержимое формы или Picture выкинуть на принтер? - Visual Basic
    34. Ошибки при замене десятичного разделителя - Visual Basic
    35. Как определить длину файла (все версии Visual Basic)
    36. Управление длиной элемента списка ComboBox - Visual Basic
    37. Увеличение и уменьшение даты с помощью клавиш [+] и [-] - Visual Basic
    38. Как перетащить элементы из одного списка в другой - Visual Basic
    39. Создание нового контекстного меню - Visual Basic
    40. Для тех, кто занимается геометрическими расчетами - Visual Basic
    41. Копирование областей памяти в DOS - Visual Basic
    42. Сортировка содержимого ListView - Visual Basic
    43. Быстрый поиск в массивах, листбоксах и комбобоксах - Visual Basic
    44. Сделать картинку светлей или темней - Visual Basic
    45. Как загрузить текст из файла в ListBox? - Visual Basic
    46. Формы в виде текста! - Visual Basic
    47. Как выполнять код пока кнопка нажата - Visual Basic
    48. КАК работать с ресурсами, файлы ресурсов (*.RES) - Visual Basic
    49. Как узнать полный путь к программе, зная её h, именно hWnd - Visual Basic
    50. Форма сверху всех - Visual Basic
    51. Как перетаскивать окно не за заголовок - Visual Basic
    52. Как ловить нажатия на клавиши вне вашей программы - Visual Basic
    53. Форматирование и копирование дискет через функции API - Visual Basic
    54. Ярылык для загрузки последнего рабочего проекта в Visual Basic
    55. Постоянно возникающий вопрос у тех, кто пишет блокнот. Функция Command - Visual Basic
    56. Создание временных файлов - Visual Basic
    57. Быстрый поиск а базе данных - Visual Basic
    58. Заперетить юзеру закрывать форму - Visual Basic
    59. Как просто отформатировать и округлить число - Visual Basic
    60. Перевод денежных сумм из цифp в 'прописью' - Visual Basic
    61. Как запретить запуск второй копии программы - Visual Basic
    62. Работа с Дисководом. Открыть/закрыть дверцу CD/DVD-ROM. Узнать инфо о CD-ROM и.т.д.
    63. Работа с Word. Создание, открытие, форматирование, закрытие и сохранение - Visual Basic
    64. Работа с Word. Добавление текста в документ Word - Visual Basic
    65. Работа с Word. Добавление текста в документ Word (Продолжение) - Visual Basic
    66. Работа с Word. Работа с таблицами в Word (часть 1) - Visual Basic
    67. Работа с Word. Работа с таблицами в Word (часть 2) - Visual Basic
    68. Работа с Word. Работа с таблицами в Word (часть 3) - Visual Basic
    69. Сортировка методом Шелла - Visual Basic
    70. Работа с Word. Работа с графическими объектами в Word (часть 1) - Visual Basic
    71. Работа с Word. Работа с графическими объектами в Word (часть 2) - Visual Basic
    72. Использование Visual Basic 6.0 для управления внешними устройствами и приём внешней информации (температура, давление, напряжение, ток и т.п.) через LPT порт
    73. Как написать игру на Visual Basic
    74. Как расшарить программно ресурс (несколько способов) - Visual Basic
    75. Как узнать сколько памяти жрет указанный процесс? - Visual Basic
    76. Создание плагина для Winamp - Visual Basic
    77. Проигрыватель файлов AVI и WAV - Visual Basic
    78. Как защитить свою программу от взломщиков - Visual Basic
    79. Как запустить Screen saver? - Visual Basic
    80. Использование специальной клавиши клавиатуры - Visual Basic
    81. Работа с Мышью и Клавиатурой - Visual Basic
    82. Работа с десктопом/окнами - Visual Basic
    83. Как сделать форму прозрачной? - Visual Basic
    84. Как сделать сканер портов? - Visual Basic
    85. Получить список запущенных приложений/процессов - Visual Basic
    86. Коды функциональных клавиш - Visual Basic
    87. Получить описание любого файла: exe, dll или… - Visual Basic
    88. Получение списка расширений, зарегистрированных в системе файлов - Visual Basic
    89. Получение сведений о зарегистрированных типах файлов в системе - Visual Basic
    90. Запуск сервисов Панели Управления - Visual Basic
    91. Возвращение путей различных каталогов(рабочий стол, папка шрифтов, меню кнопки ПУСК и т.д) - Visual Basic
    92. Добавить ссылку или удалить все ссылки в меню Пуск>Документы - Visual Basic
    93. Получить адрес переменной в памяти - Visual Basic
    94. Получение информации о Windows, используя GetSystemInfo - Visual Basic
    95. Очистить/показать содержимое корзины - Visual Basic
    96. Как воспроизвести звук и видео - Visual Basic
    97. Проиграть Avi-файл в Picture Box - Visual Basic
    98. Поиск окна - Visual Basic
    99. Создание своего контрола - Visual Basic
    100. Как создать ActiveX Control за 21 минуту на Microsoft Visual Basic - Visual Basic
    101. WithEvents - добавление новых свойств к стандартным контролам - Visual Basic
    102. 88 советов по оптимизации приложения - Visual Basic
    103. Как проиграть MP3 из VB - Visual Basic
    104. Работа с Excel - Visual Basic
    105. Типы диаграмм VBA - Visual Basic
    106. Как сделать паузу в ВБ - Visual Basic
    107. Как программно создать Button или другой элемент управления - Visual Basic
    108. Как сделать паузу без использования API и Таймера - Visual Basic
    109. Опять запрещаем диспетчер задач :) - Visual Basic
    110. Как сделать ProgressBar с процентами? - Visual Basic
    111. Ограничить переменную до определенного количества символов - Visual Basic
    112. Узнаем имя своей программы - Visual Basic
    113. Как сделать вдавленную кнопку? - Visual Basic
    114. Как сделать название кнопки не по центру - Visual Basic
    115. Извращаемся над кнопкой пуск - Visual Basic
    116. Установить дату и время на компьютере - Visual Basic
    117. Получить список пользователей Windows - Visual Basic
    118. Полезные материалы - Visual Basic

 

01. Как перезагрузить или выключить компьютер в Windows XP? - Visual Basic

    Dim strComputer As String
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate, (Shutdown)}!\\" & strComputer & "\root\cimv2")
    Set colOperatingSystems = objWMIService.ExecQuery( "Select * from Win32_OperatingSystem")
    For Each ObjOperatingSystem In colOperatingSystems
    ObjOperatingSystem.Reboot ' Для перезагрузки
    Next
    и…
    Dim strComputer As String
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate,(Shutdown)}!\\" & strComputer & "\root\cimv2")
    Set colOperatingSystems = objWMIService.ExecQuery( "Select * from Win32_OperatingSystem")
    For Each ObjOperatingSystem In colOperatingSystems
    ObjOperatingSystem.ShutDown 'Для выключения
    Next

    Наверх

02. Узнаем путь к Windows и о функции Environ - Visual Basic

    Text1.Text = Environ("windir")' вот и все!

    Но это ещё не всё! Также с помощью этой функции можно получить следующие перменные:
    MsgBox Environ ("TMP") 'директория временных файлов TEMP
    MsgBox Environ ("BLASTER") 'координаты звуковой карты
    MsgBox Environ ("PATH") 'пути, объявленные в autoexec.bat

    Наверх

03. Работа с файлами

    3.1 Копируем файл - Visual Basic
    3.2 Удаляем файл с диска - Visual Basic
    3.3 Перемещаем файл - Visual Basic
    3.4 Переименовываем файл - Visual Basic
    3.5 Устанавливаем атрибуты файла(скрытый, только для чтения и тд.)
    3.6 Открыть любой файл, директорию - Visual Basic
    3.7 Существует ли файл? - Visual Basic
    3.8 Получить размер файла - Visual Basic
    3.9 Как получить имя файла или его расширение, зная полный путь файлау - Visual Basic
    3.10 Удаление файла в корзину - Visual Basic
    3.11 Функция для изменения расширения файла - Visual Basic
    3.12 Сравнить два файла на идентичность - Visual Basiс
    3.13 Хотите знать, какие файлы скопированы в память? - Visual Basic


    3.1 Копируем файл
    ===================================================
    допустим у нас есть один файлик с именем 1.txt в папке C:\1\ , а нам нужно скопировать его в C:\2\ .
    Все просто, пишем следующие:
    Filecopy "C:\1\1.txt","C:\2\1.txt"
    (*Внимание! Если в каталоге 2 уже находиться файлик с именем 1.txt , то он будет заменен на 1.txt из каталога 1 !!!)

    2 способ API!
    обычно я делаю через API:

    Private Declare Function CopyFile Lib "kernel32.dll" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

    Private Sub Command1_Click()
    ' Скопируем файл C:\1.txt в D:\1.txt.
    Dim retval As Long ' возвращаемое значение
    ' копируем файл
    retval = CopyFile("C:\1.txt", "D:\1.txt", 1)
    If retval = 0 Then ' если ошибка
    MsgBox "Не могу скопировать"
    Else ' если все нормально
    MsgBox "Файл скопирован."
    End If
    End Sub

    3.2 Удаляем файл с диска
    ===================================================
    Например мы хотим удалить файл 1.txt из корневой диска C:
    Пишем:
    Kill ("C:\1.txt")

    2 способ API!
    Private Declare Function DeleteFile Lib "kernel32.dll" Alias "DeleteFileA" (ByVal lpFileName As String) As Long

    Private Sub Command1_Click()
    ' Удаляем файл C:\Samples\anyfile.txt
    Dim retval As Long ' возвращаемое значение

    retval = DeleteFile("C:\1.txt")
    If retval = 1 Then MsgBox "Файл успешно удален."
    End Sub

    3.3 Перемещаем файл
    ===================================================
    для этого мы используем два оператора сразу. Например нам нужно переместить файл 1.txt из C:\ в C:\2\ . Пишем:
    Filecopy "C:\1.txt","C:\2\1.txt"
    Kill ("C:\1.txt")

    2 способ API!
    Private Declare Function MoveFile Lib "kernel32.dll" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long

    Private Sub Command1_Click()
    Dim retval As Long ' возвращаемое значение

    retval = MoveFile("C:\1.txt", "C:\2\1.txt")
    If retval = 1 Then
    MsgBox "Успешно переместился )"
    Else
    MsgBox "Не успешно переместился )"
    End If
    End Sub

    3.4 Переименовываем файл
    ===================================================
    Надо переименовать файл 1.txt находящийся в C:\ на 2.txt .
    Пишем:
    Filecopy "C:\1.txt","C:\2.txt"
    Kill ("C:\1.txt")

    2 способ API!
    Private Declare Function MoveFile Lib "kernel32.dll" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long

    Private Sub Command1_Click()
    Dim retval As Long ' возвращаемое значение

    retval = MoveFile("C:\1.txt", "C:\2.txt")
    If retval = 1 Then
    MsgBox "Успешно переименовался )"
    Else
    MsgBox "Не успешно переименовался )"
    End If
    End Sub

    3.5 Устанавливаем атрибуты файла(скрытый, только для чтения и тд.)
    ===================================================
    Для этого используем оператор setattr.
    Пишем:
    Setattr "C:\1.txt" , vbHidden - теперь файл 1.txt стал скрытым.
    Чтобы изменить сразу несколько параметров нужно ставить "+" между каждым значением:
    Setattr "C:\1.txt",vbHidden+vbReadOnly -Теперь файл скрытый и только для чтения.


    3.6 Открыть любой файл, директорию - Visual Basic
    ===================================================
    ' Под Windos NT:
    Shell "cmd /X /C start c:\mydoc\example.doc"
    ' Под Windos 9x:
    Shell "start c:\mydoc\example.doc"

    ' через API
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

    Private Sub Command1_Click()
    ShellExecute 0, vbNullString, "C:\" & sFile, vbNullString, vbNullString, vbNormalFocus
    End Su

    3.7 Существует ли файл? - Visual Basic
    ===================================================
    '1. Возвращает 1(файл существует) или 0 (файла нет)

    Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
    MsgBox PathFileExists("c:\autoexec.bat")

    '2. Возвращает True(файл существует) или False(файла нет)

    Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
    Public Function DoesFileExist(ByVal strPath As String) As Boolean
    DoesFileExist = PathFileExists(strPath)
    End Function
    MsgBox DoesFileExist("c:\autoexec.bat")

    3.8 Получить размер файла - Visual Basic
    ===================================================
    Размер файла можно определить двумя путями:

    1. Если файл можно открыть функцией OPEN, то можно воспользоваться функцией LOF

    Dim FileFree As Integer
    Dim FileSize As Long
    FileFree = FreeFile
    Open "C:\WIN\GENERAL.TXT" For Input As FileFree
    FileSize = LOF(FileFree)
    Close FileFree

    2. Используя функцию FileLen

    Dim lFileSize As Long
    FileSize = FileLen("C:\WIN\GENERAL.TXT")

    3.9 Как получить имя файла или его расширение, зная полный путь файлау - Visual Basic
    ===================================================
    Private Function Spliting(sFullPath As String, point As String)
    Dim str1() As String
    str1 = Split(sFullPath, point)
    Spliting = str1(UBound(str1))
    End Function

    3.10 Удаление файла в корзину - Visual Basic
    ===================================================
    Private Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Long
    hNameMappings As Long
    lpszProgressTitle As Long
    End Type
    Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
    Private Const FO_DELETE = &H3
    Private Const FOF_ALLOWUNDO = &H40
    Private Const FOF_NOCONFIRMATION = &H10
    Private Const FOF_SILENT = &H4

    Sub SendFileToRecycleBin(FileName As String, Optional Confirm As Boolean = True, Optional Silent As Boolean = False)
    Dim FileOp As SHFILEOPSTRUCT
    With FileOp
    .wFunc = FO_DELETE
    .pFrom = FileName
    .fFlags = FOF_ALLOWUNDO
    If Not Confirm Then .fFlags = .fFlags + FOF_NOCONFIRMATION
    If Silent Then .fFlags = .fFlags + FOF_SILENT
    End With
    SHFileOperation FileOp
    End Sub

    Private Sub Command1_Click()
    SendFileToRecycleBin "C:\1.txt", False
    SendFileToRecycleBin "C:\11.txt", True
    End Sub

    Private Sub Form_Load()
    Dim FN As Integer
    FN = FreeFile
    Dim FName As String
    FName = "C:\1.txt"
    Open FName For Output As #FN
    Print #FN, ""
    Close #FN
    FName = "C:\11.txt"
    Open FName For Output As #FN
    Print #FN, ""
    Close #FN
    End Sub

    3. 11 Функция для изменения расширения файла - Visual Basic
    ===================================================
    Function ChangeFileExtension(FileName As String, Extension As String, Optional AddIfMissing As Boolean) As String
    Dim i As Long
    For i = Len(FileName) To 1 Step -1
    Select Case Mid$(FileName, i, 1)
    Case "."
    ChangeFileExtension = Left$(FileName, i) & Extension
    Exit Function
    Case ":", "\"
    Exit For
    End Select
    Next
    If AddIfMissing Then
    ChangeFileExtension = FileName & "." & Extension
    Else
    ChangeFileExtension = FileName
    End If
    End Function

    Private Sub Command1_Click()
    MsgBox ChangeFileExtension("ggg.htm", "txt")
    MsgBox ChangeFileExtension("ggg", "txt", True)
    End Sub

    3.12 Сравнить два файла на идентичность - Visual Basic
    ===================================================
    Private Sub Form_Load()
    'замените пути файлов, которые вы хотите сравнить
    Open "C:\1\convert1bmp.htm" For Binary As #1
    Open "C:\1\convert2bmp.htm" For Binary As #2
    issame% = True
    If LOF(1) <> LOF(2) Then
    issame% = False
    Else
    whole& = LOF(1) \ 10000
    part& = LOF(1) Mod 10000
    buffer1$ = String$(10000, 0)
    buffer2$ = String$(10000, 0)
    start& = 1
    For X& = 1 To whole&
    Get #1, start&, buffer1$
    Get #2, start&, buffer2$
    If buffer1$ <> buffer2$ Then
    issame% = False
    Exit For
    End If
    start& = start& + 10000
    Next
    buffer1$ = String$(part&, 0)
    buffer2$ = String$(part&, 0)
    Get #1, start&, buffer1$
    Get #2, start&, buffer2$
    If buffer1$ <> buffer2$ Then issame% = False
    End If
    Close
    If issame% Then
    MsgBox "Файлы идентичны", 64, "Info"
    Else
    MsgBox "Файлы НЕ идентичны", 16, "Info"
    End If
    End Sub

    3.13 Хотите знать, какие файлы скопированы в память? - Visual Basic
    ===================================================
    Добавьте на форму элемент CommandButton и ListBox.
    Вставьте код, запустите. Затем переключитесь в Проводник, выберите несколько файлов, скопируйте их.
    Затем перейдите в вашу программу и нажмите на кнопку.

    Private Const CF_HDROP = 15
    Private Type POINT
    x As Long
    y As Long
    End Type
    Private Type DROPFILES
    pFiles As Long
    pt As POINT
    fNC As Long
    fWide As Long
    End Type
    Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

    Private Sub ShowFilesOnClipboard()
    Dim lHandle As Long
    Dim lpResults As Long
    Dim lRet As Long
    Dim df As DROPFILES
    Dim strDest As String
    Dim lBufferSize As Long
    Dim arBuffer() As Byte
    Dim vNames As Variant
    Dim i As Long

    If OpenClipboard(0) Then
    lHandle = GetClipboardData(CF_HDROP)
    ' If you don't find a CF_HDROP, you don't want to process anything
    If lHandle > 0 Then
    lpResults = GlobalLock(lHandle)

    lBufferSize = GlobalSize(lpResults)
    ReDim arBuffer(0 To lBufferSize)

    CopyMemory df, ByVal lpResults, Len(df)
    Call CopyMemory(arBuffer(0), ByVal lpResults + df.pFiles, (lBufferSize - Len(df)))

    If df.fWide = 1 Then
    ' it is wide chars--unicode
    strDest = arBuffer
    Else
    strDest = StrConv(arBuffer, vbUnicode)
    End If
    GlobalUnlock lHandle
    vNames = Split(strDest, vbNullChar)
    i = 0
    While Len(vNames(i)) > 0
    List1.AddItem vNames(i)
    i = i + 1
    Wend
    End If
    End If
    CloseClipboard
    End Sub

    Private Sub Command1_Click()
    List1.Clear
    Call ShowFilesOnClipboard
    End Sub

    Наверх

04. Работа с папками - Visual Basic

    4.1 Как удалить каталог? - Visual Basic
    4.2 Создание директории - Visual Basic
    4.3 Выводим список всех папок с подпапками - Visual Basic
    4.4 Как показать стандартный диалог выбора каталога? - Visual Basic
    4.5 Создание многоуровневых каталогов - Visual Basic
    4.6 Как проверить, существует ли директория? - Visual Basic?
    4.7 Получить размер директории - Visual Basic
    4.8 Определить, имеет ли папка подпапки - Visual Basic
    4.9 Узнать путь к текущей рабочей папке - Visual Basic


    4.1 Как удалить каталог? - Visual Basic
    ===================================================
    Private Declare Function RemoveDirectory& Lib "kernel32" Alias "RemoveDirectoryA" (ByVal lpPathName As String)
    ' Удаление каталога (пустого!)
    PathName$ = "D:\t"
    code& = RemoveDirectory(PathName)
    If code& = 0 Then
    ' операция удаления не была выполнена
    Else
    ' каталог удален
    End If

    4.2 Создание директории - Visual Basic
    ===================================================
    Sub MakeDir(dirname As String)
    Dim i As Long, path As String
    Do
    i = InStr(i + 1, dirname & "\", "\")
    path = Left$(dirname, i - 1)
    If Right$(path, 1) <> ":" And Dir$(path, vbDirectory) = "" Then
    MkDir path
    End If
    Loop Until i >= Len(dirname)
    End Sub

    Private Sub Command1_Click()
    Call MakeDir("C:\Aleks_Soft\1\2\3\")
    End Sub

    4.3 Выводим список всех папок с подпапками - Visual Basic
    ===================================================
    На форму кинем 2 текстовых поля и кнопку, имя первого текстового поля: StartText, имя второго текстового поля OutText и сделай свойство Multiline=true, имя кнопки: CmdStart
    Далее пишим код в кнопке:

    Static running As Boolean
    Dim AllDirs As New Collection
    Dim next_dir As Integer
    Dim dir_name As String
    Dim sub_dir As String
    Dim i As Integer
    Dim txt As String
    If running Then
    running = False
    CmdStart.Enabled = False
    CmdStart.Caption = "Stopping"
    Else
    running = True
    MousePointer = vbHourglass
    CmdStart.Caption = "Stop"
    OutText.Text = ""
    DoEvents
    next_dir = 1
    AllDirs.Add StartText.Text
    Do While next_dir <= AllDirs.Count
    dir_name = AllDirs(next_dir)
    next_dir = next_dir + 1
    sub_dir = Dir$(dir_name & "\*", vbDirectory)
    Do While sub_dir <> ""
    If UCase$(sub_dir) <> "PAGEFILE.SYS" And sub_dir <> "." And sub_dir <> ".." Then
    sub_dir = dir_name & "\" & sub_dir
    On Error Resume Next
    If GetAttr(sub_dir) And vbDirectory Then AllDirs.Add sub_dir
    End If
    sub_dir = Dir$(, vbDirectory)
    Loop
    DoEvents
    If Not running Then Exit Do
    Loop
    txt = ""
    For i = 1 To AllDirs.Count
    txt = txt & AllDirs(i) & vbCrLf
    Next i
    OutText.Text = txt
    MousePointer = vbDefault
    unning = False
    End If

    Теперь запустим прогу, в текстовом поле StartText пишим: C:\windows, и жмем на кнопку и ждем!!!

    4.4 Как показать стандартный диалог выбора каталога? - Visual Basic
    ===================================================
    Private Type BrowseInfo
    hwndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
    End Type

    Dim strPath As String
    Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
    Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
    Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)

    Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String
    Const BIF_RETURNONLYFSDIRS = 1, MAX_PATH = 260
    Dim intNull As Integer, lngIdList As Long
    Dim udtBI As BrowseInfo

    With udtBI
    .hwndOwner = hwndOwner
    .lpszTitle = sPrompt
    .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    lngIdList = SHBrowseForFolder(udtBI)
    If lngIdList Then
    strPath = String$(MAX_PATH, 0)
    SHGetPathFromIDList lngIdList, strPath
    CoTaskMemFree lngIdList
    intNull = InStr(strPath, vbNullChar)
    If intNull Then strPath = Left$(strPath, intNull - 1)
    End If
    BrowseForFolder = strPath
    End Function

    Private Sub Command1_Click()
    BrowseForFolder Me.hWnd, "Hi, Select ... "
    Print strPath
    End Sub

    4.5 Создание многоуровневых каталогов - Visual Basic
    ===================================================
    Иногда приходится анализировать наличие указанного каталога (к примеру, при установке вашей программы на жесткий диск) и создавать новый при его отсутствия. Для этого можно использовать, например, такую процедуру:

    Sub CreateLongDir(sDir As String)
    Dim sBuild As String, sDirTmp As String, i As Integer
    '
    sDirTmp = sDir & "\"
    i = InStr (sDirTmp, ":")
    If i > 0 Then ' задано имя диска
    sBuild = Left$(sDirTmp, i) ' имя текущего каталога
    sDirTmp = Mid$(sDirTmp, i + 1)
    Else
    sBuild = "" ' имя текущего каталога
    End If
    Do ' проверка-создание вложенных каталогов
    i = InStr (2, sDirTmp, "\")
    If i = 0 Then Exit Do
    sBuild = sBuild & Left$(sDir, i - 1)
    sDirTmp = Mid$(sDirTmp, i)
    If Dir$(sBuild, 16) = "" Then 'нет такого каталога
    MkDir sBuild ' создание каталога
    End If
    Loop
    End Sub

    Sub Test () ' примеры обращения
    ' полное имя каталога с именем диска
    Call CreateLongDir("C:\Tests\TestDir\NewDir")
    ' полное имя каталога в текущем диске
    Call CreateLongDir("\Current\TestDir\NewDir")
    ' имя нового каталога относительно текущего каталога
    Call CreateLongDir("Current\TestDir\NewDir")
    End Sub


    Здесь крайне важно дать правильное описание имени каталога при обращении к CreateLongDir (в соответствии с правилами обращения к функциям VB: MkDir, ChDir, RmDir, Dir):

    4.6 Как проверить, существует ли директория? - Visual Basic?
    ===================================================
    Иногда необходимо проверить, существует ли папка. Данная функция возвращает True - если папка существует, и False - если такой папки на компьютере нет. В данную функцию передается строковая переменная, содержащая полный путь к директории(папке).

    Public Function FolderExists(ByVal strPathName As String) As Boolean
    Dim DirectoryFound As String
    Const errPathNotFound As Integer = 76
    On Error GoTo 0
    DirectoryFound = Dir(strPathName, vbDirectory)
    If (Len(DirectoryFound) = 0 Or Err = errPathNotFound) Then
    FolderExists = False
    Else
    FolderExists = True
    End If
    End Function
    Private Sub Command1_Click()
    'MsgBox FolderExists("D:\Basic")
    If FolderExists("D:\Basic\Module1") = False Then
    MsgBox "Такая папка не существует"
    Else
    MsgBox "Такая папка существует"
    End If
    End Sub

    4.7 Получить размер директории - Visual Basic
    ===================================================
    Const MAX_PATH = 260
    Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
    End Type
    Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
    End Type
    Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As
    WIN32_FIND_DATA) As Long
    Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA)
    As Long
    Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

    Public Function SizeOf(ByVal DirPath As String) As Double
    Dim hFind As Long
    Dim fdata As WIN32_FIND_DATA
    Dim dblSize As Double
    Dim sName As String
    Dim x As Long
    On Error Resume Next
    x = GetAttr(DirPath)
    If Err Then SizeOf = 0: Exit Function
    If (x And vbDirectory) = vbDirectory Then
    dblSize = 0
    Err.Clear
    sName = Dir$(EndSlash(DirPath) & "*.*", vbSystem Or vbHidden Or vbDirectory)
    If Err.Number = 0 Then
    hFind = FindFirstFile(EndSlash(DirPath) & "*.*", fdata)
    If hFind = 0 Then Exit Function
    Do
    If (fdata.dwFileAttributes And vbDirectory) = vbDirectory Then
    sName = Left$(fdata.cFileName, InStr(fdata.cFileName, vbNullChar) - 1)
    If sName <> "." And sName <> ".." Then
    dblSize = dblSize + SizeOf(EndSlash(DirPath) & sName)
    End If
    Else
    dblSize = dblSize + fdata.nFileSizeHigh * 65536 + fdata.nFileSizeLow
    End If
    DoEvents
    Loop While FindNextFile(hFind, fdata) <> 0
    hFind = FindClose(hFind)
    End If
    Else
    On Error Resume Next
    dblSize = FileLen(DirPath)
    End If
    SizeOf = dblSize
    End Function
    Private Function EndSlash(ByVal PathIn As String) As String
    If Right$(PathIn, 1) = "\" Then
    EndSlash = PathIn
    Else
    EndSlash = PathIn & "\"
    End If
    End Function

    Private Sub Form_Load()
    'Замените 'D:\Basic' той директорией, размер которой хотите узнать
    MsgBox SizeOf("D:\Basic") / 1000000
    End Sub

    4.8 Определить, имеет ли папка подпапки - Visual Basic
    ===================================================
    Private Const MAX_PATH = 260
    Private Type SHFILEINFO
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
    End Type
    Private Declare Function SHGetFileInfo Lib "Shell32" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long

    Function FolderHasSubFolders(ByVal sPath As String) As Boolean
    Const SFGAO_HASSUBFOLDER = &H80000000
    Const SHGFI_ATTRIBUTES = &H800
    Dim FInfo As SHFILEINFO
    SHGetFileInfo sPath, 0, FInfo, Len(FInfo), SHGFI_ATTRIBUTES
    FolderHasSubFolders = (FInfo.dwAttributes And SFGAO_HASSUBFOLDER)
    End Function

    Private Sub Command1_Click()
    MsgBox FolderHasSubFolders("C:\Program Files")
    MsgBox FolderHasSubFolders("C:\Program Files\NetMeeting")
    End Sub

    4.9 Узнать путь к текущей рабочей папке - Visual Basic
    ===================================================
    MsgBox CurDir
    Наверх

05. Как узнать имя компьютера и имя пользователя?

    Private Declare Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As String, nSize As Long) As Long
    Private Declare Function WNetGetUserA Lib "mpr.dll" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
    Function GetComputerName() As String
    Dim sBuffer As String * 255
    If GetComputerNameA(sBuffer, 255&) <> 0 Then
    GetComputerName = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    End If
    End Function
    Function GetUserName() As String
    Dim sUserNameBuff As String * 255
    sUserNameBuff = Space(255)
    Call WNetGetUserA(vbNullString, sUserNameBuff, 255&)
    GetUserName = Left$(sUserNameBuff, InStr(sUserNameBuff, vbNullChar) - 1)
    End Function

    Private Sub Command1_Click()
    MsgBox GetComputerName, 64, "ComputerName"
    MsgBox GetUserName, 64, "GetUserName"
    End Sub

    Наверх

06. Как изменить имя компьютера?

    'добавьте модуль
    Declare Function SetComputerName Lib "kernel32" Alias "SetComputerNameA" (ByVal lpComputerName As String) As Long
    'добавьте кнопку
    a$ = "Hello World"
    b& = SetComputerName(a$)

    Наверх

07. Работа с числами, шрифтом, текстом, TextBox'om и RichTextBox'om - Visual Basic

    7.1 Загрузить текстовой файл в TextBox, сохранить текстовой файл из TextBox'а - Visual Basic
    7.2 Определение координат позиции курсора в TextBox - Visual Basic
    7.3 Как узнать сколько слов в TextBox - Visual Basic
    7.4 Как сделать первую букву каждого слова заглавной? - Visual Basic
    7.5 Запретить ввод определенных символов - Visual Basic
    7.6 Добавить новую линию в существующий текст элемента TextBox - Visual Basic
    7.7 Как очистить все TextBox'ы на форме? - Visual Basic
    7.8 Как вернуться на то же место, при потере фокуса? - Visual Basic
    7.9 Как можно заблокировать стандартное контекстное меню элемента TextBox? - Visual Basic
    7.10 Проверить тип вводимой информации - Visual Basic
    7.11 Скрыть/показать мигающий курсор в Text Box - Visual Basic
    7.12 Убрать двойные пробелы во всем тексте - Visual Basic
    7.13 Скролинг текста - Visual Basic
    7.14 Получение содержимого n-ой строки в Multiline TextBox. - Visual Basic
    7.15 Подсчитать количество определенных символов в тексте - Visual Basic
    7.16 Определение кодировки русского текста - Visual Basic
    7.17 Очистка строки от ненужных символов - Visual Basic
    7.18 Преобразование WIN в ASCII текст - Visual Basic
    7.19 ANSCII в Win - Visual Basic
    7.20 Как осуществить замену в TextBox? - Visual Basic
    7.21 Как сделать Undo или Отменить в TextBox? - Visual Basic
    7.22 Как уместить в TextBox больше 64 kb текста? - Visual Basic
    7.23 Cвойства TextBox'a. - Visual Basic
    7.24 Компонент RichTextBox. - Visual Basic
    7.25 Как найти и выделить текст в RichTextBox - Visual Basic
    7.26 Определение строки, на которой находится курсор. - Visual Basic
    7.27 Определить количество строк в TextBox'е. - Visual Basic
    7.28 Проверка орфографии. - Visual Basic
    7.29 Является ли строковая переменная e-mail-адресом. - Visual Basic
    7.30 Перекодировка текста: Rus-Lat - Visual Basic
    7.31 Перекодировка текста из DOS в Windows формат - Visual Basic
    7.32 Послать строковое сообщение в другую программу - Visual Basic
    7.33 Захват текста из любого текстового поля - Visual Basic
    7.34 Форматирование числа при выводе (заполнение до определенной длины) - Visual Basic
    7.35 Примеры работы с датами - Visual Basic
    7.36 Определить кодировку текста (Dos или Win) - Visual Basic
    7.37 Вертикальное/горизонтальное написание в элементе Label - Visual Basic
    7.38 Как получить короткий путь("c:\progra~1") файла если имеется длинный - Visual Basic
    7.39 Как вывести кавычки в MsgBox? - Visual Basic
    7.40 Как узнать ASCLL код символа? - Visual Basic
    7.41 Как узнать количество символов в строке? - Visual Basic
    7.42 Как преобразовать буквы в нижний или верхний регистр? - Visual Basic
    7.43 MsgBox впереди всех - Visual Basic
    7.44 Как в MsgBox вывести или записать в переменную данные столбиком? - Visual Basic
    7.45 Операции "копировать", "вырезать", "вставить" - Visual Basic
    7.46 3D-текст на форме - Visual Basic
    7.47 Как вывести символ & в Label - Visual Basic
    7.48 Постоянно возникающий вопрос у тех, кто пишет блокнот. Функция Command - Visual Basic
    7.49 Ввод в TextBox только цифр - Visual Basic
    7.50 Как сделать вывод только заглавных букв в TextBox - Visual Basic


    7.1 Загрузить текстовой файл в TextBox, сохранить текстовой файл из TextBox'а - Visual Basic
    ====================================================
    Зугрузить текстовой файл в TextBox:
    Dim FN as Integer
    FN = FREEFILE
    Dim FName as String
    FName = "C:\tmp\index.txt"
    Open FName For Input As #FN
    Text1.Text = Input(LOF(FN), #FN)
    Close #FN

    Сохранить текстовой файл из TextBox'а:
    Dim FN as Integer
    FN = FREEFILE
    Dim FName as String
    FName = "C:\tmp\index.txt"
    Open FName For Output As #FN
    Print #FN, Text1.Text
    Close #FN

    7.2 Определение координат позиции курсора в TextBox - Visual Basic
    ====================================================
    Private Type POINTAPI
    X As Long
    Y As Long
    End Type
    Private Declare Function GetCaretPos Lib "user32" (lpPoint As POINTAPI) As Long

    Private Sub Text1_KeyPress(KeyAscii As Integer)
    Dim XPos As Long
    Dim YPos As Long
    XPos = GetTCursX
    YPos = GetTCursY
    Me.Caption = "X: " & XPos & " Y: " & YPos
    End Sub
    Public Function GetTCursX() As Long
    Dim pt As POINTAPI
    GetCaretPos pt
    GetTCursX = pt.X
    End Function
    Public Function GetTCursY() As Long
    Dim pt As POINTAPI
    GetCaretPos pt
    GetTCursY = pt.Y
    End Function

    7.3 Как узнать сколько слов в TextBox - Visual Basic
    ====================================================
    MsgBox (UBound(Split(Text1.Text)) + 1)

    7.4 Как сделать первую букву каждого слова заглавной?
    ====================================================
    Private Function ccProperCase(MySourceControl As Control)
    On Error GoTo ErrH
    Dim strString As String
    strString = MySourceControl.Text
    If IsNull(strString) Then Exit Function
    strString = StrConv(strString, vbProperCase)
    MySourceControl.SelStart = Len(strString)
    MySourceControl.Text = strString
    Exit Function
    ErrH:
    MsgBox "Error at ccProperCase:::- " & Err.Number & " - " & Err.Description, vbCritical
    Exit Function
    End Function

    Private Sub Text1_Change()
    Call ccProperCase(Text1)
    End Sub

    7.5 Запретить ввод определенных символов - Visual Basic
    ====================================================
    Private Sub Text1_KeyPress(KeyAscii As Integer)
    Dim sTemplate As String
    'Replace the '!@#$%^&*()_+= ' какие символы игнорировать
    sTemplate = "!@#$%^&*()_+="
    If InStr(1, sTemplate, Chr(KeyAscii)) > 0 Then KeyAscii = 0
    End Sub

    Если тебе, например надо запретить ввод букв и разрешить только ввод цифр, то смотри ниже как это делается:
    Private Sub txtSum_KeyPress(KeyAscii As Integer)
    KeyAscii = Only_Number(KeyAscii)
    End Sub
    Function Only_Number(theParam As Integer)
    If InStr("1234567890" & Chr(8), Chr(theParam)) > 0 Then
    Only_Number = theParam
    Else
    Only_Number = 0
    End If
    End Function

    7.6 Добавить новую линию в существующий текст элемента TextBox - Visual Basic
    ====================================================
    Добавьте Command Button и TextBox на форму.

    Private Sub Command1_Click() Dim NewText As String
    With Text1
    'replace 'My New Text' with the Text you want to add
    NewText = "My New Text"
    .SelStart = Len(.Text)
    .SelText = vbNewLine & NewText
    End With

    End Sub
    Private Sub Form_Load()
    Text1.Text = "My Initial Text"
    End Sub

    7.7 Как очистить все TextBox'ы на форме? - Visual Basic
    ====================================================
    Добавьте на форму несколько элементов TextBox и CommandButton.

    Private Sub Command1_Click()
    Dim Contrl As Control
    For Each Contrl In Form1.Controls
    If (TypeOf Contrl Is TextBox) Then Contrl.Text = ""
    Next Contrl
    End Sub

    7.8 Как вернуться на то же место, при потере фокуса? - Visual Basic
    ====================================================
    Dim x
    Private Sub Text1_GotFocus()
    On Error Resume Next
    Text1.SelStart = x
    End Sub

    Private Sub Text1_LostFocus()
    x = Text1.SelStart
    End Sub

    7.9 Как можно заблокировать стандартное контекстное меню элемента TextBox? - Visual Basic
    ====================================================
    'Расположите на форме TextBox, а также создайте невидимое меню mnuText и как минимум одно подменю.
    'Запустите проект, нажмите правой клавишей мыши на TextBox'е...
    Private Declare Function LockWindowUpdate Lib "User32" (ByVal hwndLock As Long) As Long
    Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbRightButton Then
    LockWindowUpdate Text1.hWnd
    Text1.Enabled = False
    DoEvents
    PopupMenu mnuText
    Text1.Enabled = True
    LockWindowUpdate 0&
    End If
    End Sub

    7.10 Проверить тип вводимой информации - Visual Basic
    ====================================================
    Простая проверка регистра, буква или цифра, используя API.
    Добавить Text Box на форму.
    Private Declare Function IsCharUpper Lib "user32" Alias "IsCharUpperA" (ByVal cChar As Byte) As Long
    Private Declare Function IsCharLower Lib "user32" Alias "IsCharLowerA" (ByVal cChar As Byte) As Long
    Private Declare Function IsCharAlpha Lib "user32" Alias "IsCharAlphaA" (ByVal cChar As Byte) As Long
    Private Declare Function IsCharAlphaNumeric Lib "user32" Alias "IsCharAlphaNumericA" (ByVal cChar As Byte) As Long
    Private Sub Text1_KeyPress(KeyAscii As Integer)
    '1 - True, 0 - False
    MsgBox "Upper Case: " & IsCharUpper(KeyAscii) & " Lower Case: " & IsCharLower(KeyAscii) & " Alpha: " & IsCharAlpha(KeyAscii) & " Alpha or Numeric: " & IsCharAlphaNumeric(KeyAscii)
    End Sub

    7.11 Скрыть/показать мигающий курсор в Text Box - Visual Basic
    ====================================================
    Private Declare Function HideCaret Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ShowCaret& Lib "user32" (ByVal hwnd As Long)
    Private Sub CheckCaret()
    If Check1.Value = vbChecked Then
    ShowCaret (Text1.hwnd)
    Else
    HideCaret (Text1.hwnd)
    End If
    End Sub
    Private Sub Form_Load()
    Check1.Value = 1
    End Sub
    Private Sub Text1_Change()
    CheckCaret
    End Sub
    Private Sub Text1_GotFocus()
    CheckCaret
    End Sub

    7.12 Убрать двойные пробелы во всем тексте - Visual Basic
    ====================================================
    Данная функция в качестве входного параметра принимает любую текстовую строку (содержимое TextBox или RichTextBox), убирает все двойные пробелы и возвращает обновленный текст. Для пояснения действия данной функции добавьте на форму элемент TextBox, элемент CommandButton. Скопируйте следующий текст, запустите проект. В текстовом поле наберите любой текст, оставляя двойные пробелы между буквами или словами. Затем нажмите на кнопку.

    Public Function SquishSpaces(ByVal strText As String) As String
    Const TWO_SPACES As String = " "
    Dim intPos As Integer
    Dim strTemp As String
    intPos = InStr(1, strText, TWO_SPACES, vbBinaryCompare
    Do While intPos > 0
    strTemp = LTrim$(Mid$(strText, intPos + 1))
    strText = Left$(strText, intPos) & strTemp
    intPos = InStr(1, strText, TWO_SPACES, vbBinaryCompare)
    Loop
    SquishSpaces = strText
    End Function
    Private Sub Command1_Click()
    Text1.Text = SquishSpaces(Text1.Text)
    'RichTextBox1.Text = SquishSpaces(RichTextBox1.Text)
    End Sub

    7.13 Скролинг текста - Visual Basic
    ====================================================
    'Расположите на форме элемент CommandButton, элемент TextBox, элемент Timer.
    Dim strText As String
    Private Sub Command1_Click()
    strText = String(30, " ") + "Visual Basic"
    Timer1.Interval = 100
    Timer1.Enabled = True
    End Sub

    Private Sub Form_Load()
    Command1.Caption = "Начать скролинг"
    With Text1
    .Font = "Courier New Cyr"
    .FontSize = 12
    .Width = 3400
    End With
    End Sub

    Private Sub Timer1_Timer()
    strText = Mid(strText, 2) & Left(strText, 1)
    Text1 = strText
    End Sub

    7.14 Получение содержимого n-ой строки в Multiline TextBox. - Visual Basic
    ====================================================
    Расположите на форме элемент CommandButton и элемент TextBox.
    Установите свойство Multiline элемента TextBox как True.
    Синтаксис вызова функции прост: GetLine(НазваниеОкна.hWnd, НомерСтроки).
    Данный пример (при нажатии на кнопку) покажет содержимое 2-й строки элемента


    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long
    Const EM_LINEINDEX = &HBB
    Const EM_LINELENGTH = &HC1
    Const EM_GETLINE = &HC4
    Public Function GetLine(hWnd As Long, Line As Long) As String
    Dim sBuf As String, nLen As Long, nIndex As Long
    nIndex = SendMessage(hWnd, EM_LINEINDEX, Line - 1, ByVal 0&)
    If nIndex < 0 Or Line <= 0 Then Exit Function
    nLen = SendMessage(hWnd, EM_LINELENGTH, nIndex, ByVal 0&)
    sBuf = Space(nLen + 1)
    Mid$(sBuf, 1, 1) = Chr$(nLen And &HFF)
    Mid$(sBuf, 2, 1) = Chr$(nLen \ 256)
    SendMessage hWnd, EM_GETLINE, Line - 1, ByVal sBuf
    GetLine = Left$(sBuf, nLen)
    End Function

    Private Sub Form_Load()
    Text1.Text = "1111111" & vbCrLf & "22222" & vbCrLf & "3333" & vbCrLf & "4444"
    End Sub

    Private Sub Command1_Click()
    MsgBox GetLine(Text1.hWnd, 2)
    End Sub

    7.15 Подсчитать количество определенных символов в тексте. - Visual Basic
    ====================================================
    Данный пример покажет, сколько раз встречается буква Н в данном выражении.
    Вместо Н вы можете использовать любое строковое выражение.

    Private Sub Form_Load() myString = "в данном примере несколько букв н, а точнее - "
    tempString = Split(myString, "н")
    MsgBox "в данном примере несколько букв н, а точнее - " & UBound(tempString)
    tempString = Split(myString, "нн")
    MsgBox "в данном примере " & UBound(tempString) & " раз встречается выражение нн"
    End Sub

    7.16 Определение кодировки русского текста. - Visual Basic
    ====================================================
    Определение кодировки текста

    'пpовеpяем тип кодиpовки ANSI или ASCII
    'беpем пеpвые 1000 байт еcли это возможно. Hевозможно - меньше.
    l& = Len(rtbView.Text)
    If l& > 1000 Then l& = 1000
    'копиpyем yчаcток текcта из RichTextBox в пеpеменнyю, иначе тоpмоз обеcпечен
    s$ = Left$(rtbView.Text, l&)
    'обнyляем флажки
    fdo% = 0
    fwo% = 0
    'пpоcматpиваем кycок текcта
    For n% = 1 To l&
    'вытаcкиваем очеpедной cимвол
    c$ = Mid$(s$, n%, 1)
    'еcли это pyccкая "о" в DOS кодиpовке то инкpементиpyем cчетчик
    If c$ = Chr$(174) Then fdo% = fdo% + 1
    'еcли это pyccкая "о" в Win кодиpовке то инкpементиpyем cчетчик
    If c$ = Chr$(238) Then fwo% = fwo% + 1

    Next

    'ycтанавливаем в конфиге тип пpоcмотpа по дефолтy
    If fdo% > fwo% Then 'это явно ДОC-текcт
    Else 'это явно Win-текcт

    7.17 Очистка строки от ненужных символов - Visual Basic
    ====================================================
    Иногда бывает полезно иметь функцию, которая очищает строку от нежелательных символов. Эта маленькая функция принимает в качестве параметров строку для очистки и символ, от которого ее надо очистить:
    Function StringCleaner(s As String, Search As String) As String
    Dim i As Integer, res As String
    res = s
    Do While InStr(res, Search)
    i = InStr(res, Search)
    res = Left(res, i - 1) & Mid(res, i + 1)
    Loop
    StringCleaner = res
    End Function

    7.18 Преобразование WIN в ASCII текст - Visual Basic
    ====================================================
    Q: Пишу на VB 4 некую задачу. Имеются данные, котоpые нужно хpанить во внешних файлах в фоpмате ASCII. Какой пpоцедуpой можно их откpыть и считать.
    A: Alexander Shherbakov

    Dim sTemp As String, sRes As String
    Open "file.txt" For Input As #1
    While Not EOF(1)
    Line Input #1, sTemp
    sRes = sRes & sTemp & Chr$(13) & Chr$(10)
    Wend
    Close #1

    Hамного быcтpее и пpоще бyдет:

    Dim File As String, CF As String
    'объявим пеpеменнyю для имени файла и его cодеpжимого
    File = "d:\ca.log"
    'ycтановим имя файла и пyть
    Open File For Binary As #1
    'откpоем файл для чтения
    CF = Input(FileLen(File), 1)
    'загpyзить в пеpеменyю CF вcе cодеpжимое файла
    Close #1
    'закpыть файл

    У этого метода еcть пpеимyщеcтва и недоcтатки. Пpеимyщеcтво в том, что загpyзка идет быcтpее чем пpи поcтpочном чтении. Hаконец можно гpyзить бинаpные файлы. А недоcтаток в том, что немного cложнее cделать Пpогpеcc баp (хотя по идее, бей файл на 100 кycков и поочеpедно гpyзи каждый, неcложно). Во вcяком cлyчае я юзаю именно этот метод.
    P.S. Пpовеpил. У меня этим методом 144 кила гpyзятcя за 9 cекyнд.
    Конечно тоpмоз, но пpи поcтpочном чтении это бyдет на поpядок дольше.

    7.19 ANSCII - Win - Visual Basic
    ====================================================
    Q: Как сделать пpеобpазование в кодиpовку Windows. Функции OemToAnsi* и AnsiToOem* из Win32 API
    A: Vladimir Kann
    OemToChar и CharToOem

    А поподробнее можно, если можно с примером

    Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As
    String, ByVal lpszDst As String) As Long
    Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As
    String, ByVal lpszDst As String) As Long

    стpоки д.б. одинаковой длины, т.е. пpинимающую стpоку можно забить пpобелами:

    in$="OEM"
    out$=SPACE(LEN(in$))
    OemToChar in$,out$


    A: Nick Egorov
    А поподробнее можно, если можно с примером

    Да пожалуйста:

    Public Function ToAnsi(S As String) As String
    Dim Buffer As String * 1000
    OemToCharBuff S, Buffer, Len(S)
    ToAnsi = Trim(Buffer)
    End Function
    Declare Function OemToCharBuff Lib "user32" Alias "OemToCharBuffA" (ByVal
    lpszSrc As String, ByVal lpszDst As String, ByVal cchDstLength As Long) As Long

    Как тут в эхе заметили, можно писать вместо

    Dim Buffer As String * 1000
    Dim Buffer As String
    Set Buffer = String( Len(S), 32)

    Аналогичная функция CharToOemBuff конвертит из ANSI в OEM (DOS).

    A: Andrey Fedorov
    IMHO а так проще:

    Declare Function OemToChar Lib "user32" Alias "OemToCharA" _
    (ByVal lpszSrc As String, ByVal lpszDst As String) As Long

    Public Function ToAnsi(S As String) As String
    Dim ss As String
    ss = s: OemToCharBuff s, ss: ToAnsi = ss
    End Function

    7.20 Как осуществить замену в TextBox? - Visual Basic
    ====================================================
    Например вам нужно, чтобы при нажатие на кнопку все символы например "," превратился в ".". Для этого киньте TextBox на форму и 1 кнопку и вот код к кнопке:

    Text1.Text = Replace(Text1.Text, ",", ".")

    7.21 Как сделать Undo или Отменить в TextBox? - Visual Basic
    ====================================================
    Как осуществить отмену в TextBox в Visual Basic, ответ прост:)
    Кинь на форму 1 кнопку и текстовое поле, вот код:

    'Свойство TextBox Multiline установите в True
    Option Explicit
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Const EM_UNDO = &HC7

    Private Sub Command1_Click()
    SendMessage Text1.hWnd, EM_UNDO, &O0, &O0
    End Sub

    7.22 Как уместить в TextBox больше 64 kb текста? - Visual Basic
    ====================================================
    'Нужно поместить на форму TextBox, назвать его txtMain,
    'установить его свойство Multiline как True,
    'а свойство ScroolBars, как 1-Horizontal.
    'А также рядом с TextBox'ом нарисовать вертикальный ScroolBar с именем vsbText.

    Private Text()
    Private Const LineNum = 15

    Private Sub Form_Load()
    Dim i
    Open "C:\Alexey\МОИ ПРОГРАММЫ\Winapi\win32api.txt" For Input As #1 Len = 1024
    Do Until EOF(1)
    i = i + 1
    ReDim Preserve Text(i + LineNum)
    Line Input #1, Text(i)
    Loop
    Close #1
    With vsbText
    .Min = 1
    .Max = i
    .SmallChange = 1
    .LargeChange = i \ 10
    End With
    End Sub

    Private Sub vsbText_Change()
    Dim i As Integer
    Dim Temp
    For i = vsbText.Value To vsbText.Value + LineNum
    Temp = Temp + Text(i) + vbCrLf
    Next i
    txtMain.Text = Temp
    End Sub

    7.23 Cвойства TextBox'a - Visual Basic
    ====================================================
    SelLegth SelStart SelText

    Часто возникают ситуации, когда при использовании TextBox необходимо, что бы при перемещении на него фокуса, текст находящийся в нем маркировался. Или же при при перемещении на него фокуса, (или добавлении в него другого текста) курсор сразу должен перемещаться в конец имеющегося в TextBox - е текста. Или же иметь возможность для дальнейщих Ваших операций с маркированным текстом. Все это, позволяют сделать некоторые свойства TextBox-а – SelLegth, SelStart и SelText. Рассмотрим оба случая.
    Первый случай - при перемещении фокуса на TextBox, текст находящийся в нем маркировался. Для этого необходимо в процедуру Text1_GotFocus вставить следующий код:

    Private Sub Text1_GotFocus()
    'Определяем начальное положение текста
    Text1.SelStart = 0
    'Маркируем всю длину текста, вычисляя его спомощью оператора Len
    Text1.SelLength = Len(Text1.Text) End Sub
    Второй случай - - при перемещении фокуса на TextBox, (или добавлении в него другого текста) курсор должен перемещаться в конец имеющегося в TextBox - е текста. Для этого необходимо в процедуру Text1_GotFocus вставить следующий код:
    Private Sub Text1_GotFocus()
    'Определяем длинну имеющегося текста и присваиваем это позиции начала следующего текста
    Text1.SelStart = CLng(Len(Text1.Text)) End Sub
    Третий случай - возможность обработки маркированного текста. Для этого можно использовать одну строку кода.
    Dim strMarkText As String
    'Присваиваем переменной strMarkText текст маркированный в TextBox
    strMarkText = Text1.SelText

    7.24 Компонент RichTextBox - Visual Basic
    ====================================================
    Элемент RichTextBox представляет собой усовершенствованное текстовое окно, с помощью которого вы можете создавать полноценные файлы в формате RTF, в которых вы можете как угодно форматировать внешний вид своего документа: расставлять переносы, выделять текст различными шрифтами, менять гарнитуру текста и т.д. Подключается данный контрол очень просто: через меню Project | Components. установите флажок на строчке Microsoft Rich Textbox Control 6.0 и у вас на панели Toolbox появится значок этого компонента. Затем вы размещаете данный контрол на вашей форме... и все.

    Вставить рисунок
    Private Sub Command1_Click()
    a = RichTextBox1.SelStart
    RichTextBox1.OLEObjects.Add , , "D:\4\add_pictures_to_richtextbox\smile.bmp"
    RichTextBox1.SelStart = a + 1
    RichTextBox1.SetFocus
    End Sub
    Private Sub Form_Load()
    RichTextBox1.OLEObjects.Clear
    End Sub
    Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    RichTextBox1.OLEObjects.Clear
    End Sub

    Выделить текст жирным шрифтом
    RichTextBox1.SelBold = True

    Выделить текст курсивом
    RichTextBox1.SelItalic = True

    Выделить текст подчеркнутым шрифтом
    RichTextBox1.SelUnderline = True

    Просмотр текста в виде простого текста
    MsgBox RichTextBox1.Text

    Просмотр текста в виде RTF
    MsgBox RichTextBox1.TextRTF

    Загрузить файл
    RichTextBox1.LoadFile App.Path & "\RTFText.rtf", rtfRTF

    или
    RichTextBox1.LoadFile App.Path & "\RTFText.rtf", rtfText

    7.25 Как найти и выделить текст в RichTextBox? - Visual Basic
    ====================================================
    Во многих приложениях есть функция поиска и выделения ключевых слов в текстовом окошке. В Visual Basic элемент управления RichTextBox позволяет использовать эту возможность.

    Создайте новый проект. Form1 создастся поумолчанию.

    Поместите на Form1 кнопку и RichTextBox. Установите свойство Text у RichTextBox в "This is an example of finding text in a rich text box."

    Добавьте следующий код в секцию General Declarations формы Form1:
    Option Explicit

    Private Sub Command1_Click()
    HighlightWords RichTextBox1, "text", vbRed
    End Sub

    Private Function HighlightWords(rtb As RichTextBox, sFindString As String, lColor As Long) As Integer

    Dim lFoundPos As Long 'Позиция первого найденного
    'символа
    Dim lFindLength As Long 'Длина искомой строки
    Dim lOriginalSelStart As Long
    Dim lOriginalSelLength As Long
    Dim iMatchCount As Integer 'Количество найденных

    'Сохраняем текущее местоположение и длину
    lOriginalSelStart = rtb.SelStart
    lOriginalSelLength = rtb.SelLength

    'Сохраняем длину строки, которую будем искать
    lFindLength = Len(sFindString)

    'Пытаемся найти первое совпадение
    lFoundPos = rtb.Find(sFindString, 0, , rtfNoHighlight)
    While lFoundPos >= 0 'While lFoundPos >= 0 <-------------------- Должно быть. Иначе при поиске пропускается первый символ, так как отсчет идет с нуля.
    iMatchCount = iMatchCount + 1

    rtb.SelStart = lFoundPos
    'Как только Вы измените SelStart, то свойство SelLength
    'установится в 0
    rtb.SelLength = lFindLength
    rtb.SelColor = lColor

    'Пытаемся найти следующее совпадение
    lFoundPos = rtb.Find(sFindString, _
    lFoundPos + lFindLength, , rtfNoHighlight)
    Wend

    'Восстанавливаем первоначальное местоположение
    'и длину
    rtb.SelStart = lOriginalSelStart
    rtb.SelLength = lOriginalSelLength

    'Возвращаем количество совпадений
    HighlightWords = iMatchCount

    End Function

    7.26 Определение строки, на которой находится курсор. - Visual Basic
    ====================================================
    На самом деле определение строки, на которой находится курсор, не вызывает никаких трудностей.
    У элемента RichTextBox существует метод GetLineFromChar, который и отвечает на вопрос этой страницы.
    Непонятно только, почему разработчики не предусмотрели определение позиции курсора на строке.
    Ответ на этот вопрос остается открытым.

    Private Sub Command1_Click()
    MsgBox RichTextBox1.GetLineFromChar(RichTextBox1.SelStart) + 1
    End Sub

    7.27 Определить количество строк в TextBox'е. - Visual Basic
    ====================================================
    Добавьте TextBox (установите значение MultiLine=True) и CommandButton.
    Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Const EM_GETLINECOUNT = &HBA
    Private Sub Command1_Click()
    Dim lngLineCount As Long
    On Error Resume Next
    lngLineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&)
    MsgBox lngLineCount
    End Sub

    7.28 Проверка орфографии - Visual Basic
    ====================================================
    Хотелось ли вам добавить возможность проверки орфографии вашего TextBox'а?
    Такое возможно, если на вашем компьютере установлен MsWord.

    Private Sub Command1_Click()
    Text1 = SpellCheck(Text1)
    End Sub

    Public Function SpellCheck(ByVal IncorrectText$) As String
    Dim Word As Object, retText$
    On Error Resume Next
    'Создать объект и загрузить Word
    Set Word = CreateObject("Word.Basic")
    'Показать Word и вставить в него ваш текст
    Word.AppShow
    Word.FileNew
    Word.Insert IncorrectText
    'Запустить проверку орфографии
    Word.ToolsSpelling
    Word.EditSelectAll
    'Выделить текст и загрузить его обратно в TextBox
    retText = Word.Selection$()
    SpellCheck = Left$(retText, Len(retText) - 1)
    'Закрыть файл в Word и вернуться в Visual Basic.
    Word.FileClose 2
    Show
    'Освободить память от объекта word
    Set Word = Nothing
    End Function

    7.29 Является ли строковая переменная e-mail-адресом. - Visual Basic
    ====================================================
    Является ли строковая переменная e-mail-адресом.
    Этот код использует VBScript.dll - Вы можете загрузить его с www.microsoft.com/msdownload/vbscript/scripting.asp
    Добавьте Microsoft VBScript Regular Expressions reference в ваш проект (выберите Project->References, поставьте галочку на Microsoft VBScript Regular Expressions CheckBox и нажмите OK).
    RegExp - тип переменной, которую вы хотите проверить: Email-адрес, телефонный номер, любой другой формат.


    Private Sub Form_Load()
    Dim myReg As RegExp
    Dim email As String
    Set myReg = New RegExp
    myReg.IgnoreCase = True
    myReg.Pattern = "^[\w-\.]+@\w+\.\w+$"
    'replace "myName@domain.ru" любым адресом
    email = "myName@domain.ru"
    MsgBox "Результат проверки: " & myReg.Test(email)
    Unload Me
    End Sub

    7.30 Перекодировка текста: Rus-Lat - Visual Basic
    ====================================================
    Данный пример переводит текст, набранный в одной раскладке клавиатуры в другую. Например из Ghbdtn получить Привет.

    Private Function Replace_letters(InputStr As String) As String
    enStr = ";@#$^&QWERTYUIOP{}ASDFGHJKL:" & Chr(34) & "ZXCVBNM<>?qwertyuiop[]asdfghjkl;'zxcvbnm,./" & Chr(34) & "№;:?ЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЭЯЧСМИТЬБЮ,йцукенгшщзхъфывапролдэжячсмитьбю."
    rusStr = Chr(34) & "№;:?ЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЭЯЧСМИТЬБЮ,йцукенгшщзхъфывапролджэячсмитьбю." & ";@#$^&QWERTYUIOP{}ASDFGHJKL:" & Chr(34) & "ZXCVBNM<>?qwertyuiop[]asdfghjkl;'zxcvbnm,./"
    Dim i As Integer, pos As Integer, temp As String
    For i = 1 To Len(InputStr)
    temp = Mid$(InputStr, i, 1)
    pos = InStr(1, enStr, temp, vbBinaryCompare)
    If pos <> 0 Then
    Replace_letters = Replace_letters & Mid$(rusStr, pos, 1)
    Else
    Replace_letters = Replace_letters & temp
    End If
    Next i
    End Function

    Private Sub Form_Load()
    MsgBox Replace_letters("Dctv ghbdtn")
    End Sub

    7.31 Перекодировка текста из DOS в Windows формат - Visual Basic
    ====================================================
    Если Вам нужно конвертировать текст формата DOS в Windows (1251), то в API есть на этот случай хорошая функция: OemToChar.

    Объявляется она так:

    Public Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long

    Используют её следующим образом:
    Dim l_lReturn as Long
    Dim l_sSource as String 'исходный текст
    Dim l_sDestination as String 'возвращаемый текст
    l_lReturn = oemtochar(l_sSource, l_sDestination)

    Кроме этой полезной функции в API имеется и обратная её функция: CharToOem. Она служит для выполнения той же работы, только наоборот, т.е.Windows (1251) в DOS.

    Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long

    7.32 Послать строковое сообщение в другую программу - Visual Basic
    ====================================================
    Откройте заранее стандартное приложение "Блокнот". В VB-проекте расположите на форме 1 CommandButton. Добавьте следующий код, запустите проект и нажмите на кнопку...

    Private Sub Command1_Click()
    AppActivate ("Безымянный")
    SendKeys ("Привет из VB!!!")
    End Sub

    "{Up}"
    "{TAB}"
    "{ENTER}"
    "{End}"
    "+{Home}"
    "{Left}"

    7.33 Захват текста из любого текстового поля - Visual Basic
    ====================================================
    Хотелось ли вам захватить текст из текстового поля любого приложения? Данный код поможет вам в решении этой проблемы.

    Вам необходимо разместить на форме элемент Timer.

    'to get the foreground window
    Private Declare Function GetForegroundWindow Lib "user32" () As Long
    'to send a message system
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    'to get the cursor position
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    'to get the window from a point (y,x)
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    'to get the window text
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    'to get the class name (edit,combobox etc..)
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Public strBuffer As String ' the string to append to the file that has all the text "grabed"
    Public iEnum As Integer ' the file integer to open and write (I/O)
    Public hJanelaCima As Long ' the window wich the user has the mouse over
    Public hJanelaAntiga As Long ' the ancient window, to controlo if thereґs a new window or not
    'constants to grab the text
    Private Const WM_GETTEXT = &HD
    Private Const WM_GETTEXTLENGTH = &HE
    'type for the GetCursorPos API
    Private Type POINTAPI
    x As Long
    y As Long
    End Type

    Private Sub Form_Load()
    'when starting the program, print date and time of the new logging...
    strBuffer = "=============================================================" & vbCrLf
    strBuffer = strBuffer & "Date of log: " & Format(Date, "YYYY-MM-DD") & vbCrLf
    strBuffer = strBuffer & "Started logging at: " & Format(Time$, "HH:MM") & vbCrLf
    strBuffer = strBuffer & "=============================================================" & vbCrLf
    iEnum = FreeFile
    'append it in the file
    Open "C:\testes.txt" For Append As #iEnum
    Print #iEnum, strBuffer
    Close #iEnum
    strBuffer = ""
    'enable the timer...
    Timer1.Interval = 100
    Timer1.Enabled = True
    End Sub

    Private Sub Timer1_Timer()
    Dim ptCursor As POINTAPI ' the cursor type variable
    Dim texto_janela As String ' the window text
    Dim rc As Long
    Dim nome_classe As String ' the class name
    Dim fenster As Long ' the foreground window.. in deutsh.. ich wisse deutshe auch...
    fenster = GetForegroundWindow ' get the window where user is
    'create string objects
    texto_janela = String(100, Chr(0))
    nome_classe = String(100, Chr(0))
    Call GetCursorPos(ptCursor) ' get the cursor position
    'get the window(handle) where the user has the mouse
    hJanelaCima = WindowFromPoint(ptCursor.x, ptCursor.y)
    'get the window text and class name
    rc = GetWindowText(fenster, texto_janela, Len(texto_janela))
    rc = GetClassName(hJanelaCima, nome_classe, 100)
    'format the assholes...
    texto_janela = Left(texto_janela, InStr(texto_janela, Chr(0)) - 1)
    nome_classe = Left(nome_classe, InStr(nome_classe, Chr(0)) - 1)
    Debug.Print nome_classe
    ' check the class names... i tried some like WinWord and VB, but didnґt worked..

    'If nome_classe = "Edit" Or nome_classe = "_WwG" Or nome_classe = "Internet Explorer_Server" Or nome_classe = "RichEdit20A" Or nome_classe = "VbaWindow" Then
    'if this is the same window, forget
    If hJanelaCima = hJanelaAntiga Then Exit Sub
    'thereґs no text? Out!
    If WindowText(hJanelaCima) = Empty Then Exit Sub
    'put the ancient window handle, with the current one
    hJanelaAntiga = hJanelaCima
    'build string with time and the text grabed with WindowText
    strBuffer = Time$ & " - " & texto_janela & vbCrLf
    strBuffer = strBuffer & WindowText(hJanelaCima) & vbCrLf
    'append to the file
    Open "C:\testes.txt" For Append As #iEnum
    Print #iEnum, strBuffer
    Close #iEnum

    'End If
    End Sub

    'grab the text window with this function.. argument- the window handle
    Public Function WindowText(window_hwnd As Long) As String
    Dim txtlen As Long
    Dim txt As String
    If window_hwnd = 0 Then Exit Function
    'send the message to get the text lenght
    txtlen = SendMessage(window_hwnd, WM_GETTEXTLENGTH, 0, 0)
    If txtlen = 0 Then Exit Function
    txtlen = txtlen + 1
    txt = Space$(txtlen)
    'send the message to get the text
    txtlen = SendMessage(window_hwnd, WM_GETTEXT, txtlen, ByVal txt)
    'put that on the function
    WindowText = Left$(txt, txtlen)
    End Function

    7.34 Форматирование числа при выводе (заполнение до определенной длины) - Visual Basic
    ====================================================
    Пример применения функции String

    Иногда бывает полезно выводить числовую информацию с фиксированным числом знаков, заполняя левые позиции нулями. Для этого можно воспользоваться следующей функцией:

    Function PadToString(myValue, Digits) As String
    PadToString = String(Digits - Len(myValue), "0") & myValue
    End Function

    Сделав, например, такое обращение

    NewStr = PadToString(1978, 8)

    вы получите строковую переменную 00001978. Обратите внимание, что Digits и myValue — переменные типа Variant.

    7.35 Примеры работы с датами - Visual Basic
    ====================================================
    Небольшое примечание: если в качестве входного параметра указано (Optional dteDate As Date), то вызов функции можно осуществлять как НазваниеФункции() - то есть можно оставлять пустые скобки. Например MsgBox FirstOfQuarter()

    Список функций
    Определение первого/последнего дня текущего квартала
    Определение первого/последнего дня месяца
    Определение первого/последнего дня следующего месяца
    Определение первого/последнего дня предыдущего месяца
    Определение первого/последнего дня текущей недели
    Опредение номера дня в году (2 января = 2, 3 февраля = 34)
    Данная функция определяет рабочий день или нет
    Возвращение последнего рабочего дня в текущем месяце
    Функция определения полных лет со дня рождения
    Вычисление разницы в годах между двумя датами
    Определение високосности года

    Определение первого дня текущего квартала
    Function FirstOfQuarter(Optional dteDate As Date) As Date
    If CLng(dteDate) = 0 Then
    dteDate = Date
    End If
    FirstOfQuarter = DateSerial(Year(dteDate), Int((Month(dteDate) - 1) / 3) * 3 + 1, 1)
    End Function

    Определение последнего дня текущего квартала
    Function LastOfQuarter(Optional dteDate As Date) As Date
    If CLng(dteDate) = 0 Then
    dteDate = Date
    End If
    LastOfQuarter = DateSerial(Year(Date), Int((Month(Date) - 1) / 3) * 3 + 4, 0)
    End Function

    Определение первого дня месяца
    Function FirstOfMonth(Optional dteDate As Date) As Date
    'если параметр dteDate = 0 то для вычисления берется текущая дата
    If CLng(dteDate) = 0 Then
    dteDate = Date
    End If
    FirstOfMonth = DateSerial(Year(dteDate), Month(dteDate), 1)
    End Function

    Определение последнего дня месяца
    Function LastOfMonth(Optional dteDate As Date) As Date
    'если параметр dteDate = 0 то для вычисления берется текущая дата
    If CLng(dteDate) = 0 Then
    dteDate = Date
    End If
    'Ищется первый день следующего месяца, и вычитается один день
    LastOfMonth = DateSerial(Year(dteDate), Month(dteDate) + 1, 1) - 1
    End Function

    Определение первого дня следующего месяца
    Function FirstOfNextMonth(Optional dteDate As Date) As Date
    If CLng(dteDate) = 0 Then
    dteDate = Date
    End If
    FirstOfNextMonth = DateSerial(Year(dteDate), Month(dteDate) + 1, 1)
    End Function

    Определение последнего дня следующего месяца
    Function LastOfNextMonth(Optional dteDate As Date) As Date
    If CLng(dteDate) = 0 Then
    dteDate = Date
    End If
    LastOfNextMonth = DateSerial(Year(dteDate), Month(dteDate) + 2, 0)
    End Function

    Определение первого дня предыдущего месяца
    Function FirstOfPreviousMonth(Optional dteDate As Date) As Date
    If CLng(dteDate) = 0 Then
    dteDate = Date
    End If
    FirstOfPreviousMonth = DateSerial(Year(dteDate), Month(dteDate) - 1, 1)
    End Function

    Определение последнего дня предыдущего месяца
    Function LastOfPreviousMonth(Optional dteDate As Date) As Date
    If CLng(dteDate) = 0 Then
    dteDate = Date
    End If
    LastOfPreviousMonth = DateSerial(Year(dteDate), Month(dteDate), 0)
    End Function

    Определение первого дня текущей недели
    Function StartOfWeek(D As Variant, Optional FirstWeekday As Integer) As Variant '
    'Пример: MsgBox StartOfWeek(Date)
    If IsMissing(FirstWeekday) Then 'Sunday is the assumed first day of week.
    StartOfWeek = D - Weekday(D) + 1
    Else
    StartOfWeek = D - Weekday(D, FirstWeekday) + 1
    End If
    End Function

    Определение последнего дня текущей недели
    Function EndOfWeek(D As Variant, Optional FirstWeekday As Integer) As Variant
    'Пример: MsgBox EndOfWeek(Date)
    If IsMissing(FirstWeekday) Then 'Sunday is the assumed first day of week.
    EndOfWeek = D - Weekday(D) + 7
    Else
    EndOfWeek = D - Weekday(D, FirstWeekday) + 7
    End If
    End Function

    Опредение номера дня в году (2 января = 2, 3 февраля = 34)
    Function DayOfYear(Optional dteDate As Date) As Long
    If CLng(dteDate) = 0 Then
    dteDate = Date
    End If
    DayOfYear = Abs(DateDiff("d", dteDate, DateSerial(Year(dteDate) - 1, 12, 31)))
    End Function

    Данная функция определяет: рабочий день или нет
    Примечание: Дни с понедельника по пятницу считаются рабочими

    Function IsWorkday(Optional dteDate As Date) As Boolean
    If CLng(dteDate) = 0 Then
    dteDate = Date
    End If
    Select Case Weekday(dteDate)
    Case vbMonday To vbFriday
    IsWorkday = True
    Case Else
    IsWorkday = False
    End Select
    End Function

    Функция возвращает последний рабочий день в текущем месяце (Понедельник-Пятница)
    Function LastBusDay(D As Variant) As Variant
    'Пример: MsgBox LastBusDay(Date)
    Dim D2 As Variant
    If VarType(D) <> 7 Then
    LastBusDay = Null
    Else
    D2 = DateSerial(Year(D), Month(D) + 1, 0)
    Do While Weekday(D2) = 1 Or Weekday(D2) = 7
    D2 = D2 - 1
    Loop
    LastBusDay = D2
    End If
    End Function

    Функция определения полных лет со дня рождения
    Function CalcAge(dteBirthdate As Date) As Long
    'В качестве параметра dteBirthdate необходимо задать дату рождения
    'Пример: MsgBox CalcAge("09/03/75")
    Dim lngAge As Long
    If Not IsDate(dteBirthdate) Then
    dteBirthdate = Date
    End If
    'Проверить, чтобы в качестве входного параметра не была задана дата в будущем
    If dteBirthdate > Date Then
    dteBirthdate = Date
    End If
    'Подсчет разницы в годях между текущей датой и датой рождения
    lngAge = DateDiff("yyyy", dteBirthdate, Date)
    'Вычитается один год, если в этом году дня рождения еще не было
    If DateSerial(Year(Date), Month(dteBirthdate), Day(dteBirthdate)) > Date Then
    lngAge = lngAge - 1
    End If
    CalcAge = lngAge
    End Function

    Вычисление разницы в годах между двумя датами
    Естественно, что значение Bdate должно быть меньше параметра DateToday

    Function Age(Bdate, DateToday) As Integer
    If Month(DateToday) < Month(Bdate) Or (Month(DateToday) = Month(Bdate) And Day(DateToday) < Day(Bdate)) Then
    Age = Year(DateToday) - Year(Bdate) - 1
    Else
    Age = Year(DateToday) - Year(Bdate)
    End If
    End Function

    Определение високосности года
    Function LeapYear(YYYY As Integer) As Integer
    'Функция возвращает -1, если указанный входной параметр (год) является високосным
    'Пример: MsgBox LeapYear(1996)
    LeapYear = YYYY Mod 4 = 0 And (YYYY Mod 100 <> 0 Or YYYY Mod 400 = 0)
    End Function

    Function LeapYear2(YYYY As Integer) As Integer
    'Функция возвращает -1, если указанный входной параметр (год) является високосным
    'Пример: MsgBox LeapYear(1996)
    LeapYear2 = Month(DateSerial(YYYY, 2, 29)) = 2
    End Function

    Function IsLeapYear(DateIn As Date) As Boolean
    'Функция возвращает True, если год в указанной дате является високосным
    'Проверка: MsgBox IsLeapYear("01/01/00")
    If IsDate("29/02/" & Format(DateIn, "yyyy")) = True Then
    IsLeapYear = True
    End If
    End Function

    7.36 Определить кодировку текста (Dos или Win) - Visual Basic
    ====================================================
    Предположим, вы загружаете тестовой документ в TextBox. При изменении содержимого тестового блока вы можете узнать тип кодировки текста (Dos или Win)

    Private Sub Text1_Change()
    'пpовеpяем тип кодиpовки ANSI или ASCII
    'беpем пеpвые 1000 байт еcли это возможно. Hевозможно - меньше.
    l& = Len(Text1.Text)
    If l& > 1000 Then l& = 1000
    'копиpyем yчаcток текcта в пеpеменнyю, иначе тоpмоз обеcпечен
    s$ = Left$(Text1.Text, l&)
    'обнyляем флажки
    fdo% = 0
    fwo% = 0
    'пpоcматpиваем кycок текcта
    For n% = 1 To l&
    'вытаcкиваем очеpедной cимвол
    c$ = Mid$(s$, n%, 1)
    'еcли это pyccкая "о" в DOS кодиpовке то инкpементиpyем cчетчик
    If c$ = Chr$(174) Then fdo% = fdo% + 1
    'еcли это pyccкая "о" в Win кодиpовке то инкpементиpyем cчетчик
    If c$ = Chr$(238) Then fwo% = fwo% + 1
    Next
    'ycтанавливаем в конфиге тип пpоcмотpа по дефолтy
    If fdo% > fwo% Then 'это явно ДОC-текcт
    MsgBox "DOS"
    Else 'это явно Win-текcт
    MsgBox "WIN"
    End If
    End Sub

    7.37 Вертикальное/горизонтальное написание в элементе Label - Visual Basic
    ====================================================
    Расположите на форме элемент CommandButton а также элемент Label

    Private Function Vertical_Horizontal(ByVal nStr As String) As String
    Dim MyStr As String, i As Integer
    Static Vert As Boolean
    If Vert = False Then
    For i = 1 To Len(nStr)
    If i Then
    MyStr = MyStr + Mid$(nStr, i, 1) & vbCrLf
    Else
    MyStr = MyStr + Mid$(nStr, i, 1)
    End If
    Next
    Vertical_Horizontal = MyStr
    Vert = True
    Else
    For i = 1 To Len(nStr) Step 3
    MyStr = MyStr + Mid$(nStr, i, 1)
    Next
    Vertical_Horizontal = MyStr
    Vert = False
    End If
    End Function

    Private Sub Command1_Click()
    Label1.AutoSize = True
    Label1.Caption = Vertical_Horizontal(Label1.Caption)
    End Sub

    '© 2001 by Alexander Anikin
    '/www.i.com.ua/~aka

    7.38 Получение длинного и короткого имени файла/директории - Visual Basic
    ====================================================
    например: ("c:\Program Files" ==>"c:\progra~1")


    Способ 1
    'Как мне получить короткое имя файла или как мне получить длинное имя
    'файла, зная короткое.

    Private Const MAX_PATH& = 260
    Private Const INVALID_HANDLE_VALUE = -1

    Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
    End Type

    Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReservedЇ As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
    End Type

    Private Declare Function apiFindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function apiFindClose Lib "kernel32" Alias "FindClose" (ByVal hFindFile As Long) As Long
    Private Declare Function apiGetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
    Function fGetShortName(ByVal stLongPath As String) As String
    Dim stShortPath As String
    Dim lngBuffer As Long, lngRet As Long

    stShortPath = String$(MAX_PATH, 0)
    lngBuffer = Len(stShortPath)
    lngRet = apiGetShortPathName(stLongPath, stShortPath, lngBuffer)
    fGetShortName = Left(stShortPath, lngRet)
    End Function

    Function fGetLongName(ByVal strFilename As String) As String
    Dim lpFindFileData As WIN32_FIND_DATA
    Dim strPath As String, lngRet As Long
    Dim strFile As String, lngx As Long, lngY As Long
    Dim strTmp As String

    strTmp = ""
    Do While Not lngRet = INVALID_HANDLE_VALUE
    lngRet = apiFindFirstFile(strFilename, lpFindFileData)
    strFile = Left$(lpFindFileData.cFileName, InStr(lpFindFileData.cFileName, vbNullChar) - 1)
    If Len(strFilename) > 2 Then
    strTmp = strFile & "\" & strTmp
    strFilename = fParseDir(strFilename)
    Else
    strTmp = strFilename & "\" & strTmp
    Exit Do
    End If
    Loop
    fGetLongName = Left$(strTmp, Len(strTmp) - 1)
    lngY = apiFindClose(lngRet)
    End Function

    Private Function fParseDir(strInFile As String) As String
    Dim intLen As Long, boolFound As Boolean
    Dim i As Integer, F As String, strDir As String

    intLen = Len(strInFile)
    If intLen > 0 Then
    boolFound = False
    For i = intLen To 1 Step -1
    If Mid$(strInFile, i, 1) = "\" Then
    F = Mid$(strInFile, i + 1)
    strDir = Left$(strInFile, i - 1)
    boolFound = True
    Exit For
    End If
    Next i
    End If
    If boolFound Then
    fParseDir = strDir
    Else
    fParseDir = strInFile
    End If
    End Function

    Private Sub Command1_Click()
    Dim fShort

    fShort = fGetShortName("C:\Program Files")
    MsgBox fShort
    fShort = fGetLongName(fShort)
    MsgBox fShort
    End Sub

    Способ 2
    Функция GetShortName в качестве входного параметра принимает длинное имя файла и возвращает DOS-имя файла

    Private Declare Function GetShortPathName Lib "kernel32.dll" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
    Private Function GetShortName(lName As String) As String
    Dim DosName As String
    Dim LenOfDosName As Long
    DosName = Space(256)
    LenOfDosName = GetShortPathName(lName, DosName, 256)
    GetShortName = Left$(DosName, LenOfDosName)
    End Function

    Private Sub Form_Load()
    Dim LongName As String
    LongName = "C:\Program Files\Internet Explorer\Iexplore.exe"
    MsgBox GetShortName(LongName)
    End Sub

    7.39 Как вывести кавычки в MsgBox? - Visual Basic
    ====================================================
    нужно использовать функцию Chr и иметь при сибе таблицу ASCLL кодов
    ASCLL код кавычки имеет номер в десятичной системе 34.

    MsgBox Chr(34) & "ИНФОРМАЦИЯ" & Chr(34)

    7.40 Как узнать ASCLL код символа? - Visual Basic
    ====================================================
    Dim x As Byte
    x = Asc("A")'x - будет равен 65
    MsgBox x

    7.41 Как узнать количество символов в строке? - Visual Basic
    ====================================================
    Dim x As Integer
    x = Len("ПРИВЕТ") 'x - будет равен 6-ти
    MsgBox x

    7.42 Как преобразовать буквы в нижний или верхний регистр? - Visual Basic
    ====================================================
    в нижний регистр:
    Dim x As String
    x = LCase("ПРИВЕТ") 'x - будет равен: привет
    MsgBox x

    в верхний регистр:
    Dim x As String
    x = UCase("привет")'x - будет равен: ПРИВЕТ
    MsgBox x

    7.43 MsgBox - выше всех - Visual Basic
    ====================================================
    'ответ:
    MsgBox "Ааааа я впереди всех!!!", vbSystemModal

    7.44 Как в MsgBox вывести или записать в переменную данные столбиком? - Visual Basic
    ====================================================
    Можно это осуществить несколькоми способами:

    пример 1 (с помощью VbNewLine):
    dim stroka as string
    stroka="Привет " & VbNewLine & "Как дела?"
    MsgBox stroka

    или записать сразу в MsgBox
    MsgBox "Привет " & VbNewLine & "Как дела?"

    пример 2 (с помощью vbCrLf):
    dim stroka as string
    stroka="Привет " & vbCrLf & "Как дела?"
    MsgBox stroka

    пример 3 (с помощью Chr(10):
    Dim stroka As String
    stroka = "Привет " & Chr(10) & "Как дела?"
    MsgBox stroka

    пример 4 (с помощью Chr(13):
    Dim stroka As String
    stroka = "Привет " & Chr(13) & "Как дела?"
    MsgBox stroka

    7.45 Операции "копировать", "вырезать", "вставить" - Visual Basic
    ====================================================

    Для работы с Clipboard используется объект - Clipboard и свойство Form.
    Вставьте в проект меню с тремя пунктами mnuEditCopy, mnuEditCut и mnuEditPaste.
    Данные примеры применимы для TextBox'а. Для RichTextBox'а вместо SelText используйте SelRtf.

    '"копировать"
    Private Sub mnuEditCopy_Click()
    On Error Resume Next
    Clipboard.Clear
    Clipboard.SetText frmMain.Text1.SelText
    End Sub

    '"вырезать"
    Private Sub mnuEditCut_Click()
    On Error Resume Next
    Clipboard.Clear
    Clipboard.SetText frmMain.Text1.SelText
    frmMain.Text1.SelText = vbNullString
    End Sub

    '"вставить"
    Private Sub mnuEditPaste_Click()
    On Error Resume Next
    frmMain.Text1.SelText = Clipboard.GetText
    End Sub

    7.46 3D-текст на форме - Visual Basic
    ====================================================

    'Установите свойство формы AutoRedraw как True
    Private Sub Form_Load()
    Dim ShadowX
    Dim ShadowY
    ScaleMode = 3
    ForeColor = "&H808080"
    ShadowY = 5
    ShadowX = 5
    For I = 0 To 5
    CurrentX = ShadowX + I
    CurrentY = ShadowY + I
    If I = 5 Then Form1.ForeColor = vbWhite
    Form1.Print "3D Text!!!"
    Next
    End Sub

    7.47 Как вывести символ & в Label - Visual Basic
    ====================================================

    Если Вы хотите выывести символ «&» на экран, установите свойство "UseMnemonic" в False. Это свойство бывает полезно, когда, например, Labelы используются для вывода данных из баз данных. Также Вы можете вывести символ "&" в свойстве Caption, написав &&. или
    Label1.Caption = "Маша " + Chr(38) + Chr(38) + " Саша"

    7.48 Постоянно возникающий вопрос у тех, кто пишет блокнот. Функция Command - Visual Basic
    ====================================================

    Вопрос,
    допустим я сделал блокнот, и мне нужно чтобы когда я открывал например TXT файл с помощью 2ой кнопки мыши, Открыть с помощью...
    и после того как я указал в окне выбора программ, свою программу чтобы когда я нажал на кнопку ОК, не просто тупо октрылася моя программа,
    а чтобы в текстовом поле этой программы появился путь к этому файл.

    Ответ
    Используй функцию Command

    Пример
    Кинь на форму 1 TextBox и в загрузку формы, помести код:

    Text1.text = Command

    теперь скомпилируй программу
    и открой какойнибудь файл указав на свою программу
    при загрузке программы в переменную Command записывается путь того файла который ты открыл через свою прогу


    7.49 Ввод в TextBox только цифр - Visual Basic
    ====================================================
    Private Sub Text1_KeyPress(KeyAscii As Integer)
    If KeyAscii < Asc(0) Or KeyAscii > Asc(9) Then
    KeyAscii = 0
    Beep ' звуковой сигнал при ошибке
    End If
    End Sub


    7.50 Как сделать вывод только заглавных букв в TextBox - Visual Basic
    ====================================================
    Private Sub Text1_KeyPress(KeyAscii As Integer)
    Dim char
    char = Chr(KeyAscii)
    KeyAscii = Asc(UCase(char))
    End Sub

    Наверх

08. Интернет

    8.1 Узнать есть ли активное соединение с Интернетом - Visual Basic
    8.2 Программно отсоединиться от Интернета - Visual Basic
    8.3 Запуск почты и Интернета из VB - Visual Basic
    8.4 Как сохранить содержимое web-страницы на диск? - Visual Basic
    8.5 Получение сведений из URL. - Visual Basic
    8.6 Является ли строковая переменная e-mail-адресом. - Visual Basic
    8.7 Загружаем файл из интернета - Visual Basic
    8.8 Загружаем любой файл из интернета без использования WinSock - Visual Basic
    8.9 Советы по использованию компонента WebBrowser - Visual Basic
    8.10 Как вытащить все ссылки из htm-страницы - Visual Basic
    8.11 Создать ссылку на страницу в Интернете - Visual Basic
    8.12 Определить дату изменения web-страницы - Visual Basic
    8.13 Является ли строковая переменная e-mail-адресом - Visual Basic
    8.14 Имя текущего соединения с инетом - Visual Basic
    8.15 Получение списка всех интернет-соединений - Visual Basic
    8.16 Запрещение запуска дополнительных окон IE - Visual Basic
    8.17 Прокси сервер на VB - Visual Basic
    8.18 Как установить/сменить IP адресс в локальной сети - Visual Basic
    8.19 Как отправлять сообщения и файлы через Mail - Visual Basic

    8.1 Узнать есть ли активное соединение с Интернетом - Visual Basic
    'Добавьте модуль
    Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
    Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
    Private Const RAS95_MaxEntryName = 256
    Private Const RAS95_MaxDeviceType = 16
    Private Const RAS95_MaxDeviceName = 32
    Private Type RASCONN95
    dwSize As Long
    hRasCon As Long
    szEntryName(RAS95_MaxEntryName) As Byte
    szDeviceType(RAS95_MaxDeviceType) As Byte
    szDeviceName(RAS95_MaxDeviceName) As Byte
    End Type
    Private Type RASCONNSTATUS95
    dwSize As Long
    RasConnState As Long
    dwError As Long
    szDeviceType(RAS95_MaxDeviceType) As Byte
    szDeviceName(RAS95_MaxDeviceName) As Byte
    End Type
    Public Function IsConnected() As Boolean
    Dim TRasCon(255) As RASCONN95
    Dim lg As Long
    Dim lpcon As Long
    Dim RetVal As Long
    Dim Tstatus As RASCONNSTATUS95
    TRasCon(0).dwSize = 412
    lg = 256 * TRasCon(0).dwSize
    RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
    Tstatus.dwSize = 160
    RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
    If Tstatus.RasConnState = &H2000 Then
    IsConnected = True
    Else
    IsConnected = False
    End If
    End Function

    Private Sub Command1_Click()
    'если есть соединение, то IsConnected() = True, иначе False
    Select Case IsConnected()
    Case False
    MsgBox "Интернет не подключен"
    Case True
    MsgBox "Интернет включен"
    End Select
    End Sub

    8.2 Программно отсоединиться от Интернета - Visual Basic
    'Добавьте в модуль
    Const RAS_MAXENTRYNAME As Integer = 256
    Const RAS_MAXDEVICETYPE As Integer = 16
    Const RAS_MAXDEVICENAME As Integer = 128
    Const RAS_RASCONNSIZE As Integer = 412
    Const ERROR_SUCCESS = 0&
    Private Type RasEntryName
    dwSize As Long
    szEntryName(RAS_MAXENTRYNAME) As Byte
    End Type
    Private Type RasConn
    dwSize As Long
    hRasConn As Long
    szEntryName(RAS_MAXENTRYNAME) As Byte
    szDeviceType(RAS_MAXDEVICETYPE) As Byte
    szDeviceName(RAS_MAXDEVICENAME) As Byte
    End Type
    Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasConn As Any, lpcb As Long, lpcConnections As Long) As Long
    Private Declare Function RasHangUp Lib "RasApi32.dll" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long
    Private gstrISPName As String
    Public ReturnCode As Long
    Public Sub HangUp()
    Dim i As Long
    Dim lpRasConn(255) As RasConn
    Dim lpcb As Long
    Dim lpcConnections As Long
    Dim hRasConn As Long
    lpRasConn(0).dwSize = RAS_RASCONNSIZE
    lpcb = RAS_MAXENTRYNAME * lpRasConn(0).dwSize
    lpcConnections = 0
    ReturnCode = RasEnumConnections(lpRasConn(0), lpcb, lpcConnections)
    If ReturnCode = ERROR_SUCCESS Then
    For i = 0 To lpcConnections - 1
    If Trim(ByteToString(lpRasConn(i).szEntryName)) = Trim(gstrISPName) Then
    hRasConn = lpRasConn(i).hRasConn
    ReturnCode = RasHangUp(ByVal hRasConn)
    End If
    Next i
    End If
    End Sub
    Public Function ByteToString(bytString() As Byte) As String
    Dim i As Integer
    ByteToString = ""
    i = 0
    While bytString(i) = 0&
    ByteToString = ByteToString & Chr(bytString(i))
    i = i + 1
    Wend
    End Function
    'добавьте кнопку
    Private Sub Command1_Click()
    Call HangUp
    End Sub

    8.3 Запуск почты и Интернета из VB - Visual Basic
    ' Добавьте на форму 2 элемента Label, скопируйте и вставьте на форму следующий код:
    Private Declare Function ShellExecute& Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long)
    Private Sub Form_Load()
    Label1.Caption = "http://VBrus.narod.ru"
    Label2.Caption = "VBrus@yandex.ru"
    End Sub

    Private Sub Label1_Click()
    Call ShellExecute(0, "Open", Label1.Caption, "", "c:\", 1)

    End Sub

    Private Sub Label2_Click()
    Call ShellExecute(0, "Open", "mailto:" + Label2.Caption + "?Subject=" + "Письмо с сайта", "", "", 1)
    End Sub

    8.4 Как сохранить содержимое web-страницы на диск?
    Расположите на форме элемент Inet (меню Project|Components - Microsoft Internet Transfer Control 6.0).

    Private Sub Form_Load()
    Dim b() As Byte
    'установить протокол HTTP
    Inet1.Protocol = icHTTP
    'установить скачиваемый адрес
    Inet1.URL = "http://VBrus.narod.ru"
    'загрузить данные HTML-страницы в массив
    b() = Inet1.OpenURL(Inet1.URL, icByteArray)
    'создать файл на диске и записать в него информацию
    Open "c:\test.htm" For Binary Access Write As #1
    Put #1, , b()
    Close #1
    End Sub
    Вариант 2.
    Расположите на форме элемент CommandButton.
    Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
    Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
    Dim lngRetVal As Long
    lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
    If lngRetVal = 0 Then DownloadFile = True
    End Function
    Private Sub Command1_Click()
    DownloadFile "http://VBrus.narod.ru", "c:\VBrus.narod_ru.htm" End Sub

    8.5 Получение сведений из URL. - Visual Basic
    Данная функция возвращает различные компоненты web-страницы.
    Включая "host", "port", "user", "pass", "path" и "query"

    Private Type typURL 'http://sit:sitter@proxy.spiderit.net:881/prox/proxycfg.php3?openpage
    Protocol As String 'какой протокол (http://, ftp:// или другой)
    ServerName As String 'имя сервера (proxy.spiderit.net)
    Filename As String 'имя страницы (proxycfg.php3)
    Dir As String 'директория (/prox/)
    Filepath As String 'путь файла (/prox/proxycfg.php3)
    Username As String 'имя пользователя (sit)
    Password As String 'пароль (sitter)
    Query As String 'строка запроса (openpage)
    ServerPort As Integer 'порт сервера (881)
    End Type
    Const strNOCONTENT As String = "NOCONTENT"
    Const intDEFAULTPORT As Integer = 80
    Private Function ParseURL(URL As String) As typURL
    Dim strTemp As String
    Dim strServerAuth As String
    Dim strServerNPort As String
    Dim strAuth As String
    strTemp = URL
    If (InStr(1, strTemp, "://") > 0) Then
    ParseURL.Protocol = Left(strTemp, InStr(1, strTemp, "://") - 1)
    strTemp = Right(strTemp, Len(strTemp) - (Len(ParseURL.Protocol) + 3)) 'delete protocol + ://
    Else
    ParseURL.Protocol = strNOCONTENT
    End If
    If (InStr(1, strTemp, "/") > 0) Then
    strServerAuth = Left(strTemp, InStr(1, strTemp, "/") - 1)
    strTemp = Right(strTemp, Len(strTemp) - (Len(strServerAuth) + 1))
    Else
    strServerAuth = strTemp
    strTemp = "/"
    End If
    If (InStr(1, strServerAuth, "@") > 0) Then
    strAuth = Left(strServerAuth, InStr(1, strServerAuth, "@") - 1)
    strServerNPort = Right(strServerAuth, Len(strServerAuth) - (Len(strAuth) + 1))
    Else
    strAuth = ""
    strServerNPort = strServerAuth
    End If
    If (InStr(1, strAuth, ":") > 0) And (Len(strAuth) > 0) Then
    ParseURL.Username = Left(strAuth, InStr(1, strAuth, ":") - 1)
    ParseURL.Password = Right(strAuth, Len(strAuth) - InStr(1, strAuth, ":"))
    ElseIf (InStr(1, strAuth, ":") <> 0) Then
    ParseURL.Username = strAuth
    ParseURL.Password = strNOCONTENT
    Else
    ParseURL.Username = strNOCONTENT
    ParseURL.Password = strNOCONTENT
    End If
    If (InStr(1, strServerNPort, ":") > 0) Then
    ParseURL.ServerPort = Int(Right(strServerNPort, Len(strServerNPort) - InStr(1, strServerNPort, ":")))
    ParseURL.ServerName = Left(strServerNPort, InStr(1, strServerNPort, ":") - 1)
    Else
    ParseURL.ServerPort = intDEFAULTPORT
    ParseURL.ServerName = strServerNPort
    End If
    If (InStr(1, strTemp, "?") > 0) Then
    ParseURL.Query = Right(strTemp, Len(strTemp) - InStr(1, strTemp, "?"))
    strTemp = Left(strTemp, InStr(1, strTemp, "?") - 1)
    Else
    ParseURL.Query = strNOCONTENT
    End If
    For i = Len(strTemp) To 1 Step -1
    If (Mid(strTemp, i, 1) = "/") Then
    ParseURL.Filename = Right(strTemp, Len(strTemp) - i)
    ParseURL.Dir = Left(strTemp, i)
    If Not (Left(ParseURL.Dir, 1) = "/") Then
    ParseURL.Dir = "/" & ParseURL.Dir
    End If
    Exit For
    End If
    Next
    ParseURL.Filepath = "/" & strTemp
    If Not (Left(ParseURL.Filepath, 1) = "/") Then
    ParseURL.Filepath = "/" & ParseURL.Filepath
    End If
    End Function

    Private Sub Form_Load()
    Const strURL As String = "http://sit:sitter@proxy.spiderit.net:881/prox/proxycfg.php3?openpage"
    msgtext = ParseURL(strURL).Protocol & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Username & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Password & vbCrLf
    msgtext = msgtext & ParseURL(strURL).ServerName & vbCrLf
    msgtext = msgtext & ParseURL(strURL).ServerPort & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Filepath & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Dir & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Filename & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Query & vbCrLf
    MsgBox msgtext, vbInformation
    End Sub

    8.6 Является ли строковая переменная e-mail-адресом.
    Этот код использует VBScript.dll - Вы можете загрузить его с www.microsoft.com/msdownload/vbscript/scripting.asp
    Добавьте Microsoft VBScript Regular Expressions reference в ваш проект (выберите Project->References, поставьте галочку на Microsoft VBScript Regular Expressions CheckBox и нажмите OK).
    RegExp - тип переменной, которую вы хотите проверить: Email-адрес, телефонный номер, любой другой формат.

    Private Sub Form_Load()
    Dim myReg As RegExp
    Dim email As String
    Set myReg = New RegExp
    myReg.IgnoreCase = True
    myReg.Pattern = "^[\w-\.]+@\w+\.\w+$"
    'replace "myName@domain.ru" любым адресом
    email = "myName@domain.ru"
    MsgBox "Результат проверки: " & myReg.Test(email)
    Unload Me
    End Sub

    8.7 Загружаем файл из интернета - Visual Basic
    Маленькая функция, показывающая, как Ваше приложение может скачивать из интернета файлы. На вход функции достаточно подать URL и имя скачиваемого файла.

    Public Sub DLFiles(strUrl As String, fileName As String)
    On Error Resume Next
    Dim b() As
    Byte
    Inet1.Cancel
    Inet1.Protocol = icHTTP
    Inet1.URL = strUrl
    b() = Inet1.OpenURL(, icByteArray)
    Open fileName For Binary Access Write As #1
    Put #1, , b()
    Close #1
    End Sub

    8.8 Загружаем любой файл из интернета без использования WinSock - Visual Basic
    ps: работает 100%, проверял:) как на Windows Vista так и на XP
    'МОДУЛЬ
    Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

    'ФОРМА
    Call URLDownloadToFile(0, "http://vbrus.narod.ru/Info.htm", "c:\Info.htm", 0, 0)

    8.9 Советы по использованию компонента WebBrowser - Visual Basic
    Прежде всего, вы можете создать проект с использованием компонента WebBrowser, используя для этой цели VB Application Wizard. Для этого войдите в меню File | New Project и выберите VB Application Wizard. Нажмите несколько раз Next, и когда программа спросит вас "Do you want your user to be able to access the Internet from your application" смело нажимайте Yes. Можно сразу нажать кнопку Finish. В ваше приложение будет добавлена возможность навигации по Интернету, используя созданный вами проект.

    Расположите на основной форме CommandButton и впишите в него следующий код:

    frmBrowser.Show

    Некоторые возможности компонента WebBrowser у вас автоматически добавятся, и вы сами потом можете на досуге в них разобраться. Я а же предлагаю вам добавить в ваш проект возможности, которые автоматически не были добавлены Мастером Создания Приложений.

    Процесс, показывающий процесс загрузки веб-страницы
    Private Sub WebBrowser1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)
    On Error Resume Next
    PBar.Max = ProgressMax
    If Progress = -1 Then
    Exit Sub
    Else
    If Progress <> ProgressMax Then
    PBar.Value = Progress
    progresslbl.Caption = Str(Round((Progress / ProgressMax) * 100)) & pert
    Else
    PBar.Value = ProgressMax
    progresslbl.Caption = Str(Round((Progress / ProgressMax) * 100)) & pert
    Exit Sub
    End If
    End If
    End Sub

    или такой вариант.

    Private Sub WebBrowser1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)
    On Error Resume Next
    If Progress = -1 Then ProgressBar1.Value = 100
    If Progress > 0 And ProgressMax > 0 Then
    ProgressBar1.Value = Progress * 100 / ProgressMax
    End If
    Exit Sub
    End Sub

    или такой вариант.

    Private Sub WebBrowser1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)
    On Error Resume Next
    ProgressBar1.Max = ProgressMax
    ProgressBar1.Value = Progress
    ProgressBar1.Refresh
    End Sub

    Просмотр содержимого веб-страницы "В виде HTML"
    2 варианта. Загрузите оба варианта, и посмотрите, что каждый код загружает...

    Text1 = WebBrowser1.Document.documentelement.innerhtml
    Text2 = WebBrowser1.Document.Body.innerhtml

    Вызвать окно "Печать"
    On Error Resume Next
    WebBrowser1.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT

    Добавить в ComboBox URL после загрузки
    Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    Combo1.Text = URL
    End Sub

    Навигация на узел в сети
    WebBrowser1.Navigate "about:blank" 'пустая страница

    WebBrowser1.Navigate "http://sharig.webzone.ru"

    Запрет на посещение определенных узлов в Инете
    Private Sub WebBrowser1_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
    If InStr(1, URL, "playboy.com") Then
    Cancel = True
    MsgBox "Sorry, that site is restricted!"
    End If
    End Sub

    Ожидание загрузки страницы
    Do Until WebBrowser1.ReadyState = READYSTATE_COMPLETE
    DoEvents
    Loop

    Получить данные о загруженной странице
    MsgBox WebBrowser1.LocationName 'узнать имя загруженного файла (что-то типа "inet18_webbrowser.htm")

    MsgBox WebBrowser1.LocationURL 'получить URL загруженной страницы

    Вызвать окно "Сохранить как..."
    WebBrowser1.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT

    Что-то непонятное...
    Private Sub WebBrowser1_SetSecureLockIcon(ByVal SecureLockIcon As Long)
    If SecureLockIcon <> 0 Then
    imgSecure.Picture = "D:\garbage\ICON\2\face00.ico" 'path to secure icon
    Else
    imgSecure.Picture = "D:\garbage\ICON\2\face01.ico" 'path to unsecure icon
    End If
    End Sub

    Private Sub WebBrowser1_WindowClosing(ByVal IsChildWindow As Boolean, Cancel As Boolean)
    If MsgBox("This webpage is trying to close your browser window." & vbCrLf & vbCrLf & "Are you sure you want to close it?", vbYesNo, "BAPNet") = vbYes Then
    Unload Me
    Cancel = True
    ElseIf vbNo Then
    Cancel = True
    End If
    End Sub

    8.10 Как вытащить все ссылки из htm-страницы - Visual Basic
    В одном из многочисленных примеров по работе с компонентом WebBrowser я натолкнулся на пример, как можно вытащить все ссылки из любого *.htm файла, находящегося как в интернете, так и локально на жестком диске. Честно говоря, моя жизнь после нахождения данного примера очень облегчилась, поскольку я часто работаю с инетом, со ссылками.

    Нажатие на первую кнопку покажет, как можно вытащить все ссылки из файла, а нажатие на вторую кнопку - как можно вытащить ссылки только определенного типа.

    Но для начала вам надо установить через меню Project | References ссылку на Microsoft Internet Control.

    ПРИМЕР 1

    Также вам необходимо расположить на форме 2 элемента CommandButton и элемент ListBox.

    Private IEBroj1 As SHDocVw.InternetExplorer
    Private Sub Form_Load()
    Set IEBroj1 = New SHDocVw.InternetExplorer
    End Sub
    Private Sub Form_Unload(Cancel As Integer)
    IEBroj1.Quit
    Set IEBroj1 = Nothing
    End
    End Sub

    Function Delay(Pause As Single)
    Dim Start As Single
    Start = Timer
    Do While Timer < Start + Pause
    DoEvents
    Loop
    End Function

    Private Sub Command1_Click()
    List1.Clear
    Dim x
    IEBroj1.Navigate "C:\1\index.htm"
    Delay 3 'задержа необходима для загрузки страницы
    'иногда требуется увеличить время загрузки до 30 секунд.
    For i = 1 To IEBroj1.Document.links.length - 1
    List1.AddItem IEBroj1.Document.links(i).href
    Next
    End Sub

    Private Sub Command2_Click()
    List1.Clear
    Dim x
    IEBroj1.Navigate "C:\1\index.htm"
    Delay 3
    For i = 1 To IEBroj1.Document.links.length - 1
    If InStr(1, IEBroj1.Document.links(i).href, ".asp") <> 0 Or InStr(1, IEBroj1.Document.links(i).href, ".htm") <> 0 Then
    List1.AddItem IEBroj1.Document.links(i).href
    End If
    Next
    End Sub

    8.11 Создать ссылку на страницу в Интернете - Visual Basic
    Данный пример разместит на рабочем столе ярлык на сайт RusEdu.info (при условии, что ваш путь к рабочему столу = "C:\WIN\Рабочий стол").

    Sub CreateInternetShortCut(URLFile As String, URLTarget As String)
    Dim intFreeFile As Integer
    intFreeFile = FreeFile
    Open URLFile For Output As intFreeFile
    Print #intFreeFile, "[InternetShortcut]"
    Print #intFreeFile, "URL=" & URLTarget
    Close intFreeFile
    End Sub

    Private Sub Form_Load()
    CreateInternetShortCut "C:\WIN\Рабочий стол\test.url", "http://rusedu.info"
    End Sub

    8.12 Определить дату изменения web-страницы - Visual Basic
    Зазместите на форме компонент Inet и элемент CommandButton.

    Public Function PageLastModified(URL As String) As String
    Dim strHeader As String
    Inet1.Protocol = icHTTP
    On Error Resume Next
    Inet1.OpenURL (URL)
    If Err.Number > 0 Then Exit Function
    strHeader = Inet1.GetHeader("Last-modified")
    PageLastModified = strHeader
    End Function

    Private Sub Command1_Click()
    MsgBox PageLastModified("http://sharig.webzone.ru/IndexMainTopic.htm")
    End Sub

    8.13 Является ли строковая переменная e-mail-адресом - Visual Basic
    Этот код использует VBScript.dll
    Вы можете загрузить его с www.microsoft.com/msdownload/vbscript/scripting.asp

    Добавьте Microsoft VBScript Regular Expressions reference в ваш проект (выберите Project->References, поставьте галочку на Microsoft VBScript Regular Expressions CheckBox и нажмите OK).

    RegExp - тип переменной, которую вы хотите проверить: Email-адрес, телефонный номер, любой другой формат.

    Private Sub Form_Load()
    Dim myReg As RegExp
    Dim email As String
    Set myReg = New RegExp
    myReg.IgnoreCase = True
    myReg.Pattern = "^[\w-\.]+@\w+\.\w+$"
    'replace "myName@domain.ru" любым адресом
    email = "myName@domain.ru"
    MsgBox "Результат проверки: " & myReg.Test(email)
    Unload Me
    End Sub

    8.14 Имя текущего соединения с инетом - Visual Basic
    'Расположите на форме элемент CommandButton.

    Private Const RAS_MAXENTRYNAME As Integer = 256
    Private Const RAS_MAXDEVICETYPE As Integer = 16
    Private Const RAS_MAXDEVICENAME As Integer = 128
    Private Const RAS_RASCONNSIZE As Integer = 412
    Private Type RASCONN
    dwSize As Long
    hRasConn As Long
    szEntryName(RAS_MAXENTRYNAME) As Byte
    szDeviceType(RAS_MAXDEVICETYPE) As Byte
    szDeviceName(RAS_MAXDEVICENAME) As Byte
    End Type
    Private Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" (udtRasConn As Any, lpcb As Long, lpcConnections As Long) As Long
    Private Sub Command1_Click()
    Dim udtRasConn(255) As RASCONN, countConn As Long
    Dim Ret As Long, b As Long
    udtRasConn(0).dwSize = RAS_RASCONNSIZE
    Ret = RasEnumConnections(udtRasConn(0), RAS_MAXENTRYNAME * udtRasConn(0).dwSize, countConn)
    If Ret = 0 Then
    For b = 0 To countConn - 1
    MsgBox "Текущее соединение: " & StrConv(udtRasConn(b).szEntryName(), vbUnicode)
    Next b
    End If
    End Sub

    8.15 Получение списка всех интернет-соединений - Visual Basic
    Добавьте на форму CommandButton и ListBox. Вставьте следующий код, запустите программу на выполнение. В ListBox'е вы получите имена всех интернет-соединений. При нажатии на CommandButton на форме будет напечатано имя интернет-соединения по умолчанию.

    Const REG_NONE = 0&
    Const REG_SZ = 1&
    Const REG_EXPAND_SZ = 2&
    Const REG_BINARY = 3&
    Const REG_DWORD = 4&
    Const REG_DWORD_LITTLE_ENDIAN = 4&
    Const REG_DWORD_BIG_ENDIAN = 5&
    Const REG_LINK = 6&
    Const REG_MULTI_SZ = 7&
    Const REG_RESOURCE_LIST = 8&
    Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
    Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

    Public rgeEntry$
    Public rgeDataType&
    Public rgeValue$
    Public rgeMainKey&
    Public rgeSubKey$

    Const KEY_QUERY_VALUE = &H1&
    Const KEY_SET_VALUE = &H2&
    Const KEY_CREATE_SUB_KEY = &H4&
    Const KEY_ENUMERATE_SUB_KEYS = &H8&
    Const KEY_NOTIFY = &H10&
    Const KEY_CREATE_LINK = &H20&
    Const READ_CONTROL = &H20000
    Const WRITE_DAC = &H40000
    Const WRITE_OWNER = &H80000
    Const SYNCHRONIZE = &H100000
    Const STANDARD_RIGHTS_REQUIRED = &HF0000
    Const STANDARD_RIGHTS_READ = READ_CONTROL
    Const STANDARD_RIGHTS_WRITE = READ_CONTROL
    Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
    Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
    Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
    Const KEY_EXECUTE = KEY_READ
    Private Type FILETIME
    lLowDateTime As Long
    lHighDateTime As Long
    End Type
    Const HKEY_CLASSES_ROOT = &H80000000
    Const HKEY_CURRENT_USER = &H80000001
    Const HKEY_LOCAL_MACHINE = &H80000002
    Const HKEY_USERS = &H80000003
    Const HKEY_PERFORMANCE_DATA = &H80000004
    Const HKEY_CURRENT_CONFIG = &H80000005
    Const HKEY_DYN_DATA = &H80000006

    Private Declare Function RegOpenKeyEx& Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey&, ByVal lpszSubKey$, dwOptions&, ByVal samDesired&, lpHKey&)
    Private Declare Function RegCloseKey& Lib "advapi32.dll" (ByVal hKey&)
    Private Declare Function RegQueryValueEx& Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
    Private Declare Function RegEnumKeyEx& Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey&, ByVal dwIndex&, ByVal lpname$, lpcbName&, ByVal lpReserved&, ByVal lpClass$, lpcbClass&, lpftLastWriteTime As FILETIME)
    Private Declare Function RegQueryInfoKey& Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey&, ByVal lpClass$, lpcbClass&, ByVal lpReserved&, lpcSubKeys&, lpcbMaxSubKeyLen&, lpcbMaxClassLen&, lpcValues&, lpcbMaxValueNameLen&, lpcbMaxValueLen&, lpcbSecurityDescriptor&, lpftLastWriteTime As FILETIME)

    Public Function GetRegValue(keyroot As Variant, subkey As Variant, valname As String)
    Const KEY_ALL_ACCESS As Long = &HF0063
    Const ERROR_SUCCESS As Long = 0
    Const REG_SZ As Long = 1
    Dim hsubkey As Long, dwType As Long, sz As Long
    Dim R As Long
    R = RegOpenKeyEx(keyroot, subkey, 0, KEY_ALL_ACCESS, hsubkey)
    sz = 256
    v$ = String$(sz, 0)
    R = RegQueryValueEx(hsubkey, valname, 0, dwType, ByVal v$, sz)
    If R = ERROR_SUCCESS And dwType = REG_SZ Then
    retval = Left$(v$, sz)
    GetRegValue = retval
    Else
    retval = "--Not String--"
    End If
    R = RegCloseKey(hsubkey)
    End Function
    Public Sub rgeClear()
    rgeMainKey = 0
    rgeSubKey = ""
    rgeValue = ""
    rgeDataType = 0
    rgeEntry = ""
    End Sub
    Function RegEnumKeys&(bFullEnumeration As Boolean)
    Dim sRoot$, sRoot2$
    Dim lRtn&
    Dim hKey&
    Dim strucLastWriteTime As FILETIME
    Dim sSubKeyName$
    Dim sClassString$
    Dim lLenSubKey&
    Dim lLenClass&
    Dim lKeyIndx&
    Dim lRet&
    Dim hKey2&
    Dim sSubKey2$
    Dim sNewKey$
    Dim sClassName$
    Dim lClassLen&
    Dim lSubKeys&
    Dim lMaxSubKey&
    Dim sMaxSubKey$
    Dim lMaxClass&
    Dim sMaxClass$
    Dim lValues&
    Dim lMaxValueName&
    Dim lMaxValueData&
    Dim lSecurityDesc&
    lRtn = RegOpenKeyEx(rgeMainKey, rgeSubKey, 0&, KEY_READ, hKey)
    sClassName = Space$(255)
    lClassLen = CLng(Len(sClassName))
    lRet = RegQueryInfoKey(hKey, sClassName, lClassLen, 0&, lSubKeys, lMaxSubKey, _
    lMaxClass, lValues, lMaxValueName, lMaxValueData, lSecurityDesc, strucLastWriteTime)
    sMaxSubKey = Space$(lMaxSubKey + 1)
    sMaxClass = Space$(lMaxClass + 1)
    lKeyIndx = 0&
    Do While lRtn = ERROR_SUCCESS
    ReTryKeyEnumeration:
    sSubKeyName = sMaxSubKey
    lLenSubKey = lMaxSubKey
    sClassString = sMaxClass
    lLenClass = lMaxClass
    lRtn = RegEnumKeyEx(hKey, lKeyIndx, sSubKeyName, lLenSubKey, 0&, sClassString, _
    lLenClass, strucLastWriteTime)
    If InStr(sSubKeyName, Chr$(0)) > 1 Then
    sSubKeyName = Left$(sSubKeyName, InStr(sSubKeyName, Chr$(0)) - 1)
    End If
    If lRtn = ERROR_SUCCESS Then
    Form1.List1.AddItem sSubKeyName
    lNewKey = lNewKey + 1
    sNewKey = "A" & Format$(lNewKey, "000000")
    If bFullEnumeration = True Then
    sSubKey2 = sSubKeyName
    If rgeSubKey <> "" Then
    sSubKey2 = Trim(rgeSubKey) & "\" & sSubKeyName
    End If
    lRet = RegOpenKeyEx(rgeMainKey, sSubKey2, 0&, KEY_READ, hKey2)
    Else
    Exit Do
    End If
    lKeyIndx = lKeyIndx + 1
    ElseIf lRtn = ERROR_MORE_DATA Then
    lMaxSubKey = lMaxSubKey + 5
    lMaxClass = lMaxClass + 5
    sMaxSubKey = Space$(lMaxSubKey + 1)
    sMaxClass = Space$(lMaxClass + 1)
    GoTo ReTryKeyEnumeration
    ElseIf lRtn = ERROR_NO_MORE_ITEMS Then
    lRtn = ERROR_SUCCESS
    Exit Do
    Exit Do
    End If
    Loop
    RegEnumKeys = lRtn
    lRtn = RegCloseKey(hKey)
    End Function

    Private Sub Form_Load()
    rgeMainKey = HKEY_CURRENT_USER
    rgeSubKey$ = "RemoteAccess\Profile"
    RegEnumKeys True
    End Sub
    Private Sub Command1_Click()
    Print GetRegValue(HKEY_CURRENT_USER, "RemoteAccess", "Default")
    End Sub

    8.16 Запрещение запуска дополнительных окон IE
    Данный пример запретит запуск дополнительных окон броузера ИнтернетЭксплорер. Этот пример хорош для борьбы с рекламными окошками, запускаемыми автоматически на тех или иных сайтах.

    Что делает пример: 1) программа при запуске определяет количество запущенных окон InternetExplorer'а. 2) во время работы программа проводит мониторинг запущенных процессов, 3) и если запущено очередное окно Internet Explorer'а программа его закроет.

    Ну а кнопка вам понадобится, если вы захотите отключить/снова включить процесс мониторинга.

    Пример подробно описан, но... на английском языке.

    Установите на форме компонент Label, компонент Timer и CommandButton. Также в этом примере вам понадобится дополнительный модуль.

    'КОД МОДУЛЯ:

    Public Type WI
    TitleBarText As String
    TitleBarLen As Integer
    hWnd As Long
    End Type
    Public Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
    Public Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
    Public Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
    Public WinNum As Integer 'holds the number of windows examined
    Public CurrentWindows(299) As WI 'holds information about all of the currently open windows

    Public Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
    Dim WinInfo As WI 'holds information about the window currently being examined
    Dim retval As Long 'holds the return value
    Dim X As Integer

    WinInfo.TitleBarLen = GetWindowTextLength(hWnd) + 1 'find the length of the title bar text of the window currently being examined
    If WinInfo.TitleBarLen > 0 And Len(hWnd) > 1 Then 'if the title bar text of the window currently being examined is at least one character long AND the window's handle is > 1
    WinInfo.TitleBarText = Space(WinInfo.TitleBarLen) 'initialize the variable that will hold the title bar text
    retval = GetWindowText(hWnd, WinInfo.TitleBarText, WinInfo.TitleBarLen) 'retreive the title bar text of the window currently being examined
    WinInfo.hWnd = hWnd 'holds the value of this window's handle
    CurrentWindows(WinNum).hWnd = WinInfo.hWnd 'store this window's handle in the current windows array
    CurrentWindows(WinNum).TitleBarText = WinInfo.TitleBarText 'store this window's title bar text in the current windows array
    WinNum = WinNum + 1 'increment the window counter
    End If
    EnumWindowsProc = 1 'continue enumeration of windows
    End Function

    'КОД ФОРМЫ

    Option Explicit

    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Const WM_CLOSE = &H10
    Dim ExistingIEWindows(49) As Long 'holds the handles of all of the currently existing IE windows (50 max)
    Dim Flash As Integer 'holds the value that determines if the status text should flash

    Private Sub Command1_Click()
    If Command1.Caption = "Отключить мониторинг" Then
    Timer1.Enabled = False
    Command1.Caption = "Включить мониторинг"
    Else
    Timer1.Enabled = True
    End If
    End Sub

    Private Sub Form_Load()
    Timer1.Interval = 100
    Command1.Caption = "Отключить мониторинг"
    Dim X As Integer 'loop variable
    Label1.Caption = "Initializing..."
    Flash = 0
    For X = 0 To 49 'reset/initialize the existing IE windows array
    ExistingIEWindows(X) = 0
    Next
    Call GetExistingIEWindows
    End Sub

    Private Sub GetExistingIEWindows() 'this sub checks to see if any IE windows are currently open, and "remembers" them if so.
    Dim retval As Long 'holds the return value
    Dim X As Integer, Y As Integer 'loop variables
    Label1.Caption = "Examining currently active system windows..."
    WinNum = 0 'initialize number of windows to zero
    For X = 0 To 199 'reset/initialize the current windows array
    CurrentWindows(X).hWnd = 0
    CurrentWindows(X).TitleBarLen = 0
    CurrentWindows(X).TitleBarText = ""
    Next
    retval = EnumWindows(AddressOf EnumWindowsProc, 0) 'enumerate all open windows
    Y = 0
    For X = 0 To WinNum - 1 'for each window that is currently open
    If InStr(1, CurrentWindows(X).TitleBarText, "Microsoft Internet Explorer", vbTextCompare) > 0 Then 'if this window is an IE window...
    Label1.Caption = "Storing IE window handle..."
    ExistingIEWindows(Y) = CurrentWindows(X).hWnd 'add this window to the list of existing IE windows
    Y = Y + 1
    End If
    Next
    If Y > 0 Then 'if any of the existing system windows are IE windows
    Label1.Caption = "Enabling popup monitoring..."
    Timer1.Enabled = True 'enable the timer that checks for any new IE windows
    Label1.Caption = "Monitoring for new IE windows..."
    Else 'if none of the existing system windows are IE windows
    Label1.Caption = "No IE windows found!"
    MsgBox "There are currently no IE windows open!" & vbLf & vbLf & "Please start Internet Explorer before running this program.", vbExclamation + vbOKOnly, "Error" 'if no IE windows are found, display an error message
    End 'exit this program
    End If
    End Sub

    Private Sub Timer1_Timer()
    Dim retval As Long 'holds the return value
    Dim X As Integer, Y As Integer 'loop variables
    Dim KillCount As Integer 'holds the value that determines if the current window should be killed
    WinNum = 0 'initialize number of windows to zero
    For X = 0 To 199 'reset/initialize the current windows array
    CurrentWindows(X).hWnd = 0
    CurrentWindows(X).TitleBarLen = 0
    CurrentWindows(X).TitleBarText = ""
    Next
    retval = EnumWindows(AddressOf EnumWindowsProc, 0) 'enumerate all open windows
    For X = 0 To WinNum - 1 'for each window that is currently open
    If InStr(1, CurrentWindows(X).TitleBarText, "Microsoft Internet Explorer", vbTextCompare) > 0 Then 'if this window is an IE window...
    KillCount = 0
    For Y = 0 To 49
    If ExistingIEWindows(Y) <> 0 Then 'if array value holds a valid handle
    If ExistingIEWindows(Y) = CurrentWindows(X).hWnd Then 'if the window currently being examined matches any of the existing IE windows
    KillCount = KillCount + 1 'increment
    End If
    End If
    Next
    If KillCount = 0 Then 'if an IE window that did not previously exist was found
    retval = PostMessage(CurrentWindows(X).hWnd, WM_CLOSE, ByVal CLng(0), ByVal CLng(0)) 'post the window close message to the newly created IE window's message queue
    End If
    End If
    Next
    Flash = Flash + 1 'increment the flash value
    If Flash = 5 Then 'make the status label flash every 0.5 seconds
    Flash = 0
    If Label1.Visible = True Then
    Label1.Visible = False
    Else
    Label1.Visible = True
    End If
    End If
    End Sub

    8.17 Proxy Server на VB - Visual Basic
    proxy.oflameron.ru - Proxy на Visual Basic
    Онлайн учебник - прокси-сервер на Visual Basic. Курсовик

    8.18 Как установить/сменить IP адресс в локальной сети - Visual Basic
    http://vbrus.narod.ru/Primers/Lan/IP876.zip - Скачать примеp

    8.19 Как отправлять сообщения и файлы через Mail - Visual Basic
    Скачать пример

    Наверх

09. Использование Winsock контрола

    Использование компонента Winsock
    Компонент WinSock позволяет соединиться с удаленной машиной и обменяться с ней данными, используя UDP (User Datagram Protocol)
    или TCP (Transmission Control Protocol). Оба протокола могут быть использованы при создании клиент-серверных приложений. Также, как и Timer control, WinSock control является невидимым во время выполнения программы.

    Как им пользоваться?

    - cоздать приложение-клиент, которое будет собирать информацию перед отсылкой ее на центральный сервер;
    - cоздать приложение-сервер, которое будет выполнять роль сборщика и хранителя информации от различных клиентских приложений;
    - создать "chat"-приложение.

    Выбор протокола

    Когда планируется использование а WinSock, необходимо решить какой протокол будет использоваться - TCP или UDP. Основное отличие между ними заключается в способе организации связи:
    Соединение основанное на TCP протоколе, похоже на телефонное - пользователь сначала должен установить соединение, прежде чем что-либо передавать.
    Соединение основанное на UDP протоколе, похоже на передачу голосом, сообщение передается от одного компьютера к другому, но не ясно, слышат ли они друг друга. Вдобавок, максимальный размер предаваемых данных устанавливается сетью.
    Возможности приложения которое Вы создаете будет зависеть от протокола, который Вы изберете. Вот несколько вопросов которые могут помочь Вам выбрать подходящий протокол: Будет ли приложение требовать уведомления от сервера или клиента, когда данные передаются или получаются?
    Если будет, то TCP протокол требует установленного соединения между передатчиком и приемником данных.
    Будут ли передаваемые данные достаточно тяжелыми (например изображения или звуковые файлы)? Если соединение было установлено, TCP протокол будет его поддерживать и гарантируется целостность передаваемых данных. Такое соединение, из-за потребности в большем количестве вычислительных ресурсов, может сделать его более медленным.
    Будут ли данные передаваться порциями или за одну сессию? Например, если Вы создаете приложение, которое сообщает каким-то компьютерам, о том, что какие-то задачи уже выполнены, то UDP протокол более подходящий. UDP протокол также блучше подходит для передачи небольшого количества данных.


    Установка протокола

    Чтобы установить протокол, который будет использовать ваше приложение Вы должны в дизайн-тайме в окне свойств выбрать свойство Protocol
    и установить его sckTCPProtocol или sckUDPProtocol. Это можно также сделать программно:
    Winsock1.Protocol = sckTCPProtocol
    Определение имени компьютера.
    Чтобы установить связь с удаленным компьютером, Вы должны знать либо его IP-адресс, либо его имя.

    Основы TCP соединения
    Когда создается приложение, которое использует TCP протокол первое, что Вы должны решить, это чем будет ваше приложение клиентом или сервером. Если Вы создаете приложение-сервер, значит ваше приложение будет слушать указанный порт. Когда приложение-клиент подаст запрос на соедиение, приложение-сервер может принять запрос и таким образом установить соедиенеие. Если соединение установлено, приложение-клиент и приложение сервер могут свободно обмениваться данными.
    Следующие шаги позволят Вам создать элементарное приложение-сервер:

    Для создания TCP сервера

    Создайте новый Standard EXE проект.
    Замените имя формы по умолчанию на frmServer.
    В свойстве формы caption наберите "TCP Server"
    В меню Project\Components добавьте Microsoft Winsock Conrol 6.0
    Перетащите иконку компонента Winsock с панели инструментов и разместите ее на форме; измените имя компонента на tcpServer.
    Добавьте на форму два Текстбокс элемента. В свойстве Name первого текстового поля наберите txtSendData, а второго txtOutput.
    Добавьте в форму следующий код:


    Private Sub Form_Load()
    'Задать номер порта по которому будет осуществляться
    'обмен данными, присвоив значение свойству LocalPort
    'Вызвать метод Listen.
    tcpServer.LocalPort = 1001
    tcpServer.Listen
    frmClient.Show 'Показать форму клиента
    End Sub


    Private Sub tcpServer_ConnectionRequest (ByVal requestID As Long)
    ' Проверяется свойство State, было ли завершено
    ' предыдущее соединение. Если не завершено,
    ' то перед установлением нового соединения,
    ' старое закрывается принудительно.
    If tcpServer.State <> sckClosed Then tcpServer.Close
    ' Принятие запроса Accept с параметром requestID
    ' на установление соедиения.
    tcpServer.Accept requestID
    End Sub

    Private Sub txtSendData_Change()
    ' Текстовое поле txtSendData
    ' содержит данные для передачи. Все символы,
    ' которые будут вводиться в это текстовое поле, будут единой
    ' строкой посылаться приложению-клиенту, используя метод SendData.
    tcpServer.SendData txtSendData.Text
    End Sub

    Private Sub tcpServer_DataArrival (ByVal bytesTotal As Long)
    ' Декларируется переменная-буфер для получаемых данных.
    ' Вызывается метод GetData и свойству Text
    ' текстового поля txtOutput, присваивается значение переменной-
    ' буфера.

    Dim strData As String
    tcpServer.GetData strData
    txtOutput.Text = strData
    End Sub


    Описанные выше действия, выполненные Вами, приведут к созданию простого приложения-сервера. Но для того чтобы полностью выполнить задачу, необходимо создать еще и приложение-клиент.

    Для создания TCP приложения-клиента

    Добавьте новую форму в проект и назовите ее frmClient.
    И змените свойство формы caption на "TCP Client".
    Перетащите и разместите компонент Winsock на форму и измените его свойство name на "tcpClient".
    Добавьте два Текстбокс-контрола на форму frmClient.
    Имя первого установите txtSend, а второго txtOutput.
    Перетащите на форму CommandButton и установите его свойство name в "cmdConnect".
    Измените свойство caption этой кнопки на "Connect".
    Добавьте следующий код в форму.
    Важно!!! Будьте внимательны при установке свойства RemoteHost. Оно должно соответствовать либо IP-адресу вашего компьютера,
    либо его "Дружественному имени" (см. Пуск\Настройка\Панель управления\Сеть) выберите вкладку "Идентификация". Текст из поля "Имя компьютера" и будет так называемым дружественным именем, которым можно заменять IP-адрес. Сам же IP-адрес, можно посмотреть, если выбрать закладку "Конфигурация" в списке выбрать TCP/IP, нажать кнопку "Свойства" и выбрать закладку IP-адрес.

    Private Sub Form_Load()
    ' Имя Winsock-компонента tcpClient.
    ' Указывая имя удаленного компьютера можно
    ' указывать IP-адрес (например: "121.111.1.1") или
    ' дружественное имя, как в нижеприведенном коде.
    tcpClient.RemoteHost = "RemoteComputerName" 'или "121.111.1.1"
    tcpClient.RemotePort = 1001
    End Sub

    Private Sub cmdConnect_Click()
    ' Вызвать метод Connect для создания соединения
    tcpClient.Connect
    End Sub

    Private Sub txtSend_Change()
    tcpClient.SendData txtSend.Text
    End Sub

    Private Sub tcpClient_DataArrival (ByVal bytesTotal As Long)
    Dim strData As String
    tcpClient.GetData strData
    txtOutput.Text = strData
    End Sub


    Сохраните проект в отдельной директории.
    Код приведенный выше - это простейшее клиент-серверное приложение. Чтобы попробовать, как это все работает на одной машине в связке, имитирующей межмашинное соединение, значение свойства RemoteHost приложения-клиента должно соответствовать дружественному имени или IP-адресу вашего компьютера. Запустите проект и нажмите кнопку "Connect". После этого наберите текст внутри текстового поля txtSendData на каждой форме и убедитесь, что тот же самый текст появится в текстовом поле txtOutput другой формы.
    Если Вы хотите, попробовать, как приложения будут осуществлять связь между двумя компьютерами, то Вам прийдется произвести следующие действия:
    Удалить из кода формы приложения-сервера строку frmClient.Show.
    В окне Project Explorer щелкнуть правой кнопкой мыши на форме frmClient.frm и в появившемся меню выбрать Remove frmClient.frm после чего сохранить проект под именем Server1.
    Открыть первый вариант проекта и таким же образом удалить из проекта уже форму frmServer.frm.
    Создать exe модуль для frmClient-а и переписать его на удаленный компьютер и запустить его там.
    Примечание: если на удаленном компьютере не установлен VB будьте готовы к тому, что вам потребуется переписать
    на него из WINDOWS\SYSTEM\mswinsck.ocx и зарегистрировать его при помощи команды
    WINDOWS\SYSTEM\regsvr32.exe mswinsck.ocx
    Если приложение будет требовать какие-то дополнительные dll модули перепишите их со своей машины на удаленную.
    На своей машине, откройте проект Server и запустите его.
    На клиентской машине нажмите кнопку Connect и наберите текст внутри текстового поля txtSendData на каждой форме и убедитесь, что тот же самый текст появится в текстовом поле txtOutput в приложении, запущенном на другом компьютере.


    Обработка более чем одного запроса на установление соединения

    Приложение-сервер, которое мы создавали сначала может обработать только один запрос на соединение. Тем не менее, существует возможность обработать несколько запросов на соединение, используя тот же самый управляющий элемент как один из массива управляющих элементов.
    В этом случае, необязательно закрывать соединение - просто создайте новый вариант управляющего элемента (использовав его свойство Index) и вызовите метод Accept для этого нового варианта управляющего элемента.
    В приведенном ниже тексте программы, свойству Index, размещенного на форме Winsock-компонента sckServer, присваивается значение 0, таким образом, управляющий элемент становится частью массива управляющих элементов. В разделе Declarations описана локальная переменная intMax. Когда для формы происходит событие Load, переменной intMax присваивается значение 0 и свойству LocalPort первого элемента массива
    управляющих элементов присваивается значение 1001. Только после того, как вызывается метод Listen этого управляющего элемента, он начинает слушать указанный порт. Когда поступает новый запрос на соединение, осуществляется проверка значения Index и равно ли оно 0 (значение элемента, который слушает порт). Таким образом, элемент который слушает порт, будет приращивать переменную intMax и использовать значение этой переменной для создания нового элемента массива. Этот новый элемент будет использоваться для обработки запроса на соединение.

    Private intMax As Long

    Private Sub Form_Load()
    intMax = 0
    sckServer(0).LocalPort = 1001
    sckServer(0).Listen
    End Sub

    Private Sub sckServer_ConnectionRequest (Index As Integer, ByVal requestID As Long)
    If Index = 0 Then
    intMax = intMax + 1
    Load sckServer(intMax)
    sckServer(intMax).LocalPort = 0
    sckServer(intMax).Accept requestID
    Load txtData(intMax)
    End If
    End Sub



    Основы UDP

    Создавать приложения, использующие UDP протокол проще, чем создавать приложения, использующие TCP протокол. Дело в том, что UDP не требует уже установленного соединения, как необходимого условия для передачи данных. В приложениях использующих TCP соединение, один Winsock элемент должен обязательно "слушать" порт, в ожидании пока какое-нибудь другое приложение не станет инициатором соединения, использовав метод Connect. UDP протокол не требует обязательно установленного соединения для передачи данных. Для передачи данных между двумя приложениями, необходимо выполнить три следующих пункта с обеих соединяющихся сторон:
    присвоить свойству RemoteHost дружественное имя или IP-адрес компьютера с которым предстоит соединение;
    установить свойство RemotePort для LocalPort property of the second control.
    Вызвать метод Bind указав какой локальный порт будет использоваться (метод Bind подробнее будет обсужден ниже).
    Т.к. оба компьютера полагаются равными в установлении соединения, мы можем назвать это соединение peer-to-peer. Чтобы продемонстрировать
    это соединение мы создадим так называемое приложение-chat позволяющее двум людям общаться в реальном режиме времени.


    Для создания UDP соединения

    Создайте Standard EXE проект.
    Измените свойство name формы на frmPeerA.
    Измените свойство caption формы на "Peer A"
    Перетащите с панели инструментов иконку Winsock компонента и разместите его на форме. Присвойте свойству name значение udpPeerA.
    Измените свойство Protocol на UDPProtocol.
    Добавьте два текстовых поля на форму.
    Имя первой должно быть txtSend а второй txtOutput.
    Добавьте приведенный ниже код на форму.

    Private Sub Form_Load()
    ' Имя Winsock элемента udpPeerA
    With udpPeerA
    ' Важно: правильно укажите значение RemoteHost
    ' компьютера, с которым предстоит соединение.
    .RemoteHost= "PeerB"
    .RemotePort = 1001 ' Имя порта для соединения.
    .Bind 1002 ' Привязка к локальному порту.
    End With
    frmPeerB.Show ' Показать вторую форму.
    End Sub

    Private Sub txtSend_Change()
    ' Послать текст, как только он будет набран.
    udpPeerA.SendData txtSend.Text
    End Sub

    Private Sub udpPeerA_DataArrival (ByVal bytesTotal As Long)
    Dim strData As String
    udpPeerA.GetData strData
    txtOutput.Text = strData
    End Sub


    Чтобы создать второе UDP приложение

    Добавить стандартную форму в проект.
    Изменить имя формы на frmPeerB.
    Изменить свойство caption формы на "Peer B".
    Перетащить и разместить иконку Winsock компонента на форму.
    Изменить имя Winsock на udpPeerB.
    Изменить свойство Protocol на UDPProtocol.
    Добавить два текстовых поля на форму.
    Имя первого должно быть txtSend, а второго txtOutput.
    Добавьте следующий код в форму.

    Private Sub Form_Load()
    ' Имя Winsock элемента udpPeerB.
    With udpPeerB
    ' Будьте внимательны указывая имя или IP-адрес
    ' компьютера с которым предстоит соединение.
    .RemoteHost= "PeerA"
    .RemotePort = 1002 ' Номер порта для соединения.
    .Bind 1001 ' Привязка к локальному порту.
    End With
    End Sub

    Private Sub txtSend_Change()
    ' Пересылать текст, как только он будет набран в текстовом поле.
    udpPeerB.SendData txtSend.Text
    End Sub

    Private Sub udpPeerB_DataArrival (ByVal bytesTotal As Long)
    Dim strData As String
    udpPeerB.GetData strData
    txtOutput.Text = strData
    End Sub


    Чтобы попробовать приложение запустите проект, и наберите в текстовом поле txtSend каждой формы какой-то текст.
    Этот текст появится в текстовых полях txtOutput другой формы.


    О методе Bind

    Как показано в приведенном выше примере, Вы должны вызывать метод Bind, когда создается UDP приложение. Метод Bind резервирует локальный порт для использования его элементом Winsock. Например, когда Вы привязываете свой элемент Winsock к порту 1001, то ни одно другое приложение не может использовать этот порт для прослушивания. Это может быть полезным, когда Вы хотите воспрепятствовать какому-либо другому приложению использовать этот порт. Метод Bind имеет еще один необязательный аргумент. Если на вашем компьютере установлено более одного сетевого адаптера, аргумент LocalIP позволит Вам точно указать адаптер, который необходимо использовать. Если Вы не укажите этот аргумент, то Winsock компонент будет использовать тот сетевой адаптер, который расположен первым в списке, который можно посмотреть в Пуск\Настройка\Панель управления\Система\Сетевые платы. Когда используется UDP протокол, Вы можете изменять свойства RemoteHost и RemotePort пока сохраняется привязка к тому же самому LocalPort. Если бы Вы использовали TCP протокол, то прежде чем сменить свойства RemoteHost и RemotePort, необходимо сначала закрыть соединение.

    Автор: Oleg Palayda
    Наверх

10. Как заставить Winsock работать с несколькими соединениями? - VB

    Контрол Winsock позволяет создавать только одно соединение между двумя компьютерами. Однако, можно создать несколько соединений (несколько компьютеров к одному) путём создания нескольких экземпляров Winsock-а во время работы.

    Добавьте контрол Winsock в Вашу форму и установите его индекс в 0, затем добавьте следующий код в программу сервера, к которому Вы собираетесь создавать несколько соединений:

    Option Explicit
    Public NumSockets As Integer
    '//Public Variable to track number of Connections

    Private Sub Form_Load()
    Caption = Winsock1(0).LocalHostName & Winsock1(0).LocalIP
    Winsock1(0).LocalPort = 1066
    Print "Listening to " + Str(Winsock1(0).LocalPort)
    Winsock1(0).Listen
    End Sub

    Private Sub Winsock1_Close(Index As Integer)
    Print "Connection Closed :" & Winsock1(Index).RemoteHostIP
    Winsock1(Index).Close
    End Sub

    Private Sub Winsock1_ConnectionRequest(Index As Integer,ByVal requestID As Long)
    Print "Connection Request from : " & Winsock1(Index).RemoteHostIP
    NumSockets = NumSockets + 1
    '//Увеличиваем количество Сокетов на один.
    Load Winsock1(NumSockets)
    '//Загружаем новый объект Winsock
    Winsock1(NumSockets).Accept requestID
    '//Ждём нового соединения
    End Sub

    Private Sub Winsock1_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    Dim vtData As String
    Winsock1(Index).GetData vtData, vbString
    Print vtData
    End Sub

    Теперь Мы можем продолжать ожидать соединения.

Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования