Интернет FAQ

Где в реестре хранятся все интернет-соединения?

ключ HKEY_CURRENT_USER\RemoteAccess\Addresses

Как получить IP адрес?

'1 ВАРИАНТ
'Расположите на форме компонент Winsock(Winsock1) через меню Project|Components - Microsoft Winsock Control 6.0

Private Sub Form_Load()
MsgBox Winsock1.LocalIP
End Sub

'2 ВАРИАНТ

'Вставьте следующий код в событие формы
Private Sub Form_Load()
MsgBox "IP Host Name: " & GetIPHostName()
MsgBox "IP Address: " & GetIPAddress()
End Sub

'Добавьте модуль в проект. Вставьте следующий код в модуль
Public Const MAX_WSADescription = 256
Public Const MAX_WSASYSStatus = 128
Public Const ERROR_SUCCESS As Long = 0
Public Const WS_VERSION_REQD As Long = &H101
Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD As Long = 1
Public Const SOCKET_ERROR As Long = -1
Public Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Public Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Integer
wMaxUDPDG As Integer
dwVendorInfo As Long
End Type
Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Public Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Public Function GetIPAddress() As String
Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
If Not SocketsInitialize() Then
GetIPAddress = ""
Exit Function
End If
If gethostname(sHostName, 256) = SOCKET_ERROR Then
GetIPAddress = ""
MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
sHostName = Trim$(sHostName)
lpHost = gethostbyname(sHostName)
If lpHost = 0 Then
GetIPAddress = ""
MsgBox "Windows Sockets are not responding. " & "Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4
ReDim tmpIPAddr(1 To HOST.hLen)
CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
For i = 1 To HOST.hLen
sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
SocketsCleanup
End Function
Public Function GetIPHostName() As String
Dim sHostName As String * 256
If Not SocketsInitialize() Then
GetIPHostName = ""
Exit Function
End If
If gethostname(sHostName, 256) = SOCKET_ERROR Then
GetIPHostName = ""
MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
SocketsCleanup
End Function
Public Function HiByte(ByVal wParam As Integer)
HiByte = wParam \ &H100 And &HFF&
End Function
Public Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function
Public Sub SocketsCleanup()
If WSACleanup() <> ERROR_SUCCESS Then
MsgBox "Socket error occurred in Cleanup."
End If
End Sub
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
Dim sLoByte As String
Dim sHiByte As String
If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
MsgBox "The 32-bit Windows Socket is not responding."
SocketsInitialize = False
Exit Function
End If
If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
MsgBox "This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets."
SocketsInitialize = False
Exit Function
End If
If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
sHiByte = CStr(HiByte(WSAD.wVersion))
sLoByte = CStr(LoByte(WSAD.wVersion))
MsgBox "Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets."
SocketsInitialize = False
Exit Function
End If
SocketsInitialize = True
End Function

Как программно отсоединиться от Интернета?

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

Как напечатать Web-страницу?

Private Const MAX_PATH = 255
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Function PrintWebPage(ByVal URL As String) As Boolean
Dim sFile As String
sFile = SystemDir & "\MSHTML.DLL"
If Dir(sFile) = "" Then Exit Function
On Error Resume Next
Shell "rundll32.exe " & sFile & ",PrintHTML " & URL, vbNormalFocus
PrintWebPage = Err.Number = 0
End Function
Private Function SystemDir() As String
Dim sRet As String, lngRet As Long
sRet = String$(MAX_PATH, 0)
lngRet = GetSystemDirectory(sRet, MAX_PATH)
SystemDir = Left(sRet, lngRet)
End Function

Private Sub Command1_Click()
PrintWebPage "http://vbprosto.narod.ru"
End Sub

Как вызвать окно "Установка связи с Интернетом"?

Private Sub Form_Load()
Result = Shell("rundll32.exe rnaui.DLL,RnaDial " & "connection_name", 1)
End Sub

Интернет: онлайн или офлайн?

Данный пример покажет, есть ли в данное время активное соединение с Интернетом

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 Form_Load()
'если есть соединение, то IsConnected() = True, иначе False
MsgBox IsConnected()
End Sub

Как получение списка всех интернет-соединений?

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

Имя текущего соединения с инетом?

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

