Internet Access On/Off Switch

[LorinM]

Is there a way to turn off and on Internet Access from my laptop using VB6 code?

I need to maintain LAN access of all devices on the Local Network.

[LorinM]

Will this do what i want.

I do not want to try something like this fearing shutting myself off and not knowing how to turn it on.

Option Explicit

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, ByRef lpOverlapped As Any) As Long

Private Const FILE_DEVICE_NETWORK As Long = &H12
Private Const METHOD_BUFFERED As Long = 0
Private Const FILE_ANY_ACCESS As Long = 0

Private Const IOCTL_NETWORK_BLOCKINTERNET As Long = ((FILE_DEVICE_NETWORK * &H10000) Or (FILE_ANY_ACCESS * &H4000) Or (METHOD_BUFFERED))

Public Sub SetInternetAccess(enable As Boolean)
    Dim hDevice As Long
    Dim bytesReturned As Long
    Dim ret As Long
    Dim inputBuffer(0 To 1) As Byte
    
    inputBuffer(0) = IIf(enable, 1, 0)
    
    hDevice = CreateFile("\\.\NetworkDevice", &H80000000, 0, ByVal 0&, 3, 0, 0)
    
    If hDevice <> -1 Then
        ret = DeviceIoControl(hDevice, IOCTL_NETWORK_BLOCKINTERNET, inputBuffer(0), 1, ByVal 0&, 0, bytesReturned, ByVal 0&)
        CloseHandle hDevice
    End If
End Sub

[-Franky-]

There are also the COM interfaces INetConnectionManager, IEnumNetConnection and INetConnection. The latter contains the functions Connect and Disconnect with which you can switch a specific network adapter on or off. What I don't know at the moment is whether these COM interfaces are still available under Win11.

[fafalone]

Most advice is to set a firewall rule with the INetFw* interfaces. Iirc it's already meant to be VBScript (and thus vb6) compatible so you can use the FirewallAPI.dll reference and not need a VB6 specific rewrite.

[yereverluvinuncleber]

Option Explicit

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, ByRef lpOverlapped As Any) As Long

Private Const FILE_DEVICE_NETWORK As Long = &H12
Private Const METHOD_BUFFERED As Long = 0
Private Const FILE_ANY_ACCESS As Long = 0

Private Const IOCTL_NETWORK_BLOCKINTERNET As Long = ((FILE_DEVICE_NETWORK * &H10000) Or (FILE_ANY_ACCESS * &H4000) Or (METHOD_BUFFERED))

Public Sub SetInternetAccess(enable As Boolean)
    Dim hDevice As Long
    Dim bytesReturned As Long
    Dim ret As Long
    Dim inputBuffer(0 To 1) As Byte
    
    inputBuffer(0) = IIf(enable, 1, 0)
    
    hDevice = CreateFile("\\.\NetworkDevice", &H80000000, 0, ByVal 0&, 3, 0, 0)
    
    If hDevice <> -1 Then
        ret = DeviceIoControl(hDevice, IOCTL_NETWORK_BLOCKINTERNET, inputBuffer(0), 1, ByVal 0&, 0, bytesReturned, ByVal 0&)
        CloseHandle hDevice
    End If
End Sub

Where did you find your sample code?

[yereverluvinuncleber]

If you have a look on t'net for VBscript examples of enabling/disabling wifi/LAN/firewall ports then you are likely to find more such examples that may also be implementable in VB6.

[fafalone]

Where did you find your sample code?

Seems like a classic hallucination from AI. That's the kind of code you get when you ask it for something there's not dozens of examples of in its training data... It just makes up fake calls. DeviceIoControl is a real API but there's no NetworkDevice root object or ioctl code like that.

[LorinM]

Any sample starter code please ?
This is all new territory for me.

[nebeln]

Seems like a classic hallucination from AI. That's the kind of code you get when you ask it for something there's not dozens of examples of in its training data... It just makes up fake calls. DeviceIoControl is a real API but there's no NetworkDevice root object or ioctl code like that.

YES!! I do fully agree. The AI's are scams if you not are awake

[wqweto]

Check this out

Option Explicit

Private m_bEnabled As Boolean

Private Sub Form_Click()
    LanEnabled m_bEnabled
    m_bEnabled = Not m_bEnabled
End Sub

Private Sub LanEnabled(ByVal bValue As Boolean)
    Const NETWORK_CONNECTIONS As Long = &H31
    Dim oNic As Object
    Dim oVerb As Object
    
    For Each oNic In CreateObject("Shell.Application").Namespace(NETWORK_CONNECTIONS).Items
        For Each oVerb In oNic.Verbs
            Print oNic.Name & " - " & oVerb.Name
            Select Case Replace(oVerb.Name, "&", vbNullString)
            Case "Disable"
                If Not bValue Then
                    oVerb.DoIt
                    Print "DoIt"
                End If
            Case "Enable"
                If bValue Then
                    oVerb.DoIt
                    Print "DoIt"
                End If
            End Select
        Next
    Next
End Sub

Might need some tweaking as after disabling all NICs it seems Network Connections folder is not refreshed so Enable verb is not immediately available.

cheers,
</wqw>

[fafalone]

Won't that disable the local resources on that adapter too? OP wants to block only internet, not LAN, presumably they're on the same adapter.

[wqweto]

I thought this is a laptop connected to WiFi only.

Well, then OP could try to clear default gateway but not sure how to restore it. Also if DHCP is involved thigs get murky.

Windows firewall used to be unable to block outbound traffic. Not sure about latest versions though.

[yereverluvinuncleber]

I'm not sure I know what internet access actually means for this user. A definition of the actual requirement would be a good thing - if I was the PM for this mini-proj.
Otherwise, it feels as if we are tilting at windmills.

[fafalone]

I thought this is a laptop connected to WiFi only.

Well, then OP could try to clear default gateway but not sure how to restore it. Also if DHCP is involved thigs get murky.

Windows firewall used to be unable to block outbound traffic. Not sure about latest versions though.

A typical home setup a wifi connected laptop still accesses local resources; like mine can access my desktop and NAS through the router they're all connected to.

Pretty sure the firewall rules with those interfaces will still work; if not there's the newer low level firewall APIs... Windows Filtering Platform (Vista+). FwpmFilterAdd0 etc... you can use that to selectively block anything with a non-local remote address; or the low level old traffic control API... I've done the declares for WinDevLib but no VBx/tB exaples yet.

[Elroy]

I'm surprised nobody has mentioned:

• C:\Windows\System32\drivers\etc\hosts

If you just want to block certain sites, just drop their URL (or partial URL) into that file, and they'll be blocked.

---

In fact, I'm wondering if you can just place an entire protocol, such as HTTPS://, in there, and block the entire protocol. I've never tried that, but it'd certainly be worth a try if that's what you're trying to do.

Also, done that way, it wouldn't block LAN traffic.

[Darkbob]

Sort of reminds me of the good old days... when somebody joined a game and we wanted to get rid of them we would say "Use the Cheat Code! Press ALT-F4"

[nebeln]

I got the solution for this question.
I needed some Wi-Fi functionality to project and was testing some different APIs and stucked to wlanapi.h and there I had my stuff.
And also I saw this question as a cool question which correspond to my project

