modmisc.bas

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

Public Sub CloseConnection()
If TerminateThisConnection(FrmMain.ListView1.SelectedItem.Tag) = False Then MsgBox "Unable to close Connection!", vbExclamation + vbOKOnly, "Error"
End Sub

Public Sub CloseProgram()
If KillProcessById(Connection(FrmMain.ListView1.SelectedItem.Tag).ProcessID) = False Then MsgBox "Unable to close Program!", vbExclamation + vbOKOnly, "Error"
End Sub

'************************************************************************************************
Function GiveByteValues(Bytes As Double) As String


    If Bytes < BYTEVALUES.KiloByte Then
        GiveByteValues = Bytes & " Bytes"
    ElseIf Bytes >= BYTEVALUES.GigaByte Then
        GiveByteValues = CutDecimal(Bytes / BYTEVALUES.GigaByte, 2) & " GB" '" Gigabytes"
    ElseIf Bytes >= BYTEVALUES.MegaByte Then
        GiveByteValues = CutDecimal(Bytes / BYTEVALUES.MegaByte, 2) & " MB" '" Megabytes"
    ElseIf Bytes >= BYTEVALUES.KiloByte Then
        GiveByteValues = CutDecimal(Bytes / BYTEVALUES.KiloByte, 2) & " KB" '" Kilobytes"
    End If
End Function

Public Function CutDecimal(Number As String, ByPlace As Byte) As String
    Dim Dec As Byte
    Dec = InStr(1, Number, ".", vbBinaryCompare) ' find the Decimal


    If Dec = 0 Then
        CutDecimal = Number 'if there is no decimal Then dont do anything
        Exit Function
    End If
    CutDecimal = Mid(Number, 1, Dec + ByPlace) 'How many places you want after the decimal point
End Function
'****************************************Net Detect**********************************************

    'Text1 = IsNetConnectViaLAN()
    'Text2 = IsNetConnectViaModem()
    'Text3 = IsNetConnectViaProxy()
    'Text4 = IsNetConnectOnline()
    'Text5 = IsNetRASInstalled()
    'Text6 = GetNetConnectString()





Public Function IsNetConnectViaLAN() As Boolean
    Dim dwFlags As Long
    'pass an empty varialbe into which the A
    '     PI will
    'return the flags associated with the co
    '     nnection
    Call InternetGetConnectedState(dwFlags, 0&)
    'return True if the flags indicate a LAN
    '     connection
    IsNetConnectViaLAN = dwFlags And INTERNET_CONNECTION_LAN
End Function


Public Function IsNetConnectViaModem() As Boolean
    Dim dwFlags As Long
    'pass an empty varialbe into which the A
    '     PI will
    'return the flags associated with the co
    '     nnection
    Call InternetGetConnectedState(dwFlags, 0&)
    'return True if the flags indicate a mod
    '     em connection
    IsNetConnectViaModem = dwFlags And INTERNET_CONNECTION_MODEM
End Function


Public Function IsNetConnectViaProxy() As Boolean
    Dim dwFlags As Long
    'pass an empty varialbe into which the A
    '     PI will
    'return the flags associated with the co
    '     nnection
    Call InternetGetConnectedState(dwFlags, 0&)
    'return True if the flags indicate a pro
    '     xy connection
    IsNetConnectViaProxy = dwFlags And INTERNET_CONNECTION_PROXY
End Function


Public Function IsNetConnectOnline() As Boolean
    'no flags needed here - the API returns
    '     True
    'if there is a connection of any type
    IsNetConnectOnline = InternetGetConnectedState(0&, 0&)
End Function


Public Function IsNetRASInstalled() As Boolean
    Dim dwFlags As Long
    'pass an empty varialbe into which the A
    '     PI will
    'return the flags associated with the co
    '     nnection
    Call InternetGetConnectedState(dwFlags, 0&)
    'return True if the falgs include RAS in
    '     stalled
    IsNetRASInstalled = dwFlags And INTERNET_RAS_INSTALLED
End Function

'************************************************************************************************

Public Function HiWord(dw As Long) As Long
  
   If dw And &H80000000 Then
         HiWord = (dw \ 65535) - 1
   Else: HiWord = dw \ 65535
   End If
    
End Function
  

Public Function LoWord(dw As Long) As Long
  
   If dw And &H8000& Then
         LoWord = &H8000& Or (dw And &H7FFF&)
   Else: LoWord = dw And &HFFFF&
   End If
    
End Function


