Ipaddress class

Télécharger le projet
Commenter

Description

Implementation of WC_IPADDRESS (SysIPAddress32 COMCTL32.DLL) for use in VB6 (or Visual Basic Classic)
==============================================

==============================================
Important: Remember, this source code is for developpers, not for end user, so ... caution with errors

Important: You need to register windowsAPI.tlb, a free Type Library, see down for HOWTO
==============================================

==============================================
Explanation:
The erratic behavior of the control while conducting some operations, like FOCUS and TAB ORDER, has led me to write a class that might be called "usable"
There are several VB6 samples on Internet that implement WC_IPADDRESS, but none works fine. Mine does not work well, but almost...
The trick is create the class window top of a "hidden" control, catching the focus and pass it to the IPAddr window. The Hidden control it?s the future IPAddr parent's
Intercept any message for the Parent and child and pass it trough RaiseEvent. This class is designed for handling at runtime. If you prefer handling at design time, it is better to use a UserControl

How it work?
At least, place a Control (PictureBox or TextBox) in a form, or frame, or any container, and call CreateIPWindow.
Also, if you do not need debug, remove all debug references (clsDebug)

Annex A: In fact, it is not erratic, but VB6 does not know how to treat the forms as dialogs. I tried to manage the event WM_GETDLGCODE and send DLGC_WANTARROWS, DLGC_WANTTAB, even if WS_TABSTOP was set when CreateWindowEx is calling, but... nothing. If anyone solves the problem, please tell me
Anexx B: An annoying visual effect is shown at debug-mode, becouse the focus is catching form the hidden control and moves to the IPAddress window. At run-time, this effect disapear
Anexx C: from ccrpipa6: "Known issues: If two IP Address controls are next to each other in the TabOrder, the focus will appear to get 'stuck' at the 2nd control. I have yet to find a way to correct this behaviour - a workaround involves placing a hidden control (e.g. textbox) in the tab order between the 2 IP Address controls and have it set the focus to the 2nd IP Address control in it's GetFocus event."
Anexx D: KeyPreview functionality are lost when editing IPAddress

Features of the IPAddr Class include:

