Scraping data from WIFI networks that are available

johnnyL

Well-known Member
Joined
Nov 7, 2011
Messages
4,546
Office Version
  1. 2007
Platform
  1. Windows
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:

VBA Code:
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
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Got a chance to look at this again this weekend.

I realized that I don't really need the results from 2) in post #1.

I can't, for the life of me, figure out how to successfully capture the lRssi, uLinkQuality, etc from WLAN_BSS_ENTRY. :(

The following is the code I am using for 1) in post #1, hopefully someone will be able to throw me a bone to add the results from WLAN_BSS_ENTRY to the current data.
VBA Code:
Option Explicit
'
    #If VBA7 Then
                Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
                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 Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, _
                    ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As LongPtr)
    #Else
                Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
                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 Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, _
                    ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
    #End If
'
    Public Const MOUSEEVENTF_LEFTDOWN = &H2


Sub GetAvailableWifiNetworksInfo()
'
    Dim ArrayRow                            As Long
    Dim IncrementalEndPosition              As Long, IncrementalStartPosition   As Long
    Dim AvailableWirelessNetworksData       As String
    Dim TimeToAllowWifiNetworksToRefresh    As String
    Dim HeaderArray                         As Variant, ResultArray()           As Variant
    Dim ws                                  As Worksheet
'
    Set ws = Sheets("Sheet1")                                                           ' <--- Set this to the name of the sheet to diplay the results to
'
' *************************
' * Refresh the WIFI list *
' *************************
'
    TimeToAllowWifiNetworksToRefresh = "0:00:05"                                        ' <--- Set this to the amount of time to allow Wifi Networks To Refresh
'
    With CreateObject("WScript.Shell")
        .Run "%windir%\explorer.exe ms-availablenetworks:"                              ' refresh the wifi list
    End With
'
    Application.Wait (Now + TimeValue(TimeToAllowWifiNetworksToRefresh))                ' Delay script for a certain amount of time
'
    SetCursorPos 400, 400: mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0                 ' Simulate a mouse click to remove the wifi list window
'
' **********************************************
' * 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
'
' ***********************************************
' * Initialize some variables that will be used *
' ***********************************************
'
    HeaderArray = Array("SSID", "   Signal        ", "   Band        ", "   Channel        ", _
            "   Radio Type        ", "   Mac Address (BSSID)        ", _
            "   Authorization Algorithm        ", "   Encryption        ", _
            "   Network Type        ", "   RSSI        ", "   Link Quality        ", _
            "   Beacon Period        ", "   ullTimestamp        ")                      ' Establish Header names for the columns in the sheet
'
    ReDim ResultArray(1 To 1000, 1 To UBound(HeaderArray, 1) + 1)                       ' Establish initial dimensions of the ResultArray, we can fix them later, if need be
'
    IncrementalEndPosition = 1                                                          ' Initialize IncrementalEndPosition value
'
' **********************************************************
' * 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, 1) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                IncrementalEndPosition - IncrementalStartPosition)                      '   Save the SSID name into the ResultArray
'
        If ResultArray(ArrayRow, 1) = "" Then ResultArray(ArrayRow, 1) = "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, 9) = 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, 7) = 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, 8) = 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, 6) = 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, 2) = 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, 5) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                IncrementalEndPosition - IncrementalStartPosition)                      '   Save the Radiotype into the ResultArray
'
' Save the Band
        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, 3) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                IncrementalEndPosition - IncrementalStartPosition)                      '   Save the Band into the ResultArray
'
' 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, 4) = Mid$(AvailableWirelessNetworksData, IncrementalStartPosition, _
                IncrementalEndPosition - IncrementalStartPosition)                      '   Save the Channel into the ResultArray
'
' **************************************************
' * 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, 1) = ResultArray(ArrayRow - 1, 1)                 '           Save the previous SSID into the next row of ResultArray
                ResultArray(ArrayRow, 7) = ResultArray(ArrayRow - 1, 7)                 '           Save the previous Authorization into the next row of ResultArray
                ResultArray(ArrayRow, 8) = ResultArray(ArrayRow - 1, 8)                 '           Save the previous Encryption into the next row of ResultArray
                ResultArray(ArrayRow, 9) = ResultArray(ArrayRow - 1, 9)                 '           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. *
' ************************************************
'
    ResultArray = ReDimPreserve(ResultArray, ArrayRow, UBound(HeaderArray, 1) + 1)      ' Delete any unneeded rows in the ResultArray
'
    With ws
        .Cells(1, "A").Resize(.Cells(.Rows.Count, "A").End(xlUp).Row, _
                UBound(HeaderArray, 1) + 1).ClearContents                               '   Clear previous results from 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("B2:E" & ArrayRow + 1).HorizontalAlignment = xlCenter                    '   Center the data in columns B:E 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 .Cells(1, 1).CurrentRegion
            .Cells.Sort Key1:=.Columns(2), Order1:=xlDescending, _
                    Orientation:=xlTopToBottom, Header:=xlYes                           '       Sort the data according to Signal Column B values highest to lowest
            .AutoFilter                                                                 '       add AutoFilter option to the sheet
        End With
    End With
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
 
Upvote 0
Perhaps someone such as @Jaafar Tribak or others that are wise to this approach of 'scraping' data could assist.
Hi johnnyL

I can't test your code because in my windows 10, I can't seem to run the WLAN AutoConfig service.
I have googled the issue and tried various suggested solutions but still no luck.

Would you be able to adapt this vb6 code to get you the info you are after ?
 
Upvote 0
Thank you for the reply @Jaafar Tribak

I looked at/tried the code in post #5 of that thread you mentioned but the second line of the code crashes my excel
VBA Code:
    lRet = WlanGetNetworkBssList(lHandle, udtList.InterfaceInfo.ifGuid, 0&, DOT11_BSS_TYPE.DOT11_BSS_TYPE_ANY, False, 0&, lBSS)
'
    CopyMemory udtBSSList, ByVal lBSS, LenB(udtBSSList)

