Scraping data from WIFI networks that are available

[johnnyL]

Ultimately, I would like to combine the results from the following onto one sheet:

1) CreateObject("WScript.Shell").Run "cmd /c netsh wlan show networks mode=BSSID" & _
"|clip""", 0, True
specifically:
SSID, Networktype, Authentication, Encryption, MAC Address (BSSID), Signal level, Radiotype, Band, & Channel ... I have the code to do this

2) Data scraped from WLAN_AVAILABLE_NETWORK
specifically:
uNumberOfBssids, uNumberOfPhyTypes, dot11PhyTypes

3) Data scraped from WLAN_BSS_ENTRY
specifically:
lRssi, uLinkQuality, usBeaconPeriod, ullTimestamp


The code I have for getting the data from WLAN_AVAILABLE_NETWORK works perfectly.

The problems I encounter is when I try getting the data from WLAN_BSS_ENTRY.

The problems seem to be multiple.
The gathering of data from WLAN_BSS_ENTRY only occasionally works for the first row of data, most of the time it produces 'garbage' info. All additional rows seem to result in 'garbage' info.

I would tend to think that the issue is a memory pointer issue not being incremented properly.

I have also noticed that the WLAN_AVAILABLE_NETWORK section that works perfectly, doesn't 'jive' with the results from WLAN_BSS_ENTRY ... ie. The SSID's aren't matched up.


Any help would be most appreciated. Probably serves me right for delving into this area of API's and such that I am not used to dealing with.

Perhaps someone such as @Jaafar Tribak or others that are wise to this approach of 'scraping' data could assist.

The following is the code I am currently trying to use to scrape the data from WLAN_AVAILABLE_NETWORK & WLAN_BSS_ENTRY:

Option Explicit
'
    Private Const DOT11_SSID_MAX_LENGTH                 As Long = 32
    Private Const WLAN_MAX_PHY_TYPE_NUMBER              As Long = 8
    Private Const DOT11_RATE_SET_MAX_LENGTH             As Long = 126
'
    Private Type GUID
'        data1                                           As Long                         '   The first 4 bytes of the GUID.
'        data2                                           As Integer                      '   The next 2 bytes of the GUID.
'        data3                                           As Integer                      '   The next 2 bytes of the GUID.
'        data4(7)                                        As Byte                         '   The last 8 bytes of the GUID as an array of bytes.
        Data(15)                                        As Byte                         '   The entire 16 bytes of the GUID as an array of bytes.
    End Type
'
    Private Type WLAN_INTERFACE_INFO
        interfaceGuid                                   As GUID                         '   The globally unique identifier (GUID) of the WLAN interface.
        strInterfaceDescription(255)                    As Byte                         '   The description of the WLAN interface as an array of bytes with a maximum
'                                                                                       '           length of 255 characters.
'        IsState                                         As Long                         '   The current state of the WLAN interface.
    End Type
'
    Private Type DOT11_SSID
        uSSIDLength                                     As Long                         '   The length of the SSID (Service Set Identifier) in bytes.
        ucSSID(DOT11_SSID_MAX_LENGTH - 1)               As Byte                         '   The array of bytes that stores the actual SSID data.
    End Type
'
    Private Type DOT11_MAC_ADDRESS
        DOT11_MAC_ADDRESS(5)                            As Byte
    End Type
'
    Private Enum DOT11_BSS_TYPE
        infrastructure = 1                                                              '   An infrastructure network, which is a traditional Wi-Fi network with access
'                                                                                       '           points (APs).
        independent = 2                                                                 '   An independent or ad-hoc network, where devices communicate directly with
'                                                                                       '           each other without the use of an access point.
        Any_ = 3                                                                        '   Any BSS (Basic Service Set) type, which includes both infrastructure and
'                                                                                       '           independent networks.
    End Enum
'
    Private Enum DOT11_PHY_TYPE
        unknown = 0                                                                     '   An unknown or unspecified PHY type.
        Any_ = 0                                                                        '   Any PHY type. Note that "Any_" is used instead of "Any" due to the reserved
'                                                                                       '           keyword "Any" in VBA
        fhss = 1                                                                        '   Frequency-hopping spread spectrum (FHSS) PHY type
        dsss = 2                                                                        '   Direct-sequence spread spectrum (DSSS) PHY type.
        irbaseband = 3                                                                  '   Infrared baseband PHY type.
        ofdm = 4                                                                        '   Orthogonal frequency-division multiplexing (OFDM) PHY type.
        hrdsss = 5                                                                      '   High-rate DSSS (HRDSSS) PHY type
        erp = 6                                                                         '   Extended rate PHY (ERP) type.
        ht = 7                                                                          '   High throughput (HT) PHY type.
        vht = 8                                                                         '   Very high throughput (VHT) PHY type.
'        IHV_start   = 0x80000000
'        IHV_end     = 0xffffffff
    End Enum
'
    Private Type WLAN_RATE_SET
        uRateSetLength                                  As Long                         '   Length of the rate set in bytes.
        usRateSet(DOT11_RATE_SET_MAX_LENGTH - 1)        As Integer                      '   Array to store rate values with a maximum length of (DOT11_RATE_SET_MAX_LENGTH - 1) elements.
    End Type
'
    Private Type WLAN_AVAILABLE_NETWORK
        strProfileName(511)                             As Byte                         '   * 1: Profile name of the available network, stored as a byte array with a
'                                                                                       '           maximum length of 511 characters.
        dot11Ssid                                       As DOT11_SSID                   '   * 2: SSID of the available network, represented by the DOT11_SSID type.
        dot11BssType                                    As Long                         '   Type of Basic Service Set (BSS) of the network (e.g., infrastructure, independent).
        uNumberOfBssids                                 As Long                         '   * 7: Number of BSSIDs (MAC addresses) for the available network.
        bNetworkConnectable                             As Long                         '   Flag indicating if the network is currently connectable.
        wlanNotConnectableReason                        As Long                         '   Reason code for why the network is not connectable.
        uNumberOfPhyTypes                               As Long                         '   * 8: Number of supported PHY types for the network.
        dot11PhyTypes(WLAN_MAX_PHY_TYPE_NUMBER - 1)     As Long                         '   * 9: Array of supported PHY types (e.g., OFDM, HT) with a maximum length defined
'                                                                                       '           by WLAN_MAX_PHY_TYPE_NUMBER.
        bMorePhyTypes                                   As Long                         '   Flag indicating if there are additional PHY types not included in the array.
        wlanSignalQuality                               As Long                         '   * 3: Signal quality of the network.
        bSecurityEnabled                                As Long                         '   Flag indicating if the network has security enabled.
        dot11DefaultAuthAlgorithm                       As Long                         '   * 10: Default authentication algorithm used by the network (e.g., WPA, WPA2, etc).
        dot11DefaultCipherAlgorithm                     As Long                         '   * 11: Default cipher algorithm used by the network (e.g., TKIP, AES. etc).
        dwFlags                                         As Long                         '   * 6: Additional flags providing information about the network (e.g., hidden network).
        dwReserved                                      As Long                         '   Reserved field for future use.
    End Type
'
    Private Type WLAN_AVAILABLE_NETWORK_LIST                                            '   List of available WLAN networks
        dwNumberOfItems                                 As Long                         '   Number of items in the list
        dwIndex                                         As Long                         '   Index of the list
'        Network                                         As WLAN_AVAILABLE_NETWORK
    End Type
'
    Private Type WLAN_INTERFACE_INFO_LIST
        dwNumberOfItems                                 As Long                         '   The number of WLAN interfaces in the list.
        dwIndex                                         As Long                         '   The index of the current WLAN interface (used for enumeration).
        InterfaceInfo                                   As WLAN_INTERFACE_INFO          '   The WLAN_INTERFACE_INFO structure that holds information about the WLAN interface.
    End Type
