2013年06月03日 VB ファイアウォール アプリケーション例外対策 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 String, ByVal 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 String, ByVal 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 String, ByVal 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