Запуск почты и web-узла

'Вариант 1
'Добавьте на форму 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://www.vbnet.ru"
Label2.Caption = "bigsharig@mtu-net.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

'Вариант 2
Call Shell("Start.exe " & "http://www.vbnet.ru", 0)
Call Shell("Start.exe " & "mailto:bigsharig@mtu-net.ru", 0)

'Вариант 3
'Добавьте на форму 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) As Long
Private Sub ExecuteLink(ByVal sLinkTo As String)
On Error Resume Next
Dim lRet As Long
Dim lOldCursor As Long
lOldCursor = Screen.MousePointer
Screen.MousePointer = vbHourglass
lRet = ShellExecute(0, "open", sLinkTo, "", vbNull, SW_SHOWNORMAL)
If lRet >= 0 And lRet <= 0 Then
Screen.MousePointer = vbDefault
MsgBox "Error Opening Link to " & sLinkTo & vbCrLf & vbCrLf & Err.LastDllError, , "frmAbout::ExecuteLink"
End If
Screen.MousePointer = vbDefault
End Sub
Private Sub Label1_Click()
ExecuteLink "mailto:bigsharig@mtu-net.ru"
End Sub
Private Sub Label2_Click()
ExecuteLink "http://www.vbnet.ru"
End Sub

Является ли строковая переменная e-mail-адресом?

Добавьте 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

Получение сведений из web-страницы?

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
'Parse protocol
If (InStr(1, strTemp, "://") > 0) Then
'URL contains protocol
ParseURL.Protocol = Left(strTemp, InStr(1, strTemp, "://") - 1)
strTemp = Right(strTemp, Len(strTemp) - (Len(ParseURL.Protocol) + 3)) 'delete protocol + ://
Else
'URL do not contains the protocol
ParseURL.Protocol = strNOCONTENT
End If
'- Parse authenticate information
If (InStr(1, strTemp, "/") > 0) Then
'extract servername and user and password if there are directory infos
strServerAuth = Left(strTemp, InStr(1, strTemp, "/") - 1)
strTemp = Right(strTemp, Len(strTemp) - (Len(strServerAuth) + 1))
Else
'extract servername and user and password if there are no directory infos
strServerAuth = strTemp
strTemp = "/"
End If

If (InStr(1, strServerAuth, "@") > 0) Then
'there are user and password informations
strAuth = Left(strServerAuth, InStr(1, strServerAuth, "@") - 1)
strServerNPort = Right(strServerAuth, Len(strServerAuth) - (Len(strAuth) + 1))
Else
'there are no user and password informations
strAuth = ""
strServerNPort = strServerAuth
End If

If (InStr(1, strAuth, ":") > 0) And (Len(strAuth) > 0) Then
'split username and password on ":" splitter
ParseURL.Username = Left(strAuth, InStr(1, strAuth, ":") - 1)
ParseURL.Password = Right(strAuth, Len(strAuth) - InStr(1, strAuth, ":"))
ElseIf (InStr(1, strAuth, ":") <> 0) Then
'only username was submitted
ParseURL.Username = strAuth
ParseURL.Password = strNOCONTENT
Else
'no authenticate information was submitted
ParseURL.Username = strNOCONTENT
ParseURL.Password = strNOCONTENT
End If

If (InStr(1, strServerNPort, ":") > 0) Then
'Servername contains port
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://sharig.webzone.ru/IndexMainTopic.htm"
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

Определить дату изменения web-страницы

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

Создать ссылку на страницу в Интернете

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://vbnet.ru"
End Sub

Как сохранить содержимое web-страницы на диск?

'Вариант 1
'Расположите на форме элемент Inet (меню Project|Components - Microsoft Internet Transfer Control 6.0).
Private Sub Form_Load()
Dim b() As Byte
'установить протокол HTTP
Inet1.Protocol = icHTTP
'установить скачиваемый адрес
Inet1.URL = "http://www.microsoft.com"
'загрузить данные 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://sharig.webzone.ru", "c:\sharig_webzone_ru.htm"
End Sub

