监控功能如何实现？

sniffer，
use winpcap lib。search previous articles

'监视系统
Option Explicit
Private Const WM_NCDESTROY = &H82
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC = (-4)
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const OLDWNDPROC = "OldWndProc"
Public Function SubClass(hWnd As Long) As Boolean
  Dim lpfnOld As Long
  Dim fSuccess As Boolean
  If (GetProp(hWnd, OLDWNDPROC) = 0) Then
    lpfnOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WndProc)
    If lpfnOld Then
      fSuccess = SetProp(hWnd, OLDWNDPROC, lpfnOld)
    End If
  End If
  If fSuccess Then
    SubClass = True
  Else
    If lpfnOld Then Call UnSubClass(hWnd)
    MsgBox "Unable to successfully subclass &H" & Hex(hWnd), vbCritical
  End If
End Function
Public Function UnSubClass(hWnd As Long) As Boolean
  Dim lpfnOld As Long
  lpfnOld = GetProp(hWnd, OLDWNDPROC)
  If lpfnOld Then
    If RemoveProp(hWnd, OLDWNDPROC) Then
      UnSubClass = SetWindowLong(hWnd, GWL_WNDPROC, lpfnOld)
    End If
  End If
End Function
Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Select Case uMsg
    Case WM_SHNOTIFY
      Call Form1.NotificationReceipt(wParam, lParam)
    Case WM_NCDESTROY
      Call UnSubClass(hWnd)
      MsgBox "Unubclassed &H" & Hex(hWnd), vbCritical, "WndProc Error"
  End Select
  WndProc = CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
End Function

Option Explicit
Private m_hSHNotify As Long      ' the one and only shell change notification handle for the desktop folder
Private m_pidlDesktop As Long   ' the desktop's pidl
Public Const WM_SHNOTIFY = &H401
Public Type PIDLSTRUCT
   bWatchSubFolders As Long
End Type
Declare Function SHChangeNotifyRegister Lib "shell32" Alias "#2" (ByVal hWnd As Long, ByVal uFlags As SHCN_ItemFlags, ByVal dwEventID As SHCN_EventIDs, ByVal cItems As Long,  lpps As PIDLSTRUCT) As Long
Type SHNOTIFYSTRUCT
  dwItem1 As Long
  dwItem2 As Long
End TypeDeclare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" (ByVal hNotify As Long) As Boolean
Declare Sub SHChangeNotify Lib "shell32" (ByVal wEventId As SHCN_EventIDs, ByVal uFlags As SHCN_ItemFlags, ByVal dwItem1 As Long,ByVal dwItem2 As Long)
Public Enum SHCN_EventIDs
  SHCNE_RENAMEITEM = &H1      ' (D) A nonfolder item has been renamed.
  SHCNE_CREATE = &H2                ' (D) A nonfolder item has been created.
  SHCNE_DELETE = &H4                ' (D) A nonfolder item has been deleted.
  SHCNE_MKDIR = &H8                  ' (D) A folder item has been created.
  SHCNE_RMDIR = &H10                ' (D) A folder item has been removed.
  SHCNE_MEDIAINSERTED = &H20     ' (G) Storage media has been inserted into a drive.
  SHCNE_MEDIAREMOVED = &H40      ' (G) Storage media has been removed from a drive.
  SHCNE_DRIVEREMOVED = &H80      ' (G) A drive has been removed.
  SHCNE_DRIVEADD = &H100              ' (G) A drive has been added.
  SHCNE_NETSHARE = &H200             ' A folder on the local computer is being shared via the network.
  SHCNE_NETUNSHARE = &H400        ' A folder on the local computer is no longer being shared via the network.
  SHCNE_ATTRIBUTES = &H800
  SHCNE_UPDATEDIR = &H1000
  SHCNE_UPDATEITEM = &H2000
  SHCNE_SERVERDISCONNECT = &H4000   '
  SHCNE_UPDATEIMAGE = &H8000&
  SHCNE_DRIVEADDGUI = &H10000
  SHCNE_RENAMEFOLDER = &H20000
  SHCNE_FREESPACE = &H40000