'
    Private Type WLAN_BSS_ENTRY
        dot11Ssid                                       As DOT11_SSID                   '   SSID of the BSS
        uPhyId                                          As Long                         '   PHY ID
        dot11Bssid(0 To 5)                              As Byte                         '   BSSID (MAC address)
        dot11BssType                                    As DOT11_BSS_TYPE               '   Type of BSS (infrastructure, independent, or any)
        dot11BssPhyType                                 As DOT11_PHY_TYPE               '   PHY type of the BSS
        lRssi                                           As Long                         '   Received Signal Strength Indicator (RSSI) value
        uLinkQuality                                    As Long                         '   Link quality value
        bInRegDomain                                    As Boolean                      '   Is the BSS in a regulatory domain?
        usBeaconPeriod                                  As Integer                      '   Beacon period of the BSS
        ullTimestamp                                    As Double                       '   Timestamp
        ullHostTimestamp                                As Double                       '   Host timestamp
        usCapabilityInformation                         As Integer                      '   Capability information of the BSS
        ulChCenterFrequency                             As Long                         '   Channel center frequency of the BSS
        wlanRateSet                                     As WLAN_RATE_SET                '   WLAN rate set of the BSS
        ulIeOffset                                      As Long                         '   Information element offset
        ulIeSize                                        As Long                         '   Information element size
    End Type
'
    Private Type WLAN_BSS_LIST                                                          '   List of WLAN_BSS_ENTRY
        dwTotalSize                                     As Long                         '   Total size of the list
        dwNumberOfItems                                 As Long                         '   Number of items in the list
        wlanBssEntries(1)                               As WLAN_BSS_ENTRY               '   Fixed-size array of WLAN_BSS_ENTRY
    End Type
'
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, _
            Source As Any, ByVal length As Long)
'
    Declare PtrSafe Function WlanOpenHandle Lib "wlanapi.dll" (ByVal dwClientVersion As Long, _
            ByVal pdwReserved As LongPtr, ByRef pdwNegotiaitedVersion As Long, _
            ByRef phClientHandle As LongPtr) As Long
'
    Declare PtrSafe Function WlanCloseHandle Lib "wlanapi.dll" (ByVal hClientHandle As LongPtr, _
            Optional ByVal pReserved As LongPtr) As Long
'
    Declare PtrSafe Function WlanEnumInterfaces Lib "wlanapi.dll" (ByVal hClientHandle As LongPtr, _
            ByVal pReserved As LongPtr, ByRef ppInterfaceList As LongPtr) As Long
'
    Declare PtrSafe Function WlanScan Lib "wlanapi.dll" (ByVal hClientHandle As LongPtr, _
            ByRef pInterfaceGuid As GUID, Optional ByVal pDot11Ssid As LongPtr, _
            Optional ByVal pIeData As LongPtr, Optional ByVal pReserved As LongPtr) As Long
'
    Declare PtrSafe Function WlanGetAvailableNetworkList Lib "wlanapi.dll" ( _
            ByVal hClientHandle As LongPtr, ByRef pInterfaceGuid As GUID, ByVal dwFlags As Long, _
            ByVal pReserved As LongPtr, ByRef ppAvailableNetworkList As LongPtr) As Long
'
    Private Declare PtrSafe Function WlanGetNetworkBssList Lib "wlanapi.dll" (ByVal hClientHandle As LongPtr, _
            ByRef pInterfaceGuid As Any, ByVal pDot11Ssid As Any, ByVal dot11BssType As Long, _
            ByVal bSecurityEnabled As Long, ByVal pReserved As Any, ByRef ppWlanBssList As LongPtr) As Long
'
    Declare PtrSafe Sub WlanFreeMemory Lib "wlanapi.dll" (ByVal pMemory As LongPtr)
                

Sub GetWiFiConnetionsDetectedV2_CombinedV1()
'
    Dim Arrayrow                As Long
    Dim EnumInterfacesList      As Long
    Dim i                       As Long
    Dim lngAvailable            As Long
    Dim lngReturn               As Long
    Dim lngStartUdtNetwork      As Long
    Dim lngStartUdtWLANbss      As Long
    Dim NetworkBssList          As Long
    Dim NumberOfItems           As Long
    Dim OpenHandleClientHandle  As Long
    Dim OpenHandleClientVersion As Long
    Dim MacAddress              As String
    Dim PhyTypesString          As String
    Dim strProfile              As String
    Dim strSSID                 As String
    Dim HeaderArray             As Variant
    Dim resultArray()           As Variant
    Dim udtNetwork              As WLAN_AVAILABLE_NETWORK
    Dim udtAvailableList        As WLAN_AVAILABLE_NETWORK_LIST
    Dim udtWLANbss              As WLAN_BSS_ENTRY
    Dim wlanBssList             As WLAN_BSS_LIST
    Dim InterfaceInfoList       As WLAN_INTERFACE_INFO_LIST
'
    Application.ScreenUpdating = False
'
    HeaderArray = Array("Profile", "SSID", "Signal Quality", "Connected", "Number of BSSids", _
            "Number of PHY Types", "PHY Types", "Default Auth Algorithm", "Default Cypher Algorithm", _
            "SSID", "PhyId", "Bssid", "BssType", "Rssi", "LinkQuality", "InRegDomain", "BeaconPeriod", "Timestamp", _
            "HostTimestamp", "CapabilityInformation", "ChCenterFrequency", "IeOffset", "IeSize", "wlanRateSet")
'
    Range("A1").CurrentRegion.ClearContents                                                 ' Clear any existing data
'
' Get a Handle
    lngReturn = WlanOpenHandle(2&, 0&, OpenHandleClientVersion, OpenHandleClientHandle)
'
    If lngReturn = 0 Then                                                                   ' If WLAN handle was successful obtained then ...
        lngReturn = WlanEnumInterfaces(ByVal OpenHandleClientHandle, 0&, EnumInterfacesList) '   Enumerate the WLAN Interfaces, (Note: this code only looks at first interface)
        CopyMemory InterfaceInfoList, ByVal EnumInterfacesList, Len(InterfaceInfoList)      '   Copy the enumerated interface information to InterfaceInfoList
'
        lngReturn = WlanScan(OpenHandleClientHandle, InterfaceInfoList.InterfaceInfo.interfaceGuid) '   Refresh the available WIFI networks list
'
        lngReturn = WlanGetAvailableNetworkList(OpenHandleClientHandle, _
                InterfaceInfoList.InterfaceInfo.interfaceGuid, 2&, 0&, lngAvailable)        '   Get network list
        CopyMemory udtAvailableList, ByVal lngAvailable, LenB(udtAvailableList)             '   Copy the network list information to udtAvailableList
        lngStartUdtNetwork = lngAvailable + 8                                               '   Set the starting memory address for the available networks data.
'
        lngReturn = WlanGetNetworkBssList(OpenHandleClientHandle, InterfaceInfoList.InterfaceInfo.interfaceGuid, _
                0&, 1, False, ByVal 0&, NetworkBssList)                                     '   Get BSS List
        CopyMemory wlanBssList, ByVal NetworkBssList, LenB(wlanBssList)                     '   Copy the BSS list information to wlanBssList
        lngStartUdtWLANbss = NetworkBssList + 8                                             '   Set the starting memory address for the BSS list data.
'
' ********************************
' * Scrape the data that we want *
' ********************************
'
        ReDim resultArray(1 To 100, 1 To UBound(HeaderArray, 1) + 1)                        '   Establish the dimensions to use for resultArray, we can correct them later
