frmmain.frm

专业版本的vb防火墙管理程序

    Label11.Caption = "发送: " & GiveByteValues(Trim(Format(m_objIpHelper.BytesSent, "###,###,###,###")))
Else
    Label10.Caption = "接收: " & Trim(Format(m_objIpHelper.BytesReceived, "###,###,###,###"))
    Label11.Caption = "发送: " & Trim(Format(m_objIpHelper.BytesSent, "###,###,###,###"))
End If
  '
    blnIsRecv = (m_objIpHelper.BytesReceived > lngBytesRecv)
    blnIsSent = (m_objIpHelper.BytesSent > lngBytesSent)
    '
    If blnIsRecv And blnIsSent Then
        ConStatus1.SetStatus 0
    ElseIf (Not blnIsRecv) And blnIsSent Then
        ConStatus1.SetStatus 3
    ElseIf blnIsRecv And (Not blnIsSent) Then
        ConStatus1.SetStatus 2
    ElseIf Not (blnIsRecv And blnIsSent) Then
        ConStatus1.SetStatus 1
    End If
    '
    lngBytesRecv = m_objIpHelper.BytesReceived
    lngBytesSent = m_objIpHelper.BytesSent
    '

    Set st_objInterface = objInterface

End Sub

Private Sub Timer2_Timer()
Call UpdateInterfaceInfo
End Sub

Private Function GetFileNameFromPath(ByVal sFullPath As String) As String
   Dim WFD As WIN32_FIND_DATA
   Dim hFile As Long
         If sFullPath = "" Then
         GetFileNameFromPath = "未知"
         Exit Function
         End If
   hFile = FindFirstFile(sFullPath, WFD)
   If hFile <> INVALID_HANDLE_VALUE Then
      GetFileNameFromPath = TrimNull(WFD.cFileName)
      Call FindClose(hFile)
   End If
End Function


Private Function TrimNull(startstr As String) As String
   Dim pos As Integer
   pos = InStr(startstr, Chr$(0))
   If pos Then
      TrimNull = Left$(startstr, pos - 1)
      Exit Function
   End If
   TrimNull = startstr
End Function

Public Function PingIP(IP As String)
Dim ECHO As ICMP_ECHO_REPLY
   Dim pos As Long
   Dim success As Long
   Dim sIPAddress As String
   If SocketsInitialize() Then
      sIPAddress = IP
      success = Ping(sIPAddress, "Echo This", ECHO)
      If GetStatusCode(success) = "ip success" Then PingIP = "Success - Round Time : " & ECHO.RoundTripTime & " ms" Else PingIP = GetStatusCode(success)
     
      If Left$(ECHO.Data, 1) <> Chr$(0) Then
         pos = InStr(ECHO.Data, Chr$(0))
         'Left$(ECHO.Data, pos - 1)
      End If
      SocketsCleanup
   Else
        MsgBox "Windows Sockets for 32 bit Windows " & _
               "is not successfully responding.", vbInformation, "Error"
   End If
End Function

