C WinSock'ом не в ладах но может поможет
из API-guid
'This project needs a TextBox
'-> (Name)=Text1
'-> MultiLine=True
'in a form
Private Sub Form_Load()
'KPD-Team 2000
'URL:
http://www.allapi.net/
'E-Mail:
KPDTeam@Allapi.net
Dim sSave As String
Me.AutoRedraw = True
Set Obj = Me.Text1
'Start subclassing
HookForm Me
'create a new winsock session
StartWinsock sSave
'show the winsock version on this form
If InStr(1, sSave, Chr$(0)) > 0 Then sSave = Left$(sSave, InStr(1, sSave, Chr$(0)) - 1)
Me.Print sSave
'connect to Microsoft.com
lSocket = ConnectSock("www.microsoft.com", 80, 0, Me.hwnd, False)
End Sub
Private Sub Form_Unload(Cancel As Integer)
'close our connection to microsoft.com
closesocket lSocket
'end winsock session
EndWinsock
'stop subclassing
UnHookForm Me
End Sub
'in a module
Public Const AF_INET = 2
Public Const INVALID_SOCKET = -1
Public Const SOCKET_ERROR = -1
Public Const FD_READ = &H1&
Public Const FD_WRITE = &H2&
Public Const FD_CONNECT = &H10&
Public Const FD_CLOSE = &H20&
Public Const PF_INET = 2
Public Const SOCK_STREAM = 1
Public Const IPPROTO_TCP = 6
Public Const GWL_WNDPROC = (-4)
Public Const WINSOCKMSG = 1025
Public Const WSA_DESCRIPTIONLEN = 256
Public Const WSA_DescriptionSize = WSA_DESCRIPTIONLEN + 1
Public Const WSA_SYS_STATUS_LEN = 128
Public Const WSA_SysStatusSize = WSA_SYS_STATUS_LEN + 1
Public Const INADDR_NONE = &HFFFF
Public Const SOL_SOCKET = &HFFFF&
Public Const SO_LINGER = &H80&
Public Const hostent_size = 16
Public Const sockaddr_size = 16
Type WSADataType
wVersion As Integer
wHighVersion As Integer
szDescription As String * WSA_DescriptionSize
szSystemStatus As String * WSA_SysStatusSize
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Type HostEnt
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type
Type sockaddr
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero As String * 8
End Type
Type LingerType
l_onoff As Integer
l_linger As Integer
End Type
Public Declare Function setsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal Level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Public Declare Function getsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal Level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
Public Declare Function WSAGetLastError Lib "wsock32.dll" () As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function WSAIsBlocking Lib "wsock32.dll" () As Long
Public Declare Function WSACleanup Lib "wsock32.dll" () As Long
Public Declare Function Send Lib "wsock32.dll" Alias "send" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function recv Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVR As Long, lpWSAD As WSADataType) As Long
Public Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer
Public Declare Function ntohs Lib "wsock32.dll" (ByVal netshort As Long) As Integer
Public Declare Function socket Lib "wsock32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Public Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
Public Declare Function Connect Lib "wsock32.dll" Alias "connect" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long
Public Declare Function WSAAsyncSelect Lib "wsock32.dll" (ByVal s As Long, ByVal hwnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
Public Declare Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long
Public Declare Function gethostbyname Lib "wsock32.dll" (ByVal host_name As String) As Long
Public Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb&)
Public Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn As Long) As Long
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Public Declare Function WSACancelBlockingCall Lib "wsock32.dll" () As Long
Public saZero As sockaddr
Public WSAStartedUp As Boolean, Obj As TextBox
Public PrevProc As Long, lSocket As Long
'subclassing functions
'for more information about subclassing,
'check out the subclassing tutorial at
http://www.allapi.net/
Public Sub HookForm(F As Form)
PrevProc = SetWindowLong(F.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub UnHookForm(F As Form)
If PrevProc <> 0 Then
SetWindowLong F.hwnd, GWL_WNDPROC, PrevProc
PrevProc = 0
End If
End Sub
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = WINSOCKMSG Then
ProcessMessage wParam, lParam
Else
WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
End If
End Function
'our Winsock-message handler
Public Sub ProcessMessage(ByVal lFromSocket As Long, ByVal lParam As Long)
Dim X As Long, ReadBuffer(1 To 1024) As Byte, strCommand As String
Select Case lParam
Case FD_CONNECT 'we are connected to microsoft.com
Case FD_WRITE 'we can write to our connection
'this is a part of the HTTP protocol
'for more information about this protocol, visit
http://www.w3c.org/
strCommand = "GET
http://www.microsoft.com/ HTTP/1.0" + vbCrLf
strcomand = strCommand + "Pragma: no-cache" + vbCrLf
strCommand = strCommand + "Accept: */*" + vbCrLf
strCommand = strCommand + "Accept: text/html" + vbCrLf + vbCrLf
'send the data to our microsoft.com-connection
SendData lFromSocket, strCommand
Case FD_READ 'we have data waiting to be processed
'start reading the data
Do
X = recv(lFromSocket, ReadBuffer(1), 1024, 0)
If X > 0 Then
Obj.Text = Obj.Text + Left$(StrConv(ReadBuffer, vbUnicode), X)
End If
If X <> 1024 Then Exit Do
Loop
Case FD_CLOSE 'the connection with microsoft.com is closed
End Select
End Sub
'the following functions are standard WinSock functions
'from the wsksock.bas-file
Public Function StartWinsock(sDescription As String) As Boolean
Dim StartupData As WSADataType
If Not WSAStartedUp Then
If Not WSAStartup(&H101, StartupData) Then
WSAStartedUp = True
sDescription = StartupData.szDescription
Else
WSAStartedUp = False
End If
End If
StartWinsock = WSAStartedUp
End Function
Sub EndWinsock()
Dim Ret&
If WSAIsBlocking() Then
Ret = WSACancelBlockingCall()
End If
Ret = WSACleanup()
WSAStartedUp = False
End Sub
Public Function SendData(ByVal s&, vMessage As Variant) As Long
Dim TheMsg() As Byte, sTemp$
TheMsg = ""
Select Case VarType(vMessage)
Case 8209 'byte array
sTemp = vMessage
TheMsg = sTemp
Case 8 'string, if we recieve a string, its assumed we are linemode
sTemp = StrConv(vMessage, vbFromUnicode)
Case Else
sTemp = CStr(vMessage)
sTemp = StrConv(vMessage, vbFromUnicode)
End Select
TheMsg = sTemp
If UBound(TheMsg) > -1 Then
SendData = Send(s, TheMsg(0), (UBound(TheMsg) - LBound(TheMsg) + 1), 0)
End If
End Function
Function ConnectSock(ByVal Host$, ByVal Port&, retIpPort$, ByVal HWndToMsg&, ByVal Async%) As Long
Dim s&, SelectOps&, Dummy&
Dim sockin As sockaddr
SockReadBuffer$ = ""
sockin = saZero
sockin.sin_family = AF_INET
sockin.sin_port = htons(Port)
If sockin.sin_port = INVALID_SOCKET Then
ConnectSock = INVALID_SOCKET
Exit Function
End If
sockin.sin_addr = GetHostByNameAlias(Host$)
If sockin.sin_addr = INADDR_NONE Then
ConnectSock = INVALID_SOCKET
Exit Function
End If
retIpPort$ = getascip$(sockin.sin_addr) & ":" & ntohs(sockin.sin_port)
s = socket(PF_INET, SOCK_STREAM, IPPROTO_TCP)
If s < 0 Then
ConnectSock = INVALID_SOCKET
Exit Function
End If
If SetSockLinger(s, 1, 0) = SOCKET_ERROR Then
If s > 0 Then
Dummy = closesocket(s)
End If
ConnectSock = INVALID_SOCKET
Exit Function
End If
If Not Async Then
If Connect(s, sockin, sockaddr_size) <> 0 Then
If s > 0 Then
Dummy = closesocket(s)
End If
ConnectSock = INVALID_SOCKET
Exit Function
End If
SelectOps = FD_READ Or FD_WRITE Or FD_CONNECT Or FD_CLOSE
If WSAAsyncSelect(s, HWndToMsg, ByVal 1025, ByVal SelectOps) Then
If s > 0 Then
Dummy = closesocket(s)
End If
ConnectSock = INVALID_SOCKET
Exit Function
End If
Else
SelectOps = FD_READ Or FD_WRITE Or FD_CONNECT Or FD_CLOSE
If WSAAsyncSelect(s, HWndToMsg, ByVal 1025, ByVal SelectOps) Then
If s > 0 Then
Dummy = closesocket(s)
End If
ConnectSock = INVALID_SOCKET
Exit Function
End If
If Connect(s, sockin, sockaddr_size) <> -1 Then
If s > 0 Then
Dummy = closesocket(s)
End If
ConnectSock = INVALID_SOCKET
Exit Function
End If
End If
ConnectSock = s
End Function
Function GetHostByNameAlias(ByVal hostname$) As Long
On Error Resume Next
Dim phe&
Dim heDestHost As HostEnt
Dim addrList&
Dim retIP&
retIP = inet_addr(hostname)
If retIP = INADDR_NONE Then
phe = gethostbyname(hostname)
If phe <> 0 Then
MemCopy heDestHost, ByVal phe, hostent_size
MemCopy addrList, ByVal heDestHost.h_addr_list, 4
MemCopy retIP, ByVal addrList, heDestHost.h_length
Else
retIP = INADDR_NONE
End If
End If
GetHostByNameAlias = retIP
If Err Then GetHostByNameAlias = INADDR_NONE
End Function
Function getascip(ByVal inn As Long) As String
On Error Resume Next
Dim lpStr&
Dim nStr&
Dim retString$
retString = String(32, 0)
lpStr = inet_ntoa(inn)
If lpStr = 0 Then
getascip = "255.255.255.255"
Exit Function
End If
nStr = lstrlen(lpStr)
If nStr > 32 Then nStr = 32
MemCopy ByVal retString, ByVal lpStr, nStr
retString = Left(retString, nStr)
getascip = retString
If Err Then getascip = "255.255.255.255"
End Function
Public Function SetSockLinger(ByVal SockNum&, ByVal OnOff%, ByVal LingerTime%) As Long
Dim Linger As LingerType
Linger.l_onoff = OnOff
Linger.l_linger = LingerTime
If setsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, 4) Then
Debug.Print "Error setting linger info: " & WSAGetLastError()
SetSockLinger = SOCKET_ERROR
Else
If getsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, 4) Then
Debug.Print "Error getting linger info: " & WSAGetLastError()
SetSockLinger = SOCKET_ERROR
End If
End If
End Function
____________________________________________________________
'In a form
Private Sub Form_Load()
'KPD-Team 2001
'URL:
http://www.allapi.net/
'E-Mail:
KPDTeam@Allapi.net
'67119558 is the long version of the IP address 198.41.0.4
'198.41.0.4 is the primary root server
MsgBox "Root server hostname: " + GetHostName(67119558)
End Sub
'In a module
Public Const MIN_SOCKETS_REQD As Long = 1
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 SOCKET_ERROR As Long = -1
Public Const WSADESCRIPTION_LEN = 257
Public Const WSASYS_STATUS_LEN = 129
Public Const MAX_WSADescription = 256
Public Const MAX_WSASYSStatus = 128
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
Declare Function WSACleanup Lib "WSOCK32" () As Long
Declare Function WSAStartup Lib "WSOCK32" (ByVal wVersionRequired As Long, lpWSADATA As WSAData) As Long
Declare Function gethostbyaddr Lib "wsock32.dll" (haddr As Long, ByVal hnlen As Long, ByVal addrtype As Long) As Long
Declare Function lstrlenA Lib "kernel32" (ByVal Ptr As Any) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Public Function GetHostName(ByVal Address As Long) As String
Dim lLength As Long, lRet As Long
If Not SocketsInitialize() Then Exit Function
lRet = gethostbyaddr(Address, 4, AF_INET)
If lRet <> 0 Then
CopyMemory lRet, ByVal lRet, 4
lLength = lstrlenA(lRet)
If lLength > 0 Then
GetHostName = Space$(lLength)
CopyMemory ByVal GetHostName, ByVal lRet, lLength
End If
Else
GetHostName = ""
End If
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
'must be OK, so lets do it
SocketsInitialize = True
End Function
___________________________________________________________
'In a form
Private Sub Form_Load()
'KPD-Team 1999
'URL:
http://www.allapi.net/
'E-Mail:
KPDTeam@Allapi.net
MsgBox "IP-address: " + GetIPAddress
End Sub
'In a module
Public Const MIN_SOCKETS_REQD As Long = 1
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 SOCKET_ERROR As Long = -1
Public Const WSADESCRIPTION_LEN = 257
Public Const WSASYS_STATUS_LEN = 129
Public Const MAX_WSADescription = 256
Public Const MAX_WSASYSStatus = 128
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
Type WSADataInfo
wVersion As Integer
wHighVersion As Integer
szDescription As String * WSADESCRIPTION_LEN
szSystemStatus As String * WSASYS_STATUS_LEN
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As String
End Type
Public Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Declare Function WSAStartupInfo Lib "WSOCK32" Alias "WSAStartup" (ByVal wVersionRequested As Integer, lpWSADATA As WSADataInfo) As Long
Declare Function WSACleanup Lib "WSOCK32" () As Long
Declare Function WSAGetLastError Lib "WSOCK32" () As Long
Declare Function WSAStartup Lib "WSOCK32" (ByVal wVersionRequired As Long, lpWSADATA As WSAData) As Long
Declare Function gethostname Lib "WSOCK32" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Declare Function gethostbyname Lib "WSOCK32" (ByVal szHost As String) As Long
Declare Sub CopyMemoryIP 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
CopyMemoryIP HOST, lpHost, Len(HOST)
CopyMemoryIP dwIPAddr, HOST.hAddrList, 4
ReDim tmpIPAddr(1 To HOST.hLen)
CopyMemoryIP 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
'must be OK, so lets do it
SocketsInitialize = True
End Function
________________________________________________________
'Example by Realcacou (
Real-Cacou@Wanadoo.fr)
'--------------------------------------------------------------------------------
'This project needs a command button (Command1), and a listview (Listview1).
'--------------------------------------------------------------------------------
Option Explicit
Private Type MIB_TCPROW
dwState As Long
dwLocalAddr As Long
dwLocalPort As Long
dwRemoteAddr As Long
dwRemotePort As Long
End Type
Private Const ERROR_SUCCESS As Long = 0
Private Const MIB_TCP_STATE_CLOSED As Long = 1
Private Const MIB_TCP_STATE_LISTEN As Long = 2
Private Const MIB_TCP_STATE_SYN_SENT As Long = 3
Private Const MIB_TCP_STATE_SYN_RCVD As Long = 4
Private Const MIB_TCP_STATE_ESTAB As Long = 5
Private Const MIB_TCP_STATE_FIN_WAIT1 As Long = 6
Private Const MIB_TCP_STATE_FIN_WAIT2 As Long = 7
Private Const MIB_TCP_STATE_CLOSE_WAIT As Long = 8
Private Const MIB_TCP_STATE_CLOSING As Long = 9
Private Const MIB_TCP_STATE_LAST_ACK As Long = 10
Private Const MIB_TCP_STATE_TIME_WAIT As Long = 11
Private Const MIB_TCP_STATE_DELETE_TCB As Long = 12
Private Declare Function GetTcpTable Lib "iphlpapi.dll" (ByRef pTcpTable As Any, ByRef pdwSize As Long, ByVal bOrder As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dst As Any, src As Any, ByVal bcount As Long)
Private Declare Function lstrcpyA Lib "kernel32" (ByVal RetVal As String, ByVal Ptr As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal Ptr As Any) As Long
Private Declare Function inet_ntoa Lib "wsock32.dll" (ByVal addr As Long) As Long
Private Declare Function ntohs Lib "wsock32.dll" (ByVal addr As Long) As Long
Public Function GetInetAddrStr(Address As Long) As String
GetInetAddrStr = GetString(inet_ntoa(Address))
End Function
Private Sub Form_Load()
With ListView1
.View = lvwReport
.ColumnHeaders.Add , , "Local IP Address"
.ColumnHeaders.Add , , "Local Port"
.ColumnHeaders.Add , , "Remote IP Address"
.ColumnHeaders.Add , , "Remote Port"
.ColumnHeaders.Add , , "Status "
End With
End Sub
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As ColumnHeader)
ListView1.SortKey = ColumnHeader.Index - 1
ListView1.SortOrder = Abs(Not ListView1.SortOrder = 1)
ListView1.Sorted = True
End Sub
Public Function GetString(ByVal lpszA As Long) As String
GetString = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal GetString, ByVal lpszA)
End Function
Private Sub Command1_Click()
Dim TcpRow As MIB_TCPROW
Dim buff() As Byte
Dim lngRequired As Long
Dim lngStrucSize As Long
Dim lngRows As Long
Dim lngCnt As Long
Dim strTmp As String
Dim lstLine As ListItem
Call GetTcpTable(ByVal 0&, lngRequired, 1)
If lngRequired > 0 Then
ReDim buff(0 To lngRequired - 1) As Byte
If GetTcpTable(buff(0), lngRequired, 1) = ERROR_SUCCESS Then
lngStrucSize = LenB(TcpRow)
'first 4 bytes indicate the number of entries
CopyMemory lngRows, buff(0), 4
For lngCnt = 1 To lngRows
'moves past the four bytes obtained above
'to get data and cast into a TcpRow stucture
CopyMemory TcpRow, buff(4 + (lngCnt - 1) * lngStrucSize), lngStrucSize
'sends results to the listview
With TcpRow
Set lstLine = ListView1.ListItems.Add(, , GetInetAddrStr(.dwLocalAddr))
lstLine.SubItems(1) = ntohs(.dwLocalPort)
lstLine.SubItems(2) = GetInetAddrStr(.dwRemoteAddr)
lstLine.SubItems(3) = ntohs(.dwRemotePort)
lstLine.SubItems(4) = (.dwState)
Select Case .dwState
Case MIB_TCP_STATE_CLOSED: strTmp = "closed"
Case MIB_TCP_STATE_LISTEN: strTmp = "listening"
Case MIB_TCP_STATE_SYN_SENT: strTmp = "sent"
Case MIB_TCP_STATE_SYN_RCVD: strTmp = "received"
Case MIB_TCP_STATE_ESTAB: strTmp = "established"
Case MIB_TCP_STATE_FIN_WAIT1: strTmp = "fin wait 1"
Case MIB_TCP_STATE_FIN_WAIT2: strTmp = "fin wait 1"
Case MIB_TCP_STATE_CLOSE_WAIT: strTmp = "close wait"
Case MIB_TCP_STATE_CLOSING: strTmp = "closing"
Case MIB_TCP_STATE_LAST_ACK: strTmp = "last ack"
Case MIB_TCP_STATE_TIME_WAIT: strTmp = "time wait"
Case MIB_TCP_STATE_DELETE_TCB: strTmp = "TCB deleted"
End Select
lstLine.SubItems(4) = lstLine.SubItems(4) & "( " & strTmp & " )"
strTmp = ""
End With
Next
End If
End If
End Sub
_________________________________________________________
Const SOCKET_ERROR = 0
Private Type WSAdata
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
Private Type Hostent
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type
Private Type IP_OPTION_INFORMATION
TTL As Byte
Tos As Byte
Flags As Byte
OptionsSize As Long
OptionsData As String * 128
End Type
Private Type IP_ECHO_REPLY
Address(0 To 3) As Byte
Status As Long
RoundTripTime As Long
DataSize As Integer
Reserved As Integer
data As Long
Options As IP_OPTION_INFORMATION
End Type
Private Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal HostName As String) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired&, lpWSAdata As WSAdata) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal HANDLE As Long) As Boolean
Private Declare Function IcmpSendEcho Lib "ICMP" (ByVal IcmpHandle As Long, ByVal DestAddress As Long, ByVal RequestData As String, ByVal RequestSize As Integer, RequestOptns As IP_OPTION_INFORMATION, ReplyBuffer As IP_ECHO_REPLY, ByVal ReplySize As Long, ByVal TimeOut As Long) As Boolean
Private Sub Form_Load()
'KPD-Team 2000
'URL:
http://www.allapi.net/
'E-Mail:
KPDTeam@Allapi.net
Const HostName = "www.allapi.net"
Dim hFile As Long, lpWSAdata As WSAdata
Dim hHostent As Hostent, AddrList As Long
Dim Address As Long, rIP As String
Dim OptInfo As IP_OPTION_INFORMATION
Dim EchoReply As IP_ECHO_REPLY
Call WSAStartup(&H101, lpWSAdata)
If GetHostByName(HostName + String(64 - Len(HostName), 0)) <> SOCKET_ERROR Then
CopyMemory hHostent.h_name, ByVal GetHostByName(HostName + String(64 - Len(HostName), 0)), Len(hHostent)
CopyMemory AddrList, ByVal hHostent.h_addr_list, 4
CopyMemory Address, ByVal AddrList, 4
End If
hFile = IcmpCreateFile()
If hFile = 0 Then
MsgBox "Unable to Create File Handle"
Exit Sub
End If
OptInfo.TTL = 255
If IcmpSendEcho(hFile, Address, String(32, "A"), 32, OptInfo, EchoReply, Len(EchoReply) + 8, 2000) Then
rIP = CStr(EchoReply.Address(0)) + "." + CStr(EchoReply.Address(1)) + "." + CStr(EchoReply.Address(2)) + "." + CStr(EchoReply.Address(3))
Else
MsgBox "Timeout"
End If
If EchoReply.Status = 0 Then
MsgBox "Reply from " + HostName + " (" + rIP + ") recieved after " + Trim$(CStr(EchoReply.RoundTripTime)) + "ms"
Else
MsgBox "Failure ..."
End If
Call IcmpCloseHandle(hFile)
Call WSACleanup
End Sub
Вроде все что было по WinSock
