' This script will NOT make changes to Windows Firewall with Advanced Security (WFAS)

' DISCLAIMER:  This script is intended for reference only.  Just because this worked
'   for me, you must assume that this script will probably turn your computer into a
'   puddle of molten silicon, or render your system inoperable requiring a full re-install.
'   I can not be held liable for damage done to your system by using any of this script.
' REMINDER: Before making any changes to your WFAS rules with this script, Export your
'   default WFAS settings ("Restore Default Policy" will not be the same).

' PURPOSE:  enumerates Windows Firewall with Advanced Security rules using the Microsoft
    Windows Firewall APIs.  Tweaked for redirection to a tab-delimited text file
' REFERENCE: http://msdn.microsoft.com/en-us/library/aa364724(VS.85).aspx
' DEVELOPED BY: Jay Ohman, Ohman Automation Corp - www.OhmanCorp.com
' -------------------------------------------------------------------------------------------------

Option Explicit

Dim CurrentProfiles
Dim InterfaceArray
Dim LowerBound
Dim UpperBound
Dim iterate
Dim Rule
Dim strOut, strDelim

' Profile Type
Const NET_FW_PROFILE2_DOMAIN = 1
Const NET_FW_PROFILE2_PRIVATE = 2
Const NET_FW_PROFILE2_PUBLIC = 4
Const NET_FW_PROFILE2_ALL = 2147483647

' Protocol
Const NET_FW_IP_PROTOCOL_TCP = 6
Const NET_FW_IP_PROTOCOL_UDP = 17
Const NET_FW_IP_PROTOCOL_ICMPv4 = 1
Const NET_FW_IP_PROTOCOL_ICMPv6 = 58

' Direction
Const NET_FW_RULE_DIR_IN = 1
Const NET_FW_RULE_DIR_OUT = 2

' Action
Const NET_FW_ACTION_BLOCK = 0
Const NET_FW_ACTION_ALLOW = 1


' Create the FwPolicy2 object.
Dim fwPolicy2
Set fwPolicy2 = CreateObject("HNetCfg.FwPolicy2")

CurrentProfiles = fwPolicy2.CurrentProfileTypes

'// The returned 'CurrentProfiles' bitmask can have more than 1 bit set if multiple profiles
'//   are active or current at the same time

strOut = ""
strDelim = ""
strOut = "CurrentProfiles: (" & CurrentProfiles & "): "
If ( CurrentProfiles And NET_FW_PROFILE2_DOMAIN ) Then
  strOut = strOut & "Domain(" & fwPolicy2.FirewallEnabled(NET_FW_PROFILE2_DOMAIN) & ")"
  strDelim = ","
End If
If ( CurrentProfiles And NET_FW_PROFILE2_PRIVATE ) Then
  strOut = strOut & strDelim & "Private(" & fwPolicy2.FirewallEnabled(NET_FW_PROFILE2_PRIVATE) & ")"
  strDelim = ","
End If
If ( CurrentProfiles And NET_FW_PROFILE2_PUBLIC ) Then
  strOut = strOut & strDelim & "Public(" & fwPolicy2.FirewallEnabled(NET_FW_PROFILE2_PUBLIC) & ")"
End If
WScript.Echo strOut

' Get the Rules object
Dim RulesObject
Set RulesObject = fwPolicy2.Rules

' Print all the rules in currently active firewall profiles.

' header line is tab-delimited
WScript.Echo "Direction	Name	Group	Profile	Enabled	Action	Program	Protocol	IcmpTypesAndCodes" & _
             "	Local Address	Remote Address	Local Port	Remote Port	Description	Edge Traversal" & _
             "	Interface Type	Service	Interfaces"

For Each Rule In Rulesobject
  strOut = ""
  Select Case Rule.Direction
    Case NET_FW_RULE_DIR_IN  strOut = strOut & "In" & vbTab
    Case NET_FW_RULE_DIR_OUT strOut = strOut & "Out" & vbTab
  End Select
  strOut = strOut & Rule.Name & vbTab
  strOut = strOut & Rule.Grouping & vbTab
  strOut = strOut & Rule.Profiles & "-"
  If ( Rule.Profiles = "" ) Then
    strOut = strOut & vbTab
  Else
    If ( Rule.Profiles = NET_FW_PROFILE2_ALL ) Then
      strOut = strOut & "All" & vbTab
    Else
      strDelim = ""
      If ( Rule.Profiles And NET_FW_PROFILE2_DOMAIN ) Then strOut = strOut & "Domain" : strDelim = ","
      If ( Rule.Profiles And NET_FW_PROFILE2_PRIVATE ) Then strOut = strOut & strDelim & "Private" : strDelim = ","
      If ( Rule.Profiles And NET_FW_PROFILE2_PUBLIC ) Then  strOut = strOut & strDelim & "Public"
      strOut = strOut & vbTab
    End If
  End If
  strOut = strOut & Rule.Enabled & vbTab
  Select Case Rule.Action
    Case NET_FW_ACTION_ALLOW  strOut = strOut & "Allow" & vbTab
    Case NET_FW_ACTION_BLOCk  strOut = strOut & "Block" & vbTab
  End Select
  strOut = strOut & Rule.ApplicationName & vbTab
  Select Case Rule.Protocol
    Case NET_FW_IP_PROTOCOL_TCP    strOut = strOut & "TCP" & vbTab
    Case NET_FW_IP_PROTOCOL_UDP    strOut = strOut & "UDP" & vbTab
    Case NET_FW_IP_PROTOCOL_ICMPv4 strOut = strOut & "ICMPv4" & vbTab
    Case NET_FW_IP_PROTOCOL_ICMPv6 strOut = strOut & "ICMPv6" & vbTab
    Case Else                      strOut = strOut & Rule.Protocol & vbTab
  End Select
  If (Rule.Protocol = NET_FW_IP_PROTOCOL_ICMPv4) Or (Rule.Protocol = NET_FW_IP_PROTOCOL_ICMPv6) Then
    strOut = strOut & Rule.IcmpTypesAndCodes & vbTab
  Else
    strOut = strOut & vbTab
  End If
  If (Rule.Protocol = NET_FW_IP_PROTOCOL_TCP) Or (Rule.Protocol = NET_FW_IP_PROTOCOL_UDP) Then
    strOut = strOut & Rule.LocalAddresses & vbTab
    strOut = strOut & Rule.RemoteAddresses & vbTab
    strOut = strOut & Rule.LocalPorts & vbTab
    strOut = strOut & Rule.RemotePorts & vbTab
  Else
    strOut = strOut & vbTab & vbTab & vbTab & vbTab
  End If
  strOut = strOut & Rule.Description & vbTab
  strOut = strOut & Rule.EdgeTraversal & vbTab
  strOut = strOut & Rule.InterfaceTypes & vbTab
  strOut = strOut & Rule.ServiceName & vbTab
  InterfaceArray = Rule.Interfaces
  If IsEmpty(InterfaceArray) Then
    strOut = strOut & "All"
  Else
    LowerBound = LBound(InterfaceArray)
    UpperBound = UBound(InterfaceArray)
    strDelim = ""
    For iterate = LowerBound To UpperBound
      strOut = strOut & strDelim & InterfaceArray(iterate)
      strDelim = ","
    Next
  End If
  WScript.Echo strOut
Next