'Вариант 3
'Расположите на форме элемент CommandButton. Данный пример только загрузить данные со страницы в элемент TextBox. А здесь вы можете узнать, как сохранить содержимое TextBox'а в файл.
Private Sub Command1_Click()
On Error GoTo handle
Text1.Text = Inet1.OpenURL(Text2.Text, icString)
Exit Sub
handle: MsgBox "Error " & Err.Description
End Sub

Как вытащить все ссылки из 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

Практические советы по использованию компонента WebBrowser

Расположите на основной форме 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

Добавить сайт в список "Избранное"

Option Explicit
Public Enum SpecialShellFolderIDs
CSIDL_DESKTOP = &H0
CSIDL_INTERNET = &H1
CSIDL_PROGRAMS = &H2
CSIDL_CONTROLS = &H3
CSIDL_PRINTERS = &H4
CSIDL_PERSONAL = &H5
CSIDL_FAVORITES = &H6
CSIDL_STARTUP = &H7
CSIDL_RECENT = &H8
CSIDL_SENDTO = &H9
CSIDL_BITBUCKET = &HA
CSIDL_STARTMENU = &HB
CSIDL_DESKTOPDIRECTORY = &H10
CSIDL_DRIVES = &H11
CSIDL_NETWORK = &H12
CSIDL_NETHOOD = &H13
CSIDL_FONTS = &H14
CSIDL_TEMPLATES = &H15
CSIDL_COMMON_STARTMENU = &H16
CSIDL_COMMON_PROGRAMS = &H17
CSIDL_COMMON_STARTUP = &H18
CSIDL_COMMON_DESKTOPDIRECTORY = &H19
CSIDL_APPDATA = &H1A
CSIDL_PRINTHOOD = &H1B
CSIDL_ALTSTARTUP = &H1D
CSIDL_COMMON_ALTSTARTUP = &H1E
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As SpecialShellFolderIDs, pidl As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Public Function AddFavorite(SiteName As String, URL As String) As Boolean
'SiteName - название сайта, URL - адрес сайта в Инете
Dim pidl As Long
Dim psFullPath As String
Dim iFile As Integer
On Error GoTo ErrorHandler
iFile = FreeFile
psFullPath = Space(255)
If SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, pidl) = 0 Then
If pidl Then
If SHGetPathFromIDList(pidl, psFullPath) Then
psFullPath = TrimWithoutPrejudice(psFullPath)
If Right(psFullPath, 1) <> "\" Then psFullPath = psFullPath & "\"
psFullPath = psFullPath & SiteName & ".URL"
Open psFullPath For Output As #iFile
Print #iFile, "[InternetShortcut]"
Print #iFile, "URL=" & URL
Close #iFile
End If
CoTaskMemFree pidl
AddFavorite = True
End If
End If
ErrorHandler:
End Function
Public Function TrimWithoutPrejudice(ByVal InputString As String) As String
Dim sAns As String
Dim sWkg As String
Dim sChar As String
Dim lLen As Long
Dim lCtr As Long
sAns = InputString
lLen = Len(InputString)
If lLen > 0 Then
For lCtr = 1 To lLen
sChar = Mid(sAns, lCtr, 1)
If Asc(sChar) > 32 Then Exit For
Next
sAns = Mid(sAns, lCtr)
lLen = Len(sAns)
If lLen > 0 Then
For lCtr = lLen To 1 Step -1
sChar = Mid(sAns, lCtr, 1)
If Asc(sChar) > 32 Then Exit For
Next
End If
sAns = Left$(sAns, lCtr)
End If
TrimWithoutPrejudice = sAns
End Function

Private Sub Form_Load()
AddFavorite "Сайт VBnet.RU", "http://vbnet.ru"
End Sub

Получение URL из адресной строки Microsoft Internet Explorer

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 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessageLong& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Const WM_USER = &H400

Const EM_LIMITTEXT = WM_USER + 21
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const EM_GETLINECOUNT = &HBA
Private Const EM_LINEINDEX = &HBB
Private Const EM_LINELENGTH = &HC1