'
        Do                                                                                  '   Loop through the available WIFI networks found
            Arrayrow = Arrayrow + 1                                                         '       Increment Arrayrow
'
' Populate the Available network structure
            CopyMemory udtNetwork, ByVal lngStartUdtNetwork, Len(udtNetwork)                '       Copy the network WLAN_AVAILABLE_NETWORK data to udtNetwork
            CopyMemory udtWLANbss, ByVal lngStartUdtWLANbss, Len(udtWLANbss)                '       Copy the network WLAN_BSS_ENTRY data to udtWLANbss
'
' Save the Data from WLAN_AVAILABLE_NETWORK
            For i = 0 To UBound(udtNetwork.strProfileName)                                  '       Loop through the bytes of strProfileName
                strProfile = strProfile & Chr(udtNetwork.strProfileName(i))                 '           Save the formatted strProfileName byte to strProfile
            Next                                                                            '       Loop back
'
            strProfile = StrConv(strProfile, vbFromUnicode)                                 '       Strip the bs characters from strProfile
'
            strProfile = Left$(strProfile, InStr(strProfile, Chr(0)) - 1)                   '       Strip rest of bs characters from strProfile
'
            resultArray(Arrayrow, 1) = strProfile                                           '       Save strProfile to resultArray
            strProfile = ""                                                                 '       Clear strProfile
'
            strSSID = Replace(StrConv(udtNetwork.dot11Ssid.ucSSID, vbUnicode), Chr(0), "")  '       Format dot11Ssid.ucSSID & save it to strSSID
'
            If Len(strSSID) < 1 Then strSSID = "Unnamed"                                    '       If strSSID = "" then set strSSID = "Unnamed"
'
            resultArray(Arrayrow, 2) = strSSID                                              '       Save strSSID to resultArray
            resultArray(Arrayrow, 3) = udtNetwork.wlanSignalQuality                         '       Save wlanSignalQuality to resultArray
'
            resultArray(Arrayrow, 4) = udtNetwork.dwFlags                                   '       Save dwFlags to resultArray
            resultArray(Arrayrow, 5) = udtNetwork.uNumberOfBssids                           '       Save uNumberOfBssids to resultArray
            resultArray(Arrayrow, 6) = udtNetwork.uNumberOfPhyTypes                         '       Save uNumberOfPhyTypes to resultArray
'
            For i = 0 To UBound(udtNetwork.dot11PhyTypes)                                   '       Loop through the dot11PhyTypes
                If PhyTypesString <> "" Then                                                '           If this is NOT the first dot11PhyType then ...
                    PhyTypesString = PhyTypesString & "," & udtNetwork.dot11PhyTypes(i)     '               Append the value to PhyTypesString
                Else                                                                        '           Else ...
                    PhyTypesString = udtNetwork.dot11PhyTypes(i)                            '               Save value to PhyTypesString
                End If
            Next                                                                            '       Loop back
'
            PhyTypesString = Replace(PhyTypesString, ",0", "")                              '       Delete the excess zeros from PhyTypesString
'
            resultArray(Arrayrow, 7) = PhyTypesString                                       '       Save PhyTypesString to resultArray
            PhyTypesString = ""                                                             '       Clear PhyTypesString
'
            Select Case udtNetwork.dot11DefaultAuthAlgorithm                                '       Get dot11DefaultAuthAlgorithm and save the equated value to resultArray
                Case 1: resultArray(Arrayrow, 8) = "Open"
                Case 2: resultArray(Arrayrow, 8) = "WEP"
                Case 3: resultArray(Arrayrow, 8) = "WPA"
                Case 4: resultArray(Arrayrow, 8) = "WPA_PSK"
                Case 6: resultArray(Arrayrow, 8) = "WPA2"
                Case 7: resultArray(Arrayrow, 8) = "WPA2_PSK"
                Case 8: resultArray(Arrayrow, 8) = "WPA3"
                Case 9: resultArray(Arrayrow, 8) = "WPA3_SAE"
                Case 10: resultArray(Arrayrow, 8) = "OWE"
                Case 11: resultArray(Arrayrow, 8) = "WPA3_ENT"
            End Select
'
            resultArray(Arrayrow, 9) = udtNetwork.dot11DefaultCipherAlgorithm               '       Save dot11DefaultCipherAlgorithm to resultArray
'
' Save the Data from WLAN_BSS_ENTRY
            strSSID = Replace(StrConv(udtWLANbss.dot11Ssid.ucSSID, vbUnicode), Chr(0), "")  '       Format dot11Ssid.ucSSID & save it to strSSID
'
            If Len(strSSID) < 1 Then strSSID = "Unnamed"                                    '       If strSSID = "" then set strSSID = "Unnamed"
'
            resultArray(Arrayrow, 10) = strSSID                                             '       Save strSSID to resultArray
            resultArray(Arrayrow, 11) = udtWLANbss.uPhyId                                   '       Save uPhyId to resultArray
'
            For i = 0 To 5                                                                  '       Loop through the 6 bytes of the BSSID (MAC ADDRESS)
                MacAddress = MacAddress & Right$("0" & Hex(udtWLANbss.dot11Bssid(i)), 2) & ":"  '       Save the byte to MacAddress
            Next                                                                            '       Loop back
'
            MacAddress = Left$(MacAddress, Len(MacAddress) - 1)                             '
'
            resultArray(Arrayrow, 12) = MacAddress                                          '       Save MacAddress to resultArray
            MacAddress = ""                                                                 '       Clear MacAddress



            resultArray(Arrayrow, 13) = udtWLANbss.dot11BssType                             '       Save dot11BssType to resultArray
            resultArray(Arrayrow, 14) = udtWLANbss.lRssi                                    '       Save lRssi to resultArray
            resultArray(Arrayrow, 15) = udtWLANbss.uLinkQuality                             '       Save uLinkQuality to resultArray
            resultArray(Arrayrow, 16) = udtWLANbss.bInRegDomain                             '       Save bInRegDomain to resultArray
            resultArray(Arrayrow, 17) = udtWLANbss.usBeaconPeriod                           '       Save usBeaconPeriod to resultArray
            resultArray(Arrayrow, 18) = udtWLANbss.ullTimestamp                             '       Save ullTimestamp to resultArray
            resultArray(Arrayrow, 19) = udtWLANbss.ullHostTimestamp                         '       Save ullHostTimestamp to resultArray
            resultArray(Arrayrow, 20) = udtWLANbss.usCapabilityInformation                  '       Save usCapabilityInformation to resultArray
            resultArray(Arrayrow, 21) = udtWLANbss.ulChCenterFrequency                      '       Save ulChCenterFrequency to resultArray
            resultArray(Arrayrow, 22) = udtWLANbss.ulIeOffset                               '       Save ulIeOffset to resultArray
            resultArray(Arrayrow, 23) = udtWLANbss.ulIeSize                                 '       Save ulIeSize to resultArray
'            resultArray(Arrayrow, 24) = udtWLANbss.wlanRateSet                             ' Compile error on this line
'
            NumberOfItems = NumberOfItems + 1                                               '       Increment NumberOfItems
            lngStartUdtNetwork = lngStartUdtNetwork + Len(udtNetwork)                       '       Advance the lngStartUdtNetwork memory address
            lngStartUdtWLANbss = lngStartUdtWLANbss + Len(udtWLANbss)                       '       Advance the lngStartUdtWLANbss memory address
        Loop Until NumberOfItems = udtAvailableList.dwNumberOfItems                         '   Loop back if more WIFI networks are available
'
        Range("A1").Resize(, UBound(HeaderArray, 1) + 1) = HeaderArray                      '   Display HeaderArray to the sheet