#If (WIN32_IE >= &H400) Then
  SHCNE_EXTENDED_EVENT = &H4000000
#End If     ' WIN32_IE >= &H0400  SHCNE_ASSOCCHANGED = &H8000000
  SHCNE_DISKEVENTS = &H2381F
  SHCNE_GLOBALEVENTS = &HC0581E0
  SHCNE_ALLEVENTS = &H7FFFFFFF
  SHCNE_INTERRUPT = &H80000000
End Enum#If (WIN32_IE >= &H400) Then   ' ???
Public Const SHCNEE_ORDERCHANGED = &H2
#End If
Public Enum SHCN_ItemFlags
  SHCNF_IDLIST = &H0                ' LPITEMIDLIST
  SHCNF_PATHA = &H1               ' path name
  SHCNF_PRINTERA = &H2         ' printer friendly name
  SHCNF_DWORD = &H3             ' DWORD
  SHCNF_PATHW = &H5              ' path name
  SHCNF_PRINTERW = &H6        ' printer friendly name
  SHCNF_TYPE = &HFF
    SHCNF_FLUSH = &H1000
    SHCNF_FLUSHNOWAIT = &H2000#If UNICODE Then
  SHCNF_PATH = SHCNF_PATHW
  SHCNF_PRINTER = SHCNF_PRINTERW
#Else
  SHCNF_PATH = SHCNF_PATHA
  SHCNF_PRINTER = SHCNF_PRINTERA
#End If
End EnumPublic Function SHNotify_Register(hWnd As Long) As Boolean
  Dim ps As PIDLSTRUCT
  If (m_hSHNotify = 0) Then
    m_pidlDesktop = GetPIDLFromFolderID(0, CSIDL_DESKTOP)
    If m_pidlDesktop Then
      ps.pidl = m_pidlDesktop
      ps.bWatchSubFolders = True
     m_hSHNotify = SHChangeNotifyRegister(hWnd, _
                                                                       SHCNF_TYPE Or SHCNF_IDLIST, _
                                                                       SHCNE_ALLEVENTS Or SHCNE_INTERRUPT, _
                                                                       WM_SHNOTIFY, _
                                                                       1, _
                                                                       ps)
      SHNotify_Register = CBool(m_hSHNotify)

    Else
      Call CoTaskMemFree(m_pidlDesktop)

    End If   ' m_pidlDesktop
  End If   ' (m_hSHNotify = 0)

End Function
Public Function SHNotify_Unregister() As Boolean
  If m_hSHNotify Then
    If SHChangeNotifyDeregister(m_hSHNotify) Then
      m_hSHNotify = 0
      Call CoTaskMemFree(m_pidlDesktop)
      m_pidlDesktop = 0
      SHNotify_Unregister = True
    End If
  End IfEnd Function