Private Sub Command1_Click()
On Error GoTo CallErrorA
Dim iPos As Integer
Dim sClassName As String
Dim GetAddressText As String
Dim lhwnd As Long
Dim WindowHandle As Long
lhwnd = 0
sClassName = ("IEFrame")
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
sClassName = ("WorkerA")
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
sClassName = ("ReBarWindow32")
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
sClassName = ("ComboBoxEx32")
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
sClassName = ("ComboBox")
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
sClassName = ("Edit")
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
WindowHandle& = lhwnd
Dim buffer As String, TextLength As Long
TextLength& = SendMessage(WindowHandle&, WM_GETTEXTLENGTH, 0&, 0&)
buffer$ = String(TextLength&, 0&)
Call SendMessageByString(WindowHandle&, WM_GETTEXT, TextLength& + 1, buffer$)
MsgBox buffer$
Exit Sub
CallErrorA:
MsgBox Err.Description
Err.Clear
End Sub

Автозавершение набора URL

Option Explicit
Private Const SHACF_AUTOSUGGEST_FORCE_ON As Long = &H10000000
Private Const SHACF_AUTOSUGGEST_FORCE_OFF As Long = &H20000000
Private Const SHACF_AUTOAPPEND_FORCE_ON As Long = &H40000000
Private Const SHACF_AUTOAPPEND_FORCE_OFF As Long = &H80000000
Private Const SHACF_DEFAULT As Long = &H0
Private Const SHACF_FILESYSTEM As Long = &H1
Private Const SHACF_URLHISTORY As Long = &H2
Private Const SHACF_URLMRU As Long = &H4
Private Const SHACF_URLALL As Long = (SHACF_URLHISTORY Or SHACF_URLMRU)

Private Const DLLVER_PLATFORM_WINDOWS As Long = &H1 'Windows 95
Private Const DLLVER_PLATFORM_NT As Long = &H2 'Windows NT

Private Type DllVersionInfo
cbSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformID As Long
End Type

Private Declare Function SHAutoComplete Lib "Shlwapi.dll" (ByVal hwndEdit As Long, ByVal dwFlags As Long) As Long
Private Declare Function DllGetVersion Lib "Shlwapi.dll" (dwVersion As DllVersionInfo) As Long

Private Function GetIEVersion(DVI As DllVersionInfo) As Long
DVI.cbSize = Len(DVI)
Call DllGetVersion(DVI)
GetIEVersion = DVI.dwMajorVersion
End Function

Private Function GetIEVersionString() As String
Dim DVI As DllVersionInfo
DVI.cbSize = Len(DVI)
Call DllGetVersion(DVI)
GetIEVersionString = "Internet Explorer " & DVI.dwMajorVersion & "." & DVI.dwMinorVersion & "." & DVI.dwBuildNumber
End Function

Private Sub Command1_Click()
Dim DVI As DllVersionInfo
If GetIEVersion(DVI) >= 5 Then
Call SHAutoComplete(Text1.hWnd, SHACF_DEFAULT)
Command1.Caption = "Автозавершение включено"
Command1.Enabled = False
Text1.SetFocus
Text1.SelStart = Len(Text1.Text)
Else
MsgBox "Простите, но у вас не установлен IE5", vbExclamation
End If
End Sub

Private Sub Form_Load()
Dim DVI As DllVersionInfo
Label1 = "Использование Shlwapi.dll для " & GetIEVersionString
Command1.Enabled = GetIEVersion(DVI) >= 5
Command1.Caption = "Автозавершение выключено"
End Sub

Запрещение запуска дополнительных окон 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

Определение имени текущего домена и имени пользователя

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function LookupAccountName Lib "advapi32.dll" Alias "LookupAccountNameA" (lpSystemName As String, ByVal lpAccountName As String, sid As Any, cbSid As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Long) As Long
Public Function GetLogonDomainuser() As String
Dim lResult As Long
Dim I As Integer
Dim bUserSid(255) As Byte
Dim sUserName As String
Dim sDomainName As String * 255
Dim lDomainNameLength As Long
Dim lSIDType As Long
sUserName = GetLogonUser
lResult = LookupAccountName(vbNullString, sUserName, bUserSid(0), 255, sDomainName, lDomainNameLength, lSIDType)
sDomainName = Space(lDomainNameLength)
lResult = LookupAccountName(vbNullString, sUserName, bUserSid(0), 255, sDomainName, lDomainNameLength, lSIDType)
If (lResult = 0) Then
MsgBox "Ошибка: невозможно найти имя домена для юзера: " & sUserName
Exit Function
End If
sDomainName = Left$(sDomainName, InStr(sDomainName, Chr$(0)) - 1)
GetLogonDomainuser = Trim(sDomainName)
End Function
Private Function GetLogonUser() As String
Dim strTemp As String, strUserName As String
strTemp = String(100, Chr$(0))
strTemp = Left$(strTemp, InStr(strTemp, Chr$(0)) - 1)
strUserName = String(100, Chr$(0))
GetUserName strUserName, 100
strUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1)
GetLogonUser = strUserName
End Function