'
        resultArray = ReDimPreserve(resultArray, Arrayrow, UBound(HeaderArray, 1) + 1)      '   Resize resultArray to actual dimensions that we ended up needing
'
        Range("A2").Resize(UBound(resultArray, 1), UBound(resultArray, 2)) = resultArray    '   Display resultArray to the sheet
'
        With Range("C2:I" & Range("I" & Rows.Count).End(xlUp).Row)                          '   Center the data in the cells in columns C:I
            .HorizontalAlignment = xlCenter
              .VerticalAlignment = xlCenter
        End With
'
        ActiveSheet.UsedRange.EntireColumn.AutoFit                                          '   Autofit the widths of the used columns in the sheet
    End If
'
    WlanFreeMemory EnumInterfacesList
    WlanFreeMemory lngAvailable
    WlanFreeMemory NetworkBssList
    WlanCloseHandle OpenHandleClientHandle                                                  ' Release handle
'
    Application.ScreenUpdating = True                                                       ' Turn ScreenUpdating back on
End Sub


Public Function ReDimPreserve(ArrayNameToResize, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Preserve Original data & LBounds & Redim both dimensions for a 2D array
'
' example usage of the function:
' ResizedArrayName = ReDimPreserve(ArrayNameToResize,NewRowSize,NewColumnSize)
' ie.
' InputArray = ReDimPreserve(InputArray,10,20)
'
' This function will keep the LBounds (Lower Bounds) of the original array.
'
    Dim NewColumn                   As Long, NewRow                      As Long
    Dim OldColumnLbound             As Long, OldRowLbound                As Long
    Dim OldColumnUbound             As Long, OldRowUbound                As Long
    Dim NewResizedArray()           As Variant
'
    ReDimPreserve = False
'
    If IsArray(ArrayNameToResize) Then                                                                      ' If the variable is an array then ...
           OldRowLbound = LBound(ArrayNameToResize, 1)                                                      '   Save the original row Lbound to OldRowLbound
        OldColumnLbound = LBound(ArrayNameToResize, 2)                                                      '   Save the original column Lbound to OldColumnLbound
'
        ReDim NewResizedArray(OldRowLbound To NewRowUbound, OldColumnLbound To NewColumnUbound)             '   Create a New 2D Array with same Lbounds as the original array
'
        OldRowUbound = UBound(ArrayNameToResize, 1)                                                         '   Save row Ubound of original array
        OldColumnUbound = UBound(ArrayNameToResize, 2)                                                      '   Save column Ubound of original array
'
        For NewRow = OldRowLbound To NewRowUbound                                                           '   Loop through rows of original array
            For NewColumn = OldColumnLbound To NewColumnUbound                                              '       Loop through columns of original array
                If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then                             '           If more data to copy then ...
                    NewResizedArray(NewRow, NewColumn) = ArrayNameToResize(NewRow, NewColumn)               '               Append rows/columns to NewResizedArray
                End If
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        Erase ArrayNameToResize                                                                             '   Free up the memory the Original array was taking
'
        If IsArray(NewResizedArray) Then ReDimPreserve = NewResizedArray
    End If
End Function

 

[johnnyL]

For some frikkin reason, it appears that each version of excel requires different code for this to work.

I have since, created a version that works for Excel 2007, which is different from a version that works for Excel 2013, but neither of these versions works correctly with Excel 365. This is causing me to get highly perturbed.

 

[johnnyL]

Ok, I think I got this mostly worked out now.

I have added the RSSI into the results as well as an option to try and get the Vendor names associated with the MAC Addresses.


Hopefully some people will test the code and report back the results as well as what Windows & Office versions were tested.

WLANBSSEntryDataV2013.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Network Adaptor	SSID	MAC Address (BSSID)	Band	Signal	RSSI	Channel	Radio Type	Vendor	Authorization Algorithm	Encryption	Network Type
2	Realtek RTL8821CE 802.11ac PCIe Adapter	Cupcake	7c:10:c9:12:d5:80	2.4GHz	100%	-56	6	802.11ax	ASUSTek COMPUTER INC.	WPA2-Personal	CCMP	Infrastructure
3		Cupcake_5G	7c:10:c9:12:d5:84	5GHz	70%	-69	165	802.11ax	ASUSTek COMPUTER INC.	WPA2-Personal	CCMP	Infrastructure
4		NETGEAR42	e8:fc:af:a0:4c:43	2.4GHz	65%	-74	8	802.11n	NETGEAR	WPA2-Personal	CCMP	Infrastructure
5		OU812B4	50:ba:7d:80:ca:ae	2.4GHz	45%	-77	11	802.11ax	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
6		UnNamed	50:ba:7d:80:a6:ce	2.4GHz	35%	-78	1	802.11ax	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
7		OU812B4	50:ba:7d:80:a6:cd	2.4GHz	35%	-78	1	802.11ax	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
8		UnNamed	50:ba:7d:80:a6:cc	2.4GHz	15%	-79	1	802.11ax	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
9		DIRECT-roku-BF7B27	dc:3a:5e:43:b7:77	2.4GHz	35%	-79	8	802.11n	Roku, Inc.	WPA2-Personal	CCMP	Infrastructure
10		UnNamed	4e:51:a4:17:c4:0c	2.4GHz	20%	-81	11	802.11n	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
11		Strawhatpat	fc:51:a4:17:c4:0c	2.4GHz	15%	-82	11	802.11n	ARRIS Group, Inc.	WPA2-Personal	CCMP	Infrastructure
12		UnNamed	be:64:4b:0e:2e:06	2.4GHz	10%	-83	1	802.11n	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
13		Lichaam	bc:64:4b:0e:2e:06	2.4GHz	14%	-83	1	802.11n	ARRIS Group, Inc.	WPA2-Personal	CCMP	Infrastructure
14		NETGEAR71	bc:a5:11:6e:2b:e7	2.4GHz	15%	-84	6	802.11n	NETGEAR	WPA2-Personal	CCMP	Infrastructure
15		OU812B4	54:ba:7d:80:ca:ae	5GHz	14%	-84	157	802.11ax	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
16		UnNamed	54:ba:7d:80:ca:af	5GHz	15%	-85	157	802.11ax	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
17		XFINITY	2e:51:a4:17:c4:0d	5GHz	14%	-86	44	802.11ac	Vendor Not Found	WPA2-Enterprise	CCMP	Infrastructure
18		xfinitywifi	0e:51:a4:17:c4:0d	5GHz	14%	-86	44	802.11ac	Vendor Not Found	Open	None	Infrastructure
19		OU812B4	52:ba:7d:81:91:aa	5GHz	13%	-87	44	802.11ax	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
20		Strawhatpat	fc:51:a4:17:c4:0d	5GHz	13%	-87	44	802.11ac	ARRIS Group, Inc.	WPA2-Personal	CCMP	Infrastructure
21		UnNamed	4e:51:a4:17:c4:0d	5GHz	10%	-88	44	802.11ac	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
22		UnNamed	54:ba:7d:80:ca:ad	5GHz	12%	-88	157	802.11ax	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
23		UnNamed	52:ba:7d:81:91:a9	5GHz	10%	-90	44	802.11ax	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
24		UnNamed	52:ba:7d:81:91:ab	5GHz	9%	-91	44	802.11ax	Vendor Not Found	WPA2-Personal	CCMP	Infrastructure
25
Sheet1

Here is the code:

Option Explicit
'
#If VBA7 Then
         Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
        Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
        Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
   Private Declare PtrSafe Function WlanOpenHandle Lib "wlanapi.dll" ( _
            ByVal dwClientVersion As Long, ByVal pdwReserved As LongPtr, _
            ByRef pdwNegotiaitedVersion As Long, ByRef phClientHandle As LongPtr) As Long
    Private Declare PtrSafe Function WlanCloseHandle Lib "wlanapi.dll" ( _
            ByVal hClientHandle As LongPtr, ByVal pdwReserved As LongPtr) As Long
    Private Declare PtrSafe Function WlanEnumInterfaces Lib "wlanapi.dll" ( _
            ByVal hClientHandle As LongPtr, ByVal pReserved As LongPtr, _
            ppInterfaceList As LongPtr) As Long
    Private Declare PtrSafe Function WlanScan Lib "wlanapi.dll" ( _
            ByVal hClientHandle As LongPtr, pInterfaceGuid As GUID, _
            pDot11Ssid As LongPtr, pIeData As LongPtr, reserved As LongPtr) As Long
    Private Declare PtrSafe Function WlanGetNetworkBssList Lib "wlanapi.dll" ( _
            ByVal hClientHandle As LongPtr, pInterfaceGui As GUID, _
            ByVal pDot11Ssid As Long, ByVal dot11BssType As LongPtr, _
            ByVal bSecurityEnabled As LongPtr, ByVal pReserved As LongPtr, _
            ppWlanBssList As LongPtr) As Long
    Private Declare PtrSafe Sub WlanFreeMemory Lib "wlanapi.dll" ( _
            ByVal pMemory As LongPtr)
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
            Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" ( _
            lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
    Private Declare PtrSafe Function FileTimeToLocalFileTime Lib "kernel32" ( _
            lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
#Else
        Declare Function CloseClipboard Lib "user32" () As Long
        Declare Function EmptyClipboard Lib "user32" () As Long
        Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function WlanOpenHandle Lib "wlanapi.dll" ( _
            ByVal dwClientVersion As Long, ByVal pdwReserved As Long, _
            ByRef pdwNegotiaitedVersion As Long, ByRef phClientHandle As Long) As Long
    Private Declare Function WlanCloseHandle Lib "wlanapi.dll" ( _
            ByVal hClientHandle As Long, ByVal pdwReserved As Long) As Long
    Private Declare Function WlanEnumInterfaces Lib "wlanapi.dll" ( _
            ByVal hClientHandle As Long, ByVal pReserved As Long, ppInterfaceList As Long) As Long
    Private Declare Function WlanScan Lib "wlanapi.dll" ( _
            ByVal hClientHandle As Long, pInterfaceGuid As GUID, _
            pDot11Ssid As Long, pIeData As Long, reserved As Long) As Long
    Private Declare Function WlanGetNetworkBssList Lib "wlanapi.dll" ( _
            ByVal hClientHandle As Long, pInterfaceGui As GUID, ByVal pDot11Ssid As Long, _
            ByVal dot11BssType As Long, ByVal bSecurityEnabled As Long, _
            ByVal pReserved As Long, ppWlanBssList As Long) As Long
    Private Declare Sub WlanFreeMemory Lib "wlanapi.dll" (ByVal pMemory As Long)
    Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
            Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
    Private Declare Function FileTimeToSystemTime Lib "kernel32" ( _
            lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
    Private Declare Function FileTimeToLocalFileTime Lib "kernel32" ( _
            lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
#End If
'
Private Type DOT11_SSID
    uSSIDLength                 As Long
    ucSSID(31)                  As Byte
End Type
'
Private Enum DOT11_BSS_TYPE
    dot11_BSS_type_infrastructure = 1
       dot11_BSS_type_independent = 2
               DOT11_BSS_TYPE_ANY = 3
End Enum
'
Private Enum DOT11_PHY_TYPE
       dot11_phy_type_unknown = 0
           dot11_phy_type_any = 0
          dot11_phy_type_fhss = 1
          dot11_phy_type_dsss = 2
    dot11_phy_type_irbaseband = 3
          dot11_phy_type_ofdm = 4
        dot11_phy_type_hrdsss = 5
           dot11_phy_type_erp = 6
            dot11_phy_type_ht = 7
           dot11_phy_type_vht = 8
     dot11_phy_type_IHV_start = &H80000000
       dot11_phy_type_IHV_end = &HFFFFFFFF
End Enum
'
Private Type FILETIME
    dwLowDateTime               As Long
    dwHighDateTime              As Long
End Type
'
Private Type SYSTEMTIME
    wYear                       As Integer
    wMonth                      As Integer
    wDayOfWeek                  As Integer
    wDay                        As Integer
    wHour                       As Integer
    wMinute                     As Integer
    wSecond                     As Integer
    wMilliseconds               As Integer
End Type
'
Private Type WLAN_RATE_SET
    uRateSetLength              As Long
    usRateSet(125)              As Integer
End Type
'
Private Type GUID
    data1                       As Long
    data2                       As Integer
    data3                       As Integer
    data4(7)                    As Byte
End Type
'
Private Type WLAN_INTERFACE_INFO
    ifGuid                      As GUID
    InterfaceDescription(511)   As Byte
    IsState                     As Long
End Type
'
Private Type WLAN_INTERFACE_INFO_LIST
    dwNumberofItems             As Long
    dwIndex                     As Long
    InterfaceInfo               As WLAN_INTERFACE_INFO
End Type
'
Private Type WLAN_BSS_LIST
    dwTotalSize                 As Long
    dwNumberofItems             As Long
    wlanBssEntries              As Long
End Type
'
Private Type WLAN_BSS_ENTRY
    dot11Ssid                   As DOT11_SSID       '
    uPhyId                      As Long
    dot11Bssid(7)               As Byte             '
    dot11BssType                As DOT11_BSS_TYPE
    dot11BssPhyType             As DOT11_PHY_TYPE
    lRssi                       As Long             '
    uLinkQuality                As Long
    bInRegDomain                As Long
    usBeaconPeriod              As Long
    ullTimestamp                As FILETIME
    ullHostTimestamp            As FILETIME
    usCapabilityInformation     As Long
    ulChCenterFrequency         As Long
    wlanRateSet                 As WLAN_RATE_SET
    ulIeOffset                  As Long
    ulIeSize                    As Long
End Type
'
Private lVersion                As Long
Public VendorDelay              As Long
Public lHandle                  As LongPtr
Private udtBSSList              As WLAN_BSS_LIST
Private udtList                 As WLAN_INTERFACE_INFO_LIST



Sub GetBSS()
'
    Dim DisplayVendor                       As Boolean
    Dim ArrayRow                            As Long, ResultArrayRow             As Long
    Dim IncrementalEndPosition              As Long, IncrementalStartPosition   As Long
    Dim NumberOfBSSIDs                      As Long
    Dim AvailableWirelessNetworksData       As String
    Dim HeaderArray                         As Variant, ResultArray()           As Variant
    Dim ws                                  As Worksheet
'
    Dim lRet                                As Long
    Dim sLen                                As Long
    Dim lBSS                                As LongPtr, lStart                  As LongPtr
    Dim NetworkAdapterName                  As String
    Dim sSSID                               As String
    Dim sMAC                                As String
    Dim bTmp()                              As Byte
    Dim WLAN_BSS_ENTRY_Array()              As Variant
    Dim udtBSS                              As WLAN_BSS_ENTRY
'
    Set ws = Sheets("Sheet1")                                                           ' <--- Set this to the name of the sheet to diplay the maikn results to
'
    DisplayVendor = False                                                               ' <--- Set this to True if you want to see the vendor names associated with MAC Addresses
    VendorDelay = 1000                                                                  ' <--- Set this to the delay in milliseconds (1000 = 1 second) to get vendor data from site
'
    NetworkAdapterName = GetWifiAdapterName                                             ' Get the name of the WIFI adaptor and get the handle
'
    If lHandle = 0 Then Exit Sub
'
    lRet = WlanScan(lHandle, udtList.InterfaceInfo.ifGuid, ByVal 0&, ByVal 0&, ByVal 0&) ' Refresh the available wireless networks list
    Sleep 4500
'
    lRet = WlanGetNetworkBssList(lHandle, udtList.InterfaceInfo.ifGuid, ByVal 0&, _
            DOT11_BSS_TYPE.DOT11_BSS_TYPE_ANY, 0, 0, lBSS)                              ' Get the BSS data
    CopyMemory udtBSSList, ByVal lBSS, Len(udtBSSList)
'
    If lRet Then                                                                        ' If an error occurred obtaining the BSS data then ...
        Debug.Print "Error: "; CStr(lRet)                                               '   Display error to 'Immediate' window (CTRL+G in VBE window)
        MsgBox "No BSS Info Available!"                                                 '   Display pop up to user
    Else                                                                                ' Else ...
        lStart = lBSS + 8                                                               '   Initialize lStart
'
        ReDim WLAN_BSS_ENTRY_Array(1 To udtBSSList.dwNumberofItems, 1 To 16)            '   Establish dimensions of WLAN_BSS_ENTRY_Array
'
        Do                                                                              '   Loop
            CopyMemory udtBSS, ByVal lStart, Len(udtBSS)                                '       Load the data for the BSS entry
'
            ArrayRow = ArrayRow + 1                                                     '       Increment ArrayRow
'
            sLen = udtBSS.dot11Ssid.uSSIDLength                                         '       Get the length of the SSID
'
            If sLen = 0 Then                                                            '       If the length of the SSID = 0 then ...
                sSSID = "(Unknown)"                                                     '           Set the SSID to "(Unknown)"
            Else                                                                        '       Else ...
                ReDim bTmp(sLen - 1)                                                    '           Dimension the Tmp array that will hold the SSID
                CopyMemory bTmp(0), udtBSS.dot11Ssid.ucSSID(0), sLen
                sSSID = ByteToStr(bTmp)
            End If
'
            WLAN_BSS_ENTRY_Array(ArrayRow, 1) = sSSID                                   '       Save the SSID to WLAN_BSS_ENTRY_Array
            WLAN_BSS_ENTRY_Array(ArrayRow, 2) = MACtoString(udtBSS.dot11Bssid)          '       Save the BSSID (MAC Address) to WLAN_BSS_ENTRY_Array
'            WLAN_BSS_ENTRY_Array(ArrayRow, 3) = udtBSS.uPhyId
'            WLAN_BSS_ENTRY_Array(ArrayRow, 4) = udtBSS.dot11BssType
'            WLAN_BSS_ENTRY_Array(ArrayRow, 5) = udtBSS.dot11BssPhyType
            WLAN_BSS_ENTRY_Array(ArrayRow, 3) = udtBSS.lRssi                            '       Save the RSSI to WLAN_BSS_ENTRY_Array
'            WLAN_BSS_ENTRY_Array(ArrayRow, 7) = udtBSS.uLinkQuality
'            WLAN_BSS_ENTRY_Array(ArrayRow, 8) = udtBSS.bInRegDomain
'            WLAN_BSS_ENTRY_Array(ArrayRow, 9) = udtBSS.usBeaconPeriod
'            WLAN_BSS_ENTRY_Array(ArrayRow, 10) = TimeToString(udtBSS.ullTimestamp)
'            WLAN_BSS_ENTRY_Array(ArrayRow, 11) = TimeToString(udtBSS.ullHostTimestamp)
'            WLAN_BSS_ENTRY_Array(ArrayRow, 12) = udtBSS.usCapabilityInformation
'            WLAN_BSS_ENTRY_Array(ArrayRow, 13) = Round(udtBSS.ulChCenterFrequency / 1000000, 2)
'            WLAN_BSS_ENTRY_Array(ArrayRow, 14) = udtBSS.wlanRateSet.uRateSetLength
'            WLAN_BSS_ENTRY_Array(ArrayRow, 15) = udtBSS.ulIeOffset
'            WLAN_BSS_ENTRY_Array(ArrayRow, 16) = udtBSS.ulIeSize
'
            lStart = lStart + Len(udtBSS)                                               '       Increment lStart to the next BSS entry
        Loop Until ArrayRow = udtBSSList.dwNumberofItems                                '   Loop back if there are more BSS entries
'
        WlanFreeMemory lBSS
    End If








'
' **********************************************
' * Gather the available WIFI connections data *
' **********************************************
'
    CreateObject("WScript.Shell").Run "cmd /c netsh wlan show networks mode=BSSID" & _
            "|clip""", 0, True                                                          ' Save results of the cmdline to the clipboard
'
    With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard                                                               '   get cmdline output from clipboard
        AvailableWirelessNetworksData = .GetText(1)                                     '   Save the clipboard contents to AvailableWirelessNetworksData
    End With
'
    OpenClipboard (0&): EmptyClipboard: CloseClipboard                                  ' Erase the contents that were saved to the clipboard
'
' ******************************************
' * Strip the unneeded stuff from the data *
' ******************************************
'
    AvailableWirelessNetworksData = Replace(Replace(Replace(AvailableWirelessNetworksData, _
            " ", ""), vbCrLf, ""), vbLf & vbLf, vbLf)                                   ' Remove all spaces,Line feeds, and the like from the results of the clipboard
'
    NumberOfBSSIDs = (Len(AvailableWirelessNetworksData) - _
            Len(Replace(AvailableWirelessNetworksData, "BSSID", ""))) / Len("BSSID")    ' Count the number of BSSIDs in AvailableWirelessNetworksData
'
' ***********************************************
' * Initialize some variables that will be used *
' ***********************************************
'
    HeaderArray = Array("Network Adaptor", "   SSID        ", "   MAC Address (BSSID)        ", _
            "   Band        ", "   Signal        ", "   RSSI        ", "   Channel        ", _
            "   Radio Type        ", "   Vendor        ", "   Authorization Algorithm        ", _
            "   Encryption        ", "   Network Type        ")                         ' Establish Header names for the columns in the sheet
'
    ReDim ResultArray(1 To NumberOfBSSIDs, 1 To UBound(HeaderArray, 1) + 1) ' Establish initial dimensions of the ResultArray
'
    ArrayRow = 0                                                                        ' Reset ArrayRow
    IncrementalEndPosition = 1                                                          ' Initialize IncrementalEndPosition value
'
    ResultArray(1, 1) = NetworkAdapterName                                              ' Save the name of the NetworkAdapter into ResultArray
'
' **********************************************************
' * Start saving the gathered WIFI data to our ResultArray *
' **********************************************************
'
    AvailableWirelessNetworksData = Mid$(AvailableWirelessNetworksData, _
            InStr(AvailableWirelessNetworksData, "SSID"))                               ' Find first SSID position
'
    Do While InStr(IncrementalEndPosition, AvailableWirelessNetworksData, "SSID") > 0
        ArrayRow = ArrayRow + 1                                                         '   Increment ArrayRow
'
' Save the SSID
        IncrementalStartPosition = InStr(InStr(IncrementalEndPosition, AvailableWirelessNetworksData, _
                "SSID"), AvailableWirelessNetworksData, ":") + 1                        '   Find the start character position of the SSID in AvailableWirelessNetworksData
        IncrementalEndPosition = InStr(IncrementalStartPosition, AvailableWirelessNetworksData, _
                "Networktype")                                                          '   Find the end character position of the SSID in AvailableWirelessNetworksData
        ResultArray(ArrayRow, 2) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                IncrementalEndPosition - IncrementalStartPosition)                      '   Save the SSID name into the ResultArray
'
        If ResultArray(ArrayRow, 2) = "" Then ResultArray(ArrayRow, 2) = "UnNamed"      '   If the saved SSID name = "" then set the SSID name to "UnNamed"
'
' Save the Networktype
        IncrementalStartPosition = InStr(InStr(IncrementalEndPosition, AvailableWirelessNetworksData, _
                "Networktype"), AvailableWirelessNetworksData, ":") + 1                 '   Find the start character position of the Networktype in AvailableWirelessNetworksData
        IncrementalEndPosition = InStr(IncrementalStartPosition, AvailableWirelessNetworksData, _
                "Authentication")                                                       '   Find the end character position of the Networktype in AvailableWirelessNetworksData
        ResultArray(ArrayRow, 12) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                IncrementalEndPosition - IncrementalStartPosition)                      '   Save the Networktype into the ResultArray
'
' Save the Authentication
        IncrementalStartPosition = InStr(InStr(IncrementalEndPosition, AvailableWirelessNetworksData, _
                "Authentication"), AvailableWirelessNetworksData, ":") + 1              '   Find the start character position of the Authentication in AvailableWirelessNetworksData
        IncrementalEndPosition = InStr(IncrementalStartPosition, AvailableWirelessNetworksData, _
                "Encryption")                                                           '   Find the end character position of the Authentication in AvailableWirelessNetworksData
        ResultArray(ArrayRow, 10) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                IncrementalEndPosition - IncrementalStartPosition)                      '   Save the Authentication into the ResultArray
'
' Save the Encryption
        IncrementalStartPosition = InStr(InStr(IncrementalEndPosition, AvailableWirelessNetworksData, _
                "Encryption"), AvailableWirelessNetworksData, ":") + 1                  '   Find the start character position of the Encryption in AvailableWirelessNetworksData
        IncrementalEndPosition = InStr(IncrementalStartPosition, _
                AvailableWirelessNetworksData, "BSSID")                                 '   Find the end character position of the Encryption in AvailableWirelessNetworksData
        ResultArray(ArrayRow, 11) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                IncrementalEndPosition - IncrementalStartPosition)                      '   Save the Encryption into the ResultArray
