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
|
|
|
|
|
|
|
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
Наверх
Text1.Text = Environ("windir")' вот и все!
Но это ещё не всё! Также с помощью этой функции можно получить следующие перменные:
MsgBox Environ ("TMP") 'директория временных файлов TEMP
MsgBox Environ ("BLASTER") 'координаты звуковой карты
MsgBox Environ ("PATH") 'пути, объявленные в autoexec.bat
Наверх
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
Наверх
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
Наверх
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
Наверх
'добавьте модуль
Declare Function SetComputerName Lib "kernel32" Alias "SetComputerNameA" (ByVal lpComputerName As String) As Long
'добавьте кнопку
a$ = "Hello World"
b& = SetComputerName(a$)
Наверх
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
Наверх
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
Скачать пример
Наверх
Использование компонента 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
Наверх
Контрол 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
Теперь Мы можем продолжать ожидать соединения. |
|