So what you need to do is following:
1. Get a handle to the Wi-Fi
2. Enum your Wi-Fi for interface guids and available networks, profiles etc etc
3. Disconnect <--- SOLVES YOUR QUESTION
4. Reconnect <--- SOLVES YOUR QUESTION
5. Close handle when finished

I list the needed APIs below

Public Const WLAN_MAX_NAME_LENGTH As Long = 32
Public Const WLAN_MAX_PHY_TYPE_NUMBER As Long = 8
Public Const DOT11_SSID_MAX_LENGTH As Long = 32

Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(8) As Byte
End Type

Public Const ERROR_SUCCESS = 0&

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, Length As Long, ByVal iFill As Integer)

Public Declare Function StringFromIID Lib "ole32.dll" (pguid As Any, ByRef pszIID As Any) As Long

Public Declare Function WlanOpenHandle Lib "Wlanapi.dll" (ByVal dwClientVersion As Long, ByVal pReserved As Long, ByRef pdwNegotiatedVersion As Long, ByRef phClientHandle As Long) As Long
'DWORD WlanOpenHandle(
'  [in]  DWORD   dwClientVersion,
'        PVOID   pReserved,
'  [out] PDWORD  pdwNegotiatedVersion,
'  [out] PHANDLE phClientHandle
');

Public Type DOT11_MAC_ADDRESS
         PDOT11_MAC_ADDRESS(0 To 5) As Byte
End Type

Public Type NDIS_OBJECT_HEADER
    uType As Long
    uRevision As Long
    uSize As Long
End Type

Public Type DOT11_BSSID_LIST
     Header As Long
     uNumOfEntries As Long
     uTotalNumOfEntries As Long
     BSSIDs(0) As DOT11_MAC_ADDRESS
End Type

Public Type WLAN_CONNECTION_PARAMETERS
   wlanConnectionMode As Long
   strProfile As Long
   pDot11Ssid As Long
   pDesiredBssidList As Long
   dot11BssType As Long
End Type

Public Declare Function WlanConnect Lib "Wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As Any, ByVal ppConnectionParameters As Any, ByVal pReserved As Long) As Long
'DWORD WlanConnect(
'  [in] HANDLE                            hClientHandle,
'  [in] const GUID                        *pInterfaceGuid,
'  [in] const PWLAN_CONNECTION_PARAMETERS pConnectionParameters,
'       PVOID pReserved
');
Public Declare Function WlanDisconnect Lib "Wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As Any, ByVal pReserved As Long) As Long
'DWORD WlanDisconnect(
'  [in] HANDLE     hClientHandle,
'  [in] const GUID *pInterfaceGuid,
'       PVOID pReserved
');
Public Declare Function WlanCloseHandle Lib "Wlanapi.dll" (ByVal hClientHandle As Long, ByVal pReserved As Long) As Long
'DWORD WlanCloseHandle(
'  [in] HANDLE hClientHandle,
'       PVOID pReserved
');

Public Type WLAN_AVAILABLE_NETWORK
   strProfileName(32) As Integer
   dot11Ssid As Long '?
   dot11BssType As Long '?
   uNumberOfBssids As Integer
   bNetworkConnectable As Boolean
   wlanNotConnectableReason As Long '?
   uNumberOfPhyTypes As Long
   dot11PhyTypes(WLAN_MAX_PHY_TYPE_NUMBER) As Long
   bMorePhyTypes As Boolean
   wlanSignalQuality As Long '?
   bSecurityEnabled As Boolean
   dot11DefaultAuthAlgorithm As Long '?
   dot11DefaultCipherAlgorithm As Long '?
   dwFlags As Long
   dwReserved As Long
End Type

Public Type WLAN_AVAILABLE_NETWORK_LIST
      dwNumberOfItems As Long
      dwIndex As Long
      Network(9) As WLAN_AVAILABLE_NETWORK
End Type

Public Declare Function WlanGetAvailableNetworkList Lib "Wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As GUID, ByVal dwFlags As Long, ByVal pReserved As Long, ByRef ppAvailableNetworkList As Any) As Long
'DWORD WlanGetAvailableNetworkList(
'  [in]  HANDLE                       hClientHandle,
'  [in]  const GUID                   *pInterfaceGuid,
'  [in]  DWORD                        dwFlags,
'        PVOID                        pReserved,
'  [out] PWLAN_AVAILABLE_NETWORK_LIST * ppAvailableNetworkList
');

'typedef enum _WLAN_INTERFACE_STATE {
'  wlan_interface_state_not_ready,
'  wlan_interface_state_connected,
'  wlan_interface_state_ad_hoc_network_formed,
'  wlan_interface_state_disconnecting,
'  wlan_interface_state_disconnected,
'  wlan_interface_state_associating,
'  wlan_interface_state_discovering,
'  wlan_interface_state_authenticating
'} WLAN_INTERFACE_STATE, *PWLAN_INTERFACE_STATE;

Public Type WLAN_INTERFACE_INFO
   InterfaceGuid As GUID
   strInterfaceDescription(WLAN_MAX_NAME_LENGTH) As Long
   isState As Long
End Type

Public Type WLAN_INTERFACE_INFO_LIST
   dwNumberOfItems As Long
   dwIndex As Long
   InterfaceInfo(9) As WLAN_INTERFACE_INFO
End Type

Public Declare Function WlanEnumInterfaces Lib "Wlanapi.dll" (ByVal hClientHandle As Long, ByVal pReserved As Long, ByRef ppInterfaceList As Any) As Long
'DWORD WlanEnumInterfaces(
'  [in]  HANDLE                    hClientHandle,
'  [in]  PVOID                     pReserved,
'  [out] PWLAN_INTERFACE_INFO_LIST * ppInterfaceList
');

'void WlanFreeMemory(
'  [in] PVOID pMemory
');

'DWORD WlanScan(
'  [in]           HANDLE               hClientHandle,
'  [in]           const GUID           *pInterfaceGuid,
'  [in, optional] const PDOT11_SSID    pDot11Ssid,
'  [in, optional] const PWLAN_RAW_DATA pIeData,
'                 PVOID pReserved
');
Public Type DOT11_SSID
      uSSIDLength As Long
      ucSSID(DOT11_SSID_MAX_LENGTH) As Long
End Type

Public Declare Function WlanScan Lib "Wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As GUID, ByVal pDot11Ssid As Long, ByVal pIeDat As Long, ByVal pReserved As Long) As Long

Public Declare Sub WlanFreeMemory Lib "Wlanapi.dll" (ByVal pMemory As Long)

'DWORD WlanGetProfileList(
'  [in]  HANDLE                  hClientHandle,
'  [in]  const GUID              *pInterfaceGuid,
'  [in]  PVOID                   pReserved,
'  [out] PWLAN_PROFILE_INFO_LIST * ppProfileList
');
Public Declare Function WlanGetProfileList Lib "Wlanapi.dll" (ByVal hClientHandle As Long, pInterfaceGuid As GUID, ByVal pReserved As Long, ByRef ppProfileList As Any) As Long

Public Type WLAN_PROFILE_INFO
  strProfileName(WLAN_MAX_NAME_LENGTH) As Integer
  wFlags As Long
End Type

Public Type WLAN_PROFILE_INFO_LIST
   dwNumberOfItems As Long
   dwIndex As Long
   ProfileInfo(9) As WLAN_PROFILE_INFO
End Type