'
GetBSSIDdata:
' Save the MAC Address (BSSID)
        IncrementalStartPosition = InStr(InStr(IncrementalEndPosition, AvailableWirelessNetworksData, _
                "BSSID"), AvailableWirelessNetworksData, ":") + 1                       '   Find the start character position of the BSSID in AvailableWirelessNetworksData
        IncrementalEndPosition = InStr(IncrementalStartPosition, _
                AvailableWirelessNetworksData, "Signal")                                '   Find the end character position of the BSSID in AvailableWirelessNetworksData
        ResultArray(ArrayRow, 3) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                IncrementalEndPosition - IncrementalStartPosition)                      '   Save the BSSID into the ResultArray
'
' Save the Signal level
        IncrementalStartPosition = InStr(InStr(IncrementalEndPosition, AvailableWirelessNetworksData, _
                "Signal"), AvailableWirelessNetworksData, ":") + 1                      '   Find the start character position of the Signal in AvailableWirelessNetworksData
        IncrementalEndPosition = InStr(IncrementalStartPosition, _
                AvailableWirelessNetworksData, "Radiotype")                             '   Find the end character position of the Signal in AvailableWirelessNetworksData
        ResultArray(ArrayRow, 5) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                IncrementalEndPosition - IncrementalStartPosition)                      '   Save the Signal into the ResultArray
