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]

@Dan_W the clipboard code has since been updated to:

    AvailableWirelessNetworksData = CreateObject("WScript.Shell").Exec( _
            "netsh wlan show networks mode=BSSID").StdOut.ReadAll                       ' Save output of command from the standard output stream to AvailableWirelessNetworksData

 

[Jaafar Tribak]

Hi johnnyL

Your last code still gives me runtime error 5 (invalid procedure call or argument) at this line:

ResultArray(ArrayRow, 8) = Mid$(AvailableWirelessNetworksData, _
                IncrementalStartPosition, IncrementalEndPosition - _
                IncrementalStartPosition)

Obviously, this is because IncrementalEndPosition evaluates to 0
It is the same issue as before since the preceeding line finds no *Band* string

Now regarding the issue of the undesirable effect of the Exec Method displaying the cmd.exe prompt, I suggest you use the following workaround:

Basically, this workaroud will create a small vbs file on the fly which in turn will create a small txt file for containing all the BSSI data. The tmp vbs file can be optionally launched wth elevated privileges via the *runas* verb... Once the vbs script is ran and puts the data in the text file, the data can easily be read and stored in your AvailableWirelessNetworksData variable. Both, the vbs as well as the txt files are automatically deleted.

So, using this workaround will both, hide the annoying cmd window and, work with elevated privileges if required (which I personally needed to get the BSSI data)

Sub test()
    Debug.Print Get_BSSID_Data(Admin:=True)  'try as well with Admin:=False
End Sub

Function Get_BSSID_Data(Optional ByVal Admin As Boolean) As String
    Const TEMP_VBS_FILE = "C:\Users\hp\Downloads\BSSID.vbs"   ' <== Change Output vbs file path name here !!!!
    Dim sTempTextFile As String
    Dim ObjShell As Object, objFSO As Object, ObjFile As Object
 
    Call CreateTempVBS(TEMP_VBS_FILE)
    sTempTextFile = Replace(TEMP_VBS_FILE, ".vbs", ".txt")
    Set ObjShell = CreateObject("Shell.Application")
    ObjShell.ShellExecute "cscript", TEMP_VBS_FILE, "", IIf(Admin, "runas", ""), 0&
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    With objFSO
        Set ObjFile = .CreateTextFile(sTempTextFile, True)
        Set ObjFile = .OpenTextFile(sTempTextFile, 1&)
        Call Sleep(1000)
        If Not ObjFile.AtEndOfStream Then Get_BSSID_Data = ObjFile.ReadAll
        ObjFile.Close
        .DeleteFile sTempTextFile
        .DeleteFile TEMP_VBS_FILE
    End With
End Function

