все норовят юзать бесовские поделия wink.gif
IBM'овская ява еще то поделие!
)
в общем, вот моя давняя библиотечка
[codebox]'++LotusScript Development Environment:2:5
Options):0:66
Option Public
Option Declare
'++LotusScript Development Environment:2:5
Forward):0:1
Declare Public Type WSAData
Declare Type WSADataInfo
Declare Public Type HOSTENT
Declare Public Function GetIPAddress() As String
Declare Public Function GetIPHostName() As String
Declare Public Function HiByte(Byval wParam As Integer)
Declare Public Function LoByte(Byval wParam As Integer)
Declare Public Sub SocketsCleanup()
Declare Public Function SocketsInitialize() As Boolean
Declare Function GetIPAddressByName(AHostName As String) As String
Declare Function StrMoveMemory(Byval hpvSource As Long) As String
'++LotusScript Development Environment:2:5
Declarations):0:10
Public Const WSADESCRIPTION_LEN = 257
Public Const WSASYS_STATUS_LEN = 129
Public Const MAX_WSADescription = 256
Public Const MAX_WSASYSStatus = 128
Public Const MIN_SOCKETS_REQD = 1
Public Const WS_VERSION_REQD = &H101
Public Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Public Const SOCKET_ERROR = -1
Public Const ERROR_SUCCESS = 0
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
' Platform SDK: Memory Management
Const LMEM_FIXED = &H0
Const LMEM_MOVEABLE = &H2
Const LMEM_ZEROINIT = &H40
Const LHND = (LMEM_MOVEABLE + LMEM_ZEROINIT)
Const LPTR = (LMEM_FIXED + LMEM_ZEROINIT)
Const NONZEROLHND = LMEM_MOVEABLE
Const NONZEROLPTR = LMEM_FIXED
Declare Function LocalAlloc Lib "kernel32.dll" Alias "LocalAlloc" (Byval wFlags As Long, Byval wBytes As Long) As Long
Declare Function LocalFree Lib "kernel32.dll" Alias "LocalFree" (Byval hMem As Long) As Long
' Kernel-Mode Driver Architecture: Windows DDK
Declare Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, Byval hpvSource As Long, Byval cbCopy As Long)
' Platform SDK: Windows Sockets
Declare Function WSAStartupInfo Lib "wsock32.dll" Alias "WSAStartup" (Byval wVersionRequested As Integer, lpWSADATA As WSADataInfo) As Long
Declare Function WSACleanup Lib "wsock32.dll" Alias "WSACleanup" () As Long
Declare Function WSAGetLastError Lib "wsock32.dll" Alias "WSAGetLastError" () As Long
Declare Function WSAStartup Lib "wsock32.dll" Alias "WSAStartup" (Byval wVersionRequired As Long, lpWSADATA As WSAData) As Long
Declare Function gethostname Lib "wsock32.dll" Alias "gethostname" (Byval szHost As String, Byval dwHostLen As Long) As Long
Declare Function gethostbyname Lib "wsock32.dll" Alias "gethostbyname" (Byval szHost As String) As Long
'Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlCopyMemory" (hpvDest As Any, Byval hpvSource As Long, Byval cbCopy As Long)
Declare Function inet_addr Lib "wsock32.dll" Alias "inet_addr" (Byval cp As String) As Long
Declare Function inet_ntoa Lib "wsock32.dll" Alias "inet_ntoa" (Byval inn As Long) As Long
' Platform SDK: Internet Protocol Helper
'Declare Function SendARP Lib "IPHLPAPI.dll" (DestIP As IPAddr, SrcIP As IPAddr, pMacAddr As Long, PhyAddrLen As Long) As Long
Declare Function SendARP Lib "iphlpapi.dll" Alias "SendARP" (DestIP As Long, SrcIP As Long, pMacAddr As Long, PhyAddrLen As Long) As Long
' Platform SDK: Debugging and Error Handling
Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Const LANG_NEUTRAL = &H0
Const SUBLANG_DEFAULT = &H1
Const ERROR_BAD_USERNAME = 2202&
Declare Function GetLastError Lib "kernel32" () As Long
Declare Sub SetLastError Lib "kernel32" (Byval dwErrCode As Long)
Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (Byval dwFlags As Long, lpSource As Any, Byval dwMessageId As Long, Byval dwLanguageId As Long, Byval lpBuffer As String, Byval nSize As Long, Arguments As Long) As Long
'++LotusScript Development Environment:2:1:GetIPAddress:1:8
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
MoveMemory HOST, lpHost, Len(HOST)
MoveMemory dwIPAddr, HOST.hAddrList, 4
Redim tmpIPAddr(1 To HOST.hLen)
MoveMemory 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
'++LotusScript Development Environment:2:1:GetIPHostName:1:8
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
'++LotusScript Development Environment:2:1:HiByte:1:8
Public Function HiByte(Byval wParam As Integer)
HiByte = wParam \ &H100 And &HFF&
End Function
'++LotusScript Development Environment:2:1:LoByte:1:8
Public Function LoByte(Byval wParam As Integer)
LoByte = wParam And &HFF&
End Function
'++LotusScript Development Environment:2:2:SocketsCleanup:1:8
Public Sub SocketsCleanup()
If WSACleanup() <> ERROR_SUCCESS Then
Msgbox "Socket error occurred in Cleanup."
End If
End Sub
'++LotusScript Development Environment:2:1:SocketsInitialize:1:8
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
'++LotusScript Development Environment:2:1:GetIPAddressByName:1:8
Function GetIPAddressByName(AHostName As String) 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
GetIPAddressByName = "0.0.0.0"
Exit Function
End If
If Trim$(AHostName) = "" Then
If gethostname(sHostName, 256) = SOCKET_ERROR Then
GetIPAddressByName = "0.0.0.0"
Print "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
Else
Dim shn As String
shn = AHostName & Chr(0)
sHostName = AHostName & Chr(0)
End If
'sHostName = sHostName
sHostName = Trim$(sHostName)
lpHost = gethostbyname(sHostName)
If lpHost = 0 Then
GetIPAddressByName = "0.0.0.0"
Print "Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
MoveMemory HOST, lpHost, Len(HOST)
MoveMemory dwIPAddr, HOST.hAddrList, 4
Redim tmpIPAddr(1 To HOST.hLen)
MoveMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
For I = 1 To HOST.hLen
sIPAddr = sIPAddr & tmpIPAddr(I) & "."
Next
GetIPAddressByName = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
SocketsCleanup
End Function
'++LotusScript Development Environment:2:1:StrMoveMemory:1:8
Function StrMoveMemory(Byval hpvSource As Long) As String
Dim ip As String
Dim lpip As Long
Dim ipb As Byte
lpip = hpvSource
StrMoveMemory = ""
Do
MoveMemory ipb, lpip, 1
If ipb = 0 Then Exit Do
StrMoveMemory = StrMoveMemory & Chr(ipb)
lpip = lpip + 1
Loop Until ipb = 0
End Function[/codebox]
