dmip.ctl

ip地址框架,不允许输入超过255数字的。 格式为0.0.0.0控件

VERSION 5.00
Begin VB.UserControl ipBox 
   ClientHeight    =   285
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3015
   ScaleHeight     =   19
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   201
End
Attribute VB_Name = "ipBox"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：05/04/15
'描  述：IP地址框控件
'网  站：http://www.mndsoft.com/blog/
'e-mail：[e-mail]
'OICQ  : 88382850
'****************************************************************************
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
'窗口样式常数
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
' 常数
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) ' 复制指针
    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) ' 获取默认字体
        SendMessage IpBoxHwnd, WM_SETFONT, hFont, 1 '设置默认字体
    End If
End Sub

Private Sub UserControl_Initialize()
    Call CreateTextBox
    Address = "0.0.0.0" '默认
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 _
        & "正确的格式应该为: 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