Public Function GetFileDescription(sSourceFile As String) As String

   Dim FI As VS_FIXEDFILEINFO
   Dim sBuffer() As Byte
   Dim nBufferSize As Long
   Dim lpBuffer As Long
   Dim nVerSize As Long
   Dim nUnused As Long
   Dim tmpVer As String
   Dim sBlock As String
   
   If sSourceFile > "" Then

     'set file that has the encryption level
     'info and call to get required size
      nBufferSize = GetFileVersionInfoSize(sSourceFile, nUnused)
      
      ReDim sBuffer(nBufferSize)
      
      If nBufferSize > 0 Then
      
        'get the version info
         Call GetFileVersionInfo(sSourceFile, 0&, nBufferSize, sBuffer(0))
         Call VerQueryValue(sBuffer(0), "\", lpBuffer, nVerSize)
         Call CopyMemory(FI, ByVal lpBuffer, Len(FI))
   
         If VerQueryValue(sBuffer(0), "\VarFileInfo\Translation", lpBuffer, nVerSize) Then
            
            If nVerSize Then
               tmpVer = GetPointerToString(lpBuffer, nVerSize)
               tmpVer = Right("0" & Hex(Asc(Mid(tmpVer, 2, 1))), 2) & _
                        Right("0" & Hex(Asc(Mid(tmpVer, 1, 1))), 2) & _
                        Right("0" & Hex(Asc(Mid(tmpVer, 4, 1))), 2) & _
                        Right("0" & Hex(Asc(Mid(tmpVer, 3, 1))), 2)
               sBlock = "\StringFileInfo\" & tmpVer & "\FileDescription"
               
              'Get predefined version resources
               If VerQueryValue(sBuffer(0), sBlock, lpBuffer, nVerSize) Then
               
                  If nVerSize Then
                  
                    'get the file description
                     GetFileDescription = GetStrFromPtrA(lpBuffer)

                  End If  'If nVerSize
               End If  'If VerQueryValue
            End If  'If nVerSize
         End If  'If VerQueryValue
      End If  'If nBufferSize
   End If  'If sSourcefile

End Function


Private Function GetStrFromPtrA(ByVal lpszA As Long) As String

   GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
   Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
   
End Function


Private Function GetPointerToString(lpString As Long, nbytes As Long) As String

   Dim Buffer As String
   
   If nbytes Then
      Buffer = Space$(nbytes)
      CopyMemory ByVal Buffer, ByVal lpString, nbytes
      GetPointerToString = Buffer
   End If
   
End Function


Public Function GetFileVersion(sDriverFile As String) As String
   
   Dim FI As VS_FIXEDFILEINFO
   Dim sBuffer() As Byte
   Dim nBufferSize As Long
   Dim lpBuffer As Long
   Dim nVerSize As Long
   Dim nUnused As Long
   Dim tmpVer As String
   
  'GetFileVersionInfoSize determines whether the operating
  'system can obtain version information about a specified
  'file. If version information is available, it returns
  'the size in bytes of that information. As with other
  'file installation functions, GetFileVersionInfoSize
  'works only with Win32 file images.
  '
  'A empty variable must be passed as the second
  'parameter, which the call returns 0 in.
   nBufferSize = GetFileVersionInfoSize(sDriverFile, nUnused)
   
   If nBufferSize > 0 Then
   
     'create a buffer to receive file-version
     '(FI) information.
      ReDim sBuffer(nBufferSize)
      Call GetFileVersionInfo(sDriverFile, 0&, nBufferSize, sBuffer(0))
      
     'VerQueryValue function returns selected version info
     'from the specified version-information resource. Grab
     'the file info and copy it into the  VS_FIXEDFILEINFO structure.
      Call VerQueryValue(sBuffer(0), "\", lpBuffer, nVerSize)
      Call CopyMemory(FI, ByVal lpBuffer, Len(FI))
     
     'extract the file version from the FI structure
      tmpVer = Format$(HiWord(FI.dwFileVersionMS)) & "." & _
               Format$(LoWord(FI.dwFileVersionMS), "00") & "."
         
      If FI.dwFileVersionLS > 0 Then
         tmpVer = tmpVer & Format$(HiWord(FI.dwFileVersionLS), "00") & "." & _
                           Format$(LoWord(FI.dwFileVersionLS), "00")
      Else
         tmpVer = tmpVer & Format$(FI.dwFileVersionLS, "0000")
      End If
      
      End If
   
   GetFileVersion = tmpVer
   
End Function
'--end block--'

'************************************************************************************************

Public Function GetFilePath(ByVal sFilename As String, Optional ByVal bAddBackslash As Boolean) As String
    'Returns Path Without FileTitle
    Dim lPos As Long
    lPos = InStrRev(sFilename, "\")


    If lPos > 0 Then
        GetFilePath = Left$(sFilename, lPos - 1) _
        & IIf(bAddBackslash, "\", "")
    Else
        GetFilePath = ""
    End If
    
End Function

Public Function GetAppPath() As String
If Right(App.Path, 1) <> "\" Then GetAppPath = App.Path & "\" Else GetAppPath = App.Path
End Function
'***************************************Build File from resource*****************************************
Public Function BuildFileFromResource(destFILE As String, resID As Long, Optional resTITLE As String = "CUSTOM") As String
    On Error GoTo ErrorBuildFileFromResource
    Dim resBYTE() As Byte
    resBYTE = LoadResData(resID, resTITLE)
    Open destFILE For Binary Access Write As #1
    Put #1, , resBYTE
    Close #1
    BuildFileFromResource = destFILE
    Exit Function
ErrorBuildFileFromResource:
    BuildFileFromResource = ""
    MsgBox Err & ":Error in BuildFileFromResource.  Error Message: " & Err.Description, vbCritical, "Warning"
    Exit Function
End Function