dns request (vb)

Option Explicit

Sub main()
    Dim DOMAIN As String
    DOMAIN = InputBox("Input domain name:")
    Dim REM_IP As String
    REM_IP = InputBox("Input DNS server address [8.8.8.8]:")
    If REM_IP = vbNullString Then REM_IP = "8.8.8.8"
    Const REM_PORT As Long = 53

    Dim dmn_parts() As String
    dmn_parts = Split(DOMAIN, ".")
    Dim values() As Variant
    values = Array(&H123, &H100, 1, 0, 0, 0)
    Dim dmn_parts_fmt() As Variant
    dmn_parts_fmt = Array(vbInteger, vbInteger, vbInteger, vbInteger, vbInteger, vbInteger)
    Dim part As Variant
    For Each part In dmn_parts
        cnct values, Array(Len(part), part)
        cnct dmn_parts_fmt, Array(vbByte, vbString)
    Next part
    cnct values, Array(0, &H1, &H1)
    cnct dmn_parts_fmt, Array(vbByte, vbInteger, vbInteger)
    Dim MESSAGE() As Byte
    MESSAGE = pack(values, dmn_parts_fmt)

    Dim sock As Object
    Set sock = CreateObject("MSWinSock.Winsock")
    sock.Protocol = &H1 'sckUDPProtocol
    sock.RemoteHost = REM_IP
    sock.RemotePort = REM_PORT
    sock.SendData MESSAGE
    Do Until sock.BytesReceived 'Wait for response
        DoEvents
    Loop
    ReDim ANSWER(sock.BytesReceived - 1) As Byte
    sock.GetData ANSWER
    Dim h() As Variant, que_n As Long, ans_n As Long, aut_n As Long, add_n As Long
    h = unpack(ANSWER, Array(vbInteger, vbInteger, vbInteger, vbInteger, vbInteger, vbInteger))
    que_n = h(2)
    ans_n = h(3)
    aut_n = h(4)
    add_n = h(5)

    Debug.Print "DNS server: " & REM_IP & ":" & REM_PORT
    Debug.Print "Query (UDP): " & hexlify(MESSAGE)
    Debug.Print "Answer from " & sock.RemoteHostIP & ":" & sock.RemotePort & ": " & hexlify(ANSWER)
    Debug.Print
    Debug.Print "Transaction ID: 0x" & Hex(h(0))
    Debug.Print "Flags: 0x" & Hex(h(1))
    Debug.Print "Questions: " & que_n
    Debug.Print "Answer RRs: " & ans_n
    Debug.Print "Authority RRs: " & aut_n
    Debug.Print "Additional RRs: " & add_n
    Debug.Print

    Dim pos As Long, name As String, i As Long
    'Queries
    pos = 12
    For i = 1 To que_n
        name = readDomainName(ANSWER, pos)
        Debug.Print i & " Query for: " & name
        pos = pos + 2 + 2
    Next i
    Debug.Print
    'Answers
    Dim answ As String, type_ As Long
    For i = 1 To ans_n
        name = readDomainName(ANSWER, pos)
        If Len(name) Then
            answ = ""
            type_ = unpack(ANSWER, Array(vbInteger), pos)(0)
            pos = pos + 2 + 2 + 4 + 2
            If type_ = &H1 Then 'A record
                answ = getIPv4(ANSWER, pos)
            ElseIf type_ = &H5 Then 'CNAME
                answ = readDomainName(ANSWER, pos)
            End If
            If Len(answ) Then
                Debug.Print i & " Answer for " & name & " is " & answ
            Else
                Debug.Print i & " Corrupted answer for " & name
                Exit For
            End If
        Else
            Debug.Print i & " Corrupted answer"
            Exit For
        End If
    Next i
End Sub

'append values to array
Private Sub cnct(arr As Variant, vals As Variant)
    Dim l As Long, u As Long
    l = UUBound(arr) + 1
    u = l + UBound(vals)
    ReDim Preserve arr(u)
    Dim i As Long
    For i = l To u
        arr(i) = vals(i - l)
    Next i
End Sub

Private Function UUBound(arr) As Long
On Error GoTo 1:
    UUBound = UBound(arr)
Exit Function
1: UUBound = -1
End Function

Private Function pack(arr() As Variant, fmt() As Variant) As Byte()
    Dim ret() As Byte, aux() As Byte, i As Long
    For i = 0 To UBound(fmt)
        Select Case fmt(i)
        Case vbByte:
            ReDim aux(0) As Byte
            aux(0) = arr(i)
        Case vbInteger:
            Dim swap As Byte
            aux = ChrW$(arr(i))
            swap = aux(0)
            aux(0) = aux(1)
            aux(1) = swap
        Case vbString: aux = StrConv(arr(i), vbFromUnicode)
        End Select
        cnct ret, aux
    Next i
    pack = ret
End Function

Private Function unpack(arr() As Byte, fmt As Variant, Optional ByVal off As Long = -1) As Variant()
    Dim i As Long, pos As Long
    If off <> -1 Then pos = off
    Dim arrs As String
    arrs = arr
    ReDim ret(UBound(fmt)) As Variant
    For i = 0 To UBound(fmt)
        Select Case fmt(i)
        Case vbByte:
            ret(i) = AscB(MidB(arrs, pos + 1, 1))
            pos = pos + 1
        Case vbInteger:
            ret(i) = CLng(AscB(MidB(arrs, pos + 1, 1))) * &H100 Or _
                    CLng(AscB(MidB(arrs, pos + 1 + 1, 1)))
            pos = pos + 2
        End Select
    Next i
    unpack = ret
End Function

Private Function hexlify(arr() As Byte) As String
    Dim i As Long
    For i = 0 To UBound(arr)
        hexlify = hexlify & Format$(Hex$(arr(i)), "00")
    Next i
End Function

Private Function readDomainName(dat() As Byte, off As Long, Optional ByVal lvl_ptr As Long = 0) As String
    Dim got_ptr As Boolean, ret As String, isptr As Long, dats As String
    dats = dat
    got_ptr = False
    While Not got_ptr And dat(off)
        If LenB(ret) Then ret = ret & "."
        isptr = unpack(dat, Array(vbInteger), off)(0)
        If isptr >= 49152 Then '0xC000
            got_ptr = True
            If lvl_ptr < 5 Then _
                ret = ret & readDomainName(dat, isptr And &H3FFF, lvl_ptr + 1) _
            Else ret = ret & "[depth err]"
            off = off + 2
        Else
            ret = ret & StrConv(MidB(dats, off + 1 + 1, dat(off)), vbUnicode)
            off = off + dat(off) + 1
        End If
    Wend
    If Not got_ptr And dat(off) = 0 Then off = off + 1 'skip /0
    readDomainName = ret
End Function

Private Function getIPv4(dat() As Byte, off As Long) As String
    Dim ip() As Variant
    ip = unpack(dat, Array(vbByte, vbByte, vbByte, vbByte), off)
    getIPv4 = Join(ip, ".")
    off = off + 4
End Function