?? dmip.ctl
字號:
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:mnd@mndsoft.com
'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
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -