VB ファイアウォール アプリケーション例外対策

作成したアプリケーションがファイアウォールの例外に引っかかり、
起動できない場合に以下を利用します。

Comコンポーネントを使い、ファイアウォールのルールを変更します。


''' <summary>
''' COMに関する共通クラスです。
''' </summary>
''' <remarks></remarks>
Friend Class ComCommon
‌ 
#Region "Windowsファイアウォールの例外削除 アプリケーション"
‌ 
    ''' <summary>
    ''' XPのWindowsファイアウォールの例外削除を行います。
    ''' </summary>
    ''' <param name="exePath">実行ファイルパス</param>
    ''' <remarks></remarks>
    Public Shared Sub UnRegistFireWallForXP(ByVal exePath As String)
        Dim fwMgr As Object = CreateObject("HNetCfg.FwMgr")
        fwMgr.LocalPolicy.CurrentProfile.AuthorizedApplications.Remove(exePath)
    End Sub
‌ 
    ''' <summary>
    ''' Server2003のWindowsファイアウォールの例外削除を行います。
    ''' </summary>
    ''' <param name="exePath">実行ファイルパス</param>
    ''' <remarks></remarks>
    Public Shared Sub UnRegistFireWallForServer2003(ByVal exePath As String)
        Dim fwMgr As Object = CreateObject("HNetCfg.FwMgr")
        fwMgr.LocalPolicy.GetProfileByType(NET_FW_PROFILE_STANDARD).AuthorizedApplications.Remove(exePath)
    End Sub
‌ 
    ''' <summary>
    ''' 2008Server以降のWindowsファイアウォールの例外削除を行います。
    ''' </summary>
    ''' <param name="exePath">実行ファイルパス</param>
    ''' <remarks></remarks>
    Public Shared Sub UnRegistFireWallForAfterServer2008(ByVal exePath As String)
        Dim fwPolicy2 As Object = CreateObject("HNetCfg.FwPolicy2")
        fwPolicy2.Rules.Remove(exePath)
    End Sub
‌ 
#End Region
‌ 
#Region "Windowsファイアウォールの例外登録 アプリケーション"
‌ 
    ''' <summary>
    ''' XPのWindowsファイアウォールの例外にアプリケーションを登録します。
    ''' </summary>
    ''' <param name="serviceName">サービス名</param>
    ''' <param name="exePath">実行ファイルパス</param>
    ''' <remarks></remarks>
    Public Shared Sub RegistFireWallForXP(ByVal serviceName As StringByVal exePath As String)
‌ 
        Dim fwMgr As Object = CreateObject("HNetCfg.FwMgr")
        Dim policy As Object = fwMgr.LocalPolicy.CurrentProfile
‌ 
        Dim newApplication As Object = CreateObject("HNetCfg.FwAuthorizedApplication")
        newApplication.Name = serviceName
        newApplication.IPVersion = 2
        newApplication.ProcessImageFileName = exePath
        newApplication.RemoteAddresses = "*"
        newApplication.Scope = 0
        newApplication.Enabled = True
‌ 
        Dim applicationList As Object = policy.AuthorizedApplications
        applicationList.Add(newApplication)
‌ 
    End Sub
‌ 
    Private Const NET_FW_PROFILE_DOMAIN = 0
    Private Const NET_FW_PROFILE_STANDARD = 1
‌ 
    ''' <summary>
    ''' Server2003のWindowsファイアウォールの例外にアプリケーションを登録します。
    ''' </summary>
    ''' <param name="serviceName">サービス名</param>
    ''' <param name="exePath">実行ファイルパス</param>
    ''' <remarks></remarks>
    Public Shared Sub RegistFireWallForServer2003(ByVal serviceName As StringByVal exePath As String)
‌ 
        Dim fwMgr As Object = CreateObject("HNetCfg.FwMgr")
        Dim policy As Object = fwMgr.LocalPolicy.GetProfileByType(NET_FW_PROFILE_STANDARD)
‌ 
        Dim newApplication As Object = CreateObject("HNetCfg.FwAuthorizedApplication")
        newApplication.Name = serviceName
        newApplication.IPVersion = 2
        newApplication.ProcessImageFileName = exePath
        newApplication.RemoteAddresses = "*"
        newApplication.Scope = 0
        newApplication.Enabled = True
‌ 
        Dim applicationList As Object = policy.AuthorizedApplications
        applicationList.Add(newApplication)
‌ 
    End Sub
‌ 
    ' Protocol
    Private Const NET_FW_IP_PROTOCOL_TCP = 6
    Private Const NET_FW_IP_PROTOCOL_UDP = 17
    Private Const NET_FW_ACTION_ALLOW = 1
‌ 
‌ 
    ''' <summary>
    ''' 2008Server以降のWindowsファイアウォールの例外にアプリケーションを登録します。
    ''' </summary>
    ''' <param name="serviceName">サービス名</param>
    ''' <param name="exePath">実行ファイルパス</param>
    ''' <remarks></remarks>
    Public Shared Sub RegistFireWallForAfterServer2008(ByVal serviceName As StringByVal exePath As String)
‌ 
        Dim fwPolicy2 As Object = CreateObject("HNetCfg.FwPolicy2")
‌ 
        Dim NewRule As Object = CreateObject("HNetCfg.FWRule")
‌ 
        NewRule.Name = serviceName
        NewRule.Description = "Allow incoming network traffic to myservice"
        NewRule.Applicationname = exePath
        NewRule.Servicename = "myservicename"
        NewRule.Protocol = NET_FW_IP_PROTOCOL_TCP
        NewRule.LocalPorts = 135
        NewRule.Grouping = "@firewallapi.dll,-23255"
        NewRule.Profiles = fwPolicy2.CurrentProfileTypes
        NewRule.Enabled = True
        NewRule.Action = NET_FW_ACTION_ALLOW
‌ 
        'Add a new rule
        Dim RulesObject As Object = fwPolicy2.Rules
        RulesObject.Add(NewRule)
‌ 
‌ 
    End Sub
‌ 
#End Region
‌ 
End Class