Sub CreateTempVBS(ByVal FilePathName As String)
    Dim sVBSCode As String
    Dim objFSO As Object, ObjFile As Object
 
    sVBSCode = "Set ObjShell = CreateObject(""Wscript.Shell"")" & vbCrLf
    sVBSCode = sVBSCode & "strCommand =""netsh wlan show network mode=bssid""" & vbCrLf
    sVBSCode = sVBSCode & "Set objExecObject = ObjShell.Exec(strCommand)" & vbCrLf
    sVBSCode = sVBSCode & "Do While Not objExecObject.StdOut.AtEndOfStream" & vbCrLf
    sVBSCode = sVBSCode & "strText = objExecObject.StdOut.ReadAll()" & vbCrLf
    sVBSCode = sVBSCode & "Loop" & vbCrLf
    sVBSCode = sVBSCode & "ResultFile =" & Chr(34) & _
               Replace(FilePathName, ".vbs", ".txt") & Chr(34) & vbCrLf
    sVBSCode = sVBSCode & "Set objFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf
    sVBSCode = sVBSCode & "Set ObjFile = objFSO.CreateTextFile(""" & _
               Replace(FilePathName, ".vbs", ".txt") & """, True)" & vbCrLf
    sVBSCode = sVBSCode & "objFile.Close" & vbCrLf
    sVBSCode = sVBSCode & "Set objFile = objFSO.OpenTextFile(ResultFile, 2)" & vbCrLf
    sVBSCode = sVBSCode & "ObjFile.Write strText" & vbCrLf
    sVBSCode = sVBSCode & "ObjFile.Close"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set ObjFile = objFSO.CreateTextFile(FilePathName, True)
    ObjFile.Close
    Set ObjFile = objFSO.OpenTextFile(FilePathName, 2&)
    ObjFile.Write sVBSCode
    ObjFile.Close
End Sub

To apply this to your existing code, you would simply need to change this :

 AvailableWirelessNetworksData = CreateObject("WScript.Shell").Exec( _
            "netsh wlan show networks mode=BSSID").StdOut.ReadAll

To this:

'AvailableWirelessNetworksData = Get_BSSID_Data             ' <== No elevated privileges.
AvailableWirelessNetworksData = Get_BSSID_Data(Admin:=True) ' <== Run with elevated privileges.

 

[Dan_W]

@Dan_W the clipboard code has since been updated to:

    AvailableWirelessNetworksData = CreateObject("WScript.Shell").Exec( _
            "netsh wlan show networks mode=BSSID").StdOut.ReadAll                       ' Save output of command from the standard output stream to AvailableWirelessNetworksData

I did see that, I just thought I'd offer you other options for future reference.

 

[johnnyL]

@Jaafar Tribak, I am not getting anything written to the BSSID.txt file

 

[johnnyL]

To apply this to your existing code, you would simply need to change this :

 AvailableWirelessNetworksData = CreateObject("WScript.Shell").Exec( _
            "netsh wlan show networks mode=BSSID").StdOut.ReadAll

To this:

'AvailableWirelessNetworksData = Get_BSSID_Data             ' <== No elevated privileges.
AvailableWirelessNetworksData = Get_BSSID_Data(Admin:=True) ' <== Run with elevated privileges.

I am thinking maybe we can check to see if Elevated privileges need to be ran by using some VBA code to test for it? I found some posts that mention using 'CheckTokenMembership' to test if the user is Admin, but I did not find much info about that, so I came up with a possible alternative, that needs to be tested. to see if it could be an alternative:

Sub AreYouAnAdmin()
'
' This subroutine checks if the current user is a local administrator on the computer.
'
'
    Dim UserIsAnAdmin   As Boolean                                                              ' Flag to indicate if the user is an Admin
    Dim NameOfComputer  As String                                                               ' Stores the name of the computer
    Dim NameOfUser      As String                                                               ' Stores the name of the current user
    Dim AdminGroup      As Object                                                               ' Represents the Administrators group
    Dim AdminMember     As Object                                                               ' Represents a member of the Administrators group
    Dim Computer        As Object                                                               ' Represents the WScript.Network object for computer information
'
    Set Computer = CreateObject("Wscript.Network")                                              ' Create an instance of the WScript.Network object to get computer information
'
    NameOfComputer = Computer.ComputerName                                                      ' Get the name of the computer
    NameOfUser = Computer.UserName                                                              ' Get the name of the current user
'
    Set AdminGroup = GetObject("WinNT://" & NameOfComputer & "/Administrators")                 ' Get the Administrators group object for the computer
'
    For Each AdminMember In AdminGroup.Members                                                  ' Loop through each member of the AdminGroup
        If AdminMember.Name = NameOfUser Then                                                   '   If the current user is an admin
            UserIsAnAdmin = True                                                                '       Set the UserIsAnAdmin flag to True
            Exit For                                                                            '       Exit this loop
        End If
    Next                                                                                        ' Loop back
'
    If UserIsAnAdmin Then                                                                       ' If UserIsAnAdmin flag = True then ...
        MsgBox NameOfUser & " is a local administrator."                                        '   Do something
    Else                                                                                        ' Else ...
        MsgBox NameOfUser & " is not a local administrator."                                    '   Do something else
    End If
End Sub

 

[johnnyL]

I also found the error in the previous code that I submitted in regards to to testing for 'Band' in the results that are returned.

I had only corrected one spot for the 'Band' check, I should have corrected two spots, the IncrementalStartPosition & the IncrementalEndPosition that checks for 'Band' in the data.

The previous lines of code:

' 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, 9) = Mid$(AvailableWirelessNetworksData, _
                    IncrementalStartPosition, IncrementalEndPosition - _
                    IncrementalStartPosition)                                           '       Save the Band into the ResultArray
        Else                                                                            '   Else
            BandNotFound = True                                                         '       Set BandNotFound flag = True
        End If
'
' Save the Channel & maybe calculated Band
        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, 10) = Mid$(AvailableWirelessNetworksData, _
                IncrementalStartPosition, IncrementalEndPosition - _
                IncrementalStartPosition)                                               '   Save the Channel into the ResultArray
'
        If BandNotFound Then                                                            '   If the BSS data did not contain data for the 'Band' then ...
            If CInt(ResultArray(ArrayRow, 10)) < 15 Then                                '       If the integer value of the channel is lass than 15 then ...
                ResultArray(ArrayRow, 9) = "2.4GHZ"                                     '           Save "2.4GHZ" to the 'Band' column of ResultArray
            Else                                                                        '       Else ...
                ResultArray(ArrayRow, 9) = "5GHZ"                                       '           Save "5GHZ" to the 'Band' column of ResultArray
            End If
'
            BandNotFound = False                                                        '       Set BandNotFound flag back to False
        End If

need to be changed to:

' 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
'
        If IncrementalEndPosition = 0 Then                                              '   If 'Band' wasn't found then ...
            IncrementalEndPosition = InStr(IncrementalStartPosition, _
                    AvailableWirelessNetworksData, "Channel")                           '       Find the end character position of the Radiotype in AvailableWirelessNetworksData
'
            BandNotFound = True                                                         '       Set BandNotFound flag = True
        End If
'
        ResultArray(ArrayRow, 8) = Mid$(AvailableWirelessNetworksData, _
                IncrementalStartPosition, IncrementalEndPosition - _
                IncrementalStartPosition)                                               '       Save the Radiotype into the ResultArray

'
' Save the Band if found
        If BandNotFound Then                                                            '   If 'Band' wasn't found then do nothing in this section
        Else                                                                            '   Else ...
            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, 9) = Mid$(AvailableWirelessNetworksData, _
                    IncrementalStartPosition, IncrementalEndPosition - _
                    IncrementalStartPosition)                                           '       Save the Band into the ResultArray
        End If
'
' Save the Channel & maybe calculated Band
        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, 10) = Mid$(AvailableWirelessNetworksData, _
                IncrementalStartPosition, IncrementalEndPosition - _
                IncrementalStartPosition)                                               '   Save the Channel into the ResultArray
'
        If BandNotFound Then                                                            '   If the BSS data did not contain data for the 'Band' then ...
            If CInt(ResultArray(ArrayRow, 10)) < 15 Then                                '       If the integer value of the channel is lass than 15 then ...
                ResultArray(ArrayRow, 9) = "2.4GHZ"                                     '           Save "2.4GHZ" to the 'Band' column of ResultArray
            Else                                                                        '       Else ...
                ResultArray(ArrayRow, 9) = "5GHZ"                                       '           Save "5GHZ" to the 'Band' column of ResultArray
            End If
'
            BandNotFound = False                                                        '       Set BandNotFound flag back to False
        End If

 

[Jaafar Tribak]

Finally, your last code change worked for me with no errors !! Well done JohnnyL.

I am thinking maybe we can check to see if Elevated privileges need to be ran by using some VBA code to test for it? I found some posts that mention using 'CheckTokenMembership' to test if the user is Admin, but I did not find much info about that, so I came up with a possible alternative, that needs to be tested. to see if it could be an alternative:

That script (in post#75) is not reliable as there may be no admin groups. It didn't work for me and it errored out
Error# -2147022676 Automation error The group name could not be found.
Thers is also this easier IsUserAnAdmin api function which wraps CheckTokenMembership but I read as of Vista and introduction of UAC is no longer reliable.
I am logged as an Admin and calling IsUserAnAdmin erroneously returns False.

The thing that confuses me is that I am the only pc user and I am logged as an Admin, still, I need to use the *runas* flag to programmatically perform some actions! I will need to investigate this further.

@Jaafar Tribak, I am not getting anything written to the BSSID.txt file

Did you try both Get_BSSID_Data(Admin:=True) and Get_BSSID_Data(Admin:=False) ?
Also, have you tried increasing the Sleep time from 1000 ms to a higher value before opening the BSSID text file ?

    With objFSO
        Set ObjFile = .CreateTextFile(sTempTextFile, True)
        Set ObjFile = .OpenTextFile(sTempTextFile, 1&)
        Call Sleep(3000)  '<= Try experimenting with larger than 1000 ms
        If Not ObjFile.AtEndOfStream Then Get_BSSID_Data = ObjFile.ReadAll
        ObjFile.Close
        .DeleteFile sTempTextFile
        .DeleteFile TEMP_VBS_FILE
    End With

Anyways, the code now works by scraping the network data from the command line and parsing it. So, congratulations and happy to have learnt myself a few things in the process.

 

[johnnyL]

@Jaafar Tribak, I have tried both Get_BSSID_Data(Admin:=True) and Get_BSSID_Data(Admin:=False).

I have also put a stop point @:

        .DeleteFile sTempTextFile
        .DeleteFile TEMP_VBS_FILE

and the BSSID.txt file is still empty.

I ran the code that is in BSSID.vbs by itself & it does write to the BSSID.txt file so I have no clue what the issue is.

 

[johnnyL]

It almost seems like the BSSID.vbs file is not being executed because when I step through the code, the BSSID.txt file doesn't get created until the execution of the line:

        Set ObjFile = .CreateTextFile(sTempTextFile, True)

 

[Jaafar Tribak]

It almost seems like the BSSID.vbs file is not being executed because when I step through the code, the BSSID.txt file doesn't get created until the execution of the line:

        Set ObjFile = .CreateTextFile(sTempTextFile, True)

For me, when I step throught the code, I can see (in the shell explorer) that the txt file does get created and gets populated with the BSSI data before the line above is executed. Meaning the vbs is already successfully executed.

I am not sure but it may be a timing issue. Let's try suspending code execution w/o using the Sleep api. Instead, let's try waiting in a loop till we reach AtEndOfStream as follows:

Function Get_BSSID_Data(Optional ByVal Admin As Boolean) As String
    Const TEMP_VBS_FILE = "C:\Users\hp\Downloads\BSSID.vbs"   ' <== Change Output vbs file path name here !!!!
    Dim sTempTextFile As String
    Dim ObjShell As Object, objFSO As Object, ObjFile As Object
 
    Call CreateTempVBS(TEMP_VBS_FILE)
    sTempTextFile = Replace(TEMP_VBS_FILE, ".vbs", ".txt")
    Set ObjShell = CreateObject("Shell.Application")
    ObjShell.ShellExecute "cscript", TEMP_VBS_FILE, "", IIf(Admin, "runas", ""), 0&
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    With objFSO
        Set ObjFile = .CreateTextFile(sTempTextFile, True)
        ObjFile.Close
        Set ObjFile = .OpenTextFile(sTempTextFile, 1&)
        Do: Loop Until Not ObjFile.AtEndOfStream
        Get_BSSID_Data = ObjFile.Read(.GetFile(sTempTextFile).Size)
        ObjFile.Close
        .DeleteFile sTempTextFile
        .DeleteFile TEMP_VBS_FILE
    End With
End Function