Public Function SHNotify_GetEventStr(dwEventID As Long) As String
  Dim sEvent As String
  Select Case dwEventID
    Case SHCNE_RENAMEITEM: sEvent = "SHCNE_RENAMEITEM"   ' = &H1"
    Case SHCNE_CREATE: sEvent = "SHCNE_CREATE"   ' = &H2"
    Case SHCNE_DELETE: sEvent = "SHCNE_DELETE"   ' = &H4"
    Case SHCNE_MKDIR: sEvent = "SHCNE_MKDIR"   ' = &H8"
    Case SHCNE_RMDIR: sEvent = "SHCNE_RMDIR"   ' = &H10"
    Case SHCNE_MEDIAINSERTED: sEvent = "SHCNE_MEDIAINSERTED"   ' = &H20"
    Case SHCNE_MEDIAREMOVED: sEvent = "SHCNE_MEDIAREMOVED"   ' = &H40"
    Case SHCNE_DRIVEREMOVED: sEvent = "SHCNE_DRIVEREMOVED"   ' = &H80"
    Case SHCNE_DRIVEADD: sEvent = "SHCNE_DRIVEADD"   ' = &H100"
    Case SHCNE_NETSHARE: sEvent = "SHCNE_NETSHARE"   ' = &H200"
    Case SHCNE_NETUNSHARE: sEvent = "SHCNE_NETUNSHARE"   ' = &H400"
    Case SHCNE_ATTRIBUTES: sEvent = "SHCNE_ATTRIBUTES"   ' = &H800"
    Case SHCNE_UPDATEDIR: sEvent = "SHCNE_UPDATEDIR"   ' = &H1000"
    Case SHCNE_UPDATEITEM: sEvent = "SHCNE_UPDATEITEM"   ' = &H2000"
    Case SHCNE_SERVERDISCONNECT: sEvent = "SHCNE_SERVERDISCONNECT"   ' = &H4000"
    Case SHCNE_UPDATEIMAGE: sEvent = "SHCNE_UPDATEIMAGE"   ' = &H8000&"
    Case SHCNE_DRIVEADDGUI: sEvent = "SHCNE_DRIVEADDGUI"   ' = &H10000"
    Case SHCNE_RENAMEFOLDER: sEvent = "SHCNE_RENAMEFOLDER"   ' = &H20000"
    Case SHCNE_FREESPACE: sEvent = "SHCNE_FREESPACE"   ' = &H40000"

#If (WIN32_IE >= &H400) Then
    Case SHCNE_EXTENDED_EVENT: sEvent = "SHCNE_EXTENDED_EVENT"   ' = &H4000000"
#End If     ' WIN32_IE >= &H0400
    Case SHCNE_ASSOCCHANGED: sEvent = "SHCNE_ASSOCCHANGED"   ' = &H8000000"
    Case SHCNE_DISKEVENTS: sEvent = "SHCNE_DISKEVENTS"   ' = &H2381F"
    Case SHCNE_GLOBALEVENTS: sEvent = "SHCNE_GLOBALEVENTS"   ' = &HC0581E0"
    Case SHCNE_ALLEVENTS: sEvent = "SHCNE_ALLEVENTS"   ' = &H7FFFFFFF"
    Case SHCNE_INTERRUPT: sEvent = "SHCNE_INTERRUPT"   ' = &H80000000"
  End Select
  SHNotify_GetEventStr = sEvent
End Function

只发了两个模块，太多了，不大好发
再发一个窗体的Private Sub Form_Load()
  If SubClass(hWnd) Then
    If IsIDE Then
      Text1 = "**IMPORTANT**" & vbCrLf & _
                    "本窗口为 subclassed.不要用VB 的结束按钮或" & vbCrLf & _
                   "结束菜单命令\或关闭VB来关闭它,只能通过它自" & vbCrLf & _
                   "己的系统菜单关闭它." & vbCrLf & vbCrLf & Text1    End If
    Call SHNotify_Register(hWnd)
  Else
    Text1 = "Uh..., it's supposed to work... :-)"
  End If
  Move Screen.Width - Width, Screen.Height - Height
End SubPrivate Function IsIDE() As Boolean
  On Error GoTo Out
  Debug.Print 1 / 0
Out:
  IsIDE = Err
End FunctionPrivate Sub Form_Unload(Cancel As Integer)
  Call SHNotify_Unregister
  Call UnSubClass(hWnd)
End SubPrivate Sub Form_Resize()
  On Error GoTo Out
  Text1.Move 0, 0, ScaleWidth, ScaleHeight
