Phục hồi và bền hóa động cơ không tháo rã : Công Nghệ Gốm Kim Loại XADO - Metal-Ceramic Xado

THIÊN AN Technology Thiết kế website Chuyên Nghiệp ! | Domain Hosting Chất lượng Cao!

Phân giải tên thành địa chỉ IP

VB , C++ , JAVA , .... ,
Thuật toán ....

Điều hành viên: Luu Thanh Nghi, Nửa bốn mùa, Giọt nước

Phân giải tên thành địa chỉ IP

Gửi bàigửi bởi Giọt nước » 17 Tháng 6 2003, 17:48

Với đoạn code sau bạn có thể dễ dàng biết được địa chỉ IP của một website hay một máy và ngược lại. Hy vọng sẽ giúp ích cho các bạn.
Bạn tạo các control có trong đoạn code sau:

Option Explicit

Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128

Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type

Private Type WSADATA
wversion As Integer
wHighVersion As Integer
szDescription(0 To WSADescription_Len) As Byte
szSystemStatus(0 To WSASYS_Status_Len) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpszVendorInfo As Long
End Type

Private Declare Function WSAGetLastError Lib ''wsock32.dll'' () As Long
Private Declare Function WSAStartup Lib ''wsock32.dll'' (ByVal wVersionRequired As Integer, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib ''wsock32.dll'' () As Long
Private Declare Function inet_addr Lib ''wsock32.dll'' (ByVal cp As String) As Long

Private Declare Function gethostbyaddr Lib ''wsock32.dll'' (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long
Private Declare Function gethostname Lib ''wsock32.dll'' (ByVal hostname$, ByVal HostLen As Long) As Long
Private Declare Function gethostbyname Lib ''wsock32.dll'' (ByVal hostname$) As Long
Private Declare Sub RtlMoveMemory Lib ''KERNEL32'' (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)
Function hibyte(ByVal wParam As Integer)
hibyte = wParam &H100 And &HFF&
End Function

Function lobyte(ByVal wParam As Integer)
lobyte = wParam And &HFF&
End Function

' Trả về local host's name.
Private Function LocalHostName() As String
Dim hostname As String * 256

If gethostname(hostname, 256) = SOCKET_ERROR Then
LocalHostName = ''<Lỗi>''
Else
LocalHostName = Trim$(hostname)
End If
End Function
Private Sub InitializeSockets()
Dim WSAD As WSADATA
Dim iReturn As Integer
Dim sLowByte As String, sHighByte As String, sMsg As String

iReturn = WSAStartup(WS_VERSION_REQD, WSAD)

If iReturn <> 0 Then
txtIPAddress.Text = ''Winsock.dll không phải hồi .''
End
End If

If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = _
WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then

sHighByte = Trim$(Str$(hibyte(WSAD.wversion)))
sLowByte = Trim$(Str$(lobyte(WSAD.wversion)))
sMsg = ''Windows Sockets version '' & sLowByte & ''.'' & sHighByte
sMsg = sMsg & '' không hỗ trợ bởi winsock.dll ''
txtIPAddress = sMsg
End
End If


If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
sMsg = ''Chương trình yêu cầu''
sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & '' được hỗ trợ sockets.''
txtIPAddress.Text = sMsg
End
End If

End Sub

Private Sub CleanupSockets()
Dim lReturn As Long

lReturn = WSACleanup()

If lReturn <> 0 Then
txtIPAddress.Text = ''Socket Error '' & Trim$(Str$(lReturn)) & '' Occurred In Cleanup.''
End
End If

End Sub

Private Sub cmdGetIPAddress_Click()
Screen.MousePointer = vbHourglass
If Valid_IP(txtHostName) = False Then
txtIPAddress.Text = GetIPByHost(txtHostName.Text)
Else
txtIPAddress.Text = GetHostByIP(txtHostName.Text)
End If
Screen.MousePointer = vbNormal
End Sub

Private Sub Command1_Click()
End
End Sub


Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then
Unload Me
End If
End Sub

Private Sub Form_Load()
InitializeSockets
txtHostName = LocalHostName()
End Sub


Private Sub Form_Unload(Cancel As Integer)
CleanupSockets
End Sub

Private Function Valid_IP(IP As String) As Boolean
Dim i As Integer
Dim dot_count As Integer
Dim test_octet As String
Dim byte_check
IP = Trim$(IP)

If Len(IP) < 8 Then
Valid_IP = False
Exit Function
End If

i = 1
dot_count = 0
For i = 1 To Len(IP)
If Mid$(IP, i, 1) = ''.'' Then
dot_count = dot_count + 1
test_octet = ''''
If i = Len(IP) Then
Valid_IP = False
Exit Function
End If
Else
test_octet = test_octet & Mid$(IP, i, 1)
On Error Resume Next
byte_check = CByte(test_octet)
If (Err) Then
Valid_IP = False
Exit Function
End If
End If
Next i
If dot_count <> 3 Then
Valid_IP = False
Exit Function
End If
Valid_IP = True
End Function

Private Sub txtHostName_GotFocus()
txtHostName.SelStart = 0: txtHostName.SelLength = Len(txtHostName.Text)
End Sub

Private Sub txtIPAddress_GotFocus()
txtIPAddress.SelStart = 0: txtIPAddress.SelLength = Len(txtIPAddress)
End Sub

Private Sub txtIPAddress_LostFocus()
txtIPAddress.SelLength = 0
End Sub

Public Function GetHostByIP(strIP As String) As String
Dim apiError As Long
If Len(strIP) < 1 Then Exit Function
Dim Host As HOSTENT Dim lngIP As Long
Dim strHost As String * 255
Dim tmpString As String

lngIP = inet_addr(strIP & Chr(0))

apiError = gethostbyaddr(lngIP, Len(lngIP), 2)
If apiError = 0 Then
GetHostByIP = ''Error nhận HostName...''
Exit Function
End If

RtlMoveMemory Host, apiError, Len(Host)
RtlMoveMemory ByVal strHost, Host.hName, 255

tmpString = strHost
If InStr(tmpString, Chr(0)) <> 0 Then
tmpString = Left(tmpString, InStr(tmpString, Chr(0)) - 1)
End If

tmpString = Trim(tmpString)

GetHostByIP = tmpString 'Send back out
End Function

Public Function GetIPByHost(strHost As String) As String
Dim apiError As Long
If Len(strHost) < 1 Then Exit Function
Dim Host As HOSTENT 'Cannot use HOSTENT
Dim lngHostIp As Long
Dim strIP As String
Dim tmpIP() As Byte
Dim tmpInt As Integer

apiError = gethostbyname(strHost & Chr(0))
If apiError = 0 Then
GetIPByHost = ''Lỗi nhận IP Address...''
Exit Function
End If

'Copy mem
RtlMoveMemory Host, apiError, LenB(Host)
RtlMoveMemory lngHostIp, Host.hAddrList, 4 'Copy 4 parts of ip

ReDim tmpIP(1 To Host.hLength) 'Resize
RtlMoveMemory tmpIP(1), lngHostIp, Host.hLength 'Copy mem

For tmpInt = 1 To Host.hLength
strIP = strIP & tmpIP(tmpInt) & ''.''
Next
strIP = Mid(strIP, 1, Len(strIP) - 1)
GetIPByHost = strIP
End Function
Không có Giọt nước sẽ không có đại dương .... Không có Máy tính làm sao có Mạng ......
Hình đại diện của thành viên
Giọt nước
 
Bài viết: 1736
Ngày tham gia: 07 Tháng 6 2003, 11:00

Quay về LẬP TRÌNH Ứng Dụng

Đang trực tuyến

Đang xem chuyên mục này: Không có thành viên nào trực tuyến.2 khách.

cron