'
' Save the Radiotype
        IncrementalStartPosition = InStr(InStr(IncrementalEndPosition, AvailableWirelessNetworksData, _
                "Radiotype"), AvailableWirelessNetworksData, ":") + 1                   '   Find the start character position of the Radiotype in AvailableWirelessNetworksData
        IncrementalEndPosition = InStr(IncrementalStartPosition, _
                AvailableWirelessNetworksData, "Band")                                  '   Find the end character position of the Radiotype in AvailableWirelessNetworksData
        ResultArray(ArrayRow, 8) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                IncrementalEndPosition - IncrementalStartPosition)                      '   Save the Radiotype into the ResultArray
'
' Save the Band
        If InStr(IncrementalEndPosition, AvailableWirelessNetworksData, "Band") > 0 Then   '    If the AvailableWirelessNetworksData contains 'Band' data then ...
            IncrementalStartPosition = InStr(InStr(IncrementalEndPosition, _
                    AvailableWirelessNetworksData, "Band"), _
                    AvailableWirelessNetworksData, ":") + 1                             '   Find the start character position of the Band in AvailableWirelessNetworksData
'
            IncrementalEndPosition = InStr(IncrementalStartPosition, _
                    AvailableWirelessNetworksData, "Channel")                           '   Find the end character position of the Band in AvailableWirelessNetworksData
