Attribute VB_Name = "Module1"
' This sampler was created by Jim Huff of Edinborg Productions
' on April 10, 1999.  I created this sampler in order to demonstrate
' how to perform the equivalent of the NBTSTAT -A function which
' is available from a Command Prompt.

' Please feel free to use, or modify, this code in whatever method, or
' fashion, you choose.  No warranties of any kind are implicity or
' explicitly implied by the author of this code.

' If you include portions of this code into your programs, please
' give some sort of credit referring to the author of this code.

' Author's EMail:  JimHuff@JimHuff.User.ShenTel.Net
'                  JimHuff@ ShenTel.Net
Option Explicit

Type NBPkt
    XactionID As Integer
    Flags As Integer
    QCount As Integer
    ACount As Integer
    NSCount As Integer
    ARCount As Integer
    QName(33) As Byte
    QType As Integer
    QClass As Integer
End Type

Type NodeName
    bName(0 To 15) As Byte
    RRFlag As Integer
End Type

Type Response
    TTL As Long
    RDLength As Integer
    NUM_Names As Byte
End Type

Type RespPartII
    NodeNameArray() As NodeName
End Type

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb&)

Function deNibble(sValue As String) As String

    ' This function performs the DeNibbling process of the
    ' names.

    Dim sTemp As String

    Dim Byte1 As Integer
    Dim Byte2 As Integer

    For i = 1 To Len(sValue) Step 2
        Byte1 = Asc(Mid(sValue, i, 1)) - 65
        Byte2 = (Asc(Mid(sValue, i + 1, 1)) - 65)
        sTemp = sTemp + Chr$((Byte1 * 16) + Byte2)
    Next i

    deNibble = sTemp

End Function
Function NibbleIt(sValue As String) As String

    ' I don't feel like Nibbling It at this time.

End Function
Function HexConvert(bValue() As Byte) As String
    Dim i As Integer
    
    For i = 0 To UBound(bValue())
        If bValue(i) < 15 Then
            HexConvert = HexConvert + "0" & Hex(bValue(i))
            If i < UBound(bValue) Then HexConvert = HexConvert + "-"
        Else
            HexConvert = HexConvert + Hex(bValue(i))
            If i < UBound(bValue) Then HexConvert = HexConvert + "-"
        End If
    Next i

End Function
Function ProcessRcvdData(sDataFromNet As String) As String

    ' I am not going to bother explaining this mess.  You can see
    ' what I did below and compare it to RFC-1001 and RFC-1002 to
    ' figure it out.
    
    ' Simply put, this function processes the received data and
    ' provides the calling subroutine with a text-based result.

    Dim rcvdPkt As NBPkt
    Dim rcvdResponse As Response
    Dim rcvdRespPartII As RespPartII
    Dim MACCode(5) As Byte
    Dim Name_Flag As Integer
    Dim udtData As String
    Dim sTemp As String
    Dim QName As String
    Dim btemp(0) As Byte
    Dim i As Integer
    Dim j As Integer

    udtData = Left(sDataFromNet, Len(rcvdPkt))

    CopyMemory rcvdPkt.XactionID, ByVal udtData, Len(rcvdPkt)

    sDataFromNet = Right(sDataFromNet, Len(sDataFromNet) - Len(udtData))

    QName = String(32, 0)
    CopyMemory ByVal QName, rcvdPkt.QName(1), 32

    udtData = Left(sDataFromNet, 7)
    sDataFromNet = Right(sDataFromNet, Len(sDataFromNet) - Len(udtData))

    CopyMemory rcvdResponse.TTL, ByVal udtData, 8

    ReDim rcvdRespPartII.NodeNameArray(rcvdResponse.NUM_Names)

    ProcessRcvdData = "         NetBIOS Machine Name Table" + vbCrLf + vbCrLf
    ProcessRcvdData = ProcessRcvdData + " Name      " + vbTab + "Type       " + vbTab + "Status" + vbCrLf
    ProcessRcvdData = ProcessRcvdData + "---------------------------------------------" + vbCrLf

    For i = 1 To rcvdResponse.NUM_Names

        udtData = Left(sDataFromNet, Len(rcvdRespPartII.NodeNameArray(i)))
        sDataFromNet = Right(sDataFromNet, Len(sDataFromNet) - Len(udtData)) + vbTab + vbTab

        CopyMemory rcvdRespPartII.NodeNameArray(i), ByVal udtData, Len(udtData)

        sTemp = String(15, 0)
        CopyMemory ByVal sTemp, rcvdRespPartII.NodeNameArray(i).bName(0), Len(sTemp)

        For j = 1 To Len(sTemp)     ' Convert unprintable characters to a dot "."
            DoEvents
            If Asc(Mid(sTemp, j, 1)) < 32 Then Mid(sTemp, j, 1) = "."
        Next j

        ProcessRcvdData = ProcessRcvdData + sTemp + vbTab

        btemp(0) = rcvdRespPartII.NodeNameArray(i).bName(15)
    
        ProcessRcvdData = ProcessRcvdData + "<" & HexConvert(btemp) & ">  " + vbTab

        Name_Flag = htons(rcvdRespPartII.NodeNameArray(i).RRFlag)

        If Int((Name_Flag / 256) And &H80) = &H80 Then
            ProcessRcvdData = ProcessRcvdData + "GROUP       "
        Else
            ProcessRcvdData = ProcessRcvdData + "UNIQUE      "
        End If
        If Int((Name_Flag / 256) And &H10) = &H10 Then ProcessRcvdData = ProcessRcvdData + "DeRegistering"
        If Int((Name_Flag / 256) And &H8) = &H8 Then ProcessRcvdData = ProcessRcvdData + "Name Conflict"
        If Int((Name_Flag / 256) And &H4) = &H4 Then ProcessRcvdData = ProcessRcvdData + "Registered"
        If Int((Name_Flag / 256) And &H2) = &H2 Then ProcessRcvdData = ProcessRcvdData + "Permanent Name"
        ProcessRcvdData = ProcessRcvdData + vbCrLf
    Next i
    ProcessRcvdData = ProcessRcvdData + vbCrLf

    udtData = Left(sDataFromNet, 6)
    sDataFromNet = ""
    CopyMemory MACCode(0), ByVal udtData, 6
    
    ProcessRcvdData = ProcessRcvdData + "MAC Address = " & HexConvert(MACCode()) + vbCrLf + vbCrLf

End Function