Out:
End SubPublic Sub NotificationReceipt(wParam As Long, lParam As Long)
  Dim sOut As String
  Dim shns As SHNOTIFYSTRUCT

  sOut = SHNotify_GetEventStr(lParam) & vbCrLf

  ' Fill the SHNOTIFYSTRUCT from it's pointer.
  MoveMemory shns, ByVal wParam, Len(shns)

  ' lParam is the ID of the notication event, one of the SHCN_EventIDs.
  Select Case lParam

    ' ================================================================
    ' For the SHCNE_FREESPACE event, dwItem1 points to what looks like a 10 byte
    ' struct. The first two bytes are the size of the struct, and the next two members
    ' equate to SHChangeNotify's dwItem1 and dwItem2 params. The dwItem1 member
    ' is a bitfield indicating which drive(s) had it's (their) free space changed. The bitfield
    ' is identical to the bitfield returned from a GetLogicalDrives call, i.e, bit 0 = A:\, bit
    ' 1 = B:\, 2, = C:\, etc. Since VB does DWORD alignment when MoveMemory'ing
    ' to a struct, we'll extract the bitfield directly from it's memory location.
    Case SHCNE_FREESPACE
      Dim dwDriveBits As Long
      Dim wHighBit As Integer
      Dim wBit As Integer

      MoveMemory dwDriveBits, ByVal shns.dwItem1 + 2, 4      ' Get the zero based position of the highest bit set in the bitmask
      ' (essentially determining the value's highest complete power of 2).
      ' Use floating point division (we want the exact values from the Logs)
      ' and remove the fractional value (the fraction indicates the value of
      ' the last incomplete power of 2, which means the bit isn't set).
      wHighBit = Int(Log(dwDriveBits) / Log(2))

      For wBit = 0 To wHighBit
        ' If the bit is set...
        If (2 ^ wBit) And dwDriveBits Then

          ' The bit is set, get it's drive string
          sOut = sOut & Chr$(vbKeyA + wBit) & ":\" & vbCrLf        End If
      Next

    ' ================================================================
    ' shns.dwItem1 also points to a 10 byte struct. The struct's second member (after the
    ' struct's first WORD size member) points to the system imagelist index of the image
    ' that was updated.
    Case SHCNE_UPDATEIMAGE
      Dim iImage As Long

      MoveMemory iImage, ByVal shns.dwItem1 + 2, 4
      sOut = sOut & "Index of image in system imagelist: " & iImage & vbCrLf

    ' ================================================================
    ' Everything else except SHCNE_ATTRIBUTES is the pidl(s) of the changed item(s).
    ' For SHCNE_ATTRIBUTES, neither item is used. See the description of the values
    ' for the wEventId parameter of the SHChangeNotify API function for more info.
    Case Else
      Dim sDisplayname As String

      If shns.dwItem1 Then
        sDisplayname = GetDisplayNameFromPIDL(shns.dwItem1)
        If Len(sDisplayname) Then
          sOut = sOut & "first item displayname: " & sDisplayname & vbCrLf
          sOut = sOut & "first item path: " & GetPathFromPIDL(shns.dwItem1) & vbCrLf
        Else
          sOut = sOut & "first item is invalid" & vbCrLf
        End If
      End If

      If shns.dwItem2 Then
        sDisplayname = GetDisplayNameFromPIDL(shns.dwItem2)
        If Len(sDisplayname) Then
          sOut = sOut & "second item displayname: " & sDisplayname & vbCrLf
          sOut = sOut & "second item path: " & GetPathFromPIDL(shns.dwItem2) & vbCrLf
        Else
          sOut = sOut & "second item is invalid" & vbCrLf
        End If
      End If

  End Select

  Text1 = Text1 & sOut & vbCrLf
  Text1.SelStart = Len(Text1)
  tmrFlashMe = TrueEnd SubPrivate Sub tmrFlashMe_Timer()   ' initial settings: Interval = 1, Enabled = False
  Static nCount As Integer

  If nCount = 0 Then tmrFlashMe.Interval = 200
  nCount = nCount + 1
  Call FlashWindow(hWnd, True)

  ' Reset everything after 3 flash cycles
  If nCount = 6 Then
    nCount = 0
    tmrFlashMe.Interval = 1
    tmrFlashMe = False
  End IfEnd Sub

调试易

监控功能如何实现？

解决方案 »