'DWORD WlanHostedNetworkStopUsing(
'  [in]            HANDLE                      hClientHandle,
'  [out, optional] PWLAN_HOSTED_NETWORK_REASON pFailReason,
'                  PVOID pvReserved
');
Public Declare Function WlanHostedNetworkStartUsing Lib "Wlanapi.dll" (ByVal hClientHandle As Long, ByVal pFailReason As Long, ByVal pReserved As Long) As Long

Public Declare Function WlanHostedNetworkStopUsing Lib "Wlanapi.dll" (ByVal hClientHandle As Long, ByVal pFailReason As Long, ByVal pReserved As Long) As Long

Public Declare Function WlanHostedNetworkForceStop Lib "Wlanapi.dll" (ByVal hClientHandle As Long, ByVal pFailReason As Long, ByVal pReserved As Long) As Long

There are some question marks after some parameters in one type which shall be corrected but it works for now.

[fafalone]

I'm surprised nobody has mentioned:

• C:\Windows\System32\drivers\etc\hosts

If you just want to block certain sites, just drop their URL (or partial URL) into that file, and they'll be blocked.

---

In fact, I'm wondering if you can just place an entire protocol, such as HTTPS://, in there, and block the entire protocol. I've never tried that, but it'd certainly be worth a try if that's what you're trying to do.

Also, done that way, it wouldn't block LAN traffic.

Ever since Microsoft decided they'd bypass hosts for their own use I don't trust it.

[OptionBase1]

I'm surprised nobody has mentioned:

• C:\Windows\System32\drivers\etc\hosts

If you just want to block certain sites, just drop their URL (or partial URL) into that file, and they'll be blocked.

---

In fact, I'm wondering if you can just place an entire protocol, such as HTTPS://, in there, and block the entire protocol. I've never tried that, but it'd certainly be worth a try if that's what you're trying to do.

Also, done that way, it wouldn't block LAN traffic.

No one has mentioned it because the OP didn't say they wanted to block only certain websites.

The rest of your post isn't at all how the hosts file works.

[wqweto]

Windows Filtering Platform (Vista+). FwpmFilterAdd0 etc... you can use that to selectively block anything with a non-local remote address

Yes, this approach works and here is a working sample:

'--- Module1.bas
Option Explicit

Private Enum LongPtr
    [_]
End Enum

Private Const FWPM_LAYER_ALE_AUTH_CONNECT_V4    As String = "{c38d57d1-05a7-4c33-904f-7fbceee60e82}"
Private Const FWPM_CONDITION_IP_LOCAL_ADDRESS   As String = "{d9ee00de-c1ef-4617-bfe3-ffd8f5a08957}"
Private Const FWPM_CONDITION_IP_REMOTE_ADDRESS  As String = "{b235ae9a-1d64-49b8-a44c-5ff3d9095045}"
Private Const ERROR_SUCCESS                     As Long = 0
Private Const RPC_C_AUTHN_DEFAULT               As Long = -1

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pCLSID As Any) As Long
' fwpuclnt
Private Declare Function FwpmEngineOpen Lib "fwpuclnt" Alias "FwpmEngineOpen0" (ByVal serverName As LongPtr, ByVal authnService As Long, ByVal authIdentity As LongPtr, ByVal session As LongPtr, engineHandle As LongPtr) As Long
Private Declare Function FwpmEngineClose Lib "fwpuclnt" Alias "FwpmEngineClose0" (ByVal engineHandle As LongPtr) As Long
Private Declare Function FwpmFilterAdd Lib "fwpuclnt" Alias "FwpmFilterAdd0" (ByVal engineHandle As LongPtr, filter As FWPM_FILTER, ByVal sd As LongPtr, id As Currency) As Long
Private Declare Function FwpmFilterDeleteByKey Lib "fwpuclnt" Alias "FwpmFilterDeleteByKey0" (ByVal engineHandle As LongPtr, filterKey As GUID) As Long
Private Declare Function FwpmFilterCreateEnumHandle Lib "fwpuclnt" Alias "FwpmFilterCreateEnumHandle0" (ByVal engineHandle As LongPtr, ByVal enumTemplate As LongPtr, enumHandle As LongPtr) As Long
Private Declare Function FwpmFilterEnum Lib "fwpuclnt" Alias "FwpmFilterEnum0" (ByVal engineHandle As LongPtr, ByVal enumHandle As LongPtr, ByVal numEntriesRequested As Long, entries As LongPtr, numEntriesReturned As Long) As Long
Private Declare Function FwpmFilterDestroyEnumHandle Lib "fwpuclnt" Alias "FwpmFilterDestroyEnumHandle0" (ByVal engineHandle As LongPtr, ByVal enumHandle As LongPtr) As Long
Private Declare Sub FwpmFreeMemory Lib "fwpuclnt" Alias "FwpmFreeMemory0" (ByRef pPtr As LongPtr)

Private Enum FWPM_ACTION_TYPE
    FWP_ACTION_BLOCK = 4097
    FWP_ACTION_PERMIT = 4098
    ' Other action types can be added as needed
End Enum

Private Enum FWPM_CONDITION_MATCH
    FWP_MATCH_EQUAL = 0
    FWP_MATCH_NOT_EQUAL = 10
    ' Other match types can be added as needed
End Enum

Private Enum FWP_VALUE_TYPE
    FWP_EMPTY = 0
    FWP_V4_ADDR_MASK = 256
    ' Other value types can be added as needed
End Enum

Private Type GUID
    Data1               As Long
    Data2               As Integer
    Data3               As Integer
    Data4(0 To 7)       As Byte
End Type

Private Type FWPM_DISPLAY_DATA
    name                As LongPtr
    description         As LongPtr
End Type

Private Type FWP_V4_ADDR_AND_MASK
    addr                As Long
    mask                As Long
End Type

Private Type FWP_CONDITION_VALUE
    valueType           As Long
    v4AddrMask          As LongPtr
End Type

Private Type FWPM_FILTER_CONDITION
    fieldKey            As GUID
    matchType           As Long
    conditionValue      As FWP_CONDITION_VALUE
End Type

Private Type FWP_BYTE_BLOB
    size                As Long
    data                As LongPtr
End Type

Private Type FWPM_ACTION
    type                As Long
    calloutKey          As GUID
End Type

Private Type FWP_VALUE
    valueType           As Long
    uint32              As Long  ' Union
End Type

Private Type FWPM_FILTER
    filterKey           As GUID
    displayData         As FWPM_DISPLAY_DATA
    flags               As Long
    providerKey         As LongPtr
    providerData        As FWP_BYTE_BLOB
    layerKey            As GUID
    subLayerKey         As GUID
    weight              As FWP_VALUE
    numFilterConditions As Long
    filterCondition     As LongPtr
    action              As FWPM_ACTION
    providerContextKey  As GUID
    reserved            As LongPtr
    filterId            As Currency
    effectiveWeight     As FWP_VALUE
End Type

Private Const STR_BLOCK_FILTER As String = "Block non-LAN traffic"

Public Property Get NonLocalTrafficEnabled() As Boolean
    Dim engineHandle    As LongPtr
    Dim filterKey       As GUID
    Dim result          As Long
    Dim sApiName        As String
    Dim vErr            As Variant
    
    result = FwpmEngineOpen(0, RPC_C_AUTHN_DEFAULT, 0, 0, engineHandle)
    If result <> ERROR_SUCCESS Then
        sApiName = "FwpmEngineOpen"
        GoTo QH
    End If
    NonLocalTrafficEnabled = Not FindFilterByName(engineHandle, STR_BLOCK_FILTER, filterKey)
