Получить Ip-адрес сервера из обычной ссылки - VB

Option Explicit
 
Const WSADESCRIPTION_LEN As Long = 256&
Const WSASYS_STATUS_LEN As Long = 128&
 
Private Type wsaData
    wVersion As Integer
    wHighVersion As Integer
    szDescription(WSADESCRIPTION_LEN + 1) As Byte
    szSystemStatus(WSADESCRIPTION_LEN + 1) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type
 
Private Type hostent
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type
 
Private Type in_addr
    oct_1 As Byte
    oct_2 As Byte
    oct_3 As Byte
    oct_4 As Byte
End Type
 
Private Declare Function WSAStartup Lib "Ws2_32.dll" (ByVal wVersionRequested As Integer, lpWSAData As wsaData) As Long
Private Declare Function WSACleanup Lib "Ws2_32.dll" () As Long
Private Declare Function WSAGetLastError Lib "Ws2_32.dll" () As Long
 
Private Declare Function inet_addr Lib "Ws2_32.dll" (ByVal cp As Long) As in_addr  'Windows Vista +
Private Declare Function inet_ntoa Lib "Ws2_32.dll" (ByVal Addr As Long) As Long  'Windows Vista +
Private Declare Function gethostbyname Lib "Ws2_32.dll" (ByVal lpCharName As Long) As Long  'Windows Vista +
Private Declare Function gethostbyaddr Lib "Ws2_32.dll" (ByVal lpCharAddr As Long, ByVal llen As Long, ByVal ltype As Long) As Long  'Windows Vista +
'Private Declare Function RtlIpv4AddressToString Lib "Ntdll.dll" Alias "RtlIpv4AddressToStringA" (ptAddr As Long, ByVal S As Long) As Long  'Windows Vista +
 
Private Declare Function memcpy Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long) As Long
Private Declare Function FormatMessage Lib "kernel32.dll" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Any) As Long
Private Declare Function lstrlenA Lib "kernel32.dll" (ByVal lpString As Long) As Long
Private Declare Function lstrcpyA Lib "kernel32.dll" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
 
Private Const AF_INET As Long = 2
 
 
Private Sub Form_Load()
    ResolveHost "i.ua"
    ResolveHost "-"
    ResolveHost "255.1.1.1"
    ResolveHost "91.198.36.14"
    ResolveHost "https://yandex.ua/maps"
    ResolveHost "8.8.4.4:8080"
    Unload Me
End Sub
 
Function ResolveHost(ByVal Host_name As String)
    Dim wVersionRequested As Integer
    Dim dwErr As Long
    Dim wsaData As wsaData
    Dim remoteHost As hostent
    Dim lpRemoteHost As Long
    Dim i_addr As in_addr
    Dim pHost_NameA As Long
    Dim sAddr As String
 
    Debug.Print "-----------------------------------"
 
    'Extracting the host name
    Host_name = ExtractHost(Host_name)
 
    wVersionRequested = 2& * 256 + 2    '(WinSock ver. 2.2.)
 
    dwErr = WSAStartup(wVersionRequested, wsaData)
    If (dwErr <> 0) Then
        MsgBox "WSAStartup failed with error: " & dwErr
        Exit Function
    End If
    
    'Confirm that the WinSock DLL supports 2.2.
    If ((wsaData.wVersion And 255&) <> 2) Or ((wsaData.wVersion \ 256&) <> 2) Then
        MsgBox "Could not find a usable version of Winsock.dll"
        GoTo Finally
    End If
 
    pHost_NameA = StrPtr(StrConv(Host_name, vbFromUnicode)) 'WSTR -> *char[]
 
    ' If the user input is an alpha name for the host, use gethostbyname()
    ' If not, get host by addr (assume IPv4)
    
    If Host_name Like "*[!0-9.]*" Then  'host address is a name
        Debug.Print "By Name. Calling gethostbyname with " & Host_name
 
        lpRemoteHost = gethostbyname(pHost_NameA)
        
        If 0 = lpRemoteHost Then
            dwErr = Err.LastDllError
            Debug.Print "Error #" & dwErr & ". " & WSA_MessageText(dwErr)
            'Debug.Print WSAGetLastError()  ' it seems WSAGetLastError doesn't work inside vbvm; err.LastDllError redirects its code instead.
            GoTo Finally
        End If
    Else
        Debug.Print "By Address. Calling gethostbyaddr with " & Host_name
        
        i_addr = inet_addr(pHost_NameA)  'ipv4 validation
        
        ' INADDR_NONE (-1)
        If i_addr.oct_1 = 255 And i_addr.oct_2 = 255 And i_addr.oct_3 = 255 And i_addr.oct_4 = 255 Then
            MsgBox "The IPv4 address entered must be a legal address"
            GoTo Finally
        End If
        
        lpRemoteHost = gethostbyaddr(VarPtr(i_addr), 4, AF_INET)    'ipv4 type  (possible values = ipv4, ipv6, NETBIOS)
        
        If 0 = lpRemoteHost Then
            dwErr = Err.LastDllError
            Debug.Print "Error #" & dwErr & ". " & WSA_MessageText(dwErr)
            GoTo Finally
        End If
    End If
    
    If 0 <> lpRemoteHost Then
        memcpy remoteHost, ByVal lpRemoteHost, LenB(remoteHost)     ' * -> struct
        
        Debug.Print "Official name: " & GetStringFromPtrA(remoteHost.h_name)
        
        Dim PtArr   As Long
        Dim ptAddr  As Long
        Dim PtChar  As Long
        Dim Addr    As Long
        
        PtArr = remoteHost.h_addr_list
        
        Do
            GetMem4 ByVal PtArr, ptAddr ' *addr for each element
            
            If ptAddr <> 0 Then
            
                GetMem4 ByVal ptAddr, Addr
            
                PtChar = inet_ntoa(Addr)  'addr -> *char[]
                If PtChar <> 0 Then
                    Debug.Print "Address: " & GetStringFromPtrA(PtChar)
                End If
                
