rtportal.ru
01. Как перезагрузить или выключить компьютер в Windows XP? - Visual Basic
strComputer = "." Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate, (Shutdown)}!\\" & strComputer & "\root\cimv2") Set colOperatingSystems = objWMIService.ExecQuery( "Select * from Win32_OperatingSystem") For Each ObjOperatingSystem In colOperatingSystems ObjOperatingSystem.Reboot ' Для перезагрузки Next и… Dim strComputer As String strComputer = "." Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate,(Shutdown)}!\\" & strComputer & "\root\cimv2") Set colOperatingSystems = objWMIService.ExecQuery( "Select * from Win32_OperatingSystem") For Each ObjOperatingSystem In colOperatingSystems ObjOperatingSystem.ShutDown 'Для выключения Next Наверх 02. Узнаем путь к Windows и о функции Environ - Visual Basic
Но это ещё не всё! Также с помощью этой функции можно получить следующие перменные: MsgBox Environ ("TMP") 'директория временных файлов TEMP MsgBox Environ ("BLASTER") 'координаты звуковой карты MsgBox Environ ("PATH") 'пути, объявленные в autoexec.bat Наверх 03. Работа с файлами
3.2 Удаляем файл с диска - Visual Basic 3.3 Перемещаем файл - Visual Basic 3.4 Переименовываем файл - Visual Basic 3.5 Устанавливаем атрибуты файла(скрытый, только для чтения и тд.) 3.6 Открыть любой файл, директорию - Visual Basic 3.7 Существует ли файл? - Visual Basic 3.8 Получить размер файла - Visual Basic 3.9 Как получить имя файла или его расширение, зная полный путь файлау - Visual Basic 3.10 Удаление файла в корзину - Visual Basic 3.11 Функция для изменения расширения файла - Visual Basic 3.12 Сравнить два файла на идентичность - Visual Basiс 3.13 Хотите знать, какие файлы скопированы в память? - Visual Basic 3.1 Копируем файл =================================================== допустим у нас есть один файлик с именем 1.txt в папке C:\1\ , а нам нужно скопировать его в C:\2\ . Все просто, пишем следующие: Filecopy "C:\1\1.txt","C:\2\1.txt" (*Внимание! Если в каталоге 2 уже находиться файлик с именем 1.txt , то он будет заменен на 1.txt из каталога 1 !!!) 2 способ API! обычно я делаю через API: Private Declare Function CopyFile Lib "kernel32.dll" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long Private Sub Command1_Click() ' Скопируем файл C:\1.txt в D:\1.txt. Dim retval As Long ' возвращаемое значение ' копируем файл retval = CopyFile("C:\1.txt", "D:\1.txt", 1) If retval = 0 Then ' если ошибка MsgBox "Не могу скопировать" Else ' если все нормально MsgBox "Файл скопирован." End If End Sub 3.2 Удаляем файл с диска =================================================== Например мы хотим удалить файл 1.txt из корневой диска C: Пишем: Kill ("C:\1.txt") 2 способ API! Private Declare Function DeleteFile Lib "kernel32.dll" Alias "DeleteFileA" (ByVal lpFileName As String) As Long Private Sub Command1_Click() ' Удаляем файл C:\Samples\anyfile.txt Dim retval As Long ' возвращаемое значение retval = DeleteFile("C:\1.txt") If retval = 1 Then MsgBox "Файл успешно удален." End Sub 3.3 Перемещаем файл =================================================== для этого мы используем два оператора сразу. Например нам нужно переместить файл 1.txt из C:\ в C:\2\ . Пишем: Filecopy "C:\1.txt","C:\2\1.txt" Kill ("C:\1.txt") 2 способ API! Private Declare Function MoveFile Lib "kernel32.dll" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long Private Sub Command1_Click() Dim retval As Long ' возвращаемое значение retval = MoveFile("C:\1.txt", "C:\2\1.txt") If retval = 1 Then MsgBox "Успешно переместился )" Else MsgBox "Не успешно переместился )" End If End Sub 3.4 Переименовываем файл =================================================== Надо переименовать файл 1.txt находящийся в C:\ на 2.txt . Пишем: Filecopy "C:\1.txt","C:\2.txt" Kill ("C:\1.txt") 2 способ API! Private Declare Function MoveFile Lib "kernel32.dll" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long Private Sub Command1_Click() Dim retval As Long ' возвращаемое значение retval = MoveFile("C:\1.txt", "C:\2.txt") If retval = 1 Then MsgBox "Успешно переименовался )" Else MsgBox "Не успешно переименовался )" End If End Sub 3.5 Устанавливаем атрибуты файла(скрытый, только для чтения и тд.) =================================================== Для этого используем оператор setattr. Пишем: Setattr "C:\1.txt" , vbHidden - теперь файл 1.txt стал скрытым. Чтобы изменить сразу несколько параметров нужно ставить "+" между каждым значением: Setattr "C:\1.txt",vbHidden+vbReadOnly -Теперь файл скрытый и только для чтения. 3.6 Открыть любой файл, директорию - Visual Basic =================================================== ' Под Windos NT: Shell "cmd /X /C start c:\mydoc\example.doc" ' Под Windos 9x: Shell "start c:\mydoc\example.doc" ' через API Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Sub Command1_Click() ShellExecute 0, vbNullString, "C:\" & sFile, vbNullString, vbNullString, vbNormalFocus End Su 3.7 Существует ли файл? - Visual Basic =================================================== '1. Возвращает 1(файл существует) или 0 (файла нет) Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long MsgBox PathFileExists("c:\autoexec.bat") '2. Возвращает True(файл существует) или False(файла нет) Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long Public Function DoesFileExist(ByVal strPath As String) As Boolean DoesFileExist = PathFileExists(strPath) End Function MsgBox DoesFileExist("c:\autoexec.bat") 3.8 Получить размер файла - Visual Basic =================================================== Размер файла можно определить двумя путями: 1. Если файл можно открыть функцией OPEN, то можно воспользоваться функцией LOF Dim FileFree As Integer Dim FileSize As Long FileFree = FreeFile Open "C:\WIN\GENERAL.TXT" For Input As FileFree FileSize = LOF(FileFree) Close FileFree 2. Используя функцию FileLen Dim lFileSize As Long FileSize = FileLen("C:\WIN\GENERAL.TXT") 3.9 Как получить имя файла или его расширение, зная полный путь файлау - Visual Basic =================================================== Private Function Spliting(sFullPath As String, point As String) Dim str1() As String str1 = Split(sFullPath, point) Spliting = str1(UBound(str1)) End Function 3.10 Удаление файла в корзину - Visual Basic =================================================== Private Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Long hNameMappings As Long lpszProgressTitle As Long End Type Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long Private Const FO_DELETE = &H3 Private Const FOF_ALLOWUNDO = &H40 Private Const FOF_NOCONFIRMATION = &H10 Private Const FOF_SILENT = &H4 Sub SendFileToRecycleBin(FileName As String, Optional Confirm As Boolean = True, Optional Silent As Boolean = False) Dim FileOp As SHFILEOPSTRUCT With FileOp .wFunc = FO_DELETE .pFrom = FileName .fFlags = FOF_ALLOWUNDO If Not Confirm Then .fFlags = .fFlags + FOF_NOCONFIRMATION If Silent Then .fFlags = .fFlags + FOF_SILENT End With SHFileOperation FileOp End Sub Private Sub Command1_Click() SendFileToRecycleBin "C:\1.txt", False SendFileToRecycleBin "C:\11.txt", True End Sub Private Sub Form_Load() Dim FN As Integer FN = FreeFile Dim FName As String FName = "C:\1.txt" Open FName For Output As #FN Print #FN, "" Close #FN FName = "C:\11.txt" Open FName For Output As #FN Print #FN, "" Close #FN End Sub 3. 11 Функция для изменения расширения файла - Visual Basic =================================================== Function ChangeFileExtension(FileName As String, Extension As String, Optional AddIfMissing As Boolean) As String Dim i As Long For i = Len(FileName) To 1 Step -1 Select Case Mid$(FileName, i, 1) Case "." ChangeFileExtension = Left$(FileName, i) & Extension Exit Function Case ":", "\" Exit For End Select Next If AddIfMissing Then ChangeFileExtension = FileName & "." & Extension Else ChangeFileExtension = FileName End If End Function Private Sub Command1_Click() MsgBox ChangeFileExtension("ggg.htm", "txt") MsgBox ChangeFileExtension("ggg", "txt", True) End Sub 3.12 Сравнить два файла на идентичность - Visual Basic =================================================== Private Sub Form_Load() 'замените пути файлов, которые вы хотите сравнить Open "C:\1\convert1bmp.htm" For Binary As #1 Open "C:\1\convert2bmp.htm" For Binary As #2 issame% = True If LOF(1) <> LOF(2) Then issame% = False Else whole& = LOF(1) \ 10000 part& = LOF(1) Mod 10000 buffer1$ = String$(10000, 0) buffer2$ = String$(10000, 0) start& = 1 For X& = 1 To whole& Get #1, start&, buffer1$ Get #2, start&, buffer2$ If buffer1$ <> buffer2$ Then issame% = False Exit For End If start& = start& + 10000 Next buffer1$ = String$(part&, 0) buffer2$ = String$(part&, 0) Get #1, start&, buffer1$ Get #2, start&, buffer2$ If buffer1$ <> buffer2$ Then issame% = False End If Close If issame% Then MsgBox "Файлы идентичны", 64, "Info" Else MsgBox "Файлы НЕ идентичны", 16, "Info" End If End Sub 3.13 Хотите знать, какие файлы скопированы в память? - Visual Basic =================================================== Добавьте на форму элемент CommandButton и ListBox. Вставьте код, запустите. Затем переключитесь в Проводник, выберите несколько файлов, скопируйте их. Затем перейдите в вашу программу и нажмите на кнопку. Private Const CF_HDROP = 15 Private Type POINT x As Long y As Long End Type Private Type DROPFILES pFiles As Long pt As POINT fNC As Long fWide As Long End Type Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Sub ShowFilesOnClipboard() Dim lHandle As Long Dim lpResults As Long Dim lRet As Long Dim df As DROPFILES Dim strDest As String Dim lBufferSize As Long Dim arBuffer() As Byte Dim vNames As Variant Dim i As Long If OpenClipboard(0) Then lHandle = GetClipboardData(CF_HDROP) ' If you don't find a CF_HDROP, you don't want to process anything If lHandle > 0 Then lpResults = GlobalLock(lHandle) lBufferSize = GlobalSize(lpResults) ReDim arBuffer(0 To lBufferSize) CopyMemory df, ByVal lpResults, Len(df) Call CopyMemory(arBuffer(0), ByVal lpResults + df.pFiles, (lBufferSize - Len(df))) If df.fWide = 1 Then ' it is wide chars--unicode strDest = arBuffer Else strDest = StrConv(arBuffer, vbUnicode) End If GlobalUnlock lHandle vNames = Split(strDest, vbNullChar) i = 0 While Len(vNames(i)) > 0 List1.AddItem vNames(i) i = i + 1 Wend End If End If CloseClipboard End Sub Private Sub Command1_Click() List1.Clear Call ShowFilesOnClipboard End Sub Наверх 04. Работа с папками - Visual Basic
4.2 Создание директории - Visual Basic 4.3 Выводим список всех папок с подпапками - Visual Basic 4.4 Как показать стандартный диалог выбора каталога? - Visual Basic 4.5 Создание многоуровневых каталогов - Visual Basic 4.6 Как проверить, существует ли директория? - Visual Basic? 4.7 Получить размер директории - Visual Basic 4.8 Определить, имеет ли папка подпапки - Visual Basic 4.9 Узнать путь к текущей рабочей папке - Visual Basic 4.1 Как удалить каталог? - Visual Basic =================================================== Private Declare Function RemoveDirectory& Lib "kernel32" Alias "RemoveDirectoryA" (ByVal lpPathName As String) ' Удаление каталога (пустого!) PathName$ = "D:\t" code& = RemoveDirectory(PathName) If code& = 0 Then ' операция удаления не была выполнена Else ' каталог удален End If 4.2 Создание директории - Visual Basic =================================================== Sub MakeDir(dirname As String) Dim i As Long, path As String Do i = InStr(i + 1, dirname & "\", "\") path = Left$(dirname, i - 1) If Right$(path, 1) <> ":" And Dir$(path, vbDirectory) = "" Then MkDir path End If Loop Until i >= Len(dirname) End Sub Private Sub Command1_Click() Call MakeDir("C:\Aleks_Soft\1\2\3\") End Sub 4.3 Выводим список всех папок с подпапками - Visual Basic =================================================== На форму кинем 2 текстовых поля и кнопку, имя первого текстового поля: StartText, имя второго текстового поля OutText и сделай свойство Multiline=true, имя кнопки: CmdStart Далее пишим код в кнопке: Static running As Boolean Dim AllDirs As New Collection Dim next_dir As Integer Dim dir_name As String Dim sub_dir As String Dim i As Integer Dim txt As String If running Then running = False CmdStart.Enabled = False CmdStart.Caption = "Stopping" Else running = True MousePointer = vbHourglass CmdStart.Caption = "Stop" OutText.Text = "" DoEvents next_dir = 1 AllDirs.Add StartText.Text Do While next_dir <= AllDirs.Count dir_name = AllDirs(next_dir) next_dir = next_dir + 1 sub_dir = Dir$(dir_name & "\*", vbDirectory) Do While sub_dir <> "" If UCase$(sub_dir) <> "PAGEFILE.SYS" And sub_dir <> "." And sub_dir <> ".." Then sub_dir = dir_name & "\" & sub_dir On Error Resume Next If GetAttr(sub_dir) And vbDirectory Then AllDirs.Add sub_dir End If sub_dir = Dir$(, vbDirectory) Loop DoEvents If Not running Then Exit Do Loop txt = "" For i = 1 To AllDirs.Count txt = txt & AllDirs(i) & vbCrLf Next i OutText.Text = txt MousePointer = vbDefault unning = False End If Теперь запустим прогу, в текстовом поле StartText пишим: C:\windows, и жмем на кнопку и ждем!!! 4.4 Как показать стандартный диалог выбора каталога? - Visual Basic =================================================== Private Type BrowseInfo hwndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As String ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Dim strPath As String Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String Const BIF_RETURNONLYFSDIRS = 1, MAX_PATH = 260 Dim intNull As Integer, lngIdList As Long Dim udtBI As BrowseInfo With udtBI .hwndOwner = hwndOwner .lpszTitle = sPrompt .ulFlags = BIF_RETURNONLYFSDIRS End With lngIdList = SHBrowseForFolder(udtBI) If lngIdList Then strPath = String$(MAX_PATH, 0) SHGetPathFromIDList lngIdList, strPath CoTaskMemFree lngIdList intNull = InStr(strPath, vbNullChar) If intNull Then strPath = Left$(strPath, intNull - 1) End If BrowseForFolder = strPath End Function Private Sub Command1_Click() BrowseForFolder Me.hWnd, "Hi, Select ... " Print strPath End Sub 4.5 Создание многоуровневых каталогов - Visual Basic =================================================== Иногда приходится анализировать наличие указанного каталога (к примеру, при установке вашей программы на жесткий диск) и создавать новый при его отсутствия. Для этого можно использовать, например, такую процедуру: Sub CreateLongDir(sDir As String) Dim sBuild As String, sDirTmp As String, i As Integer ' sDirTmp = sDir & "\" i = InStr (sDirTmp, ":") If i > 0 Then ' задано имя диска sBuild = Left$(sDirTmp, i) ' имя текущего каталога sDirTmp = Mid$(sDirTmp, i + 1) Else sBuild = "" ' имя текущего каталога End If Do ' проверка-создание вложенных каталогов i = InStr (2, sDirTmp, "\") If i = 0 Then Exit Do sBuild = sBuild & Left$(sDir, i - 1) sDirTmp = Mid$(sDirTmp, i) If Dir$(sBuild, 16) = "" Then 'нет такого каталога MkDir sBuild ' создание каталога End If Loop End Sub Sub Test () ' примеры обращения ' полное имя каталога с именем диска Call CreateLongDir("C:\Tests\TestDir\NewDir") ' полное имя каталога в текущем диске Call CreateLongDir("\Current\TestDir\NewDir") ' имя нового каталога относительно текущего каталога Call CreateLongDir("Current\TestDir\NewDir") End Sub Здесь крайне важно дать правильное описание имени каталога при обращении к CreateLongDir (в соответствии с правилами обращения к функциям VB: MkDir, ChDir, RmDir, Dir): 4.6 Как проверить, существует ли директория? - Visual Basic? =================================================== Иногда необходимо проверить, существует ли папка. Данная функция возвращает True - если папка существует, и False - если такой папки на компьютере нет. В данную функцию передается строковая переменная, содержащая полный путь к директории(папке). Public Function FolderExists(ByVal strPathName As String) As Boolean Dim DirectoryFound As String Const errPathNotFound As Integer = 76 On Error GoTo 0 DirectoryFound = Dir(strPathName, vbDirectory) If (Len(DirectoryFound) = 0 Or Err = errPathNotFound) Then FolderExists = False Else FolderExists = True End If End Function Private Sub Command1_Click() 'MsgBox FolderExists("D:\Basic") If FolderExists("D:\Basic\Module1") = False Then MsgBox "Такая папка не существует" Else MsgBox "Такая папка существует" End If End Sub 4.7 Получить размер директории - Visual Basic =================================================== Const MAX_PATH = 260 Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long Public Function SizeOf(ByVal DirPath As String) As Double Dim hFind As Long Dim fdata As WIN32_FIND_DATA Dim dblSize As Double Dim sName As String Dim x As Long On Error Resume Next x = GetAttr(DirPath) If Err Then SizeOf = 0: Exit Function If (x And vbDirectory) = vbDirectory Then dblSize = 0 Err.Clear sName = Dir$(EndSlash(DirPath) & "*.*", vbSystem Or vbHidden Or vbDirectory) If Err.Number = 0 Then hFind = FindFirstFile(EndSlash(DirPath) & "*.*", fdata) If hFind = 0 Then Exit Function Do If (fdata.dwFileAttributes And vbDirectory) = vbDirectory Then sName = Left$(fdata.cFileName, InStr(fdata.cFileName, vbNullChar) - 1) If sName <> "." And sName <> ".." Then dblSize = dblSize + SizeOf(EndSlash(DirPath) & sName) End If Else dblSize = dblSize + fdata.nFileSizeHigh * 65536 + fdata.nFileSizeLow End If DoEvents Loop While FindNextFile(hFind, fdata) <> 0 hFind = FindClose(hFind) End If Else On Error Resume Next dblSize = FileLen(DirPath) End If SizeOf = dblSize End Function Private Function EndSlash(ByVal PathIn As String) As String If Right$(PathIn, 1) = "\" Then EndSlash = PathIn Else EndSlash = PathIn & "\" End If End Function Private Sub Form_Load() 'Замените 'D:\Basic' той директорией, размер которой хотите узнать MsgBox SizeOf("D:\Basic") / 1000000 End Sub 4.8 Определить, имеет ли папка подпапки - Visual Basic =================================================== Private Const MAX_PATH = 260 Private Type SHFILEINFO hIcon As Long iIcon As Long dwAttributes As Long szDisplayName As String * MAX_PATH szTypeName As String * 80 End Type Private Declare Function SHGetFileInfo Lib "Shell32" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long Function FolderHasSubFolders(ByVal sPath As String) As Boolean Const SFGAO_HASSUBFOLDER = &H80000000 Const SHGFI_ATTRIBUTES = &H800 Dim FInfo As SHFILEINFO SHGetFileInfo sPath, 0, FInfo, Len(FInfo), SHGFI_ATTRIBUTES FolderHasSubFolders = (FInfo.dwAttributes And SFGAO_HASSUBFOLDER) End Function Private Sub Command1_Click() MsgBox FolderHasSubFolders("C:\Program Files") MsgBox FolderHasSubFolders("C:\Program Files\NetMeeting") End Sub 4.9 Узнать путь к текущей рабочей папке - Visual Basic =================================================== MsgBox CurDir Наверх 05. Как узнать имя компьютера и имя пользователя?
Private Declare Function WNetGetUserA Lib "mpr.dll" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long Function GetComputerName() As String Dim sBuffer As String * 255 If GetComputerNameA(sBuffer, 255&) <> 0 Then GetComputerName = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1) End If End Function Function GetUserName() As String Dim sUserNameBuff As String * 255 sUserNameBuff = Space(255) Call WNetGetUserA(vbNullString, sUserNameBuff, 255&) GetUserName = Left$(sUserNameBuff, InStr(sUserNameBuff, vbNullChar) - 1) End Function Private Sub Command1_Click() MsgBox GetComputerName, 64, "ComputerName" MsgBox GetUserName, 64, "GetUserName" End Sub Наверх 06. Как изменить имя компьютера?
Declare Function SetComputerName Lib "kernel32" Alias "SetComputerNameA" (ByVal lpComputerName As String) As Long 'добавьте кнопку a$ = "Hello World" b& = SetComputerName(a$) Наверх 07. Работа с числами, шрифтом, текстом, TextBox'om и RichTextBox'om - Visual Basic
7.2 Определение координат позиции курсора в TextBox - Visual Basic 7.3 Как узнать сколько слов в TextBox - Visual Basic 7.4 Как сделать первую букву каждого слова заглавной? - Visual Basic 7.5 Запретить ввод определенных символов - Visual Basic 7.6 Добавить новую линию в существующий текст элемента TextBox - Visual Basic 7.7 Как очистить все TextBox'ы на форме? - Visual Basic 7.8 Как вернуться на то же место, при потере фокуса? - Visual Basic 7.9 Как можно заблокировать стандартное контекстное меню элемента TextBox? - Visual Basic 7.10 Проверить тип вводимой информации - Visual Basic 7.11 Скрыть/показать мигающий курсор в Text Box - Visual Basic 7.12 Убрать двойные пробелы во всем тексте - Visual Basic 7.13 Скролинг текста - Visual Basic 7.14 Получение содержимого n-ой строки в Multiline TextBox. - Visual Basic 7.15 Подсчитать количество определенных символов в тексте - Visual Basic 7.16 Определение кодировки русского текста - Visual Basic 7.17 Очистка строки от ненужных символов - Visual Basic 7.18 Преобразование WIN в ASCII текст - Visual Basic 7.19 ANSCII в Win - Visual Basic 7.20 Как осуществить замену в TextBox? - Visual Basic 7.21 Как сделать Undo или Отменить в TextBox? - Visual Basic 7.22 Как уместить в TextBox больше 64 kb текста? - Visual Basic 7.23 Cвойства TextBox'a. - Visual Basic 7.24 Компонент RichTextBox. - Visual Basic 7.25 Как найти и выделить текст в RichTextBox - Visual Basic 7.26 Определение строки, на которой находится курсор. - Visual Basic 7.27 Определить количество строк в TextBox'е. - Visual Basic 7.28 Проверка орфографии. - Visual Basic 7.29 Является ли строковая переменная e-mail-адресом. - Visual Basic 7.30 Перекодировка текста: Rus-Lat - Visual Basic 7.31 Перекодировка текста из DOS в Windows формат - Visual Basic 7.32 Послать строковое сообщение в другую программу - Visual Basic 7.33 Захват текста из любого текстового поля - Visual Basic 7.34 Форматирование числа при выводе (заполнение до определенной длины) - Visual Basic 7.35 Примеры работы с датами - Visual Basic 7.36 Определить кодировку текста (Dos или Win) - Visual Basic 7.37 Вертикальное/горизонтальное написание в элементе Label - Visual Basic 7.38 Как получить короткий путь("c:\progra~1") файла если имеется длинный - Visual Basic 7.39 Как вывести кавычки в MsgBox? - Visual Basic 7.40 Как узнать ASCLL код символа? - Visual Basic 7.41 Как узнать количество символов в строке? - Visual Basic 7.42 Как преобразовать буквы в нижний или верхний регистр? - Visual Basic 7.43 MsgBox впереди всех - Visual Basic 7.44 Как в MsgBox вывести или записать в переменную данные столбиком? - Visual Basic 7.45 Операции "копировать", "вырезать", "вставить" - Visual Basic 7.46 3D-текст на форме - Visual Basic 7.47 Как вывести символ & в Label - Visual Basic 7.48 Постоянно возникающий вопрос у тех, кто пишет блокнот. Функция Command - Visual Basic 7.49 Ввод в TextBox только цифр - Visual Basic 7.50 Как сделать вывод только заглавных букв в TextBox - Visual Basic 7.1 Загрузить текстовой файл в TextBox, сохранить текстовой файл из TextBox'а - Visual Basic ==================================================== Зугрузить текстовой файл в TextBox: Dim FN as Integer FN = FREEFILE Dim FName as String FName = "C:\tmp\index.txt" Open FName For Input As #FN Text1.Text = Input(LOF(FN), #FN) Close #FN Сохранить текстовой файл из TextBox'а: Dim FN as Integer FN = FREEFILE Dim FName as String FName = "C:\tmp\index.txt" Open FName For Output As #FN Print #FN, Text1.Text Close #FN 7.2 Определение координат позиции курсора в TextBox - Visual Basic ==================================================== Private Type POINTAPI X As Long Y As Long End Type Private Declare Function GetCaretPos Lib "user32" (lpPoint As POINTAPI) As Long Private Sub Text1_KeyPress(KeyAscii As Integer) Dim XPos As Long Dim YPos As Long XPos = GetTCursX YPos = GetTCursY Me.Caption = "X: " & XPos & " Y: " & YPos End Sub Public Function GetTCursX() As Long Dim pt As POINTAPI GetCaretPos pt GetTCursX = pt.X End Function Public Function GetTCursY() As Long Dim pt As POINTAPI GetCaretPos pt GetTCursY = pt.Y End Function 7.3 Как узнать сколько слов в TextBox - Visual Basic ==================================================== MsgBox (UBound(Split(Text1.Text)) + 1) 7.4 Как сделать первую букву каждого слова заглавной? ==================================================== Private Function ccProperCase(MySourceControl As Control) On Error GoTo ErrH Dim strString As String strString = MySourceControl.Text If IsNull(strString) Then Exit Function strString = StrConv(strString, vbProperCase) MySourceControl.SelStart = Len(strString) MySourceControl.Text = strString Exit Function ErrH: MsgBox "Error at ccProperCase:::- " & Err.Number & " - " & Err.Description, vbCritical Exit Function End Function Private Sub Text1_Change() Call ccProperCase(Text1) End Sub 7.5 Запретить ввод определенных символов - Visual Basic ==================================================== Private Sub Text1_KeyPress(KeyAscii As Integer) Dim sTemplate As String 'Replace the '!@#$%^&*()_+= ' какие символы игнорировать sTemplate = "!@#$%^&*()_+=" If InStr(1, sTemplate, Chr(KeyAscii)) > 0 Then KeyAscii = 0 End Sub Если тебе, например надо запретить ввод букв и разрешить только ввод цифр, то смотри ниже как это делается: Private Sub txtSum_KeyPress(KeyAscii As Integer) KeyAscii = Only_Number(KeyAscii) End Sub Function Only_Number(theParam As Integer) If InStr("1234567890" & Chr(8), Chr(theParam)) > 0 Then Only_Number = theParam Else Only_Number = 0 End If End Function 7.6 Добавить новую линию в существующий текст элемента TextBox - Visual Basic ==================================================== Добавьте Command Button и TextBox на форму. Private Sub Command1_Click() Dim NewText As String With Text1 'replace 'My New Text' with the Text you want to add NewText = "My New Text" .SelStart = Len(.Text) .SelText = vbNewLine & NewText End With End Sub Private Sub Form_Load() Text1.Text = "My Initial Text" End Sub 7.7 Как очистить все TextBox'ы на форме? - Visual Basic ==================================================== Добавьте на форму несколько элементов TextBox и CommandButton. Private Sub Command1_Click() Dim Contrl As Control For Each Contrl In Form1.Controls If (TypeOf Contrl Is TextBox) Then Contrl.Text = "" Next Contrl End Sub 7.8 Как вернуться на то же место, при потере фокуса? - Visual Basic ==================================================== Dim x Private Sub Text1_GotFocus() On Error Resume Next Text1.SelStart = x End Sub Private Sub Text1_LostFocus() x = Text1.SelStart End Sub 7.9 Как можно заблокировать стандартное контекстное меню элемента TextBox? - Visual Basic ==================================================== 'Расположите на форме TextBox, а также создайте невидимое меню mnuText и как минимум одно подменю. 'Запустите проект, нажмите правой клавишей мыши на TextBox'е... Private Declare Function LockWindowUpdate Lib "User32" (ByVal hwndLock As Long) As Long Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = vbRightButton Then LockWindowUpdate Text1.hWnd Text1.Enabled = False DoEvents PopupMenu mnuText Text1.Enabled = True LockWindowUpdate 0& End If End Sub 7.10 Проверить тип вводимой информации - Visual Basic ==================================================== Простая проверка регистра, буква или цифра, используя API. Добавить Text Box на форму. Private Declare Function IsCharUpper Lib "user32" Alias "IsCharUpperA" (ByVal cChar As Byte) As Long Private Declare Function IsCharLower Lib "user32" Alias "IsCharLowerA" (ByVal cChar As Byte) As Long Private Declare Function IsCharAlpha Lib "user32" Alias "IsCharAlphaA" (ByVal cChar As Byte) As Long Private Declare Function IsCharAlphaNumeric Lib "user32" Alias "IsCharAlphaNumericA" (ByVal cChar As Byte) As Long Private Sub Text1_KeyPress(KeyAscii As Integer) '1 - True, 0 - False MsgBox "Upper Case: " & IsCharUpper(KeyAscii) & " Lower Case: " & IsCharLower(KeyAscii) & " Alpha: " & IsCharAlpha(KeyAscii) & " Alpha or Numeric: " & IsCharAlphaNumeric(KeyAscii) End Sub 7.11 Скрыть/показать мигающий курсор в Text Box - Visual Basic ==================================================== Private Declare Function HideCaret Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ShowCaret& Lib "user32" (ByVal hwnd As Long) Private Sub CheckCaret() If Check1.Value = vbChecked Then ShowCaret (Text1.hwnd) Else HideCaret (Text1.hwnd) End If End Sub Private Sub Form_Load() Check1.Value = 1 End Sub Private Sub Text1_Change() CheckCaret End Sub Private Sub Text1_GotFocus() CheckCaret End Sub 7.12 Убрать двойные пробелы во всем тексте - Visual Basic ==================================================== Данная функция в качестве входного параметра принимает любую текстовую строку (содержимое TextBox или RichTextBox), убирает все двойные пробелы и возвращает обновленный текст. Для пояснения действия данной функции добавьте на форму элемент TextBox, элемент CommandButton. Скопируйте следующий текст, запустите проект. В текстовом поле наберите любой текст, оставляя двойные пробелы между буквами или словами. Затем нажмите на кнопку. Public Function SquishSpaces(ByVal strText As String) As String Const TWO_SPACES As String = " " Dim intPos As Integer Dim strTemp As String intPos = InStr(1, strText, TWO_SPACES, vbBinaryCompare Do While intPos > 0 strTemp = LTrim$(Mid$(strText, intPos + 1)) strText = Left$(strText, intPos) & strTemp intPos = InStr(1, strText, TWO_SPACES, vbBinaryCompare) Loop SquishSpaces = strText End Function Private Sub Command1_Click() Text1.Text = SquishSpaces(Text1.Text) 'RichTextBox1.Text = SquishSpaces(RichTextBox1.Text) End Sub 7.13 Скролинг текста - Visual Basic ==================================================== 'Расположите на форме элемент CommandButton, элемент TextBox, элемент Timer. Dim strText As String Private Sub Command1_Click() strText = String(30, " ") + "Visual Basic" Timer1.Interval = 100 Timer1.Enabled = True End Sub Private Sub Form_Load() Command1.Caption = "Начать скролинг" With Text1 .Font = "Courier New Cyr" .FontSize = 12 .Width = 3400 End With End Sub Private Sub Timer1_Timer() strText = Mid(strText, 2) & Left(strText, 1) Text1 = strText End Sub 7.14 Получение содержимого n-ой строки в Multiline TextBox. - Visual Basic ==================================================== Расположите на форме элемент CommandButton и элемент TextBox. Установите свойство Multiline элемента TextBox как True. Синтаксис вызова функции прост: GetLine(НазваниеОкна.hWnd, НомерСтроки). Данный пример (при нажатии на кнопку) покажет содержимое 2-й строки элемента Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long Const EM_LINEINDEX = &HBB Const EM_LINELENGTH = &HC1 Const EM_GETLINE = &HC4 Public Function GetLine(hWnd As Long, Line As Long) As String Dim sBuf As String, nLen As Long, nIndex As Long nIndex = SendMessage(hWnd, EM_LINEINDEX, Line - 1, ByVal 0&) If nIndex < 0 Or Line <= 0 Then Exit Function nLen = SendMessage(hWnd, EM_LINELENGTH, nIndex, ByVal 0&) sBuf = Space(nLen + 1) Mid$(sBuf, 1, 1) = Chr$(nLen And &HFF) Mid$(sBuf, 2, 1) = Chr$(nLen \ 256) SendMessage hWnd, EM_GETLINE, Line - 1, ByVal sBuf GetLine = Left$(sBuf, nLen) End Function Private Sub Form_Load() Text1.Text = "1111111" & vbCrLf & "22222" & vbCrLf & "3333" & vbCrLf & "4444" End Sub Private Sub Command1_Click() MsgBox GetLine(Text1.hWnd, 2) End Sub 7.15 Подсчитать количество определенных символов в тексте. - Visual Basic ==================================================== Данный пример покажет, сколько раз встречается буква Н в данном выражении. Вместо Н вы можете использовать любое строковое выражение. Private Sub Form_Load() myString = "в данном примере несколько букв н, а точнее - " tempString = Split(myString, "н") MsgBox "в данном примере несколько букв н, а точнее - " & UBound(tempString) tempString = Split(myString, "нн") MsgBox "в данном примере " & UBound(tempString) & " раз встречается выражение нн" End Sub 7.16 Определение кодировки русского текста. - Visual Basic ==================================================== Определение кодировки текста 'пpовеpяем тип кодиpовки ANSI или ASCII 'беpем пеpвые 1000 байт еcли это возможно. Hевозможно - меньше. l& = Len(rtbView.Text) If l& > 1000 Then l& = 1000 'копиpyем yчаcток текcта из RichTextBox в пеpеменнyю, иначе тоpмоз обеcпечен s$ = Left$(rtbView.Text, l&) 'обнyляем флажки fdo% = 0 fwo% = 0 'пpоcматpиваем кycок текcта For n% = 1 To l& 'вытаcкиваем очеpедной cимвол c$ = Mid$(s$, n%, 1) 'еcли это pyccкая "о" в DOS кодиpовке то инкpементиpyем cчетчик If c$ = Chr$(174) Then fdo% = fdo% + 1 'еcли это pyccкая "о" в Win кодиpовке то инкpементиpyем cчетчик If c$ = Chr$(238) Then fwo% = fwo% + 1 Next 'ycтанавливаем в конфиге тип пpоcмотpа по дефолтy If fdo% > fwo% Then 'это явно ДОC-текcт Else 'это явно Win-текcт 7.17 Очистка строки от ненужных символов - Visual Basic ==================================================== Иногда бывает полезно иметь функцию, которая очищает строку от нежелательных символов. Эта маленькая функция принимает в качестве параметров строку для очистки и символ, от которого ее надо очистить: Function StringCleaner(s As String, Search As String) As String Dim i As Integer, res As String res = s Do While InStr(res, Search) i = InStr(res, Search) res = Left(res, i - 1) & Mid(res, i + 1) Loop StringCleaner = res End Function 7.18 Преобразование WIN в ASCII текст - Visual Basic ==================================================== Q: Пишу на VB 4 некую задачу. Имеются данные, котоpые нужно хpанить во внешних файлах в фоpмате ASCII. Какой пpоцедуpой можно их откpыть и считать. A: Alexander Shherbakov Dim sTemp As String, sRes As String Open "file.txt" For Input As #1 While Not EOF(1) Line Input #1, sTemp sRes = sRes & sTemp & Chr$(13) & Chr$(10) Wend Close #1 Hамного быcтpее и пpоще бyдет: Dim File As String, CF As String 'объявим пеpеменнyю для имени файла и его cодеpжимого File = "d:\ca.log" 'ycтановим имя файла и пyть Open File For Binary As #1 'откpоем файл для чтения CF = Input(FileLen(File), 1) 'загpyзить в пеpеменyю CF вcе cодеpжимое файла Close #1 'закpыть файл У этого метода еcть пpеимyщеcтва и недоcтатки. Пpеимyщеcтво в том, что загpyзка идет быcтpее чем пpи поcтpочном чтении. Hаконец можно гpyзить бинаpные файлы. А недоcтаток в том, что немного cложнее cделать Пpогpеcc баp (хотя по идее, бей файл на 100 кycков и поочеpедно гpyзи каждый, неcложно). Во вcяком cлyчае я юзаю именно этот метод. P.S. Пpовеpил. У меня этим методом 144 кила гpyзятcя за 9 cекyнд. Конечно тоpмоз, но пpи поcтpочном чтении это бyдет на поpядок дольше. 7.19 ANSCII - Win - Visual Basic ==================================================== Q: Как сделать пpеобpазование в кодиpовку Windows. Функции OemToAnsi* и AnsiToOem* из Win32 API A: Vladimir Kann OemToChar и CharToOem А поподробнее можно, если можно с примером Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long стpоки д.б. одинаковой длины, т.е. пpинимающую стpоку можно забить пpобелами: in$="OEM" out$=SPACE(LEN(in$)) OemToChar in$,out$ A: Nick Egorov А поподробнее можно, если можно с примером Да пожалуйста: Public Function ToAnsi(S As String) As String Dim Buffer As String * 1000 OemToCharBuff S, Buffer, Len(S) ToAnsi = Trim(Buffer) End Function Declare Function OemToCharBuff Lib "user32" Alias "OemToCharBuffA" (ByVal lpszSrc As String, ByVal lpszDst As String, ByVal cchDstLength As Long) As Long Как тут в эхе заметили, можно писать вместо Dim Buffer As String * 1000 Dim Buffer As String Set Buffer = String( Len(S), 32) Аналогичная функция CharToOemBuff конвертит из ANSI в OEM (DOS). A: Andrey Fedorov IMHO а так проще: Declare Function OemToChar Lib "user32" Alias "OemToCharA" _ (ByVal lpszSrc As String, ByVal lpszDst As String) As Long Public Function ToAnsi(S As String) As String Dim ss As String ss = s: OemToCharBuff s, ss: ToAnsi = ss End Function 7.20 Как осуществить замену в TextBox? - Visual Basic ==================================================== Например вам нужно, чтобы при нажатие на кнопку все символы например "," превратился в ".". Для этого киньте TextBox на форму и 1 кнопку и вот код к кнопке: Text1.Text = Replace(Text1.Text, ",", ".") 7.21 Как сделать Undo или Отменить в TextBox? - Visual Basic ==================================================== Как осуществить отмену в TextBox в Visual Basic, ответ прост:) Кинь на форму 1 кнопку и текстовое поле, вот код: 'Свойство TextBox Multiline установите в True Option Explicit Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Const EM_UNDO = &HC7 Private Sub Command1_Click() SendMessage Text1.hWnd, EM_UNDO, &O0, &O0 End Sub 7.22 Как уместить в TextBox больше 64 kb текста? - Visual Basic ==================================================== 'Нужно поместить на форму TextBox, назвать его txtMain, 'установить его свойство Multiline как True, 'а свойство ScroolBars, как 1-Horizontal. 'А также рядом с TextBox'ом нарисовать вертикальный ScroolBar с именем vsbText. Private Text() Private Const LineNum = 15 Private Sub Form_Load() Dim i Open "C:\Alexey\МОИ ПРОГРАММЫ\Winapi\win32api.txt" For Input As #1 Len = 1024 Do Until EOF(1) i = i + 1 ReDim Preserve Text(i + LineNum) Line Input #1, Text(i) Loop Close #1 With vsbText .Min = 1 .Max = i .SmallChange = 1 .LargeChange = i \ 10 End With End Sub Private Sub vsbText_Change() Dim i As Integer Dim Temp For i = vsbText.Value To vsbText.Value + LineNum Temp = Temp + Text(i) + vbCrLf Next i txtMain.Text = Temp End Sub 7.23 Cвойства TextBox'a - Visual Basic ==================================================== SelLegth SelStart SelText Часто возникают ситуации, когда при использовании TextBox необходимо, что бы при перемещении на него фокуса, текст находящийся в нем маркировался. Или же при при перемещении на него фокуса, (или добавлении в него другого текста) курсор сразу должен перемещаться в конец имеющегося в TextBox - е текста. Или же иметь возможность для дальнейщих Ваших операций с маркированным текстом. Все это, позволяют сделать некоторые свойства TextBox-а – SelLegth, SelStart и SelText. Рассмотрим оба случая. Первый случай - при перемещении фокуса на TextBox, текст находящийся в нем маркировался. Для этого необходимо в процедуру Text1_GotFocus вставить следующий код: Private Sub Text1_GotFocus() 'Определяем начальное положение текста Text1.SelStart = 0 'Маркируем всю длину текста, вычисляя его спомощью оператора Len Text1.SelLength = Len(Text1.Text) End Sub Второй случай - - при перемещении фокуса на TextBox, (или добавлении в него другого текста) курсор должен перемещаться в конец имеющегося в TextBox - е текста. Для этого необходимо в процедуру Text1_GotFocus вставить следующий код: Private Sub Text1_GotFocus() 'Определяем длинну имеющегося текста и присваиваем это позиции начала следующего текста Text1.SelStart = CLng(Len(Text1.Text)) End Sub Третий случай - возможность обработки маркированного текста. Для этого можно использовать одну строку кода. Dim strMarkText As String 'Присваиваем переменной strMarkText текст маркированный в TextBox strMarkText = Text1.SelText 7.24 Компонент RichTextBox - Visual Basic ==================================================== Элемент RichTextBox представляет собой усовершенствованное текстовое окно, с помощью которого вы можете создавать полноценные файлы в формате RTF, в которых вы можете как угодно форматировать внешний вид своего документа: расставлять переносы, выделять текст различными шрифтами, менять гарнитуру текста и т.д. Подключается данный контрол очень просто: через меню Project | Components. установите флажок на строчке Microsoft Rich Textbox Control 6.0 и у вас на панели Toolbox появится значок этого компонента. Затем вы размещаете данный контрол на вашей форме... и все. Вставить рисунок Private Sub Command1_Click() a = RichTextBox1.SelStart RichTextBox1.OLEObjects.Add , , "D:\4\add_pictures_to_richtextbox\smile.bmp" RichTextBox1.SelStart = a + 1 RichTextBox1.SetFocus End Sub Private Sub Form_Load() RichTextBox1.OLEObjects.Clear End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) RichTextBox1.OLEObjects.Clear End Sub Выделить текст жирным шрифтом RichTextBox1.SelBold = True Выделить текст курсивом RichTextBox1.SelItalic = True Выделить текст подчеркнутым шрифтом RichTextBox1.SelUnderline = True Просмотр текста в виде простого текста MsgBox RichTextBox1.Text Просмотр текста в виде RTF MsgBox RichTextBox1.TextRTF Загрузить файл RichTextBox1.LoadFile App.Path & "\RTFText.rtf", rtfRTF или RichTextBox1.LoadFile App.Path & "\RTFText.rtf", rtfText 7.25 Как найти и выделить текст в RichTextBox? - Visual Basic ==================================================== Во многих приложениях есть функция поиска и выделения ключевых слов в текстовом окошке. В Visual Basic элемент управления RichTextBox позволяет использовать эту возможность. Создайте новый проект. Form1 создастся поумолчанию. Поместите на Form1 кнопку и RichTextBox. Установите свойство Text у RichTextBox в "This is an example of finding text in a rich text box." Добавьте следующий код в секцию General Declarations формы Form1: Option Explicit Private Sub Command1_Click() HighlightWords RichTextBox1, "text", vbRed End Sub Private Function HighlightWords(rtb As RichTextBox, sFindString As String, lColor As Long) As Integer Dim lFoundPos As Long 'Позиция первого найденного 'символа Dim lFindLength As Long 'Длина искомой строки Dim lOriginalSelStart As Long Dim lOriginalSelLength As Long Dim iMatchCount As Integer 'Количество найденных 'Сохраняем текущее местоположение и длину lOriginalSelStart = rtb.SelStart lOriginalSelLength = rtb.SelLength 'Сохраняем длину строки, которую будем искать lFindLength = Len(sFindString) 'Пытаемся найти первое совпадение lFoundPos = rtb.Find(sFindString, 0, , rtfNoHighlight) While lFoundPos >= 0 'While lFoundPos >= 0 <-------------------- Должно быть. Иначе при поиске пропускается первый символ, так как отсчет идет с нуля. iMatchCount = iMatchCount + 1 rtb.SelStart = lFoundPos 'Как только Вы измените SelStart, то свойство SelLength 'установится в 0 rtb.SelLength = lFindLength rtb.SelColor = lColor 'Пытаемся найти следующее совпадение lFoundPos = rtb.Find(sFindString, _ lFoundPos + lFindLength, , rtfNoHighlight) Wend 'Восстанавливаем первоначальное местоположение 'и длину rtb.SelStart = lOriginalSelStart rtb.SelLength = lOriginalSelLength 'Возвращаем количество совпадений HighlightWords = iMatchCount End Function 7.26 Определение строки, на которой находится курсор. - Visual Basic ==================================================== На самом деле определение строки, на которой находится курсор, не вызывает никаких трудностей. У элемента RichTextBox существует метод GetLineFromChar, который и отвечает на вопрос этой страницы. Непонятно только, почему разработчики не предусмотрели определение позиции курсора на строке. Ответ на этот вопрос остается открытым. Private Sub Command1_Click() MsgBox RichTextBox1.GetLineFromChar(RichTextBox1.SelStart) + 1 End Sub 7.27 Определить количество строк в TextBox'е. - Visual Basic ==================================================== Добавьте TextBox (установите значение MultiLine=True) и CommandButton. Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Const EM_GETLINECOUNT = &HBA Private Sub Command1_Click() Dim lngLineCount As Long On Error Resume Next lngLineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&) MsgBox lngLineCount End Sub 7.28 Проверка орфографии - Visual Basic ==================================================== Хотелось ли вам добавить возможность проверки орфографии вашего TextBox'а? Такое возможно, если на вашем компьютере установлен MsWord. Private Sub Command1_Click() Text1 = SpellCheck(Text1) End Sub Public Function SpellCheck(ByVal IncorrectText$) As String Dim Word As Object, retText$ On Error Resume Next 'Создать объект и загрузить Word Set Word = CreateObject("Word.Basic") 'Показать Word и вставить в него ваш текст Word.AppShow Word.FileNew Word.Insert IncorrectText 'Запустить проверку орфографии Word.ToolsSpelling Word.EditSelectAll 'Выделить текст и загрузить его обратно в TextBox retText = Word.Selection$() SpellCheck = Left$(retText, Len(retText) - 1) 'Закрыть файл в Word и вернуться в Visual Basic. Word.FileClose 2 Show 'Освободить память от объекта word Set Word = Nothing End Function 7.29 Является ли строковая переменная e-mail-адресом. - Visual Basic ==================================================== Является ли строковая переменная e-mail-адресом. Этот код использует VBScript.dll - Вы можете загрузить его с www.microsoft.com/msdownload/vbscript/scripting.asp Добавьте Microsoft VBScript Regular Expressions reference в ваш проект (выберите Project->References, поставьте галочку на Microsoft VBScript Regular Expressions CheckBox и нажмите OK). RegExp - тип переменной, которую вы хотите проверить: Email-адрес, телефонный номер, любой другой формат. Private Sub Form_Load() Dim myReg As RegExp Dim email As String Set myReg = New RegExp myReg.IgnoreCase = True myReg.Pattern = "^[\w-\.]+@\w+\.\w+$" 'replace "myName@domain.ru" любым адресом email = "myName@domain.ru" MsgBox "Результат проверки: " & myReg.Test(email) Unload Me End Sub 7.30 Перекодировка текста: Rus-Lat - Visual Basic ==================================================== Данный пример переводит текст, набранный в одной раскладке клавиатуры в другую. Например из Ghbdtn получить Привет. Private Function Replace_letters(InputStr As String) As String enStr = ";@#$^&QWERTYUIOP{}ASDFGHJKL:" & Chr(34) & "ZXCVBNM<>?qwertyuiop[]asdfghjkl;'zxcvbnm,./" & Chr(34) & "№;:?ЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЭЯЧСМИТЬБЮ,йцукенгшщзхъфывапролдэжячсмитьбю." rusStr = Chr(34) & "№;:?ЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЭЯЧСМИТЬБЮ,йцукенгшщзхъфывапролджэячсмитьбю." & ";@#$^&QWERTYUIOP{}ASDFGHJKL:" & Chr(34) & "ZXCVBNM<>?qwertyuiop[]asdfghjkl;'zxcvbnm,./" Dim i As Integer, pos As Integer, temp As String For i = 1 To Len(InputStr) temp = Mid$(InputStr, i, 1) pos = InStr(1, enStr, temp, vbBinaryCompare) If pos <> 0 Then Replace_letters = Replace_letters & Mid$(rusStr, pos, 1) Else Replace_letters = Replace_letters & temp End If Next i End Function Private Sub Form_Load() MsgBox Replace_letters("Dctv ghbdtn") End Sub 7.31 Перекодировка текста из DOS в Windows формат - Visual Basic ==================================================== Если Вам нужно конвертировать текст формата DOS в Windows (1251), то в API есть на этот случай хорошая функция: OemToChar. Объявляется она так: Public Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long Используют её следующим образом: Dim l_lReturn as Long Dim l_sSource as String 'исходный текст Dim l_sDestination as String 'возвращаемый текст l_lReturn = oemtochar(l_sSource, l_sDestination) Кроме этой полезной функции в API имеется и обратная её функция: CharToOem. Она служит для выполнения той же работы, только наоборот, т.е.Windows (1251) в DOS. Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long 7.32 Послать строковое сообщение в другую программу - Visual Basic ==================================================== Откройте заранее стандартное приложение "Блокнот". В VB-проекте расположите на форме 1 CommandButton. Добавьте следующий код, запустите проект и нажмите на кнопку... Private Sub Command1_Click() AppActivate ("Безымянный") SendKeys ("Привет из VB!!!") End Sub "{Up}" "{TAB}" "{ENTER}" "{End}" "+{Home}" "{Left}" 7.33 Захват текста из любого текстового поля - Visual Basic ==================================================== Хотелось ли вам захватить текст из текстового поля любого приложения? Данный код поможет вам в решении этой проблемы. Вам необходимо разместить на форме элемент Timer. 'to get the foreground window Private Declare Function GetForegroundWindow Lib "user32" () As Long 'to send a message system Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 'to get the cursor position Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 'to get the window from a point (y,x) Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long 'to get the window text Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long 'to get the class name (edit,combobox etc..) Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Public strBuffer As String ' the string to append to the file that has all the text "grabed" Public iEnum As Integer ' the file integer to open and write (I/O) Public hJanelaCima As Long ' the window wich the user has the mouse over Public hJanelaAntiga As Long ' the ancient window, to controlo if thereґs a new window or not 'constants to grab the text Private Const WM_GETTEXT = &HD Private Const WM_GETTEXTLENGTH = &HE 'type for the GetCursorPos API Private Type POINTAPI x As Long y As Long End Type Private Sub Form_Load() 'when starting the program, print date and time of the new logging... strBuffer = "=============================================================" & vbCrLf strBuffer = strBuffer & "Date of log: " & Format(Date, "YYYY-MM-DD") & vbCrLf strBuffer = strBuffer & "Started logging at: " & Format(Time$, "HH:MM") & vbCrLf strBuffer = strBuffer & "=============================================================" & vbCrLf iEnum = FreeFile 'append it in the file Open "C:\testes.txt" For Append As #iEnum Print #iEnum, strBuffer Close #iEnum strBuffer = "" 'enable the timer... Timer1.Interval = 100 Timer1.Enabled = True End Sub Private Sub Timer1_Timer() Dim ptCursor As POINTAPI ' the cursor type variable Dim texto_janela As String ' the window text Dim rc As Long Dim nome_classe As String ' the class name Dim fenster As Long ' the foreground window.. in deutsh.. ich wisse deutshe auch... fenster = GetForegroundWindow ' get the window where user is 'create string objects texto_janela = String(100, Chr(0)) nome_classe = String(100, Chr(0)) Call GetCursorPos(ptCursor) ' get the cursor position 'get the window(handle) where the user has the mouse hJanelaCima = WindowFromPoint(ptCursor.x, ptCursor.y) 'get the window text and class name rc = GetWindowText(fenster, texto_janela, Len(texto_janela)) rc = GetClassName(hJanelaCima, nome_classe, 100) 'format the assholes... texto_janela = Left(texto_janela, InStr(texto_janela, Chr(0)) - 1) nome_classe = Left(nome_classe, InStr(nome_classe, Chr(0)) - 1) Debug.Print nome_classe ' check the class names... i tried some like WinWord and VB, but didnґt worked.. 'If nome_classe = "Edit" Or nome_classe = "_WwG" Or nome_classe = "Internet Explorer_Server" Or nome_classe = "RichEdit20A" Or nome_classe = "VbaWindow" Then 'if this is the same window, forget If hJanelaCima = hJanelaAntiga Then Exit Sub 'thereґs no text? Out! If WindowText(hJanelaCima) = Empty Then Exit Sub 'put the ancient window handle, with the current one hJanelaAntiga = hJanelaCima 'build string with time and the text grabed with WindowText strBuffer = Time$ & " - " & texto_janela & vbCrLf strBuffer = strBuffer & WindowText(hJanelaCima) & vbCrLf 'append to the file Open "C:\testes.txt" For Append As #iEnum Print #iEnum, strBuffer Close #iEnum 'End If End Sub 'grab the text window with this function.. argument- the window handle Public Function WindowText(window_hwnd As Long) As String Dim txtlen As Long Dim txt As String If window_hwnd = 0 Then Exit Function 'send the message to get the text lenght txtlen = SendMessage(window_hwnd, WM_GETTEXTLENGTH, 0, 0) If txtlen = 0 Then Exit Function txtlen = txtlen + 1 txt = Space$(txtlen) 'send the message to get the text txtlen = SendMessage(window_hwnd, WM_GETTEXT, txtlen, ByVal txt) 'put that on the function WindowText = Left$(txt, txtlen) End Function 7.34 Форматирование числа при выводе (заполнение до определенной длины) - Visual Basic ==================================================== Пример применения функции String Иногда бывает полезно выводить числовую информацию с фиксированным числом знаков, заполняя левые позиции нулями. Для этого можно воспользоваться следующей функцией: Function PadToString(myValue, Digits) As String PadToString = String(Digits - Len(myValue), "0") & myValue End Function Сделав, например, такое обращение NewStr = PadToString(1978, 8) вы получите строковую переменную 00001978. Обратите внимание, что Digits и myValue — переменные типа Variant. 7.35 Примеры работы с датами - Visual Basic ==================================================== Небольшое примечание: если в качестве входного параметра указано (Optional dteDate As Date), то вызов функции можно осуществлять как НазваниеФункции() - то есть можно оставлять пустые скобки. Например MsgBox FirstOfQuarter() Список функций Определение первого/последнего дня текущего квартала Определение первого/последнего дня месяца Определение первого/последнего дня следующего месяца Определение первого/последнего дня предыдущего месяца Определение первого/последнего дня текущей недели Опредение номера дня в году (2 января = 2, 3 февраля = 34) Данная функция определяет рабочий день или нет Возвращение последнего рабочего дня в текущем месяце Функция определения полных лет со дня рождения Вычисление разницы в годах между двумя датами Определение високосности года Определение первого дня текущего квартала Function FirstOfQuarter(Optional dteDate As Date) As Date If CLng(dteDate) = 0 Then dteDate = Date End If FirstOfQuarter = DateSerial(Year(dteDate), Int((Month(dteDate) - 1) / 3) * 3 + 1, 1) End Function Определение последнего дня текущего квартала Function LastOfQuarter(Optional dteDate As Date) As Date If CLng(dteDate) = 0 Then dteDate = Date End If LastOfQuarter = DateSerial(Year(Date), Int((Month(Date) - 1) / 3) * 3 + 4, 0) End Function Определение первого дня месяца Function FirstOfMonth(Optional dteDate As Date) As Date 'если параметр dteDate = 0 то для вычисления берется текущая дата If CLng(dteDate) = 0 Then dteDate = Date End If FirstOfMonth = DateSerial(Year(dteDate), Month(dteDate), 1) End Function Определение последнего дня месяца Function LastOfMonth(Optional dteDate As Date) As Date 'если параметр dteDate = 0 то для вычисления берется текущая дата If CLng(dteDate) = 0 Then dteDate = Date End If 'Ищется первый день следующего месяца, и вычитается один день LastOfMonth = DateSerial(Year(dteDate), Month(dteDate) + 1, 1) - 1 End Function Определение первого дня следующего месяца Function FirstOfNextMonth(Optional dteDate As Date) As Date If CLng(dteDate) = 0 Then dteDate = Date End If FirstOfNextMonth = DateSerial(Year(dteDate), Month(dteDate) + 1, 1) End Function Определение последнего дня следующего месяца Function LastOfNextMonth(Optional dteDate As Date) As Date If CLng(dteDate) = 0 Then dteDate = Date End If LastOfNextMonth = DateSerial(Year(dteDate), Month(dteDate) + 2, 0) End Function Определение первого дня предыдущего месяца Function FirstOfPreviousMonth(Optional dteDate As Date) As Date If CLng(dteDate) = 0 Then dteDate = Date End If FirstOfPreviousMonth = DateSerial(Year(dteDate), Month(dteDate) - 1, 1) End Function Определение последнего дня предыдущего месяца Function LastOfPreviousMonth(Optional dteDate As Date) As Date If CLng(dteDate) = 0 Then dteDate = Date End If LastOfPreviousMonth = DateSerial(Year(dteDate), Month(dteDate), 0) End Function Определение первого дня текущей недели Function StartOfWeek(D As Variant, Optional FirstWeekday As Integer) As Variant ' 'Пример: MsgBox StartOfWeek(Date) If IsMissing(FirstWeekday) Then 'Sunday is the assumed first day of week. StartOfWeek = D - Weekday(D) + 1 Else StartOfWeek = D - Weekday(D, FirstWeekday) + 1 End If End Function Определение последнего дня текущей недели Function EndOfWeek(D As Variant, Optional FirstWeekday As Integer) As Variant 'Пример: MsgBox EndOfWeek(Date) If IsMissing(FirstWeekday) Then 'Sunday is the assumed first day of week. EndOfWeek = D - Weekday(D) + 7 Else EndOfWeek = D - Weekday(D, FirstWeekday) + 7 End If End Function Опредение номера дня в году (2 января = 2, 3 февраля = 34) Function DayOfYear(Optional dteDate As Date) As Long If CLng(dteDate) = 0 Then dteDate = Date End If DayOfYear = Abs(DateDiff("d", dteDate, DateSerial(Year(dteDate) - 1, 12, 31))) End Function Данная функция определяет: рабочий день или нет Примечание: Дни с понедельника по пятницу считаются рабочими Function IsWorkday(Optional dteDate As Date) As Boolean If CLng(dteDate) = 0 Then dteDate = Date End If Select Case Weekday(dteDate) Case vbMonday To vbFriday IsWorkday = True Case Else IsWorkday = False End Select End Function Функция возвращает последний рабочий день в текущем месяце (Понедельник-Пятница) Function LastBusDay(D As Variant) As Variant 'Пример: MsgBox LastBusDay(Date) Dim D2 As Variant If VarType(D) <> 7 Then LastBusDay = Null Else D2 = DateSerial(Year(D), Month(D) + 1, 0) Do While Weekday(D2) = 1 Or Weekday(D2) = 7 D2 = D2 - 1 Loop LastBusDay = D2 End If End Function Функция определения полных лет со дня рождения Function CalcAge(dteBirthdate As Date) As Long 'В качестве параметра dteBirthdate необходимо задать дату рождения 'Пример: MsgBox CalcAge("09/03/75") Dim lngAge As Long If Not IsDate(dteBirthdate) Then dteBirthdate = Date End If 'Проверить, чтобы в качестве входного параметра не была задана дата в будущем If dteBirthdate > Date Then dteBirthdate = Date End If 'Подсчет разницы в годях между текущей датой и датой рождения lngAge = DateDiff("yyyy", dteBirthdate, Date) 'Вычитается один год, если в этом году дня рождения еще не было If DateSerial(Year(Date), Month(dteBirthdate), Day(dteBirthdate)) > Date Then lngAge = lngAge - 1 End If CalcAge = lngAge End Function Вычисление разницы в годах между двумя датами Естественно, что значение Bdate должно быть меньше параметра DateToday Function Age(Bdate, DateToday) As Integer If Month(DateToday) < Month(Bdate) Or (Month(DateToday) = Month(Bdate) And Day(DateToday) < Day(Bdate)) Then Age = Year(DateToday) - Year(Bdate) - 1 Else Age = Year(DateToday) - Year(Bdate) End If End Function Определение високосности года Function LeapYear(YYYY As Integer) As Integer 'Функция возвращает -1, если указанный входной параметр (год) является високосным 'Пример: MsgBox LeapYear(1996) LeapYear = YYYY Mod 4 = 0 And (YYYY Mod 100 <> 0 Or YYYY Mod 400 = 0) End Function Function LeapYear2(YYYY As Integer) As Integer 'Функция возвращает -1, если указанный входной параметр (год) является високосным 'Пример: MsgBox LeapYear(1996) LeapYear2 = Month(DateSerial(YYYY, 2, 29)) = 2 End Function Function IsLeapYear(DateIn As Date) As Boolean 'Функция возвращает True, если год в указанной дате является високосным 'Проверка: MsgBox IsLeapYear("01/01/00") If IsDate("29/02/" & Format(DateIn, "yyyy")) = True Then IsLeapYear = True End If End Function 7.36 Определить кодировку текста (Dos или Win) - Visual Basic ==================================================== Предположим, вы загружаете тестовой документ в TextBox. При изменении содержимого тестового блока вы можете узнать тип кодировки текста (Dos или Win) Private Sub Text1_Change() 'пpовеpяем тип кодиpовки ANSI или ASCII 'беpем пеpвые 1000 байт еcли это возможно. Hевозможно - меньше. l& = Len(Text1.Text) If l& > 1000 Then l& = 1000 'копиpyем yчаcток текcта в пеpеменнyю, иначе тоpмоз обеcпечен s$ = Left$(Text1.Text, l&) 'обнyляем флажки fdo% = 0 fwo% = 0 'пpоcматpиваем кycок текcта For n% = 1 To l& 'вытаcкиваем очеpедной cимвол c$ = Mid$(s$, n%, 1) 'еcли это pyccкая "о" в DOS кодиpовке то инкpементиpyем cчетчик If c$ = Chr$(174) Then fdo% = fdo% + 1 'еcли это pyccкая "о" в Win кодиpовке то инкpементиpyем cчетчик If c$ = Chr$(238) Then fwo% = fwo% + 1 Next 'ycтанавливаем в конфиге тип пpоcмотpа по дефолтy If fdo% > fwo% Then 'это явно ДОC-текcт MsgBox "DOS" Else 'это явно Win-текcт MsgBox "WIN" End If End Sub 7.37 Вертикальное/горизонтальное написание в элементе Label - Visual Basic ==================================================== Расположите на форме элемент CommandButton а также элемент Label Private Function Vertical_Horizontal(ByVal nStr As String) As String Dim MyStr As String, i As Integer Static Vert As Boolean If Vert = False Then For i = 1 To Len(nStr) If i Then MyStr = MyStr + Mid$(nStr, i, 1) & vbCrLf Else MyStr = MyStr + Mid$(nStr, i, 1) End If Next Vertical_Horizontal = MyStr Vert = True Else For i = 1 To Len(nStr) Step 3 MyStr = MyStr + Mid$(nStr, i, 1) Next Vertical_Horizontal = MyStr Vert = False End If End Function Private Sub Command1_Click() Label1.AutoSize = True Label1.Caption = Vertical_Horizontal(Label1.Caption) End Sub '© 2001 by Alexander Anikin '/www.i.com.ua/~aka 7.38 Получение длинного и короткого имени файла/директории - Visual Basic ==================================================== например: ("c:\Program Files" ==>"c:\progra~1") Способ 1 'Как мне получить короткое имя файла или как мне получить длинное имя 'файла, зная короткое. Private Const MAX_PATH& = 260 Private Const INVALID_HANDLE_VALUE = -1 Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReservedЇ As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Private Declare Function apiFindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function apiFindClose Lib "kernel32" Alias "FindClose" (ByVal hFindFile As Long) As Long Private Declare Function apiGetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long Function fGetShortName(ByVal stLongPath As String) As String Dim stShortPath As String Dim lngBuffer As Long, lngRet As Long stShortPath = String$(MAX_PATH, 0) lngBuffer = Len(stShortPath) lngRet = apiGetShortPathName(stLongPath, stShortPath, lngBuffer) fGetShortName = Left(stShortPath, lngRet) End Function Function fGetLongName(ByVal strFilename As String) As String Dim lpFindFileData As WIN32_FIND_DATA Dim strPath As String, lngRet As Long Dim strFile As String, lngx As Long, lngY As Long Dim strTmp As String strTmp = "" Do While Not lngRet = INVALID_HANDLE_VALUE lngRet = apiFindFirstFile(strFilename, lpFindFileData) strFile = Left$(lpFindFileData.cFileName, InStr(lpFindFileData.cFileName, vbNullChar) - 1) If Len(strFilename) > 2 Then strTmp = strFile & "\" & strTmp strFilename = fParseDir(strFilename) Else strTmp = strFilename & "\" & strTmp Exit Do End If Loop fGetLongName = Left$(strTmp, Len(strTmp) - 1) lngY = apiFindClose(lngRet) End Function Private Function fParseDir(strInFile As String) As String Dim intLen As Long, boolFound As Boolean Dim i As Integer, F As String, strDir As String intLen = Len(strInFile) If intLen > 0 Then boolFound = False For i = intLen To 1 Step -1 If Mid$(strInFile, i, 1) = "\" Then F = Mid$(strInFile, i + 1) strDir = Left$(strInFile, i - 1) boolFound = True Exit For End If Next i End If If boolFound Then fParseDir = strDir Else fParseDir = strInFile End If End Function Private Sub Command1_Click() Dim fShort fShort = fGetShortName("C:\Program Files") MsgBox fShort fShort = fGetLongName(fShort) MsgBox fShort End Sub Способ 2 Функция GetShortName в качестве входного параметра принимает длинное имя файла и возвращает DOS-имя файла Private Declare Function GetShortPathName Lib "kernel32.dll" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long Private Function GetShortName(lName As String) As String Dim DosName As String Dim LenOfDosName As Long DosName = Space(256) LenOfDosName = GetShortPathName(lName, DosName, 256) GetShortName = Left$(DosName, LenOfDosName) End Function Private Sub Form_Load() Dim LongName As String LongName = "C:\Program Files\Internet Explorer\Iexplore.exe" MsgBox GetShortName(LongName) End Sub 7.39 Как вывести кавычки в MsgBox? - Visual Basic ==================================================== нужно использовать функцию Chr и иметь при сибе таблицу ASCLL кодов ASCLL код кавычки имеет номер в десятичной системе 34. MsgBox Chr(34) & "ИНФОРМАЦИЯ" & Chr(34) 7.40 Как узнать ASCLL код символа? - Visual Basic ==================================================== Dim x As Byte x = Asc("A")'x - будет равен 65 MsgBox x 7.41 Как узнать количество символов в строке? - Visual Basic ==================================================== Dim x As Integer x = Len("ПРИВЕТ") 'x - будет равен 6-ти MsgBox x 7.42 Как преобразовать буквы в нижний или верхний регистр? - Visual Basic ==================================================== в нижний регистр: Dim x As String x = LCase("ПРИВЕТ") 'x - будет равен: привет MsgBox x в верхний регистр: Dim x As String x = UCase("привет")'x - будет равен: ПРИВЕТ MsgBox x 7.43 MsgBox - выше всех - Visual Basic ==================================================== 'ответ: MsgBox "Ааааа я впереди всех!!!", vbSystemModal 7.44 Как в MsgBox вывести или записать в переменную данные столбиком? - Visual Basic ==================================================== Можно это осуществить несколькоми способами: пример 1 (с помощью VbNewLine): dim stroka as string stroka="Привет " & VbNewLine & "Как дела?" MsgBox stroka или записать сразу в MsgBox MsgBox "Привет " & VbNewLine & "Как дела?" пример 2 (с помощью vbCrLf): dim stroka as string stroka="Привет " & vbCrLf & "Как дела?" MsgBox stroka пример 3 (с помощью Chr(10): Dim stroka As String stroka = "Привет " & Chr(10) & "Как дела?" MsgBox stroka пример 4 (с помощью Chr(13): Dim stroka As String stroka = "Привет " & Chr(13) & "Как дела?" MsgBox stroka 7.45 Операции "копировать", "вырезать", "вставить" - Visual Basic ==================================================== Для работы с Clipboard используется объект - Clipboard и свойство Form. Вставьте в проект меню с тремя пунктами mnuEditCopy, mnuEditCut и mnuEditPaste. Данные примеры применимы для TextBox'а. Для RichTextBox'а вместо SelText используйте SelRtf. '"копировать" Private Sub mnuEditCopy_Click() On Error Resume Next Clipboard.Clear Clipboard.SetText frmMain.Text1.SelText End Sub '"вырезать" Private Sub mnuEditCut_Click() On Error Resume Next Clipboard.Clear Clipboard.SetText frmMain.Text1.SelText frmMain.Text1.SelText = vbNullString End Sub '"вставить" Private Sub mnuEditPaste_Click() On Error Resume Next frmMain.Text1.SelText = Clipboard.GetText End Sub 7.46 3D-текст на форме - Visual Basic ==================================================== 'Установите свойство формы AutoRedraw как True Private Sub Form_Load() Dim ShadowX Dim ShadowY ScaleMode = 3 ForeColor = "&H808080" ShadowY = 5 ShadowX = 5 For I = 0 To 5 CurrentX = ShadowX + I CurrentY = ShadowY + I If I = 5 Then Form1.ForeColor = vbWhite Form1.Print "3D Text!!!" Next End Sub 7.47 Как вывести символ & в Label - Visual Basic ==================================================== Если Вы хотите выывести символ «&» на экран, установите свойство "UseMnemonic" в False. Это свойство бывает полезно, когда, например, Labelы используются для вывода данных из баз данных. Также Вы можете вывести символ "&" в свойстве Caption, написав &&. или Label1.Caption = "Маша " + Chr(38) + Chr(38) + " Саша" 7.48 Постоянно возникающий вопрос у тех, кто пишет блокнот. Функция Command - Visual Basic ==================================================== Вопрос, допустим я сделал блокнот, и мне нужно чтобы когда я открывал например TXT файл с помощью 2ой кнопки мыши, Открыть с помощью... и после того как я указал в окне выбора программ, свою программу чтобы когда я нажал на кнопку ОК, не просто тупо октрылася моя программа, а чтобы в текстовом поле этой программы появился путь к этому файл. Ответ Используй функцию Command Пример Кинь на форму 1 TextBox и в загрузку формы, помести код: Text1.text = Command теперь скомпилируй программу и открой какойнибудь файл указав на свою программу при загрузке программы в переменную Command записывается путь того файла который ты открыл через свою прогу 7.49 Ввод в TextBox только цифр - Visual Basic ==================================================== Private Sub Text1_KeyPress(KeyAscii As Integer) If KeyAscii < Asc(0) Or KeyAscii > Asc(9) Then KeyAscii = 0 Beep ' звуковой сигнал при ошибке End If End Sub 7.50 Как сделать вывод только заглавных букв в TextBox - Visual Basic ==================================================== Private Sub Text1_KeyPress(KeyAscii As Integer) Dim char char = Chr(KeyAscii) KeyAscii = Asc(UCase(char)) End Sub Наверх 08. Интернет
8.2 Программно отсоединиться от Интернета - Visual Basic 8.3 Запуск почты и Интернета из VB - Visual Basic 8.4 Как сохранить содержимое web-страницы на диск? - Visual Basic 8.5 Получение сведений из URL. - Visual Basic 8.6 Является ли строковая переменная e-mail-адресом. - Visual Basic 8.7 Загружаем файл из интернета - Visual Basic 8.8 Загружаем любой файл из интернета без использования WinSock - Visual Basic 8.9 Советы по использованию компонента WebBrowser - Visual Basic 8.10 Как вытащить все ссылки из htm-страницы - Visual Basic 8.11 Создать ссылку на страницу в Интернете - Visual Basic 8.12 Определить дату изменения web-страницы - Visual Basic 8.13 Является ли строковая переменная e-mail-адресом - Visual Basic 8.14 Имя текущего соединения с инетом - Visual Basic 8.15 Получение списка всех интернет-соединений - Visual Basic 8.16 Запрещение запуска дополнительных окон IE - Visual Basic 8.17 Прокси сервер на VB - Visual Basic 8.18 Как установить/сменить IP адресс в локальной сети - Visual Basic 8.19 Как отправлять сообщения и файлы через Mail - Visual Basic 8.1 Узнать есть ли активное соединение с Интернетом - Visual Basic 'Добавьте модуль Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long Private Const RAS95_MaxEntryName = 256 Private Const RAS95_MaxDeviceType = 16 Private Const RAS95_MaxDeviceName = 32 Private Type RASCONN95 dwSize As Long hRasCon As Long szEntryName(RAS95_MaxEntryName) As Byte szDeviceType(RAS95_MaxDeviceType) As Byte szDeviceName(RAS95_MaxDeviceName) As Byte End Type Private Type RASCONNSTATUS95 dwSize As Long RasConnState As Long dwError As Long szDeviceType(RAS95_MaxDeviceType) As Byte szDeviceName(RAS95_MaxDeviceName) As Byte End Type Public Function IsConnected() As Boolean Dim TRasCon(255) As RASCONN95 Dim lg As Long Dim lpcon As Long Dim RetVal As Long Dim Tstatus As RASCONNSTATUS95 TRasCon(0).dwSize = 412 lg = 256 * TRasCon(0).dwSize RetVal = RasEnumConnections(TRasCon(0), lg, lpcon) Tstatus.dwSize = 160 RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus) If Tstatus.RasConnState = &H2000 Then IsConnected = True Else IsConnected = False End If End Function Private Sub Command1_Click() 'если есть соединение, то IsConnected() = True, иначе False Select Case IsConnected() Case False MsgBox "Интернет не подключен" Case True MsgBox "Интернет включен" End Select End Sub 8.2 Программно отсоединиться от Интернета - Visual Basic 'Добавьте в модуль Const RAS_MAXENTRYNAME As Integer = 256 Const RAS_MAXDEVICETYPE As Integer = 16 Const RAS_MAXDEVICENAME As Integer = 128 Const RAS_RASCONNSIZE As Integer = 412 Const ERROR_SUCCESS = 0& Private Type RasEntryName dwSize As Long szEntryName(RAS_MAXENTRYNAME) As Byte End Type Private Type RasConn dwSize As Long hRasConn As Long szEntryName(RAS_MAXENTRYNAME) As Byte szDeviceType(RAS_MAXDEVICETYPE) As Byte szDeviceName(RAS_MAXDEVICENAME) As Byte End Type Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasConn As Any, lpcb As Long, lpcConnections As Long) As Long Private Declare Function RasHangUp Lib "RasApi32.dll" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long Private gstrISPName As String Public ReturnCode As Long Public Sub HangUp() Dim i As Long Dim lpRasConn(255) As RasConn Dim lpcb As Long Dim lpcConnections As Long Dim hRasConn As Long lpRasConn(0).dwSize = RAS_RASCONNSIZE lpcb = RAS_MAXENTRYNAME * lpRasConn(0).dwSize lpcConnections = 0 ReturnCode = RasEnumConnections(lpRasConn(0), lpcb, lpcConnections) If ReturnCode = ERROR_SUCCESS Then For i = 0 To lpcConnections - 1 If Trim(ByteToString(lpRasConn(i).szEntryName)) = Trim(gstrISPName) Then hRasConn = lpRasConn(i).hRasConn ReturnCode = RasHangUp(ByVal hRasConn) End If Next i End If End Sub Public Function ByteToString(bytString() As Byte) As String Dim i As Integer ByteToString = "" i = 0 While bytString(i) = 0& ByteToString = ByteToString & Chr(bytString(i)) i = i + 1 Wend End Function 'добавьте кнопку Private Sub Command1_Click() Call HangUp End Sub 8.3 Запуск почты и Интернета из VB - Visual Basic ' Добавьте на форму 2 элемента Label, скопируйте и вставьте на форму следующий код: Private Declare Function ShellExecute& Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) Private Sub Form_Load() Label1.Caption = "http://VBrus.narod.ru" Label2.Caption = "VBrus@yandex.ru" End Sub Private Sub Label1_Click() Call ShellExecute(0, "Open", Label1.Caption, "", "c:\", 1) End Sub Private Sub Label2_Click() Call ShellExecute(0, "Open", "mailto:" + Label2.Caption + "?Subject=" + "Письмо с сайта", "", "", 1) End Sub 8.4 Как сохранить содержимое web-страницы на диск? Расположите на форме элемент Inet (меню Project|Components - Microsoft Internet Transfer Control 6.0). Private Sub Form_Load() Dim b() As Byte 'установить протокол HTTP Inet1.Protocol = icHTTP 'установить скачиваемый адрес Inet1.URL = "http://VBrus.narod.ru" 'загрузить данные HTML-страницы в массив b() = Inet1.OpenURL(Inet1.URL, icByteArray) 'создать файл на диске и записать в него информацию Open "c:\test.htm" For Binary Access Write As #1 Put #1, , b() Close #1 End Sub Вариант 2. Расположите на форме элемент CommandButton. Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean Dim lngRetVal As Long lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0) If lngRetVal = 0 Then DownloadFile = True End Function Private Sub Command1_Click() DownloadFile "http://VBrus.narod.ru", "c:\VBrus.narod_ru.htm" End Sub 8.5 Получение сведений из URL. - Visual Basic Данная функция возвращает различные компоненты web-страницы. Включая "host", "port", "user", "pass", "path" и "query" Private Type typURL 'http://sit:sitter@proxy.spiderit.net:881/prox/proxycfg.php3?openpage Protocol As String 'какой протокол (http://, ftp:// или другой) ServerName As String 'имя сервера (proxy.spiderit.net) Filename As String 'имя страницы (proxycfg.php3) Dir As String 'директория (/prox/) Filepath As String 'путь файла (/prox/proxycfg.php3) Username As String 'имя пользователя (sit) Password As String 'пароль (sitter) Query As String 'строка запроса (openpage) ServerPort As Integer 'порт сервера (881) End Type Const strNOCONTENT As String = "NOCONTENT" Const intDEFAULTPORT As Integer = 80 Private Function ParseURL(URL As String) As typURL Dim strTemp As String Dim strServerAuth As String Dim strServerNPort As String Dim strAuth As String strTemp = URL If (InStr(1, strTemp, "://") > 0) Then ParseURL.Protocol = Left(strTemp, InStr(1, strTemp, "://") - 1) strTemp = Right(strTemp, Len(strTemp) - (Len(ParseURL.Protocol) + 3)) 'delete protocol + :// Else ParseURL.Protocol = strNOCONTENT End If If (InStr(1, strTemp, "/") > 0) Then strServerAuth = Left(strTemp, InStr(1, strTemp, "/") - 1) strTemp = Right(strTemp, Len(strTemp) - (Len(strServerAuth) + 1)) Else strServerAuth = strTemp strTemp = "/" End If If (InStr(1, strServerAuth, "@") > 0) Then strAuth = Left(strServerAuth, InStr(1, strServerAuth, "@") - 1) strServerNPort = Right(strServerAuth, Len(strServerAuth) - (Len(strAuth) + 1)) Else strAuth = "" strServerNPort = strServerAuth End If If (InStr(1, strAuth, ":") > 0) And (Len(strAuth) > 0) Then ParseURL.Username = Left(strAuth, InStr(1, strAuth, ":") - 1) ParseURL.Password = Right(strAuth, Len(strAuth) - InStr(1, strAuth, ":")) ElseIf (InStr(1, strAuth, ":") <> 0) Then ParseURL.Username = strAuth ParseURL.Password = strNOCONTENT Else ParseURL.Username = strNOCONTENT ParseURL.Password = strNOCONTENT End If If (InStr(1, strServerNPort, ":") > 0) Then ParseURL.ServerPort = Int(Right(strServerNPort, Len(strServerNPort) - InStr(1, strServerNPort, ":"))) ParseURL.ServerName = Left(strServerNPort, InStr(1, strServerNPort, ":") - 1) Else ParseURL.ServerPort = intDEFAULTPORT ParseURL.ServerName = strServerNPort End If If (InStr(1, strTemp, "?") > 0) Then ParseURL.Query = Right(strTemp, Len(strTemp) - InStr(1, strTemp, "?")) strTemp = Left(strTemp, InStr(1, strTemp, "?") - 1) Else ParseURL.Query = strNOCONTENT End If For i = Len(strTemp) To 1 Step -1 If (Mid(strTemp, i, 1) = "/") Then ParseURL.Filename = Right(strTemp, Len(strTemp) - i) ParseURL.Dir = Left(strTemp, i) If Not (Left(ParseURL.Dir, 1) = "/") Then ParseURL.Dir = "/" & ParseURL.Dir End If Exit For End If Next ParseURL.Filepath = "/" & strTemp If Not (Left(ParseURL.Filepath, 1) = "/") Then ParseURL.Filepath = "/" & ParseURL.Filepath End If End Function Private Sub Form_Load() Const strURL As String = "http://sit:sitter@proxy.spiderit.net:881/prox/proxycfg.php3?openpage" msgtext = ParseURL(strURL).Protocol & vbCrLf msgtext = msgtext & ParseURL(strURL).Username & vbCrLf msgtext = msgtext & ParseURL(strURL).Password & vbCrLf msgtext = msgtext & ParseURL(strURL).ServerName & vbCrLf msgtext = msgtext & ParseURL(strURL).ServerPort & vbCrLf msgtext = msgtext & ParseURL(strURL).Filepath & vbCrLf msgtext = msgtext & ParseURL(strURL).Dir & vbCrLf msgtext = msgtext & ParseURL(strURL).Filename & vbCrLf msgtext = msgtext & ParseURL(strURL).Query & vbCrLf MsgBox msgtext, vbInformation End Sub 8.6 Является ли строковая переменная e-mail-адресом. Этот код использует VBScript.dll - Вы можете загрузить его с www.microsoft.com/msdownload/vbscript/scripting.asp Добавьте Microsoft VBScript Regular Expressions reference в ваш проект (выберите Project->References, поставьте галочку на Microsoft VBScript Regular Expressions CheckBox и нажмите OK). RegExp - тип переменной, которую вы хотите проверить: Email-адрес, телефонный номер, любой другой формат. Private Sub Form_Load() Dim myReg As RegExp Dim email As String Set myReg = New RegExp myReg.IgnoreCase = True myReg.Pattern = "^[\w-\.]+@\w+\.\w+$" 'replace "myName@domain.ru" любым адресом email = "myName@domain.ru" MsgBox "Результат проверки: " & myReg.Test(email) Unload Me End Sub 8.7 Загружаем файл из интернета - Visual Basic Маленькая функция, показывающая, как Ваше приложение может скачивать из интернета файлы. На вход функции достаточно подать URL и имя скачиваемого файла. Public Sub DLFiles(strUrl As String, fileName As String) On Error Resume Next Dim b() As Byte Inet1.Cancel Inet1.Protocol = icHTTP Inet1.URL = strUrl b() = Inet1.OpenURL(, icByteArray) Open fileName For Binary Access Write As #1 Put #1, , b() Close #1 End Sub 8.8 Загружаем любой файл из интернета без использования WinSock - Visual Basic ps: работает 100%, проверял:) как на Windows Vista так и на XP 'МОДУЛЬ Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long 'ФОРМА Call URLDownloadToFile(0, "http://vbrus.narod.ru/Info.htm", "c:\Info.htm", 0, 0) 8.9 Советы по использованию компонента WebBrowser - Visual Basic Прежде всего, вы можете создать проект с использованием компонента WebBrowser, используя для этой цели VB Application Wizard. Для этого войдите в меню File | New Project и выберите VB Application Wizard. Нажмите несколько раз Next, и когда программа спросит вас "Do you want your user to be able to access the Internet from your application" смело нажимайте Yes. Можно сразу нажать кнопку Finish. В ваше приложение будет добавлена возможность навигации по Интернету, используя созданный вами проект. Расположите на основной форме CommandButton и впишите в него следующий код: frmBrowser.Show Некоторые возможности компонента WebBrowser у вас автоматически добавятся, и вы сами потом можете на досуге в них разобраться. Я а же предлагаю вам добавить в ваш проект возможности, которые автоматически не были добавлены Мастером Создания Приложений. Процесс, показывающий процесс загрузки веб-страницы Private Sub WebBrowser1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long) On Error Resume Next PBar.Max = ProgressMax If Progress = -1 Then Exit Sub Else If Progress <> ProgressMax Then PBar.Value = Progress progresslbl.Caption = Str(Round((Progress / ProgressMax) * 100)) & pert Else PBar.Value = ProgressMax progresslbl.Caption = Str(Round((Progress / ProgressMax) * 100)) & pert Exit Sub End If End If End Sub или такой вариант. Private Sub WebBrowser1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long) On Error Resume Next If Progress = -1 Then ProgressBar1.Value = 100 If Progress > 0 And ProgressMax > 0 Then ProgressBar1.Value = Progress * 100 / ProgressMax End If Exit Sub End Sub или такой вариант. Private Sub WebBrowser1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long) On Error Resume Next ProgressBar1.Max = ProgressMax ProgressBar1.Value = Progress ProgressBar1.Refresh End Sub Просмотр содержимого веб-страницы "В виде HTML" 2 варианта. Загрузите оба варианта, и посмотрите, что каждый код загружает... Text1 = WebBrowser1.Document.documentelement.innerhtml Text2 = WebBrowser1.Document.Body.innerhtml Вызвать окно "Печать" On Error Resume Next WebBrowser1.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT Добавить в ComboBox URL после загрузки Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant) Combo1.Text = URL End Sub Навигация на узел в сети WebBrowser1.Navigate "about:blank" 'пустая страница WebBrowser1.Navigate "http://sharig.webzone.ru" Запрет на посещение определенных узлов в Инете Private Sub WebBrowser1_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean) If InStr(1, URL, "playboy.com") Then Cancel = True MsgBox "Sorry, that site is restricted!" End If End Sub Ожидание загрузки страницы Do Until WebBrowser1.ReadyState = READYSTATE_COMPLETE DoEvents Loop Получить данные о загруженной странице MsgBox WebBrowser1.LocationName 'узнать имя загруженного файла (что-то типа "inet18_webbrowser.htm") MsgBox WebBrowser1.LocationURL 'получить URL загруженной страницы Вызвать окно "Сохранить как..." WebBrowser1.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT Что-то непонятное... Private Sub WebBrowser1_SetSecureLockIcon(ByVal SecureLockIcon As Long) If SecureLockIcon <> 0 Then imgSecure.Picture = "D:\garbage\ICON\2\face00.ico" 'path to secure icon Else imgSecure.Picture = "D:\garbage\ICON\2\face01.ico" 'path to unsecure icon End If End Sub Private Sub WebBrowser1_WindowClosing(ByVal IsChildWindow As Boolean, Cancel As Boolean) If MsgBox("This webpage is trying to close your browser window." & vbCrLf & vbCrLf & "Are you sure you want to close it?", vbYesNo, "BAPNet") = vbYes Then Unload Me Cancel = True ElseIf vbNo Then Cancel = True End If End Sub 8.10 Как вытащить все ссылки из htm-страницы - Visual Basic В одном из многочисленных примеров по работе с компонентом WebBrowser я натолкнулся на пример, как можно вытащить все ссылки из любого *.htm файла, находящегося как в интернете, так и локально на жестком диске. Честно говоря, моя жизнь после нахождения данного примера очень облегчилась, поскольку я часто работаю с инетом, со ссылками. Нажатие на первую кнопку покажет, как можно вытащить все ссылки из файла, а нажатие на вторую кнопку - как можно вытащить ссылки только определенного типа. Но для начала вам надо установить через меню Project | References ссылку на Microsoft Internet Control. ПРИМЕР 1 Также вам необходимо расположить на форме 2 элемента CommandButton и элемент ListBox. Private IEBroj1 As SHDocVw.InternetExplorer Private Sub Form_Load() Set IEBroj1 = New SHDocVw.InternetExplorer End Sub Private Sub Form_Unload(Cancel As Integer) IEBroj1.Quit Set IEBroj1 = Nothing End End Sub Function Delay(Pause As Single) Dim Start As Single Start = Timer Do While Timer < Start + Pause DoEvents Loop End Function Private Sub Command1_Click() List1.Clear Dim x IEBroj1.Navigate "C:\1\index.htm" Delay 3 'задержа необходима для загрузки страницы 'иногда требуется увеличить время загрузки до 30 секунд. For i = 1 To IEBroj1.Document.links.length - 1 List1.AddItem IEBroj1.Document.links(i).href Next End Sub Private Sub Command2_Click() List1.Clear Dim x IEBroj1.Navigate "C:\1\index.htm" Delay 3 For i = 1 To IEBroj1.Document.links.length - 1 If InStr(1, IEBroj1.Document.links(i).href, ".asp") <> 0 Or InStr(1, IEBroj1.Document.links(i).href, ".htm") <> 0 Then List1.AddItem IEBroj1.Document.links(i).href End If Next End Sub 8.11 Создать ссылку на страницу в Интернете - Visual Basic Данный пример разместит на рабочем столе ярлык на сайт RusEdu.info (при условии, что ваш путь к рабочему столу = "C:\WIN\Рабочий стол"). Sub CreateInternetShortCut(URLFile As String, URLTarget As String) Dim intFreeFile As Integer intFreeFile = FreeFile Open URLFile For Output As intFreeFile Print #intFreeFile, "[InternetShortcut]" Print #intFreeFile, "URL=" & URLTarget Close intFreeFile End Sub Private Sub Form_Load() CreateInternetShortCut "C:\WIN\Рабочий стол\test.url", "http://rusedu.info" End Sub 8.12 Определить дату изменения web-страницы - Visual Basic Зазместите на форме компонент Inet и элемент CommandButton. Public Function PageLastModified(URL As String) As String Dim strHeader As String Inet1.Protocol = icHTTP On Error Resume Next Inet1.OpenURL (URL) If Err.Number > 0 Then Exit Function strHeader = Inet1.GetHeader("Last-modified") PageLastModified = strHeader End Function Private Sub Command1_Click() MsgBox PageLastModified("http://sharig.webzone.ru/IndexMainTopic.htm") End Sub 8.13 Является ли строковая переменная e-mail-адресом - Visual Basic Этот код использует VBScript.dll Вы можете загрузить его с www.microsoft.com/msdownload/vbscript/scripting.asp Добавьте Microsoft VBScript Regular Expressions reference в ваш проект (выберите Project->References, поставьте галочку на Microsoft VBScript Regular Expressions CheckBox и нажмите OK). RegExp - тип переменной, которую вы хотите проверить: Email-адрес, телефонный номер, любой другой формат. Private Sub Form_Load() Dim myReg As RegExp Dim email As String Set myReg = New RegExp myReg.IgnoreCase = True myReg.Pattern = "^[\w-\.]+@\w+\.\w+$" 'replace "myName@domain.ru" любым адресом email = "myName@domain.ru" MsgBox "Результат проверки: " & myReg.Test(email) Unload Me End Sub 8.14 Имя текущего соединения с инетом - Visual Basic 'Расположите на форме элемент CommandButton. Private Const RAS_MAXENTRYNAME As Integer = 256 Private Const RAS_MAXDEVICETYPE As Integer = 16 Private Const RAS_MAXDEVICENAME As Integer = 128 Private Const RAS_RASCONNSIZE As Integer = 412 Private Type RASCONN dwSize As Long hRasConn As Long szEntryName(RAS_MAXENTRYNAME) As Byte szDeviceType(RAS_MAXDEVICETYPE) As Byte szDeviceName(RAS_MAXDEVICENAME) As Byte End Type Private Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" (udtRasConn As Any, lpcb As Long, lpcConnections As Long) As Long Private Sub Command1_Click() Dim udtRasConn(255) As RASCONN, countConn As Long Dim Ret As Long, b As Long udtRasConn(0).dwSize = RAS_RASCONNSIZE Ret = RasEnumConnections(udtRasConn(0), RAS_MAXENTRYNAME * udtRasConn(0).dwSize, countConn) If Ret = 0 Then For b = 0 To countConn - 1 MsgBox "Текущее соединение: " & StrConv(udtRasConn(b).szEntryName(), vbUnicode) Next b End If End Sub 8.15 Получение списка всех интернет-соединений - Visual Basic Добавьте на форму CommandButton и ListBox. Вставьте следующий код, запустите программу на выполнение. В ListBox'е вы получите имена всех интернет-соединений. При нажатии на CommandButton на форме будет напечатано имя интернет-соединения по умолчанию. Const REG_NONE = 0& Const REG_SZ = 1& Const REG_EXPAND_SZ = 2& Const REG_BINARY = 3& Const REG_DWORD = 4& Const REG_DWORD_LITTLE_ENDIAN = 4& Const REG_DWORD_BIG_ENDIAN = 5& Const REG_LINK = 6& Const REG_MULTI_SZ = 7& Const REG_RESOURCE_LIST = 8& Const REG_FULL_RESOURCE_DESCRIPTOR = 9& Const REG_RESOURCE_REQUIREMENTS_LIST = 10& Public rgeEntry$ Public rgeDataType& Public rgeValue$ Public rgeMainKey& Public rgeSubKey$ Const KEY_QUERY_VALUE = &H1& Const KEY_SET_VALUE = &H2& Const KEY_CREATE_SUB_KEY = &H4& Const KEY_ENUMERATE_SUB_KEYS = &H8& Const KEY_NOTIFY = &H10& Const KEY_CREATE_LINK = &H20& Const READ_CONTROL = &H20000 Const WRITE_DAC = &H40000 Const WRITE_OWNER = &H80000 Const SYNCHRONIZE = &H100000 Const STANDARD_RIGHTS_REQUIRED = &HF0000 Const STANDARD_RIGHTS_READ = READ_CONTROL Const STANDARD_RIGHTS_WRITE = READ_CONTROL Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Const KEY_EXECUTE = KEY_READ Private Type FILETIME lLowDateTime As Long lHighDateTime As Long End Type Const HKEY_CLASSES_ROOT = &H80000000 Const HKEY_CURRENT_USER = &H80000001 Const HKEY_LOCAL_MACHINE = &H80000002 Const HKEY_USERS = &H80000003 Const HKEY_PERFORMANCE_DATA = &H80000004 Const HKEY_CURRENT_CONFIG = &H80000005 Const HKEY_DYN_DATA = &H80000006 Private Declare Function RegOpenKeyEx& Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey&, ByVal lpszSubKey$, dwOptions&, ByVal samDesired&, lpHKey&) Private Declare Function RegCloseKey& Lib "advapi32.dll" (ByVal hKey&) Private Declare Function RegQueryValueEx& Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&) Private Declare Function RegEnumKeyEx& Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey&, ByVal dwIndex&, ByVal lpname$, lpcbName&, ByVal lpReserved&, ByVal lpClass$, lpcbClass&, lpftLastWriteTime As FILETIME) Private Declare Function RegQueryInfoKey& Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey&, ByVal lpClass$, lpcbClass&, ByVal lpReserved&, lpcSubKeys&, lpcbMaxSubKeyLen&, lpcbMaxClassLen&, lpcValues&, lpcbMaxValueNameLen&, lpcbMaxValueLen&, lpcbSecurityDescriptor&, lpftLastWriteTime As FILETIME) Public Function GetRegValue(keyroot As Variant, subkey As Variant, valname As String) Const KEY_ALL_ACCESS As Long = &HF0063 Const ERROR_SUCCESS As Long = 0 Const REG_SZ As Long = 1 Dim hsubkey As Long, dwType As Long, sz As Long Dim R As Long R = RegOpenKeyEx(keyroot, subkey, 0, KEY_ALL_ACCESS, hsubkey) sz = 256 v$ = String$(sz, 0) R = RegQueryValueEx(hsubkey, valname, 0, dwType, ByVal v$, sz) If R = ERROR_SUCCESS And dwType = REG_SZ Then retval = Left$(v$, sz) GetRegValue = retval Else retval = "--Not String--" End If R = RegCloseKey(hsubkey) End Function Public Sub rgeClear() rgeMainKey = 0 rgeSubKey = "" rgeValue = "" rgeDataType = 0 rgeEntry = "" End Sub Function RegEnumKeys&(bFullEnumeration As Boolean) Dim sRoot$, sRoot2$ Dim lRtn& Dim hKey& Dim strucLastWriteTime As FILETIME Dim sSubKeyName$ Dim sClassString$ Dim lLenSubKey& Dim lLenClass& Dim lKeyIndx& Dim lRet& Dim hKey2& Dim sSubKey2$ Dim sNewKey$ Dim sClassName$ Dim lClassLen& Dim lSubKeys& Dim lMaxSubKey& Dim sMaxSubKey$ Dim lMaxClass& Dim sMaxClass$ Dim lValues& Dim lMaxValueName& Dim lMaxValueData& Dim lSecurityDesc& lRtn = RegOpenKeyEx(rgeMainKey, rgeSubKey, 0&, KEY_READ, hKey) sClassName = Space$(255) lClassLen = CLng(Len(sClassName)) lRet = RegQueryInfoKey(hKey, sClassName, lClassLen, 0&, lSubKeys, lMaxSubKey, _ lMaxClass, lValues, lMaxValueName, lMaxValueData, lSecurityDesc, strucLastWriteTime) sMaxSubKey = Space$(lMaxSubKey + 1) sMaxClass = Space$(lMaxClass + 1) lKeyIndx = 0& Do While lRtn = ERROR_SUCCESS ReTryKeyEnumeration: sSubKeyName = sMaxSubKey lLenSubKey = lMaxSubKey sClassString = sMaxClass lLenClass = lMaxClass lRtn = RegEnumKeyEx(hKey, lKeyIndx, sSubKeyName, lLenSubKey, 0&, sClassString, _ lLenClass, strucLastWriteTime) If InStr(sSubKeyName, Chr$(0)) > 1 Then sSubKeyName = Left$(sSubKeyName, InStr(sSubKeyName, Chr$(0)) - 1) End If If lRtn = ERROR_SUCCESS Then Form1.List1.AddItem sSubKeyName lNewKey = lNewKey + 1 sNewKey = "A" & Format$(lNewKey, "000000") If bFullEnumeration = True Then sSubKey2 = sSubKeyName If rgeSubKey <> "" Then sSubKey2 = Trim(rgeSubKey) & "\" & sSubKeyName End If lRet = RegOpenKeyEx(rgeMainKey, sSubKey2, 0&, KEY_READ, hKey2) Else Exit Do End If lKeyIndx = lKeyIndx + 1 ElseIf lRtn = ERROR_MORE_DATA Then lMaxSubKey = lMaxSubKey + 5 lMaxClass = lMaxClass + 5 sMaxSubKey = Space$(lMaxSubKey + 1) sMaxClass = Space$(lMaxClass + 1) GoTo ReTryKeyEnumeration ElseIf lRtn = ERROR_NO_MORE_ITEMS Then lRtn = ERROR_SUCCESS Exit Do Exit Do End If Loop RegEnumKeys = lRtn lRtn = RegCloseKey(hKey) End Function Private Sub Form_Load() rgeMainKey = HKEY_CURRENT_USER rgeSubKey$ = "RemoteAccess\Profile" RegEnumKeys True End Sub Private Sub Command1_Click() Print GetRegValue(HKEY_CURRENT_USER, "RemoteAccess", "Default") End Sub 8.16 Запрещение запуска дополнительных окон IE Данный пример запретит запуск дополнительных окон броузера ИнтернетЭксплорер. Этот пример хорош для борьбы с рекламными окошками, запускаемыми автоматически на тех или иных сайтах. Что делает пример: 1) программа при запуске определяет количество запущенных окон InternetExplorer'а. 2) во время работы программа проводит мониторинг запущенных процессов, 3) и если запущено очередное окно Internet Explorer'а программа его закроет. Ну а кнопка вам понадобится, если вы захотите отключить/снова включить процесс мониторинга. Пример подробно описан, но... на английском языке. Установите на форме компонент Label, компонент Timer и CommandButton. Также в этом примере вам понадобится дополнительный модуль. 'КОД МОДУЛЯ: Public Type WI TitleBarText As String TitleBarLen As Integer hWnd As Long End Type Public Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long Public Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long Public Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long Public WinNum As Integer 'holds the number of windows examined Public CurrentWindows(299) As WI 'holds information about all of the currently open windows Public Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long Dim WinInfo As WI 'holds information about the window currently being examined Dim retval As Long 'holds the return value Dim X As Integer WinInfo.TitleBarLen = GetWindowTextLength(hWnd) + 1 'find the length of the title bar text of the window currently being examined If WinInfo.TitleBarLen > 0 And Len(hWnd) > 1 Then 'if the title bar text of the window currently being examined is at least one character long AND the window's handle is > 1 WinInfo.TitleBarText = Space(WinInfo.TitleBarLen) 'initialize the variable that will hold the title bar text retval = GetWindowText(hWnd, WinInfo.TitleBarText, WinInfo.TitleBarLen) 'retreive the title bar text of the window currently being examined WinInfo.hWnd = hWnd 'holds the value of this window's handle CurrentWindows(WinNum).hWnd = WinInfo.hWnd 'store this window's handle in the current windows array CurrentWindows(WinNum).TitleBarText = WinInfo.TitleBarText 'store this window's title bar text in the current windows array WinNum = WinNum + 1 'increment the window counter End If EnumWindowsProc = 1 'continue enumeration of windows End Function 'КОД ФОРМЫ Option Explicit Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const WM_CLOSE = &H10 Dim ExistingIEWindows(49) As Long 'holds the handles of all of the currently existing IE windows (50 max) Dim Flash As Integer 'holds the value that determines if the status text should flash Private Sub Command1_Click() If Command1.Caption = "Отключить мониторинг" Then Timer1.Enabled = False Command1.Caption = "Включить мониторинг" Else Timer1.Enabled = True End If End Sub Private Sub Form_Load() Timer1.Interval = 100 Command1.Caption = "Отключить мониторинг" Dim X As Integer 'loop variable Label1.Caption = "Initializing..." Flash = 0 For X = 0 To 49 'reset/initialize the existing IE windows array ExistingIEWindows(X) = 0 Next Call GetExistingIEWindows End Sub Private Sub GetExistingIEWindows() 'this sub checks to see if any IE windows are currently open, and "remembers" them if so. Dim retval As Long 'holds the return value Dim X As Integer, Y As Integer 'loop variables Label1.Caption = "Examining currently active system windows..." WinNum = 0 'initialize number of windows to zero For X = 0 To 199 'reset/initialize the current windows array CurrentWindows(X).hWnd = 0 CurrentWindows(X).TitleBarLen = 0 CurrentWindows(X).TitleBarText = "" Next retval = EnumWindows(AddressOf EnumWindowsProc, 0) 'enumerate all open windows Y = 0 For X = 0 To WinNum - 1 'for each window that is currently open If InStr(1, CurrentWindows(X).TitleBarText, "Microsoft Internet Explorer", vbTextCompare) > 0 Then 'if this window is an IE window... Label1.Caption = "Storing IE window handle..." ExistingIEWindows(Y) = CurrentWindows(X).hWnd 'add this window to the list of existing IE windows Y = Y + 1 End If Next If Y > 0 Then 'if any of the existing system windows are IE windows Label1.Caption = "Enabling popup monitoring..." Timer1.Enabled = True 'enable the timer that checks for any new IE windows Label1.Caption = "Monitoring for new IE windows..." Else 'if none of the existing system windows are IE windows Label1.Caption = "No IE windows found!" MsgBox "There are currently no IE windows open!" & vbLf & vbLf & "Please start Internet Explorer before running this program.", vbExclamation + vbOKOnly, "Error" 'if no IE windows are found, display an error message End 'exit this program End If End Sub Private Sub Timer1_Timer() Dim retval As Long 'holds the return value Dim X As Integer, Y As Integer 'loop variables Dim KillCount As Integer 'holds the value that determines if the current window should be killed WinNum = 0 'initialize number of windows to zero For X = 0 To 199 'reset/initialize the current windows array CurrentWindows(X).hWnd = 0 CurrentWindows(X).TitleBarLen = 0 CurrentWindows(X).TitleBarText = "" Next retval = EnumWindows(AddressOf EnumWindowsProc, 0) 'enumerate all open windows For X = 0 To WinNum - 1 'for each window that is currently open If InStr(1, CurrentWindows(X).TitleBarText, "Microsoft Internet Explorer", vbTextCompare) > 0 Then 'if this window is an IE window... KillCount = 0 For Y = 0 To 49 If ExistingIEWindows(Y) <> 0 Then 'if array value holds a valid handle If ExistingIEWindows(Y) = CurrentWindows(X).hWnd Then 'if the window currently being examined matches any of the existing IE windows KillCount = KillCount + 1 'increment End If End If Next If KillCount = 0 Then 'if an IE window that did not previously exist was found retval = PostMessage(CurrentWindows(X).hWnd, WM_CLOSE, ByVal CLng(0), ByVal CLng(0)) 'post the window close message to the newly created IE window's message queue End If End If Next Flash = Flash + 1 'increment the flash value If Flash = 5 Then 'make the status label flash every 0.5 seconds Flash = 0 If Label1.Visible = True Then Label1.Visible = False Else Label1.Visible = True End If End If End Sub 8.17 Proxy Server на VB - Visual Basic proxy.oflameron.ru - Proxy на Visual Basic Онлайн учебник - прокси-сервер на Visual Basic. Курсовик 8.18 Как установить/сменить IP адресс в локальной сети - Visual Basic http://vbrus.narod.ru/Primers/Lan/IP876.zip - Скачать примеp 8.19 Как отправлять сообщения и файлы через Mail - Visual Basic Скачать пример Наверх 09. Использование Winsock контрола
Компонент WinSock позволяет соединиться с удаленной машиной и обменяться с ней данными, используя UDP (User Datagram Protocol) или TCP (Transmission Control Protocol). Оба протокола могут быть использованы при создании клиент-серверных приложений. Также, как и Timer control, WinSock control является невидимым во время выполнения программы. Как им пользоваться? - cоздать приложение-клиент, которое будет собирать информацию перед отсылкой ее на центральный сервер; - cоздать приложение-сервер, которое будет выполнять роль сборщика и хранителя информации от различных клиентских приложений; - создать "chat"-приложение. Выбор протокола Когда планируется использование а WinSock, необходимо решить какой протокол будет использоваться - TCP или UDP. Основное отличие между ними заключается в способе организации связи: Соединение основанное на TCP протоколе, похоже на телефонное - пользователь сначала должен установить соединение, прежде чем что-либо передавать. Соединение основанное на UDP протоколе, похоже на передачу голосом, сообщение передается от одного компьютера к другому, но не ясно, слышат ли они друг друга. Вдобавок, максимальный размер предаваемых данных устанавливается сетью. Возможности приложения которое Вы создаете будет зависеть от протокола, который Вы изберете. Вот несколько вопросов которые могут помочь Вам выбрать подходящий протокол: Будет ли приложение требовать уведомления от сервера или клиента, когда данные передаются или получаются? Если будет, то TCP протокол требует установленного соединения между передатчиком и приемником данных. Будут ли передаваемые данные достаточно тяжелыми (например изображения или звуковые файлы)? Если соединение было установлено, TCP протокол будет его поддерживать и гарантируется целостность передаваемых данных. Такое соединение, из-за потребности в большем количестве вычислительных ресурсов, может сделать его более медленным. Будут ли данные передаваться порциями или за одну сессию? Например, если Вы создаете приложение, которое сообщает каким-то компьютерам, о том, что какие-то задачи уже выполнены, то UDP протокол более подходящий. UDP протокол также блучше подходит для передачи небольшого количества данных. Установка протокола Чтобы установить протокол, который будет использовать ваше приложение Вы должны в дизайн-тайме в окне свойств выбрать свойство Protocol и установить его sckTCPProtocol или sckUDPProtocol. Это можно также сделать программно: Winsock1.Protocol = sckTCPProtocol Определение имени компьютера. Чтобы установить связь с удаленным компьютером, Вы должны знать либо его IP-адресс, либо его имя. Основы TCP соединения Когда создается приложение, которое использует TCP протокол первое, что Вы должны решить, это чем будет ваше приложение клиентом или сервером. Если Вы создаете приложение-сервер, значит ваше приложение будет слушать указанный порт. Когда приложение-клиент подаст запрос на соедиение, приложение-сервер может принять запрос и таким образом установить соедиенеие. Если соединение установлено, приложение-клиент и приложение сервер могут свободно обмениваться данными. Следующие шаги позволят Вам создать элементарное приложение-сервер: Для создания TCP сервера Создайте новый Standard EXE проект. Замените имя формы по умолчанию на frmServer. В свойстве формы caption наберите "TCP Server" В меню Project\Components добавьте Microsoft Winsock Conrol 6.0 Перетащите иконку компонента Winsock с панели инструментов и разместите ее на форме; измените имя компонента на tcpServer. Добавьте на форму два Текстбокс элемента. В свойстве Name первого текстового поля наберите txtSendData, а второго txtOutput. Добавьте в форму следующий код: Private Sub Form_Load() 'Задать номер порта по которому будет осуществляться 'обмен данными, присвоив значение свойству LocalPort 'Вызвать метод Listen. tcpServer.LocalPort = 1001 tcpServer.Listen frmClient.Show 'Показать форму клиента End Sub Private Sub tcpServer_ConnectionRequest (ByVal requestID As Long) ' Проверяется свойство State, было ли завершено ' предыдущее соединение. Если не завершено, ' то перед установлением нового соединения, ' старое закрывается принудительно. If tcpServer.State <> sckClosed Then tcpServer.Close ' Принятие запроса Accept с параметром requestID ' на установление соедиения. tcpServer.Accept requestID End Sub Private Sub txtSendData_Change() ' Текстовое поле txtSendData ' содержит данные для передачи. Все символы, ' которые будут вводиться в это текстовое поле, будут единой ' строкой посылаться приложению-клиенту, используя метод SendData. tcpServer.SendData txtSendData.Text End Sub Private Sub tcpServer_DataArrival (ByVal bytesTotal As Long) ' Декларируется переменная-буфер для получаемых данных. ' Вызывается метод GetData и свойству Text ' текстового поля txtOutput, присваивается значение переменной- ' буфера. Dim strData As String tcpServer.GetData strData txtOutput.Text = strData End Sub Описанные выше действия, выполненные Вами, приведут к созданию простого приложения-сервера. Но для того чтобы полностью выполнить задачу, необходимо создать еще и приложение-клиент. Для создания TCP приложения-клиента Добавьте новую форму в проект и назовите ее frmClient. И змените свойство формы caption на "TCP Client". Перетащите и разместите компонент Winsock на форму и измените его свойство name на "tcpClient". Добавьте два Текстбокс-контрола на форму frmClient. Имя первого установите txtSend, а второго txtOutput. Перетащите на форму CommandButton и установите его свойство name в "cmdConnect". Измените свойство caption этой кнопки на "Connect". Добавьте следующий код в форму. Важно!!! Будьте внимательны при установке свойства RemoteHost. Оно должно соответствовать либо IP-адресу вашего компьютера, либо его "Дружественному имени" (см. Пуск\Настройка\Панель управления\Сеть) выберите вкладку "Идентификация". Текст из поля "Имя компьютера" и будет так называемым дружественным именем, которым можно заменять IP-адрес. Сам же IP-адрес, можно посмотреть, если выбрать закладку "Конфигурация" в списке выбрать TCP/IP, нажать кнопку "Свойства" и выбрать закладку IP-адрес. Private Sub Form_Load() ' Имя Winsock-компонента tcpClient. ' Указывая имя удаленного компьютера можно ' указывать IP-адрес (например: "121.111.1.1") или ' дружественное имя, как в нижеприведенном коде. tcpClient.RemoteHost = "RemoteComputerName" 'или "121.111.1.1" tcpClient.RemotePort = 1001 End Sub Private Sub cmdConnect_Click() ' Вызвать метод Connect для создания соединения tcpClient.Connect End Sub Private Sub txtSend_Change() tcpClient.SendData txtSend.Text End Sub Private Sub tcpClient_DataArrival (ByVal bytesTotal As Long) Dim strData As String tcpClient.GetData strData txtOutput.Text = strData End Sub Сохраните проект в отдельной директории. Код приведенный выше - это простейшее клиент-серверное приложение. Чтобы попробовать, как это все работает на одной машине в связке, имитирующей межмашинное соединение, значение свойства RemoteHost приложения-клиента должно соответствовать дружественному имени или IP-адресу вашего компьютера. Запустите проект и нажмите кнопку "Connect". После этого наберите текст внутри текстового поля txtSendData на каждой форме и убедитесь, что тот же самый текст появится в текстовом поле txtOutput другой формы. Если Вы хотите, попробовать, как приложения будут осуществлять связь между двумя компьютерами, то Вам прийдется произвести следующие действия: Удалить из кода формы приложения-сервера строку frmClient.Show. В окне Project Explorer щелкнуть правой кнопкой мыши на форме frmClient.frm и в появившемся меню выбрать Remove frmClient.frm после чего сохранить проект под именем Server1. Открыть первый вариант проекта и таким же образом удалить из проекта уже форму frmServer.frm. Создать exe модуль для frmClient-а и переписать его на удаленный компьютер и запустить его там. Примечание: если на удаленном компьютере не установлен VB будьте готовы к тому, что вам потребуется переписать на него из WINDOWS\SYSTEM\mswinsck.ocx и зарегистрировать его при помощи команды WINDOWS\SYSTEM\regsvr32.exe mswinsck.ocx Если приложение будет требовать какие-то дополнительные dll модули перепишите их со своей машины на удаленную. На своей машине, откройте проект Server и запустите его. На клиентской машине нажмите кнопку Connect и наберите текст внутри текстового поля txtSendData на каждой форме и убедитесь, что тот же самый текст появится в текстовом поле txtOutput в приложении, запущенном на другом компьютере. Обработка более чем одного запроса на установление соединения Приложение-сервер, которое мы создавали сначала может обработать только один запрос на соединение. Тем не менее, существует возможность обработать несколько запросов на соединение, используя тот же самый управляющий элемент как один из массива управляющих элементов. В этом случае, необязательно закрывать соединение - просто создайте новый вариант управляющего элемента (использовав его свойство Index) и вызовите метод Accept для этого нового варианта управляющего элемента. В приведенном ниже тексте программы, свойству Index, размещенного на форме Winsock-компонента sckServer, присваивается значение 0, таким образом, управляющий элемент становится частью массива управляющих элементов. В разделе Declarations описана локальная переменная intMax. Когда для формы происходит событие Load, переменной intMax присваивается значение 0 и свойству LocalPort первого элемента массива управляющих элементов присваивается значение 1001. Только после того, как вызывается метод Listen этого управляющего элемента, он начинает слушать указанный порт. Когда поступает новый запрос на соединение, осуществляется проверка значения Index и равно ли оно 0 (значение элемента, который слушает порт). Таким образом, элемент который слушает порт, будет приращивать переменную intMax и использовать значение этой переменной для создания нового элемента массива. Этот новый элемент будет использоваться для обработки запроса на соединение. Private intMax As Long Private Sub Form_Load() intMax = 0 sckServer(0).LocalPort = 1001 sckServer(0).Listen End Sub Private Sub sckServer_ConnectionRequest (Index As Integer, ByVal requestID As Long) If Index = 0 Then intMax = intMax + 1 Load sckServer(intMax) sckServer(intMax).LocalPort = 0 sckServer(intMax).Accept requestID Load txtData(intMax) End If End Sub Основы UDP Создавать приложения, использующие UDP протокол проще, чем создавать приложения, использующие TCP протокол. Дело в том, что UDP не требует уже установленного соединения, как необходимого условия для передачи данных. В приложениях использующих TCP соединение, один Winsock элемент должен обязательно "слушать" порт, в ожидании пока какое-нибудь другое приложение не станет инициатором соединения, использовав метод Connect. UDP протокол не требует обязательно установленного соединения для передачи данных. Для передачи данных между двумя приложениями, необходимо выполнить три следующих пункта с обеих соединяющихся сторон: присвоить свойству RemoteHost дружественное имя или IP-адрес компьютера с которым предстоит соединение; установить свойство RemotePort для LocalPort property of the second control. Вызвать метод Bind указав какой локальный порт будет использоваться (метод Bind подробнее будет обсужден ниже). Т.к. оба компьютера полагаются равными в установлении соединения, мы можем назвать это соединение peer-to-peer. Чтобы продемонстрировать это соединение мы создадим так называемое приложение-chat позволяющее двум людям общаться в реальном режиме времени. Для создания UDP соединения Создайте Standard EXE проект. Измените свойство name формы на frmPeerA. Измените свойство caption формы на "Peer A" Перетащите с панели инструментов иконку Winsock компонента и разместите его на форме. Присвойте свойству name значение udpPeerA. Измените свойство Protocol на UDPProtocol. Добавьте два текстовых поля на форму. Имя первой должно быть txtSend а второй txtOutput. Добавьте приведенный ниже код на форму. Private Sub Form_Load() ' Имя Winsock элемента udpPeerA With udpPeerA ' Важно: правильно укажите значение RemoteHost ' компьютера, с которым предстоит соединение. .RemoteHost= "PeerB" .RemotePort = 1001 ' Имя порта для соединения. .Bind 1002 ' Привязка к локальному порту. End With frmPeerB.Show ' Показать вторую форму. End Sub Private Sub txtSend_Change() ' Послать текст, как только он будет набран. udpPeerA.SendData txtSend.Text End Sub Private Sub udpPeerA_DataArrival (ByVal bytesTotal As Long) Dim strData As String udpPeerA.GetData strData txtOutput.Text = strData End Sub Чтобы создать второе UDP приложение Добавить стандартную форму в проект. Изменить имя формы на frmPeerB. Изменить свойство caption формы на "Peer B". Перетащить и разместить иконку Winsock компонента на форму. Изменить имя Winsock на udpPeerB. Изменить свойство Protocol на UDPProtocol. Добавить два текстовых поля на форму. Имя первого должно быть txtSend, а второго txtOutput. Добавьте следующий код в форму. Private Sub Form_Load() ' Имя Winsock элемента udpPeerB. With udpPeerB ' Будьте внимательны указывая имя или IP-адрес ' компьютера с которым предстоит соединение. .RemoteHost= "PeerA" .RemotePort = 1002 ' Номер порта для соединения. .Bind 1001 ' Привязка к локальному порту. End With End Sub Private Sub txtSend_Change() ' Пересылать текст, как только он будет набран в текстовом поле. udpPeerB.SendData txtSend.Text End Sub Private Sub udpPeerB_DataArrival (ByVal bytesTotal As Long) Dim strData As String udpPeerB.GetData strData txtOutput.Text = strData End Sub Чтобы попробовать приложение запустите проект, и наберите в текстовом поле txtSend каждой формы какой-то текст. Этот текст появится в текстовых полях txtOutput другой формы. О методе Bind Как показано в приведенном выше примере, Вы должны вызывать метод Bind, когда создается UDP приложение. Метод Bind резервирует локальный порт для использования его элементом Winsock. Например, когда Вы привязываете свой элемент Winsock к порту 1001, то ни одно другое приложение не может использовать этот порт для прослушивания. Это может быть полезным, когда Вы хотите воспрепятствовать какому-либо другому приложению использовать этот порт. Метод Bind имеет еще один необязательный аргумент. Если на вашем компьютере установлено более одного сетевого адаптера, аргумент LocalIP позволит Вам точно указать адаптер, который необходимо использовать. Если Вы не укажите этот аргумент, то Winsock компонент будет использовать тот сетевой адаптер, который расположен первым в списке, который можно посмотреть в Пуск\Настройка\Панель управления\Система\Сетевые платы. Когда используется UDP протокол, Вы можете изменять свойства RemoteHost и RemotePort пока сохраняется привязка к тому же самому LocalPort. Если бы Вы использовали TCP протокол, то прежде чем сменить свойства RemoteHost и RemotePort, необходимо сначала закрыть соединение. Автор: Oleg Palayda Наверх 10. Как заставить Winsock работать с несколькими соединениями? - VB
Добавьте контрол Winsock в Вашу форму и установите его индекс в 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 Теперь Мы можем продолжать ожидать соединения. Наверх | ||