'
            ResultArray(ArrayRow, 4) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                    IncrementalEndPosition - IncrementalStartPosition)                      '   Save the Band into the ResultArray
        End If
'
' Save the Channel
        IncrementalStartPosition = InStr(InStr(IncrementalEndPosition, AvailableWirelessNetworksData, _
                "Channel"), AvailableWirelessNetworksData, ":") + 1                     '   Find the start character position of the Channel in AvailableWirelessNetworksData
'
        If InStr(IncrementalStartPosition, AvailableWirelessNetworksData, "H") > 0 Then '   If there is data after the Channel data that starts with "H" then ...
            IncrementalEndPosition = Application.Min(InStr(IncrementalStartPosition, _
                    AvailableWirelessNetworksData, "B"), InStr(IncrementalStartPosition, _
                    AvailableWirelessNetworksData, "H"))                                '       Find the end character position of the Channel in AvailableWirelessNetworksData
        Else                                                                            '   Else ...
            IncrementalEndPosition = InStr(IncrementalStartPosition, _
                    AvailableWirelessNetworksData, "B")                                 '       Find the end character position of the Channel in AvailableWirelessNetworksData
        End If
'
        ResultArray(ArrayRow, 7) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                IncrementalEndPosition - IncrementalStartPosition)                      '   Save the Channel into the ResultArray
'
' Save the Vendor
        If DisplayVendor Then                                                           '   If the User chose to get the vendors associated with the MAC Addresses then ...
            ResultArray(ArrayRow, 9) = GetRouterBrand(ResultArray(ArrayRow, 3))         '       Save the Vendor according to the Mac Address
        End If
'
' **************************************************
' * Check for additional BSSID's for the same SSID *
' **************************************************
'
        IncrementalStartPosition = InStr(IncrementalEndPosition, _
                AvailableWirelessNetworksData, "SSID")                                  '   Check for additional BSSIDs
'
        If IncrementalStartPosition <> 0 Then                                           '   If another 'SSID' is found in AvailableWirelessNetworksData then ...
            If Mid$(AvailableWirelessNetworksData, _
                    IncrementalStartPosition - 1, 1) = "B" Then                         '       If the found 'SSID' in AvailableWirelessNetworksData is preceded by 'B" then
                ArrayRow = ArrayRow + 1                                                 '           Increment ArrayRow
'
                ResultArray(ArrayRow, 2) = ResultArray(ArrayRow - 1, 2)                 '           Save the previous SSID into the next row of ResultArray
                ResultArray(ArrayRow, 10) = ResultArray(ArrayRow - 1, 10)               '           Save the previous Authorization into the next row of ResultArray
                ResultArray(ArrayRow, 11) = ResultArray(ArrayRow - 1, 11)               '           Save the previous Encryption into the next row of ResultArray
                ResultArray(ArrayRow, 12) = ResultArray(ArrayRow - 1, 12)               '           Save the previous Networktype into the next row of ResultArray
'
                GoTo GetBSSIDdata                                                       '           Jump to GetBSSIDdata
            End If
        End If
    Loop                                                                                ' Loop back