QH:
    If engineHandle <> 0 Then
        Call FwpmEngineClose(engineHandle)
    End If
    If LenB(sApiName) <> 0 Then
        Err.Raise vbObjectError, "NonLocalTrafficEnabled [get]", sApiName & " failed: &H" & Hex$(result)
    End If
    If IsArray(vErr) Then
        Err.Raise vErr(0), vErr(1), vErr(2)
    End If
    Exit Property
EH:
    vErr = Array(Err.Number, Err.Source, Err.description)
    Resume QH
End Property

Public Property Let NonLocalTrafficEnabled(ByVal bValue As Boolean)
    Dim engineHandle    As LongPtr
    Dim filterKey       As GUID
    Dim result          As Long
    Dim sApiName        As String
    Dim vErr            As Variant
    
    On Error GoTo EH
    result = FwpmEngineOpen(0, RPC_C_AUTHN_DEFAULT, 0, 0, engineHandle)
    If result <> ERROR_SUCCESS Then
        sApiName = "FwpmEngineOpen"
        GoTo QH
    End If
    If Not bValue Then
        AddBlockNonLANTrafficFilter engineHandle, STR_BLOCK_FILTER
    Else
        Do While FindFilterByName(engineHandle, STR_BLOCK_FILTER, filterKey)
            result = FwpmFilterDeleteByKey(engineHandle, filterKey)
            If result <> ERROR_SUCCESS Then
                sApiName = "FwpmFilterDeleteByKey"
                GoTo QH
            End If
        Loop
    End If
QH:
    If engineHandle <> 0 Then
        Call FwpmEngineClose(engineHandle)
    End If
    If LenB(sApiName) <> 0 Then
        Err.Raise vbObjectError, "NonLocalTrafficEnabled [let]", sApiName & " failed: &H" & Hex$(result)
    End If
    If IsArray(vErr) Then
        Err.Raise vErr(0), vErr(1), vErr(2)
    End If
    Exit Property
EH:
    vErr = Array(Err.Number, Err.Source, Err.description)
    Resume QH
End Property

Private Function FindFilterByName(ByVal engineHandle As LongPtr, filterName As String, filterKey As GUID) As Boolean
    Dim enumHandle      As LongPtr
    Dim filters         As LongPtr
    Dim numFilters      As Long
    Dim lIdx            As Integer
    Dim lPtr            As LongPtr
    Dim filter          As FWPM_FILTER
    Dim result          As Long
    Dim sApiName        As String
    
    result = FwpmFilterCreateEnumHandle(engineHandle, 0, enumHandle)
    If result <> ERROR_SUCCESS Then
        sApiName = "FwpmFilterCreateEnumHandle"
        GoTo QH
    End If
    result = FwpmFilterEnum(engineHandle, enumHandle, -1, filters, numFilters)
    If result <> ERROR_SUCCESS Then
        sApiName = "FwpmFilterEnum"
        GoTo QH
    End If
    For lIdx = 0 To numFilters - 1
        Call CopyMemory(lPtr, ByVal filters + lIdx * LenB(lPtr), LenB(lPtr))
        Call CopyMemory(filter, ByVal lPtr, LenB(filter))
        If StrComp(pvToString(filter.displayData.name), filterName, vbTextCompare) = 0 Then
            filterKey = filter.filterKey
            FindFilterByName = True
            GoTo QH
        End If
    Next
QH:
    If filters <> 0 Then
        Call FwpmFreeMemory(filters)
    End If
    If enumHandle <> 0 Then
        Call FwpmFilterDestroyEnumHandle(engineHandle, enumHandle)
    End If
    If LenB(sApiName) <> 0 Then
        Err.Raise vbObjectError, "FindFilterByName", sApiName & " failed: &H" & Hex$(result)
    End If
End Function

Private Sub AddBlockNonLANTrafficFilter(ByVal engineHandle As LongPtr, filterName As String)
    Dim lanAddr(0 To 3) As FWP_V4_ADDR_AND_MASK
    Dim lanCond(0 To 3) As FWPM_FILTER_CONDITION
    Dim filter          As FWPM_FILTER
    Dim lIdx            As Long
    Dim result          As Long
    Dim sApiName        As String

    lanAddr(0) = pvToInetAddr("127.0.0.0", 8)           '-- local address
    lanAddr(1) = pvToInetAddr("192.168.0.0", 16)
    lanAddr(2) = pvToInetAddr("10.0.0.0", 8)
    lanAddr(3) = pvToInetAddr("172.16.0.0", 12)
    For lIdx = 0 To UBound(lanCond)
        lanCond(lIdx).fieldKey = pvToGUID(IIf(lIdx = 0, FWPM_CONDITION_IP_LOCAL_ADDRESS, FWPM_CONDITION_IP_REMOTE_ADDRESS))
        lanCond(lIdx).matchType = FWP_MATCH_NOT_EQUAL
        lanCond(lIdx).conditionValue.valueType = FWP_V4_ADDR_MASK
        lanCond(lIdx).conditionValue.v4AddrMask = VarPtr(lanAddr(lIdx))
    Next
    filter.displayData.name = StrPtr(filterName)
    filter.layerKey = pvToGUID(FWPM_LAYER_ALE_AUTH_CONNECT_V4)
    filter.action.type = FWP_ACTION_BLOCK
    filter.filterCondition = VarPtr(lanCond(0))
    filter.numFilterConditions = UBound(lanCond) + 1
    result = FwpmFilterAdd(engineHandle, filter, 0, 0)
    If result <> ERROR_SUCCESS Then
        sApiName = "FwpmFilterAdd"
        GoTo QH
    End If
QH:
    If LenB(sApiName) <> 0 Then
        Err.Raise vbObjectError, "AddBlockNonLANTrafficFilter", sApiName & " failed: &H" & Hex$(result)
    End If
End Sub

Private Function pvToGUID(guidString As String) As GUID
    Call CLSIDFromString(StrPtr(guidString), pvToGUID)
End Function

Private Function pvToInetAddr(ipAddress As String, ByVal prefix As Long) As FWP_V4_ADDR_AND_MASK
    Dim parts()         As String
    
    parts = Split(ipAddress, ".")
    pvToInetAddr.addr = LShift32(parts(0), 24) + LShift32(parts(1), 16) + LShift32(parts(2), 8) + CLng(parts(3))
    pvToInetAddr.mask = LShift32(-1, 32 - prefix)
End Function

Private Function LShift32(ByVal lX As Long, ByVal lN As Long) As Long
    If lN = 0 Then
        LShift32 = lX
    Else
        LShift32 = (lX And (CLng(2 ^ (31 - lN)) - 1)) * CLng(2 ^ lN) Or -((lX And CLng(2 ^ (31 - lN))) <> 0) * &H80000000
    End If
End Function

Private Function pvToString(ByVal lPtr As LongPtr) As String
    If lPtr <> 0 Then
        pvToString = String$(lstrlen(lPtr), 0)
        Call CopyMemory(ByVal StrPtr(pvToString), ByVal lPtr, LenB(pvToString))
    End If
End Function

Simple form to test the module above:

'--- Form1
Option Explicit