'                sAddr = String$(8, vbNullChar)  'at least 16 chars
'                dwErr = RtlIpv4AddressToString(ByVal ptAddr, StrPtr(sAddr))
'                sAddr = StrConv(sAddr, vbUnicode)
'                Debug.Print "Address: " & sAddr
            End If
            PtArr = PtArr + 4
        Loop While ptAddr <> 0
    End If
    
Finally:
    WSACleanup
End Function
 
Function GetStringFromPtrA(Ptr As Long) As String
    Dim Size As Long
    Dim sText As String
    If Ptr <> 0 Then
        Size = lstrlenA(Ptr)
        If Size > 0 Then
            sText = String$(Size \ 2 + 1, vbNullChar)
            lstrcpyA StrPtr(sText), Ptr
            GetStringFromPtrA = Left$(StrConv(sText, vbUnicode), Size)
        End If
    End If
End Function
 
Private Function WSA_MessageText(lCode As Long) As String
    Const MAX_PATH As Long = 260&
    Const FORMAT_MESSAGE_FROM_SYSTEM    As Long = &H1000&
    Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200
    Const WSANO_DATA As Long = 11004
    Const WSAHOST_NOT_FOUND As Long = 11001
    
    Dim sRtrnCode   As String
    Dim lRet        As Long
    
    Select Case lCode
        Case WSAHOST_NOT_FOUND
            WSA_MessageText = "Host not found"
        Case WSANO_DATA
            WSA_MessageText = "No data record found"
        Case Else
            sRtrnCode = Space$(MAX_PATH)
            lRet = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, ByVal 0&, lCode, ByVal 0&, sRtrnCode, MAX_PATH, ByVal 0&)
            If lRet > 0 Then
                WSA_MessageText = Left$(sRtrnCode, lRet)
                WSA_MessageText = Replace$(WSA_MessageText, vbCrLf, vbNullString)
            End If
    End Select
End Function
 
' Вытягивает из строки адрес хоста для HTTP-адреса
Public Function ExtractHost(sText As String) As String
    On Error GoTo ErrorHandler
    Dim S        As String
    Dim pos      As Long
    Dim pos2     As Long
    Dim oRegEx   As Object
    Dim oMatches As Object
    
    Set oRegEx = CreateObject("VBScript.RegExp")
    oRegEx.Pattern = """?(http:|www(2)?\.|https:)[^ \r\n""]*( |""|$|\r|\n)"
    Set oMatches = oRegEx.Execute(sText)
    If oMatches.Count = 0 Then
        ExtractHost = sText
        GoTo Finally
    End If
    S = UnQuote(oMatches.Item(0).Value)
    
    ' - 0x0D 0x0A
    If Right$(S, 1) = Chr$(10) Then S = Left$(S, Len(S) - 1)
    If Right$(S, 1) = Chr$(13) Then S = Left$(S, Len(S) - 1)
    
    ' - http://
    If StrComp(Left$(S, 5), "http:", 1) = 0 Then
        S = Mid$(S, 8)
    ' - https://
    ElseIf StrComp(Left$(S, 6), "https:", 1) = 0 Then
        S = Mid$(S, 9)
    End If
    
    ' - www.
    If StrComp(Left$(S, 4), "www.", 1) = 0 Then
        S = Mid$(S, 5)
    ' - www2.
    ElseIf StrComp(Left$(S, 5), "www2.", 1) = 0 Then
        S = Mid$(S, 6)
    End If
    
    ' / с конца
    pos = InStr(S, "/")
    pos2 = InStr(S, "")
    If pos = 0 And pos2 = 0 Then
        ExtractHost = S
    Else
        If pos <> 0 And pos2 <> 0 Then
            ExtractHost = Left$(S, IIf(pos < pos2, pos - 1, pos2 - 1))
        ElseIf pos <> 0 Then
            ExtractHost = Left$(S, pos - 1)
        Else
            ExtractHost = Left$(S, pos2 - 1)
        End If
    End If
 
Finally:
    ' remove :port
    oRegEx.Pattern = ".*:\d+$"
    Set oMatches = oRegEx.Execute(ExtractHost)
    If oMatches.Count <> 0 Then
        ExtractHost = Left$(ExtractHost, InStrRev(ExtractHost, ":") - 1)
    End If
    
    Exit Function
ErrorHandler:
    Debug.Print Now, Err, "Parser.ExtractHost"
End Function
 
Public Function UnQuote(str As String) As String   ' Убрать кавычки (слева и справа)
    On Error GoTo ErrorHandler
    Dim S As String: S = str
    Do While Left$(S, 1&) = """"
        S = Mid$(S, 2&)
    Loop
    Do While Right$(S, 1&) = """"
        S = Left$(S, Len(S) - 1&)
    Loop
    UnQuote = S
    Exit Function
ErrorHandler:
    Debug.Print Now, Err, "Parser.UnQuote", "String: ", str
End Function