VERSION 5.00
Begin VB.UserControl ipBox 
   ClientHeight    =   285
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1995
   ScaleHeight     =   19
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   133
End
Attribute VB_Name = "ipBox"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Const DEFAULT_GUI_FONT As Long = 17
'窗口樣式常數(shù)
Private Const WM_USER As Long = &H400
Private Const WS_CHILD As Long = &H40000000
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_BORDER As Long = &H800000
Private Const WS_TABSTOP As Long = &H10000
Private Const WS_EX_CLIENTEDGE As Long = &H200&

Private Const WM_SETFONT As Long = &H30
' 常數(shù)
Private Const IPM_SETADDRESS As Long = (WM_USER + 101)
Private Const IPM_GETADDRESS As Long = (WM_USER + 102)
' 樣式
Private Const IP_BOX_STYLE = WS_CHILD Or WS_VISIBLE Or WS_BORDER Or WS_TABSTOP

Private IpBoxHwnd As Long
Private m_ipAdder As String

Function CountIF(lzExpr As String, nChar As String)
    Dim X As Integer, iCount As Integer
    Dim sByte() As Byte
    sByte = lzExpr
    For X = LBound(sByte) To UBound(sByte)
        If sByte(X) = Asc(nChar) Then iCount = iCount + 1
    Next
    X = 0: Erase sByte
    CountIF = iCount
    iCount = 0
End Function

Private Function GetAddress() As String
    Dim IpPtr As Long
    Dim mIPAddr(3) As Byte
    
    m_ipAdder = ""
    SendMessage IpBoxHwnd, IPM_GETADDRESS, 0, ByVal VarPtr(IpPtr) '獲取指針
    CopyMemory mIPAddr(0), IpPtr, Len(IpPtr) ' 復(fù)制指針
    GetAddress = mIPAddr(3) & "." & mIPAddr(2) & "." & mIPAddr(1) & "." & mIPAddr(0)
End Function

Sub CreateTextBox()
    Dim X As Long, y As Long
    Dim hFont As Long

    xWidth = UserControl.ScaleWidth
    yHeight = UserControl.ScaleHeight
    
    IpBoxHwnd = CreateWindowEx(WS_EX_CLIENTEDGE, "SysIPAddress32", "" _
    , IP_BOX_STYLE, 0, 0, xWidth, yHeight, UserControl.hwnd, 0, App.hInstance, ByVal 0&)
    If IpBoxHwnd = 0 Then
        Exit Sub
    Else
        hFont = GetStockObject(DEFAULT_GUI_FONT) ' 獲取默認(rèn)字體
        SendMessage IpBoxHwnd, WM_SETFONT, hFont, 1 '設(shè)置默認(rèn)字體
    End If
End Sub

Private Sub UserControl_Initialize()
    Call CreateTextBox
    Address = "0.0.0.0" '默認(rèn)
End Sub

Private Sub UserControl_Resize()
    If IpBoxHwnd <> 0 Then
        MoveWindow IpBoxHwnd, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, True
    End If
End Sub

Public Property Get Address() As String
    Address = GetAddress '返回IP地址
End Property

Public Property Let Address(ByVal NewIP As String)
    Dim mByte(3) As Byte, vIp As Variant
    Dim IpPrt As Long

    If CountIF(NewIP, ".") < 3 Then
        Err.Raise 102, , "Ip 地址格式錯誤" & vbCrLf _
        & "正確的格式應(yīng)該為: 255.255.255.255"
        Exit Property
    Else
        vIp = Split(NewIP, ".") ' IP地址分隔符
        mByte(0) = vIp(3)
        mByte(1) = vIp(2)
        mByte(2) = vIp(1)
        mByte(3) = vIp(0)
        '刪除臨時
        Erase vIp
        CopyMemory IpPrt, mByte(0), 4
        SendMessage IpBoxHwnd, IPM_SETADDRESS, 0, ByVal IpPrt
    End If
    
End Property