Public Function UserName() As String
Dim cn As String
Dim ls As Long
Dim res As Long
cn = String(1024, 0)
ls = 1024
res = GetUserName(cn, ls)
If res <> 0 Then
UserName = Mid(cn, 1, InStr(cn, Chr(0)) - 1)
Else
UserName = ""
End If
End Function

Private Sub Command1_Click()
MsgBox GetLogonDomainuser
MsgBox GetLogonUser 'или MsgBox UserName
End Sub

Подключение/отключение сетевого диска

'КОД ФОРМЫ

Private Sub Command1_Click()
Call Module1.Connect("Oksana\c$", "K:", "defaultsharename", "garik")
If (Module1.rc <> 0) And (Module1.rc <> 85) Then
MsgBox Module1.ErrorMsg
End If
End Sub

Private Sub Command2_Click()
Call Module1.DisConnect("K:", True)
If (Module1.rc <> 0) And (Module1.rc <> 85) Then
MsgBox Module1.ErrorMsg
End If
End Sub

'КОД МОДУЛЯ

Option Explicit
Public Declare Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETRESOURCE, ByVal lpPassword As String, ByVal lpUsername As String, ByVal dwFlags As Long) As Long
Public Declare Function WNetCancelConnection2 Lib "mpr.dll" Alias "WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As Long, ByVal fForce As Long) As Long

Public ErrorNum As Long
Public ErrorMsg As String
Public rc As Long
Public RemoteName As String

Public Const ERROR_BAD_DEV_TYPE = 66&
Public Const ERROR_ALREADY_ASSIGNED = 85&
Public Const ERROR_ACCESS_DENIED = 5&
Public Const ERROR_BAD_NET_NAME = 67&
Public Const ERROR_BAD_PROFILE = 1206&
Public Const ERROR_BAD_PROVIDER = 1204&
Public Const ERROR_BUSY = 170&
Public Const ERROR_CANCEL_VIOLATION = 173&
Public Const ERROR_CANNOT_OPEN_PROFILE = 1205&
Public Const ERROR_DEVICE_ALREADY_REMEMBERED = 1202&
Public Const ERROR_EXTENDED_ERROR = 1208&
Public Const ERROR_INVALID_PASSWORD = 86&
Public Const ERROR_NO_NET_OR_BAD_PATH = 1203&
Public Const ERROR_NO_NETWORK = 1222&
Public Const ERROR_NO_CONNECTION = 8
Public Const ERROR_NO_DISCONNECT = 9
Public Const ERROR_DEVICE_IN_USE = 2404&
Public Const ERROR_NOT_CONNECTED = 2250&
Public Const ERROR_OPEN_FILES = 2401&
Public Const ERROR_MORE_DATA = 234

Public Const CONNECT_UPDATE_PROFILE = &H1
Public Const RESOURCETYPE_DISK = &H1

Public Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
lpLocalName As String
lpRemoteName As String
lpComment As String
lpProvider As String
End Type

Public lpNetResourse As NETRESOURCE

Public Sub Connect(ByVal HostName As String, ByVal RemoteName As String, ByVal Username As String, ByVal Password As String)
Dim lpUsername As String
Dim lpPassword As String
On Error GoTo Err_Connect
ErrorNum = 0
ErrorMsg = ""
lpNetResourse.dwType = RESOURCETYPE_DISK
lpNetResourse.lpLocalName = RemoteName & Chr(0)
'Drive Letter to use
lpNetResourse.lpRemoteName = "\\" & HostName & Chr(0)
'Network Path to share
lpNetResourse.lpProvider = Chr(0)
lpPassword = Password & Chr(0)
'password on share pass "" if none
lpUsername = Username & Chr(0)
'username to connect as if applicable
rc = WNetAddConnection2(lpNetResourse, lpPassword, lpUsername, CONNECT_UPDATE_PROFILE)
If rc <> 0 Then GoTo Err_Connect
Exit Sub
Err_Connect:
ErrorNum = rc
ErrorMsg = WnetError(rc)
End Sub