lRet = 87 instead of 0 :(

On a side note, if you have a wifi adapter but it is not allowing you to see wifi networks, you might try looking --->
Here There seems to be a few different approaches that have reportedly worked for people.
 
Upvote 0
I might be wrong on this, but when it comes to Win32 API errors, I believe Error 87 means "The parameter is incorrect. ERROR_INVALID_PARAMETER". But in my defense, I am sitting in an airport in the middle of a 38hr journey.

Looking at your parameters, the code youve used in the most recent snippet and the variable names don't track what's set out in OP so it's difficult to follow - but critically, given that the error message that you're getting indicates that something is away with the parameters, but first thoughts are - have you opened the handle and is that handle stored in this new variable name of lHandle? And, have you declared lBSS as the correct UDT?
 
Last edited:
Upvote 0
Hey @Dan_W !
You are correct on both accounts, error 87 does mean invalid parameter & the last snippet I posted does not match the code in the OP. The reason the the last snippet doesn't match is because it is from the code that is in the file attached in post #5 of the link that @Jaafar Tribak posted.

This is the code from the file in that post:
VBA Code:
Private Const WLAN_NOTIFICATION_SOURCE_MOST As Long = &H7F

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_IHV_start = &H80000000
    dot11_phy_type_IHV_end = &HFFFFFFFF
End Enum

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_AUTH_ALGORITHM
    DOT11_AUTH_ALGO_80211_OPEN = 1
    DOT11_AUTH_ALGO_80211_SHARED_KEY = 2
    DOT11_AUTH_ALGO_WPA = 3
    DOT11_AUTH_ALGO_WPA_PSK = 4
    DOT11_AUTH_ALGO_WPA_NONE = 5
    DOT11_AUTH_ALGO_RSNA = 6
    DOT11_AUTH_ALGO_RSNA_PSK = 7
    DOT11_AUTH_ALGO_IHV_START = &H80000000
    DOT11_AUTH_ALGO_IHV_END = &HFFFFFFFF
End Enum

Private Enum DOT11_CIPHER_ALGORITHM
    DOT11_CIPHER_ALGO_NONE = &H0
    DOT11_CIPHER_ALGO_WEP40 = &H1
    DOT11_CIPHER_ALGO_TKIP = &H2
    DOT11_CIPHER_ALGO_CCMP = &H4
    DOT11_CIPHER_ALGO_WEP104 = &H5
    DOT11_CIPHER_ALGO_WPA_USE_GROUP = &H100
    DOT11_CIPHER_ALGO_RSN_USE_GROUP = &H100
    DOT11_CIPHER_ALGO_WEP = &H101
    DOT11_CIPHER_ALGO_IHV_START = &H80000000
    DOT11_CIPHER_ALGO_IHV_END = &HFFFFFFFF
End Enum

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
'    ifGuid(0 To 15) As Byte
'    InterfaceDescription(0 To 511) As Byte
'    IsState As WLAN_INTERFACE_STATE
'End Type

Private Type DOT11_SSID
    uSSIDLength As Long
    ucSSID(31) As Byte
End Type

Private Type WLAN_RATE_SET
    uRateSetLength As Long
    usRateSet(125) As Integer
End Type

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 TIME_ZONE_INFORMATION
   Bias As Long
   StandardName(0 To 63) As Byte  'unicode (0-based)
   StandardDate As SYSTEMTIME
   StandardBias As Long
   DaylightName(0 To 63) As Byte  'unicode (0-based)
   DaylightDate As SYSTEMTIME
   DaylightBias As Long
End Type

Private Type WLAN_AVAILABLE_NETWORK
    strProfileName(511) As Byte
    dot11Ssid As DOT11_SSID
    dot11BssType As Long
    uNumberOfBssids As Long
    bNetworkConnectable As Long
    wlanNotConnectableReason As Long
    uNumberOfPhyTypes As Long
    dot11PhyTypes(7) As Long
    bMorePhyTypes As Long
    wlanSignalQuality As Long
    bSecurityEnabled As Long
    dot11DefaultAuthAlgorithm As Long
    dot11DefaultCipherAlgorithm As Long
    dwFlags As Long
    dwreserved As Long
End Type

Private Type AVAILABLE_NETWORK
    dot11Ssid As DOT11_SSID
    dot11BssType As Long
    uNumberOfBssids As Long
    bNetworkConnectable As Long
    wlanNotConnectableReason As Long
    uNumberOfPhyTypes As Long
    dot11PhyTypes(7) As Long
    bMorePhyTypes As Long
    wlanSignalQuality As Long
    bSecurityEnabled As Long
    dot11DefaultAuthAlgorithm As Long
    dot11DefaultCipherAlgorithm As Long
    dwFlags As Long
    dwreserved As Long
End Type

'Private Type WLAN_BSS_ENTRY
'    dot11Ssid As DOT11_SSID
'    phyId As Long
'    dot11Bssid(5) As Byte
'    dot11BssType As DOT11_BSS_TYPE
'    dot11BssPhyType As DOT11_PHY_TYPE
'    rssi As Long
'    LinkQuality As Long
'    inRegDomain As Boolean
'    BeaconPeriod As Long
'    timestamp As Currency
'    hostTimestamp As Currency
'    CapabilityInformation As Long
'    chCenterFrequency As Long
'    wlanRateSet As WLAN_RATE_SET
'    ieOffset As Long
'    ieSize 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 'Boolean
    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 Type WLAN_INTERFACE_INFO_LIST
    dwNumberofItems As Long
    dwIndex As Long
    InterfaceInfo As WLAN_INTERFACE_INFO
End Type

Private Type WLAN_AVAILABLE_NETWORK_LIST
    dwNumberofItems As Long
    dwIndex As Long
    Network As WLAN_AVAILABLE_NETWORK
End Type

Private Type WLAN_CONNECTION_PARAMETERS
    ConnectionMode As Long
    Profile As Long
    pDot11Ssid As Long
    pDesiredBssidList As Long
    dot11BssType As Long
    dwFlags As Long
End Type

Private Type WLAN_BSS_LIST
    dwTotalSize As Long
    dwNumberofItems As Long
    wlanBssEntries As Long
End Type

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 WlanEnumInterfaces Lib "wlanapi.dll" (ByVal hClientHandle As Long, ByVal pReserved As Long, ppInterfaceList As Long) As Long
Private Declare Function WlanGetAvailableNetworkList Lib "wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As GUID, ByVal dwFlags As Long, ByVal pReserved As Long, ppAvailableNetworkList As Long) As Long
Private Declare Function WlanConnect Lib "wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As GUID, pConnectionParameters As WLAN_CONNECTION_PARAMETERS, ByVal reserved 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 WlanDisconnect Lib "wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As GUID, ByVal pReserved 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 WLAN_BSS_LIST) 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 Function WlanGetProfile Lib "wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As GUID, ByVal strProfileName As Long, ByVal pReserved As Long, pstrProfileXml As Long, pdwFlags As Long, pdwGrantedAccess As Long) As Long
'Private Declare Function WlanGetProfile Lib "wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As Any, ByVal strProfileName As Long, ByVal pReserved As Long, pStrProfileXML As Long, pdwFlags As Long, pdwGrantedAccess As Long) As Long
Private Declare Function CreateEvent Lib "kernel32.dll" Alias "CreateEventA" (lpEventAttributes As Long, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub WlanFreeMemory Lib "wlanapi.dll" (ByVal pMemory As Long)
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Declare Function lstrlenW& Lib "kernel32.dll" (ByVal lpszSrc&)
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private udtList As WLAN_INTERFACE_INFO_LIST
Private udtBSSList As WLAN_BSS_LIST
Private ConIndex As Long
Private lHandle As Long
Private lVersion As Long
Private Connected As String
Private bBuffer() As Byte

Private Sub BasicServiceSet()
    Dim lBSS As Long
    Dim lRet As Long
    Dim sLen As Long
    Dim lStart As Long
    Dim lCount As Long
    Dim sSSID As String
    Dim sMAC As String
    Dim sTime As String
    Dim bTmp() As Byte
    Dim ListArray(7) As String
    Dim BSSInfo() As Byte
    Dim udtBSS As WLAN_BSS_ENTRY
    lRet = WlanGetNetworkBssList(lHandle, udtList.InterfaceInfo.ifGuid, 0&, DOT11_BSS_TYPE.DOT11_BSS_TYPE_ANY, False, 0&, lBSS)
    CopyMemory udtBSSList, ByVal lBSS, LenB(udtBSSList)
    Debug.Print udtBSSList.dwTotalSize, udtBSSList.dwNumberofItems, udtBSSList.wlanBssEntries
    If lRet Then
        Debug.Print "Error: "; CStr(lRet)
        MsgBox "No BSS Info Available!"
    Else
        lStart = lBSS + 8
        lCount = 0
        Do
            CopyMemory udtBSS, ByVal lStart, Len(udtBSS)
            'ReDim BSSInfo(359)
            'CopyMemory BSSInfo(0), ByVal lStart, 360
            'Call DebugPrintByte("BSSInfo", BSSInfo)
            'Debug.Print Hex$(udtBSS.ullTimestamp.dwLowDateTime)
            'Debug.Print Hex$(udtBSS.ullTimestamp.dwHighDateTime)
            'Debug.Print Hex$(udtBSS.ullHostTimestamp.dwLowDateTime)
            'Debug.Print Hex$(udtBSS.ullHostTimestamp.dwHighDateTime)
            'Debug.Print udtBSS.wlanRateSet.uRateSetLength
            'Debug.Print Hex$(udtBSS.ulIeOffset)
            'Debug.Print Hex$(udtBSS.ulIeSize)
            'Debug.Print TimeToString(udtBSS.ullTimestamp)
            'Debug.Print TimeToString(udtBSS.ullHostTimestamp)
            
            sLen = udtBSS.dot11Ssid.uSSIDLength
             If sLen = 0 Then
                sSSID = "(Unknown)"
            Else
                ReDim bTmp(sLen - 1)
                CopyMemory bTmp(0), udtBSS.dot11Ssid.ucSSID(0), sLen
                sSSID = ByteToStr(bTmp)
            End If
            ListArray(0) = CStr(lCount + 1)
'            Debug.Print ListArray(0) & " ";
'            Debug.Print sSSID,
            ListArray(1) = sSSID
'            Debug.Print udtBSS.uPhyId,
            sMAC = MACtoString(udtBSS.dot11Bssid)
'            Debug.Print sMAC,
            ListArray(2) = sMAC
'            Debug.Print udtBSS.dot11BssType,
            ListArray(3) = udtBSS.dot11BssType
'            Debug.Print udtBSS.dot11BssPhyType,
            ListArray(4) = udtBSS.dot11BssPhyType
'            Debug.Print Hex$(udtBSS.lRssi),
'            Debug.Print udtBSS.uLinkQuality,
            ListArray(5) = udtBSS.uLinkQuality
            sTime = TimeToString(udtBSS.ullHostTimestamp)
            ListArray(6) = sTime
            'Debug.Print udtBSS.ulChCenterFrequency
            ListArray(7) = udtBSS.ulChCenterFrequency
'            Debug.Print udtBSS.wlanRateSet.uRateSetLength
'            Debug.Print Hex$(udtBSS.ulIeOffset)
'            Debug.Print udtBSS.ulIeSize
            Call FrmList.AddToList(ListArray)
            lCount = lCount + 1
            lStart = lStart + Len(udtBSS)
        Loop Until lCount = udtBSSList.dwNumberofItems
        WlanFreeMemory lBSS
    End If
End Sub


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 lPntr
    Let ByteToStr = bTmp
    Exit Function
ByteErr:
    ByteToStr = ""
End Function

Private Function Connect() As Boolean
    Dim lRet As Long
    Dim sSSID As String
    Dim udtConnect As WLAN_CONNECTION_PARAMETERS
    sSSID = Trim(lstSSID.Text)
    udtConnect.ConnectionMode = 0&
    udtConnect.dot11BssType = DOT11_BSS_TYPE.DOT11_BSS_TYPE_ANY
    udtConnect.Profile = StrPtr(sSSID)
    lRet = WlanConnect(lHandle, udtList.InterfaceInfo.ifGuid, udtConnect, 0&)
End Function


Private Sub DebugPrintByte(sDescr As String, bArray() As Byte)
    Dim lPtr As Long
    Debug.Print sDescr & ":"
    If GetbSize(bArray) = 0 Then Exit Sub
    For lPtr = 0 To UBound(bArray)
        Debug.Print Right$("0" & Hex$(bArray(lPtr)), 2) & " ";
        If (lPtr + 1) Mod 16 = 0 Then Debug.Print
    Next lPtr
    Debug.Print
End Sub

Private Function Disconnect() As Boolean
    Dim lRet As Long
    lRet = WlanDisconnect(lHandle, udtList.InterfaceInfo.ifGuid, 0&)
    If lRet = 0 Then
        Disconnect = True
    End If
End Function

Private Function GetbSize(bArray() As Byte) As Long
    On Error GoTo GetSizeErr
    GetbSize = UBound(bArray) + 1
    Exit Function
GetSizeErr:
    GetbSize = 0
End Function

Private Sub GetInfo(ByVal Index As Long)
    Dim Network As AVAILABLE_NETWORK
    Dim lStart As Long
    Dim sLen As Long
    Dim bSSID() As Byte
    Dim sSSID As String
    Dim lPtr As Long
    Dim Msg As String
    lStart = VarPtr(bBuffer(0)) + Index * Len(Network)
    CopyMemory Network, ByVal lStart, Len(Network)
    sLen = Network.dot11Ssid.uSSIDLength
    If sLen = 0 Then
        sSSID = "(Unknown)"
    Else
        ReDim bSSID(sLen - 1)
        CopyMemory bSSID(0), Network.dot11Ssid.ucSSID(0), sLen
        sSSID = ByteToStr(bSSID)
    End If
    Msg = "Signal Strength: " & CStr(Network.wlanSignalQuality)
    If Network.dwFlags And 1 Then
        Msg = Msg & vbCrLf & "Connected"
    Else
        Msg = Msg & vbCrLf & "Not Connected"
    End If
    Select Case Network.dot11BssType
        Case DOT11_BSS_TYPE.dot11_BSS_type_infrastructure
            Msg = Msg & vbCrLf & "BSS: Infrastructure"
        Case DOT11_BSS_TYPE.dot11_BSS_type_independent
            Msg = Msg & vbCrLf & "BSS: Peer to Peer"
    End Select
    If Network.bNetworkConnectable <> 0 Then
        Msg = Msg & vbCrLf & "Connectable"
    Else
        Msg = Msg & vbCrLf & "Not Connectable"
    End If
    For lPtr = 0 To UBound(Network.dot11PhyTypes)
        Select Case Network.dot11PhyTypes(lPtr)
            Case DOT11_PHY_TYPE.dot11_phy_type_ht
                Msg = Msg & vbCrLf & "802.11n"
            Case DOT11_PHY_TYPE.dot11_phy_type_erp
                Msg = Msg & vbCrLf & "802.11g"
            Case DOT11_PHY_TYPE.dot11_phy_type_ofdm
                Msg = Msg & vbCrLf & "802.11a"
        End Select
    Next lPtr
    If Network.bSecurityEnabled Then Msg = Msg & vbCrLf & "Security Enabled"
    Select Case Network.dot11DefaultAuthAlgorithm
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_80211_OPEN
            Msg = Msg & vbCrLf & "Auth Algorithm: Open"
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_80211_SHARED_KEY
            Msg = Msg & vbCrLf & "Auth Algorithm: Shared Key"
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_WPA
            Msg = Msg & vbCrLf & "Auth Algorithm: WPA"
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_RSNA
            Msg = Msg & vbCrLf & "Auth Algorithm: RSNA"
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_RSNA_PSK
            Msg = Msg & vbCrLf & "Auth Algorithm: RSNA with Pre-shared Keys"
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_WPA_PSK
            Msg = Msg & vbCrLf & "Auth Algorithm: WPA with Pre-shared Keys"
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_80211_SHARED_KEY
            Msg = Msg & vbCrLf & "Auth Algorithm: WEP"
    End Select
    Select Case Network.dot11DefaultCipherAlgorithm
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_CCMP
            Msg = Msg & vbCrLf & "Cypher Algorithm: AES - CCMP"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_NONE
            Msg = Msg & vbCrLf & "Cypher Algorithm: None"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_RSN_USE_GROUP
            Msg = Msg & vbCrLf & "Cypher Algorithm: RSN - Use Group Key"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_TKIP
            Msg = Msg & vbCrLf & "Cypher Algorithm: TKIP"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_WEP
            Msg = Msg & vbCrLf & "Cypher Algorithm: WEP"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_WEP104
            Msg = Msg & vbCrLf & "Cypher Algorithm: WEP - 104 Bit Key"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_WEP40
            Msg = Msg & vbCrLf & "Cypher Algorithm: WEP - 40 Bit Key"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_WPA_USE_GROUP
            Msg = Msg & vbCrLf & "Cypher Algorithm: WPA - Use Group Key"
    End Select
    MsgBox Msg, , sSSID
End Sub

Private Function GetTimeBias() As Long
    Const TIME_ZONE_ID_DAYLIGHT As Long = 2
    Dim tzi As TIME_ZONE_INFORMATION
    Dim dwBias As Long
    Select Case GetTimeZoneInformation(tzi)
        Case TIME_ZONE_ID_DAYLIGHT
            dwBias = tzi.Bias + tzi.DaylightBias
        Case Else
            dwBias = tzi.Bias + tzi.StandardBias
    End Select
    GetTimeBias = dwBias
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


Private Sub Scan()
    Dim lRet As Long
    Dim lList As Long
    Dim lAvailable As Long
    Dim lStart As Long
    Dim lCount As Long
    Dim sLen As Long
    Dim bSSID() As Byte
    Dim lBSS As Long
    Dim sSSID As String
    Dim udtAvailableList As WLAN_AVAILABLE_NETWORK_LIST
    Dim udtNetwork As WLAN_AVAILABLE_NETWORK
    Dim Network As AVAILABLE_NETWORK
    Dim lPtr As Long
    Dim dwFlags As Long
    Dim dwreserved As Long
    Dim XMLBuffer(1023) As Byte
    lstSSID.Clear
    ConIndex = -1
    lblNetwork.Visible = False
    lblNetwork.Caption = ""
    ReDim bBuffer(0)
    If lHandle Then
        lRet = WlanScan(lHandle, udtList.InterfaceInfo.ifGuid, ByVal 0&, ByVal 0&, ByVal 0&)
        Screen.MousePointer = vbHourglass
        'Wait for scan to finish (4 seconds)
        Sleep 4000
        Screen.MousePointer = vbDefault
    Else 'Get adapter handle and find WLAN interfaces
        lRet = WlanOpenHandle(2&, 0&, lVersion, lHandle)
        'NOTE: This code currently only processes the first wireless adapter
        lRet = WlanEnumInterfaces(ByVal lHandle, 0&, lList)
        CopyMemory udtList, ByVal lList, Len(udtList)
        Debug.Print udtList.dwNumberofItems, "WiFi Adapter found!"
    End If
    If udtList.dwNumberofItems > 0 Then
        lRet = WlanGetAvailableNetworkList(lHandle, udtList.InterfaceInfo.ifGuid, 2&, 0&, lAvailable)
        CopyMemory udtAvailableList, ByVal lAvailable, LenB(udtAvailableList)
        lCount = 0
        lStart = lAvailable + 8
        lblStatus.Caption = CStr(udtAvailableList.dwNumberofItems) & " Networks Found!"
        ReDim bBuffer(Len(Network) * udtAvailableList.dwNumberofItems - 1)
        Do 'Create new abbreviated buffer
            CopyMemory udtNetwork, ByVal lStart, Len(udtNetwork)
            lCount = lCount + 1
            lStart = lStart + Len(udtNetwork)
            CopyMemory bBuffer(lPtr), udtNetwork.dot11Ssid.uSSIDLength, Len(Network)
            lPtr = lPtr + Len(Network)
        Loop Until lCount = udtAvailableList.dwNumberofItems
        WlanFreeMemory lAvailable
        WlanFreeMemory lList
        'Create new list from new buffer
        lStart = VarPtr(bBuffer(0))
        lCount = 0
        Do
            CopyMemory Network, ByVal lStart, Len(Network)
            sLen = Network.dot11Ssid.uSSIDLength
            If sLen = 0 Then
                sSSID = "(Unknown)"
            Else
                ReDim bSSID(sLen - 1)
                CopyMemory bSSID(0), Network.dot11Ssid.ucSSID(0), sLen
                sSSID = ByteToStr(bSSID)
            End If
            Debug.Print "SSID "; sSSID, "Signal "; Network.wlanSignalQuality
            sSSID = Left$(sSSID & Space$(25), 25) & Network.wlanSignalQuality
            lstSSID.AddItem sSSID
            If (Network.dwFlags And 1) = 1 Then
                ConIndex = lCount
            End If
            lCount = lCount + 1
            lStart = lStart + Len(Network)
        Loop Until lCount = udtAvailableList.dwNumberofItems
    Else
        MsgBox "No Wireless Adapters Found"
    End If
    'Call DebugPrintByte("bBuffer", bBuffer)
    If ConIndex > -1 Then 'Display connected network
        Connected = Trim(Left$(lstSSID.List(ConIndex), 25))
        lblNetwork.Caption = Connected
        lblNetwork.Visible = True
    End If
End Sub

Private Function TimeToString(File_Time As FILETIME) As String
    'Dim dSerial As Single
    Dim tSerial As Single
    Dim File_Time_Local As FILETIME
    Dim sys_Time As SYSTEMTIME
    'convert the file time to a local file time
    If FileTimeToLocalFileTime(File_Time, File_Time_Local) Then
        'convert the local file time to the system time format
        If FileTimeToSystemTime(File_Time_Local, sys_Time) Then
            'calculate the DateSerial/TimeSerial values for the system time
            'dSerial = DateSerial(sys_Time.wYear, sys_Time.wMonth, sys_Time.wDay)
            tSerial = TimeSerial(sys_Time.wHour, sys_Time.wMinute, sys_Time.wSecond)
            'Debug.Print FormatDateTime(dSerial, vbLongDate) & "  " & FormatDateTime(tSerial, vbLongTime)
            TimeToString = FormatDateTime(tSerial)
        End If
    End If
End Function


Private Sub cmdBSS_Click()
    FrmList.Show
    Call BasicServiceSet
End Sub

Private Sub cmdProfile_Click()
    Dim strProfileName As String
    Dim pstrProfileXml As Long
    Dim GetProfile As String
    Dim lRet As Long
    Dim sLen As Long
    strProfileName = Trim(Left$(lstSSID.Text, 15)) & Chr$(0)  '"coutts2.4" & Chr$(0)
    lRet = WlanGetProfile(lHandle, udtList.InterfaceInfo.ifGuid, StrPtr(strProfileName), 0&, pstrProfileXml, 0&, 0&)
    If lRet Then
        Debug.Print "Error: "; CStr(lRet)
        MsgBox "No profile Available!"
    Else
        sLen = lstrlenW(pstrProfileXml)
        If sLen Then
            GetProfile = Space$(sLen)
            CopyMemory ByVal StrPtr(GetProfile), ByVal pstrProfileXml, sLen * 2
        End If
        WlanFreeMemory pstrProfileXml
        MsgBox GetProfile
    End If
End Sub


Private Sub cmdScan_Click()
    Call Scan
End Sub

Private Sub Form_Load()
    Call Scan
End Sub

Private Sub lstSSID_Click()
    Call GetInfo(lstSSID.ListIndex)
End Sub
 
Upvote 0
Ok. Sp those are 32 bit API declarations. I take it then that you're using VBA7 32 bit office?
 
Upvote 0
Yes Windows is 64 bit but office is 32 bit.
 
Upvote 0
Hi johnnyL

So, did you manage to get the WLAN_BSS_ENTRY entries in the end?

I borowed an external network adapter from a friend so I could (hopefully) adapt the vb6 code to vba x32 & x64.

File Demo:
WifiScanner.xlsm






This is the main api worker code stripped of unnecessay stuff and with some new added routines:
1- In a Standard Module:
VBA Code:
Option Explicit

'code adapted to vba from: (Credits for the original code go to 'J.A. Coutts' @ VBForums)
'https://www.vbforums.com/showthread.php?881991-Simplified-WiFi-Scan&p=5442943&viewfull=1#post5442943

#If VBA7 Then
    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 WlanGetAvailableNetworkList Lib "wlanapi.dll" (ByVal hClientHandle As LongPtr, pInterfaceGuid As GUID, ByVal dwFlags As Long, ByVal pReserved As LongPtr, ppAvailableNetworkList As LongPtr) As Long
    Private Declare PtrSafe Function WlanConnect Lib "wlanapi.dll" (ByVal hClientHandle As LongPtr, pInterfaceGuid As GUID, pConnectionParameters As WLAN_CONNECTION_PARAMETERS, ByVal reserved 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 WlanDisconnect Lib "wlanapi.dll" (ByVal hClientHandle As LongPtr, pInterfaceGuid As GUID, ByVal pReserved 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
    Private Enum LongPtr
        [_]
    End Enum
    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 WlanGetAvailableNetworkList Lib "wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As GUID, ByVal dwFlags As Long, ByVal pReserved As Long, ppAvailableNetworkList As Long) As Long
    Private Declare Function WlanConnect Lib "wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As GUID, pConnectionParameters As WLAN_CONNECTION_PARAMETERS, ByVal reserved 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 WlanDisconnect Lib "wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As GUID, ByVal pReserved 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 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 DOT11_SSID
    uSSIDLength As Long
    ucSSID(31) As Byte
End Type

Private Type WLAN_RATE_SET
    uRateSetLength As Long
    usRateSet(125) As Integer
End Type

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 TIME_ZONE_INFORMATION
   Bias As Long
   StandardName(0 To 63) As Byte
   StandardDate As SYSTEMTIME
   StandardBias As Long
   DaylightName(0 To 63) As Byte
   DaylightDate As SYSTEMTIME
   DaylightBias As Long
End Type

Private Type WLAN_AVAILABLE_NETWORK
    strProfileName(511) As Byte
    dot11Ssid As DOT11_SSID
    dot11BssType As Long
    uNumberOfBssids As Long
    bNetworkConnectable As Long
    wlanNotConnectableReason As Long
    uNumberOfPhyTypes As Long
    dot11PhyTypes(7) As Long
    bMorePhyTypes As Long
    wlanSignalQuality As Long
    bSecurityEnabled As Long
    dot11DefaultAuthAlgorithm As Long
    dot11DefaultCipherAlgorithm As Long
    dwFlags As Long
    dwreserved As Long
End Type

Private Type AVAILABLE_NETWORK
    dot11Ssid As DOT11_SSID
    dot11BssType As Long
    uNumberOfBssids As Long
    bNetworkConnectable As Long
    wlanNotConnectableReason As Long
    uNumberOfPhyTypes As Long
    dot11PhyTypes(7) As Long
    bMorePhyTypes As Long
    wlanSignalQuality As Long
    bSecurityEnabled As Long
    dot11DefaultAuthAlgorithm As Long
    dot11DefaultCipherAlgorithm As Long
    dwFlags As Long
    dwreserved 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 Type WLAN_INTERFACE_INFO_LIST
    dwNumberofItems As Long
    dwIndex As Long
    InterfaceInfo As WLAN_INTERFACE_INFO
End Type

Private Type WLAN_AVAILABLE_NETWORK_LIST
    dwNumberofItems As Long
    dwIndex As Long
    Network As WLAN_AVAILABLE_NETWORK
End Type

Private Type WLAN_CONNECTION_PARAMETERS
    ConnectionMode As Long
    Profile As LongPtr
    pDot11Ssid As LongPtr
    pDesiredBssidList As LongPtr
    dot11BssType As Long
    dwFlags As Long
End Type

Private Type WLAN_BSS_LIST
    dwTotalSize As Long
    dwNumberofItems As Long
    wlanBssEntries As Long
End Type

Public Type BSS_INFO
    uPhyId As Long
    MAC As String
    dot11BssType As DOT11_BSS_TYPE
    dot11BssPhyType As DOT11_PHY_TYPE
    lRssi  As Long
    uLinkQuality As Long
    ullHostTimestamp As String
    ullTimestamp As String
    ulChCenterFrequency As Currency
    uRateSetLength As Long
    ulIeOffset As Long
    ulIeSize  As Long
    usCapabilityInformation As Double
    bInRegDomain As Long
    usBeaconPeriod As Long
End Type

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_IHV_start = &H80000000
    dot11_phy_type_IHV_end = &HFFFFFFFF
End Enum

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_AUTH_ALGORITHM
    DOT11_AUTH_ALGO_80211_OPEN = 1
    DOT11_AUTH_ALGO_80211_SHARED_KEY = 2
    DOT11_AUTH_ALGO_WPA = 3
    DOT11_AUTH_ALGO_WPA_PSK = 4
    DOT11_AUTH_ALGO_WPA_NONE = 5
    DOT11_AUTH_ALGO_RSNA = 6
    DOT11_AUTH_ALGO_RSNA_PSK = 7
    DOT11_AUTH_ALGO_IHV_START = &H80000000
    DOT11_AUTH_ALGO_IHV_END = &HFFFFFFFF
End Enum

Private Enum DOT11_CIPHER_ALGORITHM
    DOT11_CIPHER_ALGO_NONE = &H0
    DOT11_CIPHER_ALGO_WEP40 = &H1
    DOT11_CIPHER_ALGO_TKIP = &H2
    DOT11_CIPHER_ALGO_CCMP = &H4
    DOT11_CIPHER_ALGO_WEP104 = &H5
    DOT11_CIPHER_ALGO_WPA_USE_GROUP = &H100
    DOT11_CIPHER_ALGO_RSN_USE_GROUP = &H100
    DOT11_CIPHER_ALGO_WEP = &H101
    DOT11_CIPHER_ALGO_IHV_START = &H80000000
    DOT11_CIPHER_ALGO_IHV_END = &HFFFFFFFF
End Enum

Private udtList As WLAN_INTERFACE_INFO_LIST
Private udtBSSList As WLAN_BSS_LIST
Private ConIndex As Long
Public lHandle As LongPtr
Private lVersion As Long
Private Connected As String
Private bBuffer() As Byte
Public lNumberOfnetworkItems As Long


Public Function GetBSS(ByVal SSID As String) As BSS_INFO  ' WLAN_BSS_ENTRY
    Dim lBSS As LongPtr
    Dim lRet As Long
    Dim sLen As Long
    Dim lStart As LongPtr
    Dim lCount As Long
    Dim sSSID As String
    Dim sMAC As String
    Dim sTime As String
    Dim bTmp() As Byte
    Dim ListArray(10) As String
    Dim BSSInfo() As Byte
    Dim udtBSS As WLAN_BSS_ENTRY
    Dim tINFO As BSS_INFO

    If lHandle = 0 Then Exit Function
    lRet = WlanGetNetworkBssList(lHandle, udtList.InterfaceInfo.ifGuid, ByVal 0&, DOT11_BSS_TYPE.DOT11_BSS_TYPE_ANY, 0^, 0^, lBSS)
    CopyMemory udtBSSList, ByVal lBSS, Len(udtBSSList)
    If lRet Then
        Debug.Print "Error: "; CStr(lRet)
        MsgBox "No BSS Info Available!"
    Else
        lStart = lBSS + 8
        lCount = 0
        Do
            CopyMemory udtBSS, ByVal lStart, Len(udtBSS)
            sLen = udtBSS.dot11Ssid.uSSIDLength
             If sLen = 0 Then
                sSSID = "(Unknown)"
            Else
                ReDim bTmp(sLen - 1)
                CopyMemory bTmp(0), udtBSS.dot11Ssid.ucSSID(0), sLen
                sSSID = ByteToStr(bTmp)
            End If
            If UCase(RTrim(SSID)) = UCase(RTrim(sSSID)) Then
                sMAC = MACtoString(udtBSS.dot11Bssid)
                With tINFO
                    .uPhyId = udtBSS.uPhyId
                    .MAC = sMAC
                    .dot11BssType = udtBSS.dot11BssType
                    .dot11BssPhyType = udtBSS.dot11BssPhyType
                    .lRssi = udtBSS.lRssi
                    .uLinkQuality = udtBSS.uLinkQuality
                    .ullHostTimestamp = TimeToString(udtBSS.ullHostTimestamp)
                    .ullTimestamp = TimeToString(udtBSS.ullTimestamp)
                    .ulChCenterFrequency = Round(udtBSS.ulChCenterFrequency / 1000000, 2)
                    .uRateSetLength = udtBSS.wlanRateSet.uRateSetLength
                    .ulIeOffset = udtBSS.ulIeOffset
                    .ulIeSize = udtBSS.ulIeSize
                    .usCapabilityInformation = udtBSS.usCapabilityInformation
                    .bInRegDomain = udtBSS.bInRegDomain
                    .usBeaconPeriod = udtBSS.usBeaconPeriod
                End With
                GetBSS = tINFO
                Exit Do
            End If
            lCount = lCount + 1
            lStart = lStart + Len(udtBSS)
        Loop Until lCount = udtBSSList.dwNumberofItems
        WlanFreeMemory lBSS
    End If
End Function

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

Public Function GetNetWorksNames() As String()
    Dim lRet As Long
    Dim lList As LongPtr
    Dim lAvailable As LongPtr
    Dim lStart As LongPtr
    Dim lCount As Long
    Dim sLen As Long
    Dim bSSID() As Byte
    Dim sSSID As String
    Dim udtAvailableList As WLAN_AVAILABLE_NETWORK_LIST
    Dim udtNetwork As WLAN_AVAILABLE_NETWORK
    Dim Network As AVAILABLE_NETWORK
    Dim lPtr As Long
    Dim sTmp() As String
 
    ConIndex = -1
    ReDim bBuffer(0)
    If lHandle Then
        lRet = WlanScan(lHandle, udtList.InterfaceInfo.ifGuid, ByVal 0&, ByVal 0&, ByVal 0&)
        'Wait for scan to finish (2 seconds)
        Call Wait(4)
    Else 'Get adapter handle and find WLAN interfaces
        lRet = WlanOpenHandle(2&, 0&, lVersion, lHandle)
        'NOTE: This code currently only processes the first wireless adapter
        lRet = WlanEnumInterfaces(ByVal lHandle, 0&, lList)
        CopyMemory udtList, ByVal lList, LenB(udtList)
'        Debug.Print udtList.dwNumberofItems, "WiFi Adapter found!"
    End If
    If udtList.dwNumberofItems > 0 Then
        lRet = WlanGetAvailableNetworkList(lHandle, udtList.InterfaceInfo.ifGuid, 2&, 0&, lAvailable)
        CopyMemory udtAvailableList, ByVal lAvailable, LenB(udtAvailableList)
        lCount = 0
        lStart = lAvailable + 8^
        ReDim bBuffer(Len(Network) * udtAvailableList.dwNumberofItems - 1)
        Do 'Create new abbreviated buffer
            CopyMemory udtNetwork, ByVal lStart, Len(udtNetwork)
            lCount = lCount + 1
            lStart = lStart + Len(udtNetwork)
            CopyMemory bBuffer(lPtr), udtNetwork.dot11Ssid.uSSIDLength, Len(Network)
            lPtr = lPtr + Len(Network)
        Loop Until lCount = udtAvailableList.dwNumberofItems
        WlanFreeMemory lAvailable
        WlanFreeMemory lList
        'Create new list from new buffer
        lStart = VarPtr(bBuffer(0))
        lCount = 0
        Do
            CopyMemory Network, ByVal lStart, Len(Network)
            sLen = Network.dot11Ssid.uSSIDLength
            If sLen = 0 Then
                sSSID = "(Unknown)"
            Else
                ReDim bSSID(sLen - 1)
                CopyMemory bSSID(0), Network.dot11Ssid.ucSSID(0), sLen
                sSSID = ByteToStr(bSSID)
            End If
            sSSID = Left$(sSSID & Space$(25), 25)
            ReDim Preserve sTmp(lCount)
            sTmp(lCount) = sSSID
            If (Network.dwFlags And 1) = 1 Then
                ConIndex = lCount
            End If
            lCount = lCount + 1
            lStart = lStart + Len(Network)
        Loop Until lCount = udtAvailableList.dwNumberofItems
        GetNetWorksNames = sTmp
    Else
        MsgBox "No Wireless Adapters Found"
    End If
    If ConIndex > -1 Then 'Display connected network
    End If
End Function

Public Function GetInfo(ByVal Index As Long) As String()
    Dim Network As AVAILABLE_NETWORK
    Dim lStart As LongPtr, sLen As Long, bSSID() As Byte
    Dim sSSID As String, lPtr As Long, Msg As String
 
    lStart = VarPtr(bBuffer(0)) + Index * Len(Network)
    CopyMemory Network, ByVal lStart, Len(Network)
    sLen = Network.dot11Ssid.uSSIDLength
    If sLen = 0 Then
        sSSID = "(Unknown)"
    Else
        ReDim bSSID(sLen - 1)
        CopyMemory bSSID(0), Network.dot11Ssid.ucSSID(0), sLen
        sSSID = ByteToStr(bSSID)
    End If
    Msg = CStr(Network.wlanSignalQuality)
    If Network.dwFlags And 1 Then
        Msg = Msg & vbCrLf & "TRUE" ' Connected
    Else
        Msg = Msg & vbCrLf & "FALSE" 'Disconnected
    End If
    Select Case Network.dot11BssType
        Case DOT11_BSS_TYPE.dot11_BSS_type_infrastructure
            Msg = Msg & vbCrLf & "BSS: Infrastructure"
        Case DOT11_BSS_TYPE.dot11_BSS_type_independent
            Msg = Msg & vbCrLf & "BSS: Peer to Peer"
    End Select
    If Network.bNetworkConnectable <> 0 Then
        Msg = Msg & vbCrLf & "TRUE"  'Connectable
    Else
        Msg = Msg & vbCrLf & "FALSE" 'Not Connectable
    End If
    For lPtr = 0 To UBound(Network.dot11PhyTypes)
        Select Case Network.dot11PhyTypes(lPtr)
            Case DOT11_PHY_TYPE.dot11_phy_type_ht
                Msg = Msg & vbCrLf & "802.11n"
            Case DOT11_PHY_TYPE.dot11_phy_type_erp
                Msg = Msg & vbCrLf & "802.11g"
            Case DOT11_PHY_TYPE.dot11_phy_type_ofdm
                Msg = Msg & vbCrLf & "802.11a"
        End Select
    Next lPtr
    If Network.bSecurityEnabled Then
        Msg = Msg & vbCrLf & "TRUE"   'Security Enabled
    Else
        Msg = Msg & vbCrLf & "FALSE"  'Security Disabled
    End If
    Select Case Network.dot11DefaultAuthAlgorithm
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_80211_OPEN
            Msg = Msg & vbCrLf & "Auth Algorithm: Open"
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_80211_SHARED_KEY
            Msg = Msg & vbCrLf & "Auth Algorithm: Shared Key"
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_WPA
            Msg = Msg & vbCrLf & "Auth Algorithm: WPA"
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_RSNA
            Msg = Msg & vbCrLf & "Auth Algorithm: RSNA"
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_RSNA_PSK
            Msg = Msg & vbCrLf & "Auth Algorithm: RSNA with Pre-shared Keys"
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_WPA_PSK
            Msg = Msg & vbCrLf & "Auth Algorithm: WPA with Pre-shared Keys"
        Case DOT11_AUTH_ALGORITHM.DOT11_AUTH_ALGO_80211_SHARED_KEY
            Msg = Msg & vbCrLf & "Auth Algorithm: WEP"
    End Select
    Select Case Network.dot11DefaultCipherAlgorithm
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_CCMP
            Msg = Msg & vbCrLf & "Cypher Algorithm: AES - CCMP"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_NONE
            Msg = Msg & vbCrLf & "Cypher Algorithm: None"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_RSN_USE_GROUP
            Msg = Msg & vbCrLf & "Cypher Algorithm: RSN - Use Group Key"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_TKIP
            Msg = Msg & vbCrLf & "Cypher Algorithm: TKIP"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_WEP
            Msg = Msg & vbCrLf & "Cypher Algorithm: WEP"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_WEP104
            Msg = Msg & vbCrLf & "Cypher Algorithm: WEP - 104 Bit Key"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_WEP40
            Msg = Msg & vbCrLf & "Cypher Algorithm: WEP - 40 Bit Key"
        Case DOT11_CIPHER_ALGORITHM.DOT11_CIPHER_ALGO_WPA_USE_GROUP
            Msg = Msg & vbCrLf & "Cypher Algorithm: WPA - Use Group Key"
    End Select
    GetInfo = Split(Msg, vbCrLf)
End Function

Public Function Connect(ByVal SSID As String) As Boolean
    Dim lRet As Long
    Dim udtConnect As WLAN_CONNECTION_PARAMETERS
    SSID = Trim(Left$(SSID, 15)) & Chr$(0)
    udtConnect.ConnectionMode = 0&
    udtConnect.dot11BssType = DOT11_BSS_TYPE.DOT11_BSS_TYPE_ANY
    udtConnect.Profile = StrPtr(SSID)
    lRet = WlanConnect(lHandle, udtList.InterfaceInfo.ifGuid, udtConnect, 0&)
    If lRet = 0 Then
        Connect = True
    End If
End Function

Public Function Disconnect() As Boolean
    Dim lRet As Long
    lRet = WlanDisconnect(lHandle, udtList.InterfaceInfo.ifGuid, 0&)
    If lRet = 0 Then
        Disconnect = True
    End If
End Function

Public Sub ReleaseHandle()
    Call WlanCloseHandle(lHandle, 0)
    Call Sleep(1000)
    ConIndex = 0
    lHandle = 0
    lVersion = 0
    Connected = ""
    lNumberOfnetworkItems = 0
    Erase bBuffer()
End Sub

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

Private Function TimeToString(File_Time As FILETIME) As String
    Dim tSerial As Single
    Dim File_Time_Local As FILETIME
    Dim sys_Time As SYSTEMTIME
    'convert the file time to a local file time
    If FileTimeToLocalFileTime(File_Time, File_Time_Local) Then
        'convert the local file time to the system time format
        If FileTimeToSystemTime(File_Time_Local, sys_Time) Then
            'calculate the DateSerial/TimeSerial values for the system time
            'dSerial = DateSerial(sys_Time.wYear, sys_Time.wMonth, sys_Time.wDay)
            tSerial = TimeSerial(sys_Time.wHour, sys_Time.wMinute, sys_Time.wSecond)
            'Debug.Print FormatDateTime(dSerial, vbLongDate) & "  " & FormatDateTime(tSerial, vbLongTime)
            TimeToString = FormatDateTime(tSerial)
        End If
    End If
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 lPntr
    Let ByteToStr = bTmp
    Exit Function
ByteErr:
    ByteToStr = ""
End Function

Private Function ByteToStr2(b() As Byte) As String
    Dim sDescription As String, bTmp() As Byte, lNullCharPos As Long
    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 Sub Wait(ByVal Delay As Single)
    Dim t As Single
    t = Timer: Do: DoEvents: Loop Until Timer - t >= Delay
End Sub



2- UserForm Module:
VBA Code:
Option Explicit

Private bRefreshing As Boolean

Private Sub UserForm_Activate()
    Call RefreshNetworks
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If bRefreshing Then Cancel = True: Exit Sub
    Call ReleaseHandle
End Sub

Private Sub btnConnect_Click()
    With btnConnect
        If .Caption = "Connect" Then
            If Connect(lstSSID.Value) Then
                .Caption = "Disconnect"
            Else
                MsgBox "Connection failed.": Exit Sub
            End If
        Else
            If Disconnect Then
                .Caption = "Connect"
            Else
                MsgBox "DisConnection failed.": Exit Sub
            End If
        End If
    End With
    Call RefreshNetworks
End Sub

Private Sub lstSSID_Change()
    Call UpdateListBox(lstBBS)
End Sub

Private Sub RefreshNetworks()
    bRefreshing = True
    btnConnect.Enabled = False
    lblStatus.Caption = "Loading\Refreshing ...  Please,wait."
    Call SetUpListBox(lstBBS, False)
    lblWifiAdapterName = "[ " & GetWifiAdapterName & " ]"
    lstSSID.List = GetNetWorksNames
    lstSSID.ListIndex = 0&
    lblNetWorksFound = "[ " & lstSSID.ListCount & " ]"
    Call SetUpListBox(lstBBS, True)
    Call UpdateListBox(lstBBS)
    btnConnect.Enabled = True
    lblStatus.Caption = ""
    bRefreshing = False
End Sub

Private Sub SetUpListBox(ByVal Lbx As MSForms.ListBox, ByVal bClear As Boolean)
    Dim vArray As Variant, vItem As Variant

    vArray = Array( _
        "bSSID (MAC):", _
        "Connected:", _
        "LinkQuality (Signal Strength):", _
        "PhyId:", _
        "BssType:", _
        "BssPhyType:", _
        "lRssi:", _
        "RegDomain:", _
        "BeaconPeriod:", _
        "Timestamp:", _
        "HostTimestamp:", _
        "CapabilityInformation:", _
        "ulChCenterFrequency:", _
        "wlanRateSet:", _
        "ulIeOffset:", _
        "ulIeSize:", _
        "BSS_TYPE:", _
        "Connectable:", _
        "PHY_TYPE:", _
        "Security Enabled:", _
        "Auth Algorithm:", _
        "Cypher Algorithm:" _
    )
With Lbx
    If bClear Then
        .Clear
    End If
    .ColumnCount = 2&
    .ColumnWidths = "120;220"
    For Each vItem In vArray
        .AddItem IIf(bClear, vItem, "")
    Next vItem
End With
End Sub

Private Sub UpdateListBox(ByVal Lbx As MSForms.ListBox)
    Dim uBSS As BSS_INFO, arSSID() As String
 
    uBSS = GetBSS(lstSSID.Value)
    arSSID = GetInfo(lstSSID.ListIndex)
    With Lbx
        .List(0, 1) = uBSS.MAC
        .List(1, 1) = arSSID(1)
        .List(2, 1) = uBSS.uLinkQuality & " %"
        .List(3, 1) = uBSS.uPhyId
        .List(4, 1) = uBSS.dot11BssType
        .List(5, 1) = uBSS.dot11BssPhyType
        .List(6, 1) = uBSS.lRssi
        .List(7, 1) = uBSS.bInRegDomain
        .List(8, 1) = uBSS.usBeaconPeriod
        .List(9, 1) = uBSS.ullTimestamp
        .List(10, 1) = uBSS.ullHostTimestamp
        .List(11, 1) = uBSS.usCapabilityInformation
        .List(12, 1) = uBSS.ulChCenterFrequency & " GHz"
        .List(13, 1) = uBSS.uRateSetLength
        .List(14, 1) = uBSS.ulIeOffset
        .List(15, 1) = uBSS.ulIeSize
        .List(16, 1) = arSSID(2&)
        .List(17, 1) = arSSID(3&)
        .List(18, 1) = arSSID(4&)
        .List(19, 1) = arSSID(5&)
        .List(20, 1) = arSSID(6&)
        .List(21, 1) = arSSID(7&)
    End With
    If lstBBS.List(1, 1) = "FALSE" Then
        btnConnect.Caption = "Connect"
    Else
        btnConnect.Caption = "Disconnect"
    End If
End Sub

Code written and tested on Office 2016 x64bit Windows 10 x64bit... I hope this works without issues and the code is not buggy.
 
Last edited:
Upvote 0
Thank you @Jaafar Tribak for responding again.

I am currently going through your code submission & I initially see some problems:

1) lines in the 'bas_API' module with the '^' are not liked by excel. I had to remove all of those '^' in the lines that they were found in.
2) a few lines in the 'UserForm1' module produced errors RTE 9

VBA Code:
        .List(20, 1) = arSSID(6&)
        .List(21, 1) = arSSID(7&)

I will keep plugging away at it in the mean time. Again, Thank you for responding.
 
Upvote 0

Forum statistics

Threads
1,215,086
Messages
6,123,038
Members
449,092
Latest member
ikke

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top