Private Sub Form_Load()
    Check1.Caption = "Non-local Traffic Enabled"
    Check1.Value = IIf(NonLocalTrafficEnabled, vbChecked, vbUnchecked)
End Sub

Private Sub Check1_Click()
    NonLocalTrafficEnabled = (Check1.Value = vbChecked)
End Sub

Obviously the code originated in ChatGPT but it just took me all day to fix all the wrong API declares, enums, GUIDs, arithmetic overflows and bonkers pointer dereferences it introduced in the code. Highly not recommended for anything production code.

The sample above blocks even ping to every address outside of 192.168.0.0/16, 10.0.0.0/8 and 172.16.0.0/12 subnets. One can tweak the LAN subnets if using unusual addresses for LAN (which is highly unlikely).

The blocking filter is added as non-persistent so if anything goes wrong machine reboot clears it.

cheers,
</wqw>

[yereverluvinuncleber]

wqweto, you are a gentleman. I looked at that code and decided I didn't want to do that work myself.

[fafalone]

Yes, this approach works and here is a working sample:

'--- Module1.bas
Option Explicit

Private Enum LongPtr
    [_]
End Enum

Private Const FWPM_LAYER_ALE_AUTH_CONNECT_V4    As String = "{c38d57d1-05a7-4c33-904f-7fbceee60e82}" ' "{C38D57D1-05A7-4C33-904F-7F8F2460C068}"
Private Const FWPM_CONDITION_IP_REMOTE_ADDRESS  As String = "{b235ae9a-1d64-49b8-a44c-5ff3d9095045}" ' "{C491AD5E-F882-4283-B916-436B2A57AAB4}"
Private Const ERROR_SUCCESS                     As Long = 0
Private Const RPC_C_AUTHN_DEFAULT               As Long = -1

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pCLSID As Any) As Long
' fwpuclnt
Private Declare Function FwpmEngineOpen Lib "fwpuclnt" Alias "FwpmEngineOpen0" (ByVal serverName As LongPtr, ByVal authnService As Long, ByVal authIdentity As LongPtr, ByVal session As LongPtr, engineHandle As LongPtr) As Long
Private Declare Function FwpmEngineClose Lib "fwpuclnt" Alias "FwpmEngineClose0" (ByVal engineHandle As LongPtr) As Long
Private Declare Function FwpmFilterAdd Lib "fwpuclnt" Alias "FwpmFilterAdd0" (ByVal engineHandle As LongPtr, filter As FWPM_FILTER, ByVal sd As LongPtr, id As Currency) As Long
Private Declare Function FwpmFilterDeleteByKey Lib "fwpuclnt" Alias "FwpmFilterDeleteByKey0" (ByVal engineHandle As LongPtr, filterKey As GUID) As Long
Private Declare Function FwpmFilterCreateEnumHandle Lib "fwpuclnt" Alias "FwpmFilterCreateEnumHandle0" (ByVal engineHandle As LongPtr, ByVal enumTemplate As LongPtr, enumHandle As LongPtr) As Long
Private Declare Function FwpmFilterEnum Lib "fwpuclnt" Alias "FwpmFilterEnum0" (ByVal engineHandle As LongPtr, ByVal enumHandle As LongPtr, ByVal numEntriesRequested As Long, entries As LongPtr, numEntriesReturned As Long) As Long
Private Declare Function FwpmFilterDestroyEnumHandle Lib "fwpuclnt" Alias "FwpmFilterDestroyEnumHandle0" (ByVal engineHandle As LongPtr, ByVal enumHandle As LongPtr) As Long
Private Declare Sub FwpmFreeMemory Lib "fwpuclnt" Alias "FwpmFreeMemory0" (ByRef pPtr As LongPtr)

Private Enum FWPM_ACTION_TYPE
    FWP_ACTION_BLOCK = 4097
    FWP_ACTION_PERMIT = 4098
    ' Other action types can be added as needed
End Enum

Private Enum FWPM_CONDITION_MATCH
    FWP_MATCH_EQUAL = 0
    FWP_MATCH_NOT_EQUAL = 10
    ' Other match types can be added as needed
End Enum

Private Enum FWP_VALUE_TYPE
    FWP_EMPTY = 0
    FWP_V4_ADDR_MASK = 256
    ' Other value types can be added as needed
End Enum

Private Type GUID
    Data1               As Long
    Data2               As Integer
    Data3               As Integer
    Data4(0 To 7)       As Byte
End Type

Private Type FWPM_DISPLAY_DATA
    name                As LongPtr
    description         As LongPtr
End Type

Private Type FWP_V4_ADDR_AND_MASK
    addr                As Long
    mask                As Long
End Type

Private Type FWP_CONDITION_VALUE
    valueType           As Long
    v4AddrMask          As LongPtr
End Type

Private Type FWPM_FILTER_CONDITION
    fieldKey            As GUID
    matchType           As Long
    conditionValue      As FWP_CONDITION_VALUE
End Type

Private Type FWP_BYTE_BLOB
    size                As Long
    data                As LongPtr
End Type

Private Type FWPM_ACTION
    type                As Long
    calloutKey          As GUID
End Type

Private Type FWP_VALUE
    valueType           As Long
    uint32              As Long  ' Union
End Type

Private Type FWPM_FILTER
    filterKey           As GUID
    displayData         As FWPM_DISPLAY_DATA
    flags               As Long
    providerKey         As LongPtr
    providerData        As FWP_BYTE_BLOB
    layerKey            As GUID
    subLayerKey         As GUID
    weight              As FWP_VALUE
    numFilterConditions As Long
    filterCondition     As LongPtr
    action              As FWPM_ACTION
    providerContextKey  As GUID
    reserved            As LongPtr
    filterId            As Currency
    effectiveWeight     As FWP_VALUE
End Type

Private Const STR_BLOCK_FILTER As String = "Block non-LAN traffic"

' Function to configure non-local traffic
Public Sub ConfigureNonLocalTraffic(ByVal enable As Boolean)
    Dim engineHandle    As LongPtr
    Dim result          As Long

    result = FwpmEngineOpen(0, RPC_C_AUTHN_DEFAULT, 0, 0, engineHandle)
    If result <> ERROR_SUCCESS Then
        Err.Raise vbObjectError, , "FwpmEngineOpen failed: &H" & Hex$(result)
        Exit Sub
    End If
    If enable Then
        DeleteFilterByName engineHandle, STR_BLOCK_FILTER
    Else
        AddBlockNonLANTrafficFilter engineHandle, STR_BLOCK_FILTER
    End If
    Call FwpmEngineClose(engineHandle)
End Sub