Public Sub DisConnect(ByVal Name As String, ByVal ForceOff As Boolean)
On Error GoTo Err_DisConnect
ErrorNum = 0
ErrorMsg = ""
rc = WNetCancelConnection2(Name & Chr(0), CONNECT_UPDATE_PROFILE, ForceOff)
If rc <> 0 Then GoTo Err_DisConnect
Exit Sub
Err_DisConnect:
ErrorNum = rc
ErrorMsg = WnetError(rc)
End Sub

Private Function WnetError(Errcode As Long) As String
Select Case Errcode
Case ERROR_BAD_DEV_TYPE
WnetError = "Bad device."
Case ERROR_ALREADY_ASSIGNED
WnetError = "Already Assigned."
Case ERROR_ACCESS_DENIED
WnetError = "Access Denied."
Case ERROR_BAD_NET_NAME
WnetError = "Bad net name"
Case ERROR_BAD_PROFILE
WnetError = "Bad Profile"
Case ERROR_BAD_PROVIDER
WnetError = "Bad Provider"
Case ERROR_BUSY
WnetError = "Busy"
Case ERROR_CANCEL_VIOLATION
WnetError = "Cancel Violation"
Case ERROR_CANNOT_OPEN_PROFILE
WnetError = "Cannot Open Profile"
Case ERROR_DEVICE_ALREADY_REMEMBERED
WnetError = "Device already remembered"
Case ERROR_EXTENDED_ERROR
WnetError = "Device already remembered"
Case ERROR_INVALID_PASSWORD
WnetError = "Invalid Password"
Case ERROR_NO_NET_OR_BAD_PATH
WnetError = "Could not find the specified device"
Case ERROR_NO_NETWORK
WnetError = "No Network Present"
Case ERROR_DEVICE_IN_USE
WnetError = "Connection Currently in use "
Case ERROR_NOT_CONNECTED
WnetError = "No Connection Present"
Case ERROR_OPEN_FILES
WnetError = "Files open and the force parameter is false"
Case ERROR_MORE_DATA
WnetError = "Buffer to small to hold network name, make lpnLength bigger"
Case Else:
WnetError = "Unrecognized Error " + Str(Errcode) + "."
End Select
End Function

Определение имени или IP-адреса удаленного компьютера в сети

'КОД ФОРМЫ

Private Sub Command1_Click()
'Вначале вы должны инициализировать winsock
WinsockInit
'Определение имени машины, зная ее IP-адрес
MsgBox HostByAddress("192.168.1.1")
MsgBox HostByAddress("192.168.1.2")
'Определение IP-адреса машины, зная ее имя
MsgBox HostByName("GARIK")
MsgBox HostByName("OKSANA")
'В конце работы вы должны использовать функцию WSACleanUp
WSACleanUp
End Sub

'КОД МОДУЛЯ

Option Explicit
Public Const SOCKET_ERROR = -1
Public Const AF_INET = 2
Public Const PF_INET = AF_INET
Public Const MAXGETHOSTSTRUCT = 1024
Public Const SOCK_STREAM = 1
Public Const MSG_PEEK = 2
Private Type SockAddr
sin_family As Integer
sin_port As Integer
sin_addr As String * 4
sin_zero As String * 8
End Type
Private Type T_WSA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To 255) As Byte
szSystemStatus(0 To 128) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Dim WSAData As T_WSA
Type Inet_Address
Byte4 As String * 1
Byte3 As String * 1
Byte2 As String * 1
Byte1 As String * 1
End Type
Public IPStruct As Inet_Address
Public Type T_Host
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type

Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb&)
Declare Function gethostbyaddr Lib "wsock32.dll" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long
Declare Function inet_addr Lib "wsock32.dll" (ByVal addr As String) As Long
Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal HostName As String) As Long
Declare Function GetHostName Lib "wsock32.dll" Alias "gethostname" (ByVal HostName As String, HostLen As Long) As Long
Declare Function WSAStartup Lib "wsock32.dll" (ByVal a As Long, b As T_WSA) As Long
Declare Function WSACleanUp Lib "wsock32.dll" Alias "WSACleanup" () As Integer