.- All properties, events, macros and methods from the Original WC_IPADDRESS = SysIPAddress32 (see more at http://msdn.microsoft.com/en-us/library/bb761372(VS.85).aspx)
.- same font and size as Control Hidden (only at run-time)
.- VBPing to ping an IP Address
.- Each field (text edit) in the control is represented by a handle (hWnd)
==============================================

Source / Exemple : 


Option Explicit
Implements IHookXP
'windows handle's
Dim hWndIPcls&
Dim hWndCTRLHidden&

'class name for debugging
Dim szName$

'hidden text's reference
Dim hCTRLHidden As Control
'for debugging
Dim clsDebug As TextBox
'clsIPAddr's reference
Dim hIPAddr As clsIPAddr

'create only one time
Dim bCreateOnControl As Boolean

'array to store hWnd Child Text Edit of IPAddr
'collections dont work fine in VB6. Impossible to retrieve Key
'better classic array
Private Type FIELD
    hWnd As Long
    nField As Integer
End Type

Dim arrFields(0 To 3) As FIELD

Public Event IPAddrChange(ByVal nField&)
Public Event IPAddrGotFocus(ByVal nField&)
Public Event IPAddrLostFocus(ByVal nField&)
Public Event IPAddrFieldChanged(ByVal nField&, ByRef FieldValue&)

Private Enum EN
    EN_SETFOCUS = &H100
    EN_KILLFOCUS = &H200
    EN_CHANGE = &H300
    EN_UPDATE = &H400
    EN_ERRSPACE = &H500
    EN_MAXTEXT = &H501
    EN_HSCROLL = &H601
    EN_VSCROLL = &H602
End Enum
Private Enum IPN
    IPN_FIRST = &HFCA4 '-860
    IPN_FIELDCHANGED = (IPN_FIRST - 0)
End Enum
Private Type NMHDR
    hWndFrom As Long
    idFrom As Long
    code As Long
End Type

Private Type NMIPADDRESS
    hdr As NMHDR
    iField As Long
    iValue As Long
End Type

'WSock API's
Private Declare Function htonl& Lib "wsock32" (ByVal hostlong&)
Private Declare Function ntohl& Lib "wsock32" (ByVal netlong&)

'Windows API's not included in WindowsAPI.tlb
Private Declare Function lstrlen& Lib "kernel32" Alias "lstrlenA" (lpString As Any)
Private Declare Function lstrcpy& Lib "kernel32" Alias "lstrcpyA" (lpszDst As Any, lpszSrc As Any)
Private Declare Function SendMessage& Lib "user32" Alias "SendMessageA" (ByVal hWnd&, ByVal wMsg&, ByVal wParam&, lParam As Any)
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (dst As Any, src As Any, ByVal bcount&)

'VBPing
Private Const IP_STATUS_BASE As Long = 11000
Private Const IP_SUCCESS As Long = 0
Private Const IP_BUF_TOO_SMALL As Long = (11000 + 1)
Private Const IP_DEST_NET_UNREACHABLE As Long = (11000 + 2)
Private Const IP_DEST_HOST_UNREACHABLE As Long = (11000 + 3)
Private Const IP_DEST_PROT_UNREACHABLE As Long = (11000 + 4)
Private Const IP_DEST_PORT_UNREACHABLE As Long = (11000 + 5)
Private Const IP_NO_RESOURCES As Long = (11000 + 6)
Private Const IP_BAD_OPTION As Long = (11000 + 7)
Private Const IP_HW_ERROR As Long = (11000 + 8)
Private Const IP_PACKET_TOO_BIG As Long = (11000 + 9)
Private Const IP_REQ_TIMED_OUT As Long = (11000 + 10)
Private Const IP_BAD_REQ As Long = (11000 + 11)
Private Const IP_BAD_ROUTE As Long = (11000 + 12)
Private Const IP_TTL_EXPIRED_TRANSIT As Long = (11000 + 13)
Private Const IP_TTL_EXPIRED_REASSEM As Long = (11000 + 14)
Private Const IP_PARAM_PROBLEM As Long = (11000 + 15)
Private Const IP_SOURCE_QUENCH As Long = (11000 + 16)
Private Const IP_OPTION_TOO_BIG As Long = (11000 + 17)
Private Const IP_BAD_DESTINATION As Long = (11000 + 18)
Private Const IP_ADDR_DELETED As Long = (11000 + 19)
Private Const IP_SPEC_MTU_CHANGE As Long = (11000 + 20)
Private Const IP_MTU_CHANGE As Long = (11000 + 21)
Private Const IP_UNLOAD As Long = (11000 + 22)
Private Const IP_ADDR_ADDED As Long = (11000 + 23)
Private Const IP_GENERAL_FAILURE As Long = (11000 + 50)
Private Const MAX_IP_STATUS As Long = (11000 + 50)
Private Const IP_PENDING As Long = (11000 + 255)
Private Const INADDR_NONE = 0

Private Type ICMP_OPTIONS
   Ttl             As Byte
   Tos             As Byte
   Flags           As Byte
   OptionsSize     As Byte
   OptionsData     As Long
End Type

Private Type ICMP_ECHO_REPLY
   Address         As Long
   status          As Long
   RoundTripTime   As Long
   DataSize        As Long
   DataPointer     As Long
   Options         As ICMP_OPTIONS
   Data            As String * 250
End Type

Private Declare Function IcmpCreateFile& Lib "icmp.dll" ()
Private Declare Function IcmpCloseHandle& Lib "icmp.dll" (ByVal IcmpHandle&)
Private Declare Function IcmpSendEcho& Lib "icmp.dll" (ByVal IcmpHandle&, ByVal DestinationAddress&, ByVal RequestData$, ByVal RequestSize&, ByVal RequestOptions&, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize&, ByVal TIMEOUT&)
Private Sub ClassDebug(ByVal hW&, ByVal uiMsg&, ByVal wParam&, ByVal lParam&, ByVal dwRefData&)
'debugging IPAddr

Dim szDebug$
    Select Case uiMsg&
    Case WM_SETFOCUS, WM_KILLFOCUS
            szDebug$ = "Message: " & GetWinMsgStr$(uiMsg&, wParam&) & vbTab & "lParam& = &H(" & Hex(lParam&) & ")"
    Case WM_COMMAND
            szDebug$ = "Message: " & GetWinMsgStr$(uiMsg&) & vbTab & "lParam& = " & ParamTOStr$(lParam&) & vbTab & "wParam& = &H(" & Hex(wParam&) & ")"
    Case IPM_SETFOCUS
            szDebug$ = "Message: " & "IPM_SETFOCUS " & vbTab & "nField& = " & wParam& & ")"
    Case WM_SETCURSOR, WM_NCMOUSEMOVE, WM_NCHITTEST, WM_CTLCOLOREDIT, WM_MOUSEFIRST
    
    Case Else
            szDebug$ = "Message: " & GetWinMsgStr$(uiMsg&) & vbTab & "wParam& = &H(" & Hex(((wParam&))) & ")" & vbTab & "lParam& = &H(" & Hex(lParam&) & ")"
    End Select
    If Len(szDebug$) And (clsDebug Is Nothing = False) Then
#If IPADDRDEBUG Then
    If IsIDE Then clsDebug.Text = "hWnd " & ParamTOStr$(hWnd&) & vbTab & szDebug$ & vbCrLf & Left$(clsDebug.Text, BUFFER_DEBUG)
#End If
    End If

End Sub
Private Function IHookXP_Message&(ByVal hW&, ByVal uMsg&, ByVal wParam&, ByVal lParam&, ByVal dwRefData&)
On Local Error GoTo ErrIHookXP_Message
Dim uEN As EN
Dim hdrX As NMHDR
Dim nmIP As NMIPADDRESS
Dim nField&
Dim clsNameParam$, iCount%, fMessageDontDebug As Boolean
Static bSetKill As Boolean
Dim CurrentFocus&
    Select Case hW&

'    Case arrFields(0).hWnd
'            If IsIDE Then If (clsDebug Is Nothing) = False Then clsDebug.Text = "nField& = 0" & vbCrLf & Left(clsDebug.Text, BUFFER_DEBUG)
    
    Case hWndCTRLHidden&
        Select Case uMsg&
        
        Case WM_SETFOCUS
        'trick for catching focus
        'and send it to IPAddr's window
            Call windows.SetFocus(hIPAddr.hWnd)
        
        Case WM_NOTIFY
        'IPAddr Field has Changed, but this mesage is sent always
            Call CopyMemory(hdrX, ByVal lParam&, Len(hdrX))
            
            Select Case hdrX.code
            Case IPN_FIELDCHANGED
                If bSetKill Then
                    IHookXP_Message& = True
                    Exit Function
                End If
                Call CopyMemory(nmIP, ByVal lParam&, Len(nmIP))
                RaiseEvent IPAddrFieldChanged(nmIP.iField, nmIP.iValue)
                Call CopyMemory(ByVal lParam&, nmIP, Len(nmIP))
                IHookXP_Message& = True
                fMessageDontDebug = True
            End Select
        End Select
    
    Case hIPAddr.hWnd
        Select Case uMsg&
        Case WM_MOUSEACTIVATE
'try to discover wath message is neccesary for tab order sequence
'this trick work always??? yessss
        
        'only manage this message if focus isn't at edit text
            CurrentFocus& = windows.GetFocus
            For iCount% = 0 To 3
                If CurrentFocus& = arrFields(iCount%).hWnd Then Exit Function
            Next iCount%
            
            bSetKill = True
            Call windows.SetFocus(hWndCTRLHidden&)
        
        Case WM_USER + 1
        'trick to pass hWnd of Child Edit text when enumerating Child
            arrFields(wParam&).hWnd = lParam&
            arrFields(wParam&).nField = wParam&
#If IPADDRDEBUG Then
If IsIDE Then If IsWindow(clsDebug.hWnd) Then clsDebug.Text = "nField& = " & wParam& & vbTab & ParamTOStr(arrFields(wParam&).hWnd) & vbCrLf & Left(clsDebug.Text, BUFFER_DEBUG)
#End If
        Case WM_USER + 2
            
            If wParam Then
        'trick to pass ClassName when are debugging
        'trough API's Messages
                For iCount% = 0 To 3
                    If wParam& = arrFields(iCount%).hWnd Then Exit For
                Next iCount%
                If iCount% < 4 Then
                    'clsNameParam$ = hIPAddr.strName & " field " & CStr(iCount%)
                    clsNameParam$ = hIPAddr.strName & " field " & arrFields(iCount%).nField
                    Call CopyMemory(ByVal lParam&, ByVal StrPtr(clsNameParam$), 2 * Len(clsNameParam$))
                    IHookXP_Message& = Len(clsNameParam$)
                End If
            Else
                clsNameParam$ = hIPAddr.strName
                Call CopyMemory(ByVal lParam&, ByVal StrPtr(clsNameParam$), 2 * Len(clsNameParam$))
                IHookXP_Message& = Len(clsNameParam$)
                fMessageDontDebug = True
            End If
        Case WM_COMMAND
        'wParam
        'The LOWORD contains the identifier of the edit control
        'siempre devuelve 0 porque no es un díalogo, sino un form
        'en el caso de un diálogo devuleve el ID del control dentro del diálogo, NO EL hWnd
        'sin embargo lParam contiene el hWnd de cada edit
        'The HIWORD specifies the notification code.
            uEN = HiWord%(VarPtr(ByVal wParam&))
            nField& = GetWindowLong(lParam&, GWL_USERDATA)
            
            Select Case uEN
                
            Case EN_CHANGE
                RaiseEvent IPAddrChange(nField&)
            Case EN_SETFOCUS
                If bSetKill Then
                    IHookXP_Message& = True
                    Exit Function
                End If
                RaiseEvent IPAddrGotFocus(nField&)
            Case EN_KILLFOCUS ' comprobar si la IP es válida
                If bSetKill Then
                    bSetKill = False
                    IHookXP_Message& = True
                    Exit Function
                End If
                RaiseEvent IPAddrLostFocus(nField&)
            Case EN_UPDATE ' ==== EN_CHANGE
            '    RaiseEvent IPAddrUpdate(nField&)
            Case EN_MAXTEXT 'cuando la ventana anterior está deshabilitada
            'Sent when the current text insertion has exceeded the specified number of characters for the edit control.
            Case Else
#If IPADDRDEBUG Then
               If IsIDE Then If IsWindow(clsDebug.hWnd) Then clsDebug.Text = "ELSE WM_COMMAND " & vbTab & "nField& = " & nField& & vbTab & "wParam&(Low): &H(" & LoWord%(wParam&) & ", " & Hex(wParam&) & ")" & vbTab & "lParam& = &H(" & Hex(lParam&) & ")" & vbCrLf & Left(clsDebug.Text, BUFFER_DEBUG)
#End If
            End Select
        End Select
    End Select
    'only for debug purposses
    If fMessageDontDebug Then Exit Function
#If IPADDRDEBUG Then
    If IsIDE Then Call ClassDebug(hW&, uMsg&, wParam&, lParam&, dwRefData&)
#End If

Exit Function
ErrIHookXP_Message:
    Select Case MsgBox("nº de error = " & Err & vbCrLf & Err.Description & ": " & Err.Source, vbQuestion Or vbAbortRetryIgnore, App.Title)
        Case vbRetry: Resume 0
        Case vbAbort:  Exit Function
        Case vbIgnore: Resume Next
    End Select
End Function
Public Sub CreateIPWindow(ByVal ctrlHidden As Control)
Dim hFont&, lpRectTXT As RECT
Const DEFAULT_GUI_FONT = 17
    
    'only call CreateWindow one time
    If bCreateOnControl Then Exit Sub
    
    'for TextBox or PictureBox
    If InStr(1, "TextBoxPictureBox", TypeName(ctrlHidden), vbTextCompare) Then
        Set hIPAddr = Me
        Set hCTRLHidden = ctrlHidden
        Set clsDebug = frmPublic.txtDebug
        'no 3d and no border
        ctrlHidden.Appearance = 0
        ctrlHidden.BorderStyle = 0
        bCreateOnControl = True
        hWndCTRLHidden& = hCTRLHidden.hWnd
        Call GetClientRect(hWndCTRLHidden&, lpRectTXT)
        'size = size of Control Hidden
        hWndIPcls& = CreateWindowExA&(WS_EX_NOPARENTNOTIFY Or WS_EX_CLIENTEDGE, WC_IPADDRESS, vbNullString, WS_CHILD Or WS_VISIBLE, 0&, 0&, lpRectTXT.Right, lpRectTXT.bottom, hWndCTRLHidden&, 0&, App.hInstance, ByVal 0&)
    End If
    strIP$ = ""
    'for debug, asign a "NAME" for each IPAddr
    strName$ = "clsIP" & ctrlHidden.Name

'because a bug, only get font of Control Hidden at run time
    If IsIDE Then
    'at develloper time IPAddr show the DEFAULT_GUI_FONT
        hFont& = GetStockObject(DEFAULT_GUI_FONT)
    Else
    'at runtime the font is correct
        hFont& = SendMessage&(hWndCTRLHidden&, WM_GETFONT, 0&, 0&)
    End If
    Call SendMessage(hIPAddr.hWnd&, WM_SETFONT, hFont&, 1)
    
    Call HookSet(hWndCTRLHidden&, hIPAddr)
    Call HookSet(hIPAddr.hWnd, hIPAddr)
    Call EnumChildWindows&(hIPAddr.hWnd, AddressOf EnumChildProc&, ByVal hIPAddr.hWnd)
    'you can debug any edit text
    'Call HookSet(arrFields(0).hWnd, hIPAddr)
End Sub
Public Property Get lngIP&()
    Dim lIP&
    Call SendMessage(hIPAddr.hWnd&, IPM_GETADDRESS, 0, lIP&)
    lngIP& = ntohl&(lIP&)
End Property
Private Property Let lngIP(ByVal IPNueva&)
    SendMessage hIPAddr.hWnd&, IPM_SETADDRESS, 0, ByVal htonl&(IPNueva&)
End Property
Public Property Get strIP$()
    Dim lRes&, lpszDst$
    lRes& = inet_ntoa&(ByVal lngIP&)
    lpszDst$ = String(lstrlen&(ByVal lRes&), 0)
    lRes& = lstrcpy&(ByVal lpszDst$, ByVal lRes&)
    If lRes& = 0 Then lpszDst$ = "0.0.0.0"
    strIP$ = lpszDst$
End Property
Public Property Let strIP(strIP$)
If Len(strIP$) Then
    lngIP& = inet_addr&(strIP$)
Else
    lngIP& = 0 'asignar valor por defecto del Gateway
End If
End Property
Private Property Let strName(strName$)
If Len(szName$) Then Exit Property
    szName$ = strName$
End Property
Public Property Get strName$()
    If Len(szName$) = 0 Then Exit Property
    strName$ = szName$
End Property
Public Property Get hWnd&()
    hWnd& = hWndIPcls&
End Property
Public Property Get hDC&()
   hDC& = GetWindowDC(hIPAddr.hWnd)
End Property
Private Sub Class_Initialize()
    Dim iccex As tINITCOMMONCONTROLSEX
    With iccex
        .dwSize = LenB(iccex): .dwICC = ICC_INTERNET_CLASSES
    End With
    Call InitCommonControlsEx(iccex)
End Sub
Public Sub NoMoreDebug()
    Set clsDebug = Nothing
    Set hCTRLHidden = Nothing
End Sub
Private Sub Class_Terminate()
    If hIPAddr Is Nothing Then Exit Sub
    Call DestroyWindow&(hIPAddr.hWnd&)
    bCreateOnControl = False
    Set hIPAddr = Nothing
End Sub
Private Function IsIDE() As Boolean
  On Local Error GoTo ErrIsIDE
  Debug.Print 1 / 0
ErrIsIDE:
  IsIDE = Err
End Function
Private Function MAKEwParam&(LowWord&, HiWord&)
    MAKEwParam& = (LowWord& And &HFFFF&) Or (HiWord& * &H10000)
End Function
Private Function LoWord%(ByVal dwValue&)
    LoWord% = dwValue& And &HFFFF&
End Function
Private Function HiWord%(ByVal dwValue&)
    HiWord% = dwValue& \ &HFFFF&
End Function
Private Property Get APIIPdeLong$()
Dim arrIp(3) As Byte, iCount%, arrsIp$(3)
    Call CopyMemory(arrIp(0), lngIP&, ByVal 4)
    For iCount% = 0 To 3
        arrsIp$(iCount%) = CStr(arrIp(iCount%))
    Next iCount%
    APIIPdeLong$ = Join(arrsIp, ".")
End Property
Private Property Let APIIPdeLong(APIIPdeLong$)
    lngIP& = inet_addr&(APIIPdeLong$)
End Property
Public Sub ClearAddr()
    SendMessage hIPAddr.hWnd&, IPM_CLEARADDRESS, 0&, ByVal 0&
End Sub
Public Sub SetFieldFocus(Optional ByVal nField&)
    If hIPAddr.hWnd Then Call SendMessage(hIPAddr.hWnd, IPM_SETFOCUS, nField&, ByVal 0&)
End Sub
Public Function GetField&(ByVal nField&)
Dim lRes&, lpBuf$
    If hIPAddr.hWnd Then
        lpBuf$ = String$(254, 0)
        lRes& = GetWindowText(arrFields(nField&).hWnd, lpBuf$, Len(lpBuf$))
        lpBuf$ = Left$(lpBuf$, lRes&)
        If lRes& Then GetField& = CLng(lpBuf$)
    End If
End Function
Public Function EnableField&(ByVal nField&, ByVal bEnable As Boolean)
If hIPAddr.hWnd Then EnableField& = EnableWindow(arrFields(nField&).hWnd, bEnable)
End Function
Private Sub SetAddress(ByVal Address1 As Byte, ByVal Address2 As Byte, ByVal Address3 As Byte, ByVal Address4 As Byte)
    Call SendMessage(hIPAddr.hWnd, IPM_SETADDRESS, 0, ByVal MAKEIPADDRESS(Address1, Address2, Address3, Address4))
End Sub
'Sets the permissible range (from 0 to 255) for the specified field.
Private Sub SetFieldRange(ByVal nField As Long, ByVal Lower As Byte, ByVal Upper As Byte)
    Call SendMessage(hIPAddr.hWnd, IPM_SETRANGE, nField, ByVal MAKEIPRANGE(Lower, Upper))
End Sub
Public Function VBPing&(Optional ByRef szMessage$, Optional ByVal TIMEOUT As Long = 1500)
Dim ECHO As ICMP_ECHO_REPLY, sDataToSend$, hPort&
If hIPAddr.hWnd = 0 Then Exit Function
    hPort& = IcmpCreateFile&()
    If hPort& Then
        sDataToSend$ = "abcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklm"
        'for local network TIMEOUT 500ms
        'dont work if IP= 217.X.X.X xDDDD
        If InStr(1, "192172", Left$(hIPAddr.strIP$, 3), vbTextCompare) Then TIMEOUT& = 500
        Call IcmpSendEcho&(hPort&, hIPAddr.lngIP, sDataToSend$, Len(sDataToSend$), 0&, ECHO, Len(ECHO), TIMEOUT)
        VBPing& = ECHO.status
        szMessage$ = GetStatusCode$(ECHO.status)
        Call IcmpCloseHandle&(hPort&)
    End If
End Function
Private Function GetStatusCode$(status&)
   Dim msg As String
   
   Select Case status
      Case IP_SUCCESS:               msg = "ip success"
      Case INADDR_NONE:              msg = "inet_addr: bad IP format"
      Case IP_BUF_TOO_SMALL:         msg = "ip buf too_small"
      Case IP_DEST_NET_UNREACHABLE:  msg = "ip dest net unreachable"
      Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable"
      Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable"
      Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable"
      Case IP_NO_RESOURCES:          msg = "ip no resources"
      Case IP_BAD_OPTION:            msg = "ip bad option"
      Case IP_HW_ERROR:              msg = "ip hw_error"
      Case IP_PACKET_TOO_BIG:        msg = "ip packet too_big"
      Case IP_REQ_TIMED_OUT:         msg = "ip req timed out"
      Case IP_BAD_REQ:               msg = "ip bad req"
      Case IP_BAD_ROUTE:             msg = "ip bad route"
      Case IP_TTL_EXPIRED_TRANSIT:   msg = "ip ttl expired transit"
      Case IP_TTL_EXPIRED_REASSEM:   msg = "ip ttl expired reassem"
      Case IP_PARAM_PROBLEM:         msg = "ip param_problem"
      Case IP_SOURCE_QUENCH:         msg = "ip source quench"
      Case IP_OPTION_TOO_BIG:        msg = "ip option too_big"
      Case IP_BAD_DESTINATION:       msg = "ip bad destination"
      Case IP_ADDR_DELETED:          msg = "ip addr deleted"
      Case IP_SPEC_MTU_CHANGE:       msg = "ip spec mtu change"
      Case IP_MTU_CHANGE:            msg = "ip mtu_change"
      Case IP_UNLOAD:                msg = "ip unload"
      Case IP_ADDR_ADDED:            msg = "ip addr added"
      Case IP_GENERAL_FAILURE:       msg = "ip general failure"
      Case IP_PENDING:               msg = "ip pending"
      Case Else:                     msg = "unknown msg returned"
   End Select
   GetStatusCode$ = CStr(status) & "   [ " & msg & " ]"
End Function
Private Function MAKEIPADDRESS(ByVal b1 As Byte, ByVal b2 As Byte, ByVal b3 As Byte, ByVal b4 As Byte) As Long
    '// And this is a useful macro for making the IP Address to be passed
    '// as a LPARAM.
    'MAKEIPADDRESS=  ((LPARAM)(((DWORD)(b1)<<24)+((DWORD)(b2)<<16)+((DWORD)(b3)<<8)+((DWORD)(b4))))
    MAKEIPADDRESS = Val("&H" & Right$("00" & Hex$(b1), 2) & Right$("00" & Hex$(b2), 2) & Right$("00" & Hex$(b3), 2) & Right$("00" & Hex$(b4), 2))
End Function
Private Function FIRST_IPADDRESS(ByVal x As Long) As Byte
    FIRST_IPADDRESS = (x \ (2 ^ 24)) And &HFF
End Function
Private Function SECOND_IPADDRESS(ByVal x As Long) As Byte
    SECOND_IPADDRESS = (x \ (2 ^ 16)) And &HFF
End Function
Private Function THIRD_IPADDRESS(ByVal x As Long) As Byte
    THIRD_IPADDRESS = (x \ (2 ^ 8)) And &HFF
End Function
Private Function FOURTH_IPADDRESS(ByVal x As Long) As Byte
    FOURTH_IPADDRESS = x And &HFF
End Function
Private Function MAKEIPRANGE(ByVal low As Byte, ByVal high As Byte) As Long
    '// The following is a useful macro for passing the range values in the
    '// IPM_SETRANGE message.
    MAKEIPRANGE = (CLng(high) * (2 ^ 8) + CLng(low))
End Function

Conclusion :


References and bibliography

I am use in all API projects, a Type Library, but YOU DON'T NEED to redistribute with the final executable
More information about windowsAPI.tlb
El Camino Real - sources libres pour les développeurs Visual Basic
http://www.el-camino-real.fr
Caution when try passing API ByRef: declare AS ANY, not AS LONG
If you do not use this library (or similar), you need to declare ALL API FUNCTIONS. Ridiculous.

This solution it?s very complex, only for a simple window...
http://www.vbaccelerator.com/home/VB/Code/Techniques/Trapping_The_Tab_Key_in_a_UserControl_with_IOLEInPlaceActiveObject/article.asp?id=1025

Subclassing XP
thanks to Karl E. Peterson, great Work
http://vb.mvps.org/samples/HookMe/
http://msdn.microsoft.com/en-us/library/bb761374(VS.85).aspx
http://www.geoffchappell.com/studies/windows/shell/comctl32/history/ords472.htm

IP Address Box Ctrl
Coded by EBArtSoft@
ebartsoft@hotmail.com

IP Address Control
http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=29518&lngWId=1

from China
PcCode_200885212415453

from Japan
http://www.mitene.or.jp/~sugisita/smp/ipedit.lzh
http://hpcgi1.nifty.com/MADIA/VBBBS2/wwwlng.cgi?print+200509/05090172.txt
Copyright (C) 1998, Sugi.
sugisita@mitene.or.jp

From Russia
Founder1e2@gmail.com
sources.ru

Common Controls Replacement Project IP Address Control
not free source-code ;(
==============================================
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.