' Function to add a filter to block non-LAN traffic
Private Sub AddBlockNonLANTrafficFilter(ByVal engineHandle As LongPtr, filterName As String)
    Dim lanAddr(0 To 2) As FWP_V4_ADDR_AND_MASK
    Dim lanCond(0 To 2) As FWPM_FILTER_CONDITION
    Dim filter          As FWPM_FILTER
    Dim lIdx            As Long
    Dim result          As Long
    Dim sApiName        As String

    ' Initialize LAN addresses and masks
    lanAddr(0) = pvToInetAddr("192.168.0.0", 16)
    lanAddr(1) = pvToInetAddr("10.0.0.0", 8)
    lanAddr(2) = pvToInetAddr("172.16.0.0", 12)
    
    ' Initialize the filter conditions
    For lIdx = 0 To UBound(lanCond)
        lanCond(lIdx).fieldKey = pvToGUID(FWPM_CONDITION_IP_REMOTE_ADDRESS)
        lanCond(lIdx).matchType = FWP_MATCH_NOT_EQUAL
        lanCond(lIdx).conditionValue.valueType = FWP_V4_ADDR_MASK
        lanCond(lIdx).conditionValue.v4AddrMask = VarPtr(lanAddr(lIdx))
    Next

    ' Initialize the filter
    filter.displayData.name = StrPtr(filterName)
    filter.layerKey = pvToGUID(FWPM_LAYER_ALE_AUTH_CONNECT_V4)
    filter.action.type = FWP_ACTION_BLOCK
    filter.filterCondition = VarPtr(lanCond(0))
    filter.numFilterConditions = UBound(lanCond) + 1
    
    result = FwpmFilterAdd(engineHandle, filter, 0, 0)
    If result <> ERROR_SUCCESS Then
        sApiName = "FwpmFilterAdd"
        GoTo QH
    End If
QH:
    If LenB(sApiName) <> 0 Then
        Err.Raise vbObjectError, , sApiName & " failed: &H" & Hex$(result)
    End If
End Sub

' Function to delete a filter by its name
Private Sub DeleteFilterByName(ByVal engineHandle As LongPtr, filterName As String)
    Dim enumHandle      As LongPtr
    Dim filters         As LongPtr
    Dim numFilters      As Long
    Dim lIdx            As Integer
    Dim lPtr            As LongPtr
    Dim filter          As FWPM_FILTER
    Dim result          As Long
    Dim sApiName        As String
    
    result = FwpmFilterCreateEnumHandle(engineHandle, 0, enumHandle)
    If result <> ERROR_SUCCESS Then
        sApiName = "FwpmFilterCreateEnumHandle"
        GoTo QH
    End If
    result = FwpmFilterEnum(engineHandle, enumHandle, -1, filters, numFilters)
    If result <> ERROR_SUCCESS Then
        sApiName = "FwpmFilterEnum"
        GoTo QH
    End If
    For lIdx = 0 To numFilters - 1
        Call CopyMemory(lPtr, ByVal filters + lIdx * LenB(lPtr), LenB(lPtr))
        Call CopyMemory(filter, ByVal lPtr, LenB(filter))
        If StrComp(pvToString(filter.displayData.name), filterName, vbTextCompare) = 0 Then
            result = FwpmFilterDeleteByKey(engineHandle, filter.filterKey)
            If result <> ERROR_SUCCESS Then
                sApiName = "FwpmFilterDeleteByKey"
                GoTo QH
            End If
        End If
    Next
QH:
    If filters <> 0 Then
        Call FwpmFreeMemory(filters)
    End If
    If enumHandle <> 0 Then
        Call FwpmFilterDestroyEnumHandle(engineHandle, enumHandle)
    End If
    If LenB(sApiName) <> 0 Then
        Err.Raise vbObjectError, , sApiName & " failed: &H" & Hex$(result)
    End If
End Sub

' Convert a string representation of a GUID to a GUID UDT
Private Function pvToGUID(guidString As String) As GUID
    Call CLSIDFromString(StrPtr(guidString), pvToGUID)
End Function

' Function to convert IP address string to long
Private Function pvToInetAddr(ipAddress As String, ByVal prefix As Long) As FWP_V4_ADDR_AND_MASK
    Dim parts()         As String
    
    parts = Split(ipAddress, ".")
    pvToInetAddr.addr = LShift32(parts(0), 24) + LShift32(parts(1), 16) + LShift32(parts(2), 8) + CLng(parts(3))
    pvToInetAddr.mask = LShift32(-1, 32 - prefix)
End Function

Private Function LShift32(ByVal lX As Long, ByVal lN As Long) As Long
    If lN = 0 Then
        LShift32 = lX
    Else
        LShift32 = (lX And (LNG_POW2(31 - lN) - 1)) * LNG_POW2(lN) Or -((lX And LNG_POW2(31 - lN)) <> 0) * &H80000000
    End If
End Function

Private Function LNG_POW2(ByVal lN As Long) As Long
    LNG_POW2 = 2 ^ lN
End Function

Private Function pvToString(ByVal lPtr As LongPtr) As String
    If lPtr <> 0 Then
        pvToString = String$(lstrlen(lPtr), 0)
        Call CopyMemory(ByVal StrPtr(pvToString), ByVal lPtr, LenB(pvToString))
    End If
End Function

Simple form to test the module above:

'--- Form1
Option Explicit

Private m_bEnabled As Boolean

Private Sub Form_Click()
    On Error GoTo EH
    m_bEnabled = Not m_bEnabled
    ConfigureNonLocalTraffic m_bEnabled
    Print "Non-LAN traffic " & IIf(m_bEnabled, "enabled", "disabled")
    Exit Sub
EH:
    MsgBox Err.description, vbCritical
End Sub

Obviously the code originated in ChatGPT but it just took me all day to fix all the wrong API declares, enums, GUIDs, arithmetic overflows and bonkers pointer dereferences it introduced in the code. Highly not recommended for anything production code.

The sample above blocks even ping to every address outside of 192.168.0.0/16, 10.0.0.0/8 and 172.16.0.0/12 subnets. One can tweak the LAN subnets if using unusual addresses for LAN (which is highly unlikely).

The blocking filter is added as non-persistent so if anything goes wrong machine reboot clears it.

cheers,
</wqw>

guarantee my api declares, enums, and guids had fewer errors than ChatGPT's... and that removing the tB-only syntax would have been faster than fixing those... was kinda hoping to help people avoid spending so much time re-doing all the APIs themselves every time

https://github.com/fafalone/WinDevLi.../wdAPIWFP.twin

pps -- I caught one error in mine (now fixed) thanks to comparing to yours, but believe you missed one; did you test 64bit?

Private Type FWP_VALUE
    valueType           As Long
    uint32              As Long  ' Union
End Type

The union should be LongPtr.

[fafalone]

Yes, this approach works and here is a working sample:

'--- Module1.bas
Option Explicit

Private Enum LongPtr
    [_]
End Enum

