frmip.frm

取的 IP 地址和主机名称 该程序使用 WinSock API , 但不能处理同机多个地址的情况。

VERSION 5.00
Begin VB.Form frmIP 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "TCP/IP 信息"
   ClientHeight    =   1530
   ClientLeft      =   3375
   ClientTop       =   1485
   ClientWidth     =   4935
   Icon            =   "frmIP.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   1530
   ScaleWidth      =   4935
   Begin VB.CommandButton Command3 
      Caption         =   "复制到剪贴板"
      Height          =   315
      Left            =   3120
      TabIndex        =   1
      Top             =   600
      Width           =   1575
   End
   Begin VB.CommandButton Command2 
      Caption         =   "复制到剪贴板"
      Height          =   315
      Left            =   3120
      TabIndex        =   0
      Top             =   180
      Width           =   1575
   End
   Begin VB.TextBox Text2 
      Height          =   255
      Left            =   1080
      TabIndex        =   5
      Text            =   "IP Address"
      Top             =   660
      Width           =   1755
   End
   Begin VB.TextBox Text1 
      Height          =   255
      Left            =   1080
      TabIndex        =   4
      Text            =   "ComputerName"
      Top             =   240
      Width           =   1755
   End
   Begin VB.CommandButton Command1 
      Caption         =   "退出(&X)"
      Height          =   315
      Left            =   3120
      TabIndex        =   3
      Top             =   1020
      Width           =   1575
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "IP 地址:"
      Height          =   180
      Left            =   180
      TabIndex        =   6
      Top             =   660
      Width           =   720
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "计算机名:"
      Height          =   180
      Left            =   180
      TabIndex        =   2
      Top             =   240
      Width           =   810
   End
End
Attribute VB_Name = "frmIP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
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&, lpWSAData As WSADATA) As Long
   Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
   Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal hostname$, HostLen&) 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
 
   Sub SocketsInitialize()
   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
           MsgBox "Winsock.dll 没有响应！", vbCritical
           Text1.Text = "ERROR!"
           Text2.Text = "ERROR!"
           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 & " is not supported by winsock.dll "
           MsgBox sMsg
           End
       End If
 
       If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
           sMsg = "This application requires a minimum of "
           sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
           MsgBox sMsg
           End
       End If
 
   End Sub
 
   Sub SocketsCleanup()
   Dim lReturn As Long
 
       lReturn = WSACleanup()
 
       If lReturn <> 0 Then
           MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup """
           End
       End If
 
   End Sub
 


Private Sub Command1_Click()
    Unload Me
    End
End Sub

Private Sub Command2_Click()
    Clipboard.SetText Text1.Text
    Command3.SetFocus
    Beep
End Sub

Private Sub Command3_Click()
    Clipboard.SetText Text2.Text
    Command1.SetFocus
    Beep
End Sub

Private Sub Form_Load()
       SocketsInitialize
          Dim hostname As String * 256
   Dim hostent_addr As Long
   Dim host As HOSTENT
   Dim hostip_addr As Long
   Dim temp_ip_address() As Byte
   Dim i As Integer
   Dim ip_address As String
 
       If gethostname(hostname, 256) = SOCKET_ERROR Then
           MsgBox "Windows Sockets error " & Str(WSAGetLastError())
           Exit Sub
       Else
           hostname = Trim$(hostname)
       End If
 
       hostent_addr = gethostbyname(hostname)
 
       If hostent_addr = 0 Then
           MsgBox "Winsock.dll 没有响应！", vbCritical
           Text1.Text = "ERROR!"
           Text2.Text = "ERROR!"
           Exit Sub
       End If
 
       RtlMoveMemory host, hostent_addr, LenB(host)
       RtlMoveMemory hostip_addr, host.hAddrList, 4
 
       ReDim temp_ip_address(1 To host.hLength)
       RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
 
       For i = 1 To host.hLength
           ip_address = ip_address & temp_ip_address(i) & "."
       Next
       ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
 
       Text1.Text = hostname
       Text2.Text = ip_address
 
       Me.Show
        
End Sub


Private Sub Form_Unload(Cancel As Integer)
   SocketsCleanup
End Sub


Private Sub Text1_KeyPress(KeyAscii As Integer)
    KeyAscii = 0
    Beep
End Sub

Private Sub Text2_KeyPress(KeyAscii As Integer)
    KeyAscii = 0
    Beep
End Sub