Private Function GetFileInformation(FP As FILE_PARAMS) As Long

   Dim WFD As WIN32_FIND_DATA
   Dim hFile As Long
   Dim nSize As Long
   Dim sPath As String
   Dim sRoot As String
   Dim sTmp As String
   Dim itmx As ListItem
   Dim lv As Control

   sPath = FP.sFileNameExt
   hFile = FindFirstFile(sPath, WFD)
   If hFile <> INVALID_HANDLE_VALUE Then
         sTmp = TrimNull(WFD.cFileName)
         If Not (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
            = FILE_ATTRIBUTE_DIRECTORY Then
            nSize = nSize + (WFD.nFileSizeHigh * (MAXDWORD + 1)) + WFD.nFileSizeLow
               'Set itmx = lv.ListItems.Add(, , LCase$(sTmp))
               Label7(8).Caption = "版本: " & GetFileVersion(sRoot & sTmp)
               Label7(2).Caption = "大小: " & GetFileSizeStr(WFD.nFileSizeHigh + WFD.nFileSizeLow)
               'itmx.SubItems(2) = GetFileDescription(sRoot & sTmp)
               'itmx.SubItems(4) = LCase$(sRoot)
                'If GetFileDescription(sPath) = "" Then Lblinfo.Caption = "Description : (No Description) " Else Lblinfo.Caption = "Description : " & GetFileDescription(sPath)
                'If GetFileVersion(sPath) = "" Then LblVersion.Caption = "Version : (No Version) " Else LblVersion.Caption = "Version : " & GetFileVersion(sPath)
                'LblSize.Caption = "Size : " & GetFileSizeStr(WFD.nFileSizeHigh + WFD.nFileSizeLow)
         End If
      hFile = FindClose(hFile)
   End If
   GetFileInformation = nSize
End Function


Private Function GetFileSizeStr(fsize As Long) As String
    GetFileSizeStr = GiveByteValues(Format$((fsize), "###,###,###"))  '& " kb"
End Function

Public Function GetTempDir() As String
   Dim tmp As String
   tmp = Space$(256)
   Call GetTempPath(Len(tmp), tmp)
   GetTempDir = TrimNull(tmp)
End Function

Public Function BasePath(ByVal fname As String, Optional delim As String = "\", Optional keeplast As Boolean = True) As String
    Dim outstr As String
    Dim llen As Long
    llen = InStrRev(fname, delim)
    If (Not keeplast) Then
        llen = llen - 1
    End If
    If (llen > 0) Then
        BasePath = Mid(fname, 1, llen)
    Else
        BasePath = fname
    End If
End Function


Private Sub Timer4_Timer()
If Pub_BlockAll = True Then
Status1.SetStatus 1
Label6.Caption = "过滤程序: 开启"
Else
Status1.SetStatus 0
Label6.Caption = "过滤程序: 关闭"
End If

If Firewall_Enabled = True Then
Status2.SetStatus 1
Label15.Caption = "防火墙允许"
Else
Status2.SetStatus 0
Label15.Caption = "防火墙禁止"
End If
End Sub

Private Sub UserControl11_Clicked(State As Integer)
UserControl12.Reset
UserControl42.Reset
UserControl42.Visible = False
Select Case State
Case 0
UserControl41.Visible = False
UserControl12.Top = UserControl11.Top + UserControl11.Height + 5
Case 1
UserControl41.Left = UserControl11.Left
UserControl41.Top = UserControl11.Top + UserControl11.Height
UserControl41.Width = UserControl11.Width
UserControl41.ShowMe
UserControl41.Visible = True
UserControl12.Top = UserControl41.Top + UserControl41.Height + 5
End Select
End Sub

Private Sub UserControl12_Clicked(State As Integer)
UserControl11.Reset
UserControl41.Reset
UserControl41.Visible = False
UserControl12.Top = UserControl11.Top + UserControl11.Height + 5
Select Case State
Case 0
UserControl42.Visible = False
Case 1
UserControl42.Left = UserControl12.Left
UserControl42.Top = UserControl12.Top + UserControl12.Height
UserControl42.Width = UserControl12.Width
UserControl42.ShowMe
UserControl42.Visible = True
End Select
End Sub

Private Sub UserControl41_ButtonClick(Index As Integer)
Select Case Index
Case 1
    HideFrames
    UserControl21(0).Visible = True
    'UserControl21(0).Gradient &H52F18A
Case 2
    HideFrames
    UserControl21(1).Visible = True
    UserControl21(1).Gradient &H8080FF
Case 3
    HideFrames
    UpdatePrograms
    UserControl21(2).Visible = True
    UserControl21(2).Gradient &H80FFFF
End Select
End Sub

Private Sub UserControl42_ButtonClick(Index As Integer)
Select Case Index
Case 1
UserControl21(0).Gradient &HFF8080
Case 2
UserControl21(1).Gradient &H80C0FF
Case 3
UserControl21(2).Gradient &HFF80FF
End Select
End Sub

Private Sub UserControl61_ButtonClick(Index As Integer)
Select Case Index
Case 1
    If Pub_BlockAll = False Then
    Pub_BlockAll = True
    Else
    Pub_BlockAll = False
    End If
    RefreshList
Case 2
Case 3
End Select
End Sub

Function HideFrames()
Dim x
For x = 0 To UserControl21.Count - 1
UserControl42.ZOrder 0
UserControl41.ZOrder 0
UserControl21(x).Visible = False
UserControl21(x).Top = UserControl21(0).Top
UserControl21(x).Left = UserControl21(0).Left
UserControl21(x).Width = UserControl21(0).Width
UserControl21(x).Height = UserControl21(0).Height
Next
End Function

Private Sub UserControl72_Clicked()
TerminateThisConnection ListView1.SelectedItem.Tag
End Sub

Function UpdatePrograms()
ListView2.ListItems.Clear
    Dim Item As ListItem
    Dim x, z, y(4) As String
    x = GetSetting(App.Title & "Firewall", "Programs", "ProgramCount", 0)
    For z = 0 To x
        y(0) = GetSetting(App.Title & "Firewall", "Programs", "Name" & z, "[Name Not Found]")
        y(1) = GetSetting(App.Title & "Firewall", "Programs", "Path" & z, "c:\Program Files\Internet Explorer\iexplore.exe")
        y(2) = GetSetting(App.Title & "Firewall", "Programs", "Status" & z, "0")
        y(3) = GetSetting(App.Title & "Firewall", "Programs", "Attempts" & z, "0")
        y(4) = GetSetting(App.Title & "Firewall", "Programs", "Blocks" & z, "0")
        
        ListView2.ListItems.Add , , y(0)
        ListView2.ListItems(ListView2.ListItems.Count).ListSubItems.Add , , y(1)
        
        With Program(z)
        .FileName = y(0)
        .FilePath = y(1)
            If Int(y(2)) = 0 Then
            .Block = True
            ListView2.ListItems(ListView2.ListItems.Count).ListSubItems.Add , , "Block"
            Else
            .Block = False
            ListView2.ListItems(ListView2.ListItems.Count).ListSubItems.Add , , "Allow"
            End If
            .Attempts = y(3)
        .Blocked = y(4)
        .Count = x
        End With
        ListView2.ListItems(ListView2.ListItems.Count).Tag = z
        'ListView2.ListItems(ListView2.ListItems.Count).ListSubItems.Add , , y(3)
        'ListView2.ListItems(ListView2.ListItems.Count).ListSubItems.Add , , y(4)
    Next
End Function

Function CheckPrograms(ProgramPath As String, Index As Integer) As Boolean
Dim x
CheckPrograms = False
For x = 0 To Program(0).Count
    If UCase(Program(x).FilePath) = UCase(ProgramPath) Then
        Program(x).Attempts = Program(x).Attempts + 1
        SaveSetting App.Title & "Firewall", "Programs", "Attempts" & x, Program(x).Attempts
            If Program(x).Block = True Then
                Program(x).Blocked = Program(x).Blocked + 1
                SaveSetting App.Title & "Firewall", "Programs", "Blocks" & x, Program(x).Blocked
                If Firewall_Enabled = True Then CheckPrograms = True
            End If
        Exit Function
    End If
Next
If InStr(1, CurrentProcessing, Chr(1) & ProgramPath & Chr(1)) Then Exit Function
    SuspendThreads (Connection(Index).ProcessID)
    CurrentProcessing = CurrentProcessing & Chr(1) & ProgramPath & Chr(1)
    Set xfrmAttempt = New frmAttempt
    xfrmAttempt.ShowInfo ProgramPath, Index
End Function

Function CheckProgramID(ProgramPath) As Integer
Dim x
CheckProgramID = -1
For x = 1 To Program(0).Count
    If UCase(Program(x).FilePath) = UCase(ProgramPath) Then
        CheckProgramID = x
        Exit Function
    End If
Next
End Function

Function AddProgram(ProgramPath As String, Block As Integer)
    Dim FileNameShort
    FileNameShort = Right(ProgramPath, Len(ProgramPath) - InStrRev(ProgramPath, "\"))
    MsgBox "Are you sure you want to ALLAWAYS ALLOW this " & FileNameShort & " ?", vbYesNo
    Dim Xt
    Xt = GetSetting(App.Title & "Firewall", "Programs", "ProgramCount", 0)
    Xt = Xt + 1
    SaveSetting App.Title & "Firewall", "Programs", "Name" & Xt, UCase(FileNameShort)
    SaveSetting App.Title & "Firewall", "Programs", "Path" & Xt, UCase(ProgramPath)
    SaveSetting App.Title & "Firewall", "Programs", "Status" & Xt, Block
    SaveSetting App.Title & "Firewall", "Programs", "ProgramCount", Xt
End Function

Function DeleteProgram(Index As Integer)
    Dim Xt, Xp
    Xt = GetSetting(App.Title & "Firewall", "Programs", "ProgramCount", 0)
    If Index <> Xt Then
    For Xp = Index To Xt
    DeleteSetting App.Title & "Firewall", "Programs", "Name" & Xp
    DeleteSetting App.Title & "Firewall", "Programs", "Path" & Xp
    DeleteSetting App.Title & "Firewall", "Programs", "Status" & Xp
    If Xp <> Xt Then
    SaveSetting App.Title & "Firewall", "Programs", "Name" & Xp, GetSetting(App.Title & "Firewall", "Programs", "Name" & Xp + 1)
    SaveSetting App.Title & "Firewall", "Programs", "Path" & Xp, GetSetting(App.Title & "Firewall", "Programs", "Path" & Xp + 1)
    SaveSetting App.Title & "Firewall", "Programs", "Status" & Xp, GetSetting(App.Title & "Firewall", "Programs", "Status" & Xp + 1)
    SaveSetting App.Title & "Firewall", "Programs", "Attempts" & Xp, GetSetting(App.Title & "Firewall", "Programs", "Attempts" & Xp + 1, 0)
    SaveSetting App.Title & "Firewall", "Programs", "Blocks" & Xp, GetSetting(App.Title & "Firewall", "Programs", "Blocks" & Xp + 1, 0)
    End If
    Next
    Else
    DeleteSetting App.Title & "Firewall", "Programs", "Name" & Xt
    DeleteSetting App.Title & "Firewall", "Programs", "Path" & Xt
    DeleteSetting App.Title & "Firewall", "Programs", "Status" & Xt
    End If
    Xt = Xt - 1
    SaveSetting App.Title & "Firewall", "Programs", "ProgramCount", Xt
End Function

Private Sub UserControl73_Clicked()
SaveSetting App.Title & "Firewall", "Programs", "Status" & ListView2.SelectedItem.Index - 1, 1
UpdatePrograms
UserControl21(2).Visible = True
End Sub

Private Sub UserControl74_Clicked()
SaveSetting App.Title & "Firewall", "Programs", "Status" & ListView2.SelectedItem.Index - 1, 0
UpdatePrograms
UserControl21(2).Visible = True
End Sub

Private Sub UserControl75_Clicked()
DeleteProgram ListView2.SelectedItem.Index - 1
UpdatePrograms
UserControl21(2).Visible = True
End Sub