Private Const FWPM_LAYER_ALE_AUTH_CONNECT_V4    As String = "{c38d57d1-05a7-4c33-904f-7fbceee60e82}" ' "{C38D57D1-05A7-4C33-904F-7F8F2460C068}"
Private Const FWPM_CONDITION_IP_REMOTE_ADDRESS  As String = "{b235ae9a-1d64-49b8-a44c-5ff3d9095045}" ' "{C491AD5E-F882-4283-B916-436B2A57AAB4}"
Private Const ERROR_SUCCESS                     As Long = 0
Private Const RPC_C_AUTHN_DEFAULT               As Long = -1

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pCLSID As Any) As Long
' fwpuclnt
Private Declare Function FwpmEngineOpen Lib "fwpuclnt" Alias "FwpmEngineOpen0" (ByVal serverName As LongPtr, ByVal authnService As Long, ByVal authIdentity As LongPtr, ByVal session As LongPtr, engineHandle As LongPtr) As Long
Private Declare Function FwpmEngineClose Lib "fwpuclnt" Alias "FwpmEngineClose0" (ByVal engineHandle As LongPtr) As Long
Private Declare Function FwpmFilterAdd Lib "fwpuclnt" Alias "FwpmFilterAdd0" (ByVal engineHandle As LongPtr, filter As FWPM_FILTER, ByVal sd As LongPtr, id As Currency) As Long
Private Declare Function FwpmFilterDeleteByKey Lib "fwpuclnt" Alias "FwpmFilterDeleteByKey0" (ByVal engineHandle As LongPtr, filterKey As GUID) As Long
Private Declare Function FwpmFilterCreateEnumHandle Lib "fwpuclnt" Alias "FwpmFilterCreateEnumHandle0" (ByVal engineHandle As LongPtr, ByVal enumTemplate As LongPtr, enumHandle As LongPtr) As Long
Private Declare Function FwpmFilterEnum Lib "fwpuclnt" Alias "FwpmFilterEnum0" (ByVal engineHandle As LongPtr, ByVal enumHandle As LongPtr, ByVal numEntriesRequested As Long, entries As LongPtr, numEntriesReturned As Long) As Long
Private Declare Function FwpmFilterDestroyEnumHandle Lib "fwpuclnt" Alias "FwpmFilterDestroyEnumHandle0" (ByVal engineHandle As LongPtr, ByVal enumHandle As LongPtr) As Long
Private Declare Sub FwpmFreeMemory Lib "fwpuclnt" Alias "FwpmFreeMemory0" (ByRef pPtr As LongPtr)

Private Enum FWPM_ACTION_TYPE
    FWP_ACTION_BLOCK = 4097
    FWP_ACTION_PERMIT = 4098
    ' Other action types can be added as needed
End Enum

Private Enum FWPM_CONDITION_MATCH
    FWP_MATCH_EQUAL = 0
    FWP_MATCH_NOT_EQUAL = 10
    ' Other match types can be added as needed
End Enum

Private Enum FWP_VALUE_TYPE
    FWP_EMPTY = 0
    FWP_V4_ADDR_MASK = 256
    ' Other value types can be added as needed
End Enum

Private Type GUID
    Data1               As Long
    Data2               As Integer
    Data3               As Integer
    Data4(0 To 7)       As Byte
End Type

Private Type FWPM_DISPLAY_DATA
    name                As LongPtr
    description         As LongPtr
End Type

Private Type FWP_V4_ADDR_AND_MASK
    addr                As Long
    mask                As Long
End Type

Private Type FWP_CONDITION_VALUE
    valueType           As Long
    v4AddrMask          As LongPtr
End Type

Private Type FWPM_FILTER_CONDITION
    fieldKey            As GUID
    matchType           As Long
    conditionValue      As FWP_CONDITION_VALUE
End Type

Private Type FWP_BYTE_BLOB
    size                As Long
    data                As LongPtr
End Type

Private Type FWPM_ACTION
    type                As Long
    calloutKey          As GUID
End Type

Private Type FWP_VALUE
    valueType           As Long
    uint32              As Long  ' Union
End Type

Private Type FWPM_FILTER
    filterKey           As GUID
    displayData         As FWPM_DISPLAY_DATA
    flags               As Long
    providerKey         As LongPtr
    providerData        As FWP_BYTE_BLOB
    layerKey            As GUID
    subLayerKey         As GUID
    weight              As FWP_VALUE
    numFilterConditions As Long
    filterCondition     As LongPtr
    action              As FWPM_ACTION
    providerContextKey  As GUID
    reserved            As LongPtr
    filterId            As Currency
    effectiveWeight     As FWP_VALUE
End Type

Private Const STR_BLOCK_FILTER As String = "Block non-LAN traffic"

' Function to configure non-local traffic
Public Sub ConfigureNonLocalTraffic(ByVal enable As Boolean)
    Dim engineHandle    As LongPtr
    Dim result          As Long

    result = FwpmEngineOpen(0, RPC_C_AUTHN_DEFAULT, 0, 0, engineHandle)
    If result <> ERROR_SUCCESS Then
        Err.Raise vbObjectError, , "FwpmEngineOpen failed: &H" & Hex$(result)
        Exit Sub
    End If
    If enable Then
        DeleteFilterByName engineHandle, STR_BLOCK_FILTER
    Else
        AddBlockNonLANTrafficFilter engineHandle, STR_BLOCK_FILTER
    End If
    Call FwpmEngineClose(engineHandle)
End Sub

' Function to add a filter to block non-LAN traffic
Private Sub AddBlockNonLANTrafficFilter(ByVal engineHandle As LongPtr, filterName As String)
    Dim lanAddr(0 To 2) As FWP_V4_ADDR_AND_MASK
    Dim lanCond(0 To 2) As FWPM_FILTER_CONDITION
    Dim filter          As FWPM_FILTER
    Dim lIdx            As Long
    Dim result          As Long
    Dim sApiName        As String

    ' Initialize LAN addresses and masks
    lanAddr(0) = pvToInetAddr("192.168.0.0", 16)
    lanAddr(1) = pvToInetAddr("10.0.0.0", 8)
    lanAddr(2) = pvToInetAddr("172.16.0.0", 12)
    
    ' Initialize the filter conditions
    For lIdx = 0 To UBound(lanCond)
        lanCond(lIdx).fieldKey = pvToGUID(FWPM_CONDITION_IP_REMOTE_ADDRESS)
        lanCond(lIdx).matchType = FWP_MATCH_NOT_EQUAL
        lanCond(lIdx).conditionValue.valueType = FWP_V4_ADDR_MASK
        lanCond(lIdx).conditionValue.v4AddrMask = VarPtr(lanAddr(lIdx))
    Next

    ' Initialize the filter
    filter.displayData.name = StrPtr(filterName)
    filter.layerKey = pvToGUID(FWPM_LAYER_ALE_AUTH_CONNECT_V4)
    filter.action.type = FWP_ACTION_BLOCK
    filter.filterCondition = VarPtr(lanCond(0))
    filter.numFilterConditions = UBound(lanCond) + 1
    
    result = FwpmFilterAdd(engineHandle, filter, 0, 0)
    If result <> ERROR_SUCCESS Then
        sApiName = "FwpmFilterAdd"
        GoTo QH
    End If
QH:
    If LenB(sApiName) <> 0 Then
        Err.Raise vbObjectError, , sApiName & " failed: &H" & Hex$(result)
    End If
End Sub

' Function to delete a filter by its name
Private Sub DeleteFilterByName(ByVal engineHandle As LongPtr, filterName As String)
    Dim enumHandle      As LongPtr
    Dim filters         As LongPtr
    Dim numFilters      As Long
    Dim lIdx            As Integer
    Dim lPtr            As LongPtr
    Dim filter          As FWPM_FILTER
    Dim result          As Long
    Dim sApiName        As String
    
    result = FwpmFilterCreateEnumHandle(engineHandle, 0, enumHandle)
    If result <> ERROR_SUCCESS Then
        sApiName = "FwpmFilterCreateEnumHandle"
        GoTo QH
    End If
    result = FwpmFilterEnum(engineHandle, enumHandle, -1, filters, numFilters)
    If result <> ERROR_SUCCESS Then
        sApiName = "FwpmFilterEnum"
        GoTo QH
    End If
    For lIdx = 0 To numFilters - 1
        Call CopyMemory(lPtr, ByVal filters + lIdx * LenB(lPtr), LenB(lPtr))
        Call CopyMemory(filter, ByVal lPtr, LenB(filter))
        If StrComp(pvToString(filter.displayData.name), filterName, vbTextCompare) = 0 Then
            result = FwpmFilterDeleteByKey(engineHandle, filter.filterKey)
            If result <> ERROR_SUCCESS Then
                sApiName = "FwpmFilterDeleteByKey"
                GoTo QH
            End If
        End If
    Next