Function HostByName(sHost As String) As String
Dim s As String
Dim p As Long
Dim Host As T_Host
Dim ListAddress As Long
Dim ListAddr As Long
Dim Address As Long
s = String(64, 0)
sHost = sHost + Right(s, 64 - Len(sHost))
p = GetHostByName(sHost)
If p = SOCKET_ERROR Then
Exit Function
Else
If p <> 0 Then
CopyMemory Host.h_name, ByVal p, Len(Host)
ListAddress = Host.h_addr_list
CopyMemory ListAddr, ByVal ListAddress, 4
CopyMemory Address, ByVal ListAddr, 4
HostByName = InetAddrLongToString(Address)
Else
HostByName = "No DNS Entry"
End If
End If
End Function

Private Function InetAddrLongToString(Address As Long) As String
CopyMemory IPStruct, Address, 4
InetAddrLongToString = CStr(Asc(IPStruct.Byte4)) + "." + CStr(Asc(IPStruct.Byte3)) + "." + CStr(Asc(IPStruct.Byte2)) + "." + CStr(Asc(IPStruct.Byte1))
End Function

Function HostByAddress(ByVal sAddress As String) As String
Dim lAddress As Long
Dim p As Long
Dim HostName As String
Dim Host As T_Host
lAddress = inet_addr(sAddress)
p = gethostbyaddr(lAddress, 4, PF_INET)
If p <> 0 Then
CopyMemory Host, ByVal p, Len(Host)
HostName = String(256, 0)
CopyMemory ByVal HostName, ByVal Host.h_name, 256
If HostName = "" Then HostByAddress = "Unable to Resolve Address"
HostByAddress = Left(HostName, InStr(HostName, Chr(0)) - 1)
Else
HostByAddress = "No DNS Entry"
End If
End Function

Public Sub WinsockInit()
WSAStartup &H101, WSAData
End Sub

Как загрузить файл из интернета?

Private Declare Function DoFileDownload Lib "shdocvw.dll" (ByVal lpszFile As String) As Long

Private Sub Command1_Click()
DownLoadFile "http://demin.narod.ru/2001/wall/", "wall3.jpg"
End Sub

Public Sub DownLoadFile(sUrl As String, sFile As String)
Dim DL As Long
On Error GoTo errHandler
If sUrl$ = "" Then sUrl$ = strUrl$
If strUrl$ = "" Then strUrl$ = sUrl$
If Left(strUrl$, 4) <> "http" Then strUrl$ = "http://" & strUrl$
If Right$(strUrl$, 1) <> "/" Then strUrl$ = strUrl$ & "/"
If Left$(sFile$, 1) = "/" Then sFile = Mid$(sFile$, 2)
DL& = DoFileDownload(StrConv(strUrl$ & sFile$, vbUnicode))
Exit Sub
errHandler:
Debug.Print "Error Source:", Err.Source
Debug.Print "Error Description:", Err.Description
Debug.Print "Error Number:", Err.Number
MsgBox "An error has occured attempting to start download to " & sUrl & sFile$ & ".", vbApplicationModal + vbCritical + vbDefaultButton1, "Error"
End Sub

Сохранение файла из Интернета на жесткий диск?

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 Event ErrorDownload(FromPathName As String, ToPathName As String)
Public Event DownloadComplete(FromPathName As String, ToPathName As String)

Public Function DownloadFile(FromPathName As String, ToPathName As String)
If URLDownloadToFile(0, FromPathName, ToPathName, 0, 0) = 0 Then
DownloadFile = True
RaiseEvent DownloadComplete(FromPathName, ToPathName)
Else
DownloadFile = False
RaiseEvent ErrorDownload(FromPathName, ToPathName)
End If
End Function

Private Sub Command1_Click()
Call DownloadFile("http://vbnet.ru/subscribe/images/question.gif", "c:\1.gif")
End Sub