'
' ************************************************
' * Display the final results, format data, etc. *
' ************************************************
'
    For ResultArrayRow = 1 To UBound(ResultArray, 1)                                    ' Loop through the rows of ResultArray
        For ArrayRow = 1 To UBound(WLAN_BSS_ENTRY_Array, 1)                             '   Loop through the rows of WLAN_BSS_ENTRY_Array
            If UCase(WLAN_BSS_ENTRY_Array(ArrayRow, 2)) = UCase(ResultArray(ResultArrayRow, 3)) Then  '       If we find a matching MAC Address then ...
                ResultArray(ResultArrayRow, 6) = WLAN_BSS_ENTRY_Array(ArrayRow, 3)      '           Save the corresponding RSSI value to ResultArray
            End If
        Next                                                                            '   Loop back
    Next                                                                                ' Loop back
'
    With ws
        .Cells.Delete                                                                   '   Delete any previous results from the sheet
'
        With .Range("A1").Resize(, UBound(HeaderArray, 1) + 1)
            .Value2 = HeaderArray                                                       '       Display the HeaderArray to the sheet
            .HorizontalAlignment = xlCenter                                             '       Center the Headers horizontally in the cells
              .VerticalAlignment = xlCenter                                             '       Center the Headers vertically in the cells
                 .Font.FontStyle = "Bold"                                               '       Bold the Headers
        End With
'
        .Range("A2").Resize(UBound(ResultArray, 1), UBound(ResultArray, 2)) = ResultArray   ' Display the ResultArray to the sheet
'
        .Range("D2:G" & ArrayRow + 1).HorizontalAlignment = xlCenter                    '   Center the data in columns D:G horizontally in the cells
'
        .UsedRange.EntireColumn.AutoFit                                                 '   Autofit the used columns widths of the sheet
'
        If .AutoFilterMode Then .AutoFilterMode = False                                 '   If there is filtered data on the sheet then remove the filter
'
        With .Range(.Cells(1, 2), .Cells(.Rows.Count, .Cells(1, .Columns.Count).End(xlToLeft).Column))
            .Cells.Sort Key1:=.Columns(6), Order1:=xlAscending, _
                    Orientation:=xlTopToBottom, Header:=xlYes                           '       Sort the data according to Channel Column G values highest to lowest
            .Cells.Sort Key1:=.Columns(5), Order1:=xlDescending, _
                    Orientation:=xlTopToBottom, Header:=xlYes                           '       Sort the data according to RSSI Column F values highest to lowest
            .AutoFilter                                                                 '       add AutoFilter option to the sheet
        End With
    End With
'
    MsgBox "Complete!"
End Sub


Public Function GetWifiAdapterName() As String
'
'   NOTE: This code currently only processes the first wireless adapter
'
    Dim lRet    As Long
    Dim lList   As LongPtr
'
    If lHandle Then
        lRet = WlanScan(lHandle, udtList.InterfaceInfo.ifGuid, ByVal 0&, ByVal 0&, ByVal 0&)
        Sleep 4500
    Else
        lRet = WlanOpenHandle(2&, 0&, lVersion, lHandle)
'
        lRet = WlanEnumInterfaces(ByVal lHandle, 0&, lList)
        Call CopyMemory(udtList, ByVal lList, LenB(udtList))
    End If
'
    GetWifiAdapterName = ByteToStr2(udtList.InterfaceInfo.InterfaceDescription)
End Function


Private Function ByteToStr(bArray() As Byte) As String
'
    Dim lPntr   As Long
    Dim bTmp()  As Byte
'
    On Error GoTo ByteErr
        ReDim bTmp(UBound(bArray) * 2 + 1)
'
        For lPntr = 0 To UBound(bArray)
            bTmp(lPntr * 2) = bArray(lPntr)
        Next
'
        Let ByteToStr = bTmp
        Exit Function
'
ByteErr:
    ByteToStr = ""
End Function


Private Function ByteToStr2(b() As Byte) As String
'
    Dim lNullCharPos    As Long
    Dim sDescription    As String
    Dim bTmp()          As Byte
'
            bTmp = StrConv(b, vbUnicode)
    sDescription = String(UBound(bTmp), Chr(0&))
    sDescription = bTmp
    sDescription = StrConv(sDescription, vbFromUnicode)
    lNullCharPos = InStr(sDescription, Chr(0&)) - 1&
'
    If lNullCharPos Then
        ByteToStr2 = Left$(sDescription, lNullCharPos)
    End If
End Function


Private Function MACtoString(bMAC() As Byte) As String
'
    Dim sTmp As String
'
    MACtoString = Right$("0" & Hex$(bMAC(0)), 2) & ":" _
        & Right$("0" & Hex$(bMAC(1)), 2) & ":" _
        & Right$("0" & Hex$(bMAC(2)), 2) & ":" _
        & Right$("0" & Hex$(bMAC(3)), 2) & ":" _
        & Right$("0" & Hex$(bMAC(4)), 2) & ":" _
        & Right$("0" & Hex$(bMAC(5)), 2)
End Function


Function GetRouterBrand(ByVal MacAddr As String) As String
'
    Dim HTMLDoc             As Object, XML_HTTP             As Object, ZipCode      As Object
    Dim WebSite             As String, WebSiteDataNeeded    As String
'
'    Application.Wait (Now + TimeValue("00:00:04"))
    Sleep VendorDelay
'
    WebSite = "https://api.macvendors.com/" & Left$(MacAddr, 8)                                              ' <--- Set this to the website to get data from
'
    Set HTMLDoc = CreateObject("htmlfile")
    Set XML_HTTP = CreateObject("MSXML2.XMLHTTP")
'
    With XML_HTTP
        .Open "Get", WebSite, False
        .send
    End With
'
    If XML_HTTP.responsetext = "{""errors"":{""detail"":""Not Found""}}" Then
        GetRouterBrand = "Vendor Not Found"
    Else
        GetRouterBrand = XML_HTTP.responsetext                                         ' Return the data received from website back to the worksheet
    End If
End Function

 

[Dan_W]

Wow. I go offline for a few days (jetlag) and ... wow. Am excited to start going through it now.

 

[johnnyL]

Welcome back @Dan_W !!!

This is still a work in progress so feel free to slap me on the back of the head when you find my mistakes or missed opportunities.

 

[Dan_W]

I'm still working my way through it (Jetlagged ATM), but Jaafar's workbook example is working for me. Give me 20 mins to catch up.

 

[Dan_W]

Welcome back @Dan_W !!!

This is still a work in progress so feel free to slap me on the back of the head when you find my mistakes or missed opportunities.

I just tried your code above (Post #42) and it seems to work. I'm on MS365, Windows 11 (64bit) using Office (64 bit).

 

[johnnyL]

Did you try the 'Vendor' option?

This will add time to the script, it may appear that excel is frozen, but let it run. It will add about 1 second to the script for each MAC address discovered

 

[Dan_W]

I just tried the Vendor option now, and it appeared to work, yes.

 

[johnnyL]

TY

 

[Dan_W]

Just looking at it briefly, a few things jump out at me:

                ReDim bTmp(sLen - 1)                                                    '           Dimension the Tmp array that will hold the SSID
                CopyMemory bTmp(0), udtBSS.dot11Ssid.ucSSID(0), sLen
                sSSID = ByteToStr(bTmp)

Using CopyMemory can be time-consuming, and it strictly speaking isn't necessary here. You can accomplish the same function by accessing the udtBSS.dot11ssid.ucSSID member direct.

     sSSID = ByteToStr(udtBSS.dot11ssid.ucSSID)

Also, in the final function you don't seem to use HTMLDoc at all, so this can be deleted.

    Set HTMLDoc = CreateObject("htmlfile")