QH:
    If filters <> 0 Then
        Call FwpmFreeMemory(filters)
    End If
    If enumHandle <> 0 Then
        Call FwpmFilterDestroyEnumHandle(engineHandle, enumHandle)
    End If
    If LenB(sApiName) <> 0 Then
        Err.Raise vbObjectError, , sApiName & " failed: &H" & Hex$(result)
    End If
End Sub

' Convert a string representation of a GUID to a GUID UDT
Private Function pvToGUID(guidString As String) As GUID
    Call CLSIDFromString(StrPtr(guidString), pvToGUID)
End Function

' Function to convert IP address string to long
Private Function pvToInetAddr(ipAddress As String, ByVal prefix As Long) As FWP_V4_ADDR_AND_MASK
    Dim parts()         As String
    
    parts = Split(ipAddress, ".")
    pvToInetAddr.addr = LShift32(parts(0), 24) + LShift32(parts(1), 16) + LShift32(parts(2), 8) + CLng(parts(3))
    pvToInetAddr.mask = LShift32(-1, 32 - prefix)
End Function

Private Function LShift32(ByVal lX As Long, ByVal lN As Long) As Long
    If lN = 0 Then
        LShift32 = lX
    Else
        LShift32 = (lX And (LNG_POW2(31 - lN) - 1)) * LNG_POW2(lN) Or -((lX And LNG_POW2(31 - lN)) <> 0) * &H80000000
    End If
End Function

Private Function LNG_POW2(ByVal lN As Long) As Long
    LNG_POW2 = 2 ^ lN
End Function

Private Function pvToString(ByVal lPtr As LongPtr) As String
    If lPtr <> 0 Then
        pvToString = String$(lstrlen(lPtr), 0)
        Call CopyMemory(ByVal StrPtr(pvToString), ByVal lPtr, LenB(pvToString))
    End If
End Function

Simple form to test the module above:

'--- Form1
Option Explicit

Private m_bEnabled As Boolean

Private Sub Form_Click()
    On Error GoTo EH
    m_bEnabled = Not m_bEnabled
    ConfigureNonLocalTraffic m_bEnabled
    Print "Non-LAN traffic " & IIf(m_bEnabled, "enabled", "disabled")
    Exit Sub
EH:
    MsgBox Err.description, vbCritical
End Sub

Obviously the code originated in ChatGPT but it just took me all day to fix all the wrong API declares, enums, GUIDs, arithmetic overflows and bonkers pointer dereferences it introduced in the code. Highly not recommended for anything production code.

The sample above blocks even ping to every address outside of 192.168.0.0/16, 10.0.0.0/8 and 172.16.0.0/12 subnets. One can tweak the LAN subnets if using unusual addresses for LAN (which is highly unlikely).

The blocking filter is added as non-persistent so if anything goes wrong machine reboot clears it.

cheers,
</wqw>

twinBASIC has only local host connections and that filter nukes every instance from orbit, even after adding 127.0.0.0/8

[yereverluvinuncleber]

Can we gather that Wqweto is not yet digging into TB?

re: Windevlib - When I start to get my own code in a good shape I will try your Windevlib Faf. I am just not yet ready as for me, everything is step by step, test the water, take a step back and then stride forward in the new direction.

[wqweto]

> The union should be LongPtr.

Yes, I didn't test in TB

> Can we gather that Wqweto is not yet digging into TB?

No, I'm just solving the issue at hand, namely the VB6 solution needed all API declares included.

> twinBASIC has only local host connections and that filter nukes every instance from orbit, even after adding 127.0.0.0/8

Ouch!

cheers,
</wqw>

[fafalone]

Turns out it's the filter itself... Running the code from vb6 still destroys every tB instance... So somehow it's impacting local machine to local machine connections.. but I can't figure out how since it's not killing similar local machine to local machine connections held by other processes.

[wqweto]

Probably 127.0.0.0/8 should be added with FWPM_CONDITION_IP_LOCAL_ADDRESS again with FWP_MATCH_NOT_EQUAL i.e. not filtered on remote address.

cheers,
</wqw>

[fafalone]

Probably 127.0.0.0/8 should be added with FWPM_CONDITION_IP_LOCAL_ADDRESS again with FWP_MATCH_NOT_EQUAL i.e. not filtered on remote address.

cheers,
</wqw>

That fixed it, thanks

    lanAddr(0) = pvToInetAddr("192.168.0.0", 16)
    lanAddr(1) = pvToInetAddr("10.0.0.0", 8)
    lanAddr(2) = pvToInetAddr("172.16.0.0", 12)
    lanAddr(3) = pvToInetAddr("127.0.0.0", 8)
    ' Initialize the filter conditions
    For lIdx = 0 To UBound(lanCond)
        If lIdx = 3 Then
        lanCond(lIdx).fieldKey = pvToGUID(FWPM_CONDITION_IP_LOCAL_ADDRESS)
        Else
        lanCond(lIdx).fieldKey = pvToGUID(FWPM_CONDITION_IP_REMOTE_ADDRESS)
        End If
        lanCond(lIdx).matchType = FWP_MATCH_NOT_EQUAL
        lanCond(lIdx).conditionValue.valueType = FWP_V4_ADDR_MASK
        lanCond(lIdx).conditionValue.v4AddrMask = VarPtr(lanAddr(lIdx))
    Next

[LorinM]

Thanks all !
This is a home network with one router + modem. (Currently connected to Spectrum)
Yes, all internet needs to be blocked and all LAN needs to be available.
This Internet blocking is on a per PC blocking.
I do have several PC and NAS on the LAN and several Switches to interconnect devices.
Some connections are WiFi and some are by pure Cat 5 to the router directly or through Switches.

I am knowledge poor on routers so I do not dare mess with the router directly other than to set the SSID and password.

[OptionBase1]

Take a device in question and manually remove the default gateway from the TCP/IP configuration. Then test out trying to access LAN resources and internet resources. If that provides the functionality that you are looking for, then you just need to find a way to make that change via VB6, and a way to restore what was there in the first place.

Note that I am using this method in my VM's to prevent them from accessing the internet and it works fine, but I am using all static IP's, no DHCP. I can't speak to how this would work if you are using DHCP, which you almost certainly are. I suppose it might be possible that making manual changes to the default gateway might only be temporary, and that the DHCP functionality will put the old Default Gateway IP back periodically. No idea, and I'm not motivated to make the necessary changes on my end to test that theory out.

Good luck.

[wqweto]

Thanks all !
This is a home network with one router + modem. (Currently connected to Spectrum)
Yes, all internet needs to be blocked and all LAN needs to be available.
This Internet blocking is on a per PC blocking.
I do have several PC and NAS on the LAN and several Switches to interconnect devices.
Some connections are WiFi and some are by pure Cat 5 to the router directly or through Switches.

I am knowledge poor on routers so I do not dare mess with the router directly other than to set the SSID and password.

There is already fixed code in post #20 which implements all your requirements: VB6 code, turns on/off internet access, maintains LAN access

Here is the whole project zipped to test it: BlockNonLanTraffic.zip

cheers,
</wqw>