frmenumshare.frm

全面网络扫描器VB源代码 很实用

VERSION 5.00
Begin VB.Form frmenumshare 
   BackColor       =   &H00000000&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Enumerating Shared Resources on Remote Machines"
   ClientHeight    =   6840
   ClientLeft      =   1245
   ClientTop       =   915
   ClientWidth     =   7680
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   6840
   ScaleWidth      =   7680
   Begin VB.TextBox Text1 
      Height          =   285
      Left            =   1920
      TabIndex        =   4
      Top             =   240
      Width           =   3615
   End
   Begin VB.ListBox List1 
      Height          =   5280
      Left            =   240
      TabIndex        =   3
      Top             =   720
      Width           =   7095
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   240
      TabIndex        =   0
      Top             =   6240
      Width           =   2415
   End
   Begin VB.Label Label3 
      BackColor       =   &H00FFFFFF&
      Caption         =   "Computer Name"
      Height          =   255
      Left            =   240
      TabIndex        =   5
      Top             =   240
      Width           =   1575
   End
   Begin VB.Label Label2 
      BackColor       =   &H80000003&
      Height          =   375
      Left            =   4680
      TabIndex        =   2
      Top             =   6240
      Width           =   1215
   End
   Begin VB.Label Label1 
      BackColor       =   &H80000003&
      Height          =   375
      Left            =   3000
      TabIndex        =   1
      Top             =   6240
      Width           =   1215
   End
End
Attribute VB_Name = "frmenumshare"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Windows type used to call the Net API
Private Const MAX_PREFERRED_LENGTH As Long = -1
Private Const NERR_SUCCESS As Long = 0&
Private Const ERROR_MORE_DATA As Long = 234&
Private Const LB_SETTABSTOPS As Long = &H192

'See NetServerEnum demo for complete
'list of server types supported
Private Const SV_TYPE_ALL                 As Long = &HFFFFFFFF
Private Const SV_TYPE_WORKSTATION         As Long = &H1
Private Const SV_TYPE_SERVER              As Long = &H2

Private Const STYPE_ALL       As Long = -1  'note: my const
Private Const STYPE_DISKTREE  As Long = 0
Private Const STYPE_PRINTQ    As Long = 1
Private Const STYPE_DEVICE    As Long = 2
Private Const STYPE_IPC       As Long = 3
Private Const STYPE_SPECIAL   As Long = &H80000000
Private Const ACCESS_READ     As Long = &H1
Private Const ACCESS_WRITE    As Long = &H2
Private Const ACCESS_CREATE   As Long = &H4
Private Const ACCESS_EXEC     As Long = &H8
Private Const ACCESS_DELETE   As Long = &H10
Private Const ACCESS_ATRIB    As Long = &H20
Private Const ACCESS_PERM     As Long = &H40
Private Const ACCESS_ALL      As Long = ACCESS_READ Or _
                                        ACCESS_WRITE Or _
                                        ACCESS_CREATE Or _
                                        ACCESS_EXEC Or _
                                        ACCESS_DELETE Or _
                                        ACCESS_ATRIB Or _
                                        ACCESS_PERM
'for use on Win NT/2000 only
Private Type SERVER_INFO_100
  sv100_platform_id  As Long
  sv100_name         As Long
End Type

'shi2_current_uses: number of current connections to the resource
'shi2_max_uses    : max concurrent connections resource can accommodate
'shi2_netname     : share name of a resource
'shi2_passwd      : share's password when
'                  (server running with share-level security)
'shi2_path        : local path for the shared resource
'shi2_permissions : shared resource's permissions
'                  (servers running with share-level security)
'shi2_remark      : string containing optional comment about the resource
'shi2_type        : the type of the shared resource
Private Type SHARE_INFO_2
  shi2_netname       As Long
  shi2_type          As Long
  shi2_remark        As Long
  shi2_permissions   As Long
  shi2_max_uses      As Long
  shi2_current_uses  As Long
  shi2_path          As Long
  shi2_passwd        As Long
End Type

Private Declare Function NetServerEnum Lib "netapi32" _
  (ByVal servername As Long, _
   ByVal level As Long, _
   buf As Any, _
   ByVal prefmaxlen As Long, _
   entriesread As Long, _
   totalentries As Long, _
   ByVal servertype As Long, _
   ByVal domain As Long, _
   resume_handle As Long) As Long

Private Declare Function NetShareEnum Lib "netapi32" _
  (ByVal servername As Long, _
   ByVal level As Long, _
   bufptr As Long, _
   ByVal prefmaxlen As Long, _
   entriesread As Long, _
   totalentries As Long, _
   resume_handle As Long) As Long
   
Private Declare Function NetApiBufferFree Lib "netapi32" _
   (ByVal Buffer As Long) As Long
     
Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (pTo As Any, uFrom As Any, _
   ByVal lSize As Long)
   
Private Declare Function lstrlenW Lib "kernel32" _
  (ByVal lpString As Long) As Long

Private Declare Function SendMessage Lib "user32" _
   Alias "SendMessageA" _
  (ByVal hwnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lParam As Any) As Long


Private Sub Form_Load()

   ReDim TabArray(0 To 4) As Long
   
   TabArray(0) = 73
   TabArray(1) = 125
   TabArray(2) = 151
   TabArray(3) = 232
   
  'Clear any existing tabs
  'and set the list tabstops
   Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 0&, ByVal 0&)
   Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 4&, TabArray(0))
   List1.Refresh
   
   Command1.Caption = "Net Share Enum"
   Label1.Caption = "call success (0) or error :"
   Label2.Caption = ""

End Sub


Private Sub Command1_Click()

   Dim bufptr          As Long  'output
   Dim dwServer        As Long  'pointer to the server
   Dim dwEntriesread   As Long  'out
   Dim dwTotalentries  As Long  'out
   Dim dwResumehandle  As Long  'out
   Dim success         As Long
   Dim nStructSize     As Long
   Dim cnt             As Long
   Dim usrname         As String
   Dim bServer         As String
   Dim shi2            As SHARE_INFO_2
     
  'demo using the local machine
 If Text1.Text = "" Then
   bServer = "\\" & Environ$("COMPUTERNAME") & vbNullString
 Else
   bServer = "\\" & Text1.Text
 End If
   
   
  'create pointer to the machine name
   dwServer = StrPtr(bServer)
   
   success = NetShareEnum(dwServer, _
                          2, _
                          bufptr, _
                          MAX_PREFERRED_LENGTH, _
                          dwEntriesread, _
                          dwTotalentries, _
                          dwResumehandle)

   List1.Clear
   Label2.Caption = success
   
   If success = NERR_SUCCESS And _
      success <> ERROR_MORE_DATA Then
      
      nStructSize = LenB(shi2)
      
      For cnt = 0 To dwEntriesread - 1
         
        'get one chunk of data and cast
        'into an SHARE_INFO_2 type, and
        'add the data to a list
         CopyMemory shi2, ByVal bufptr + (nStructSize * cnt), nStructSize

         List1.AddItem GetPointerToByteStringW(shi2.shi2_netname) & vbTab & _
                       GetConnectionType(shi2.shi2_type) & vbTab & _
                       GetConnectionPermissions(shi2.shi2_permissions) & vbTab & _
                       GetPointerToByteStringW(shi2.shi2_remark) & vbTab & _
                       GetPointerToByteStringW(shi2.shi2_path)  ' & vbTab & _

      Next
      
   End If
   
   Call NetApiBufferFree(bufptr)

End Sub


Private Function GetConnectionPermissions(ByVal dwPermissions As Long) As String

  'Permissions are only returned a shared
  'resource running with share-level security.
  'A server running user-level security ignores
  'this member, so the function returns
  '"not applicable".
   Dim tmp As String
   
   If (dwPermissions And ACCESS_READ) Then tmp = tmp & "R"
   If (dwPermissions And ACCESS_WRITE) Then tmp = tmp & " W"
   If (dwPermissions And ACCESS_CREATE) Then tmp = tmp & " C"
   If (dwPermissions And ACCESS_DELETE) Then tmp = tmp & " D"
   If (dwPermissions And ACCESS_EXEC) Then tmp = tmp & " E"
   If (dwPermissions And ACCESS_ATRIB) Then tmp = tmp & " A"
   If (dwPermissions And ACCESS_PERM) Then tmp = tmp & " P"

   If Len(tmp) = 0 Then tmp = "n/a"
  
   GetConnectionPermissions = tmp
   
   
End Function


Private Function GetConnectionType(ByVal dwConnectType As Long) As String

  'compare connection type value
   Select Case dwConnectType
      Case STYPE_DISKTREE: GetConnectionType = "disk drive"
      Case STYPE_PRINTQ:   GetConnectionType = "print queue"
      Case STYPE_DEVICE:   GetConnectionType = "communication device"
      Case STYPE_IPC:      GetConnectionType = "ipc"
      Case STYPE_SPECIAL:  GetConnectionType = "administrative"
      Case Else
         
        'weird case. On my NT2000 machines,
        'I have to do this to identify the
        'IPC$ share type
         Select Case (dwConnectType Xor STYPE_SPECIAL) 'rtns 3 if IPC
            Case STYPE_IPC: GetConnectionType = "ipc"
            Case Else:      GetConnectionType = "undefined"
         End Select
         
   End Select
   
End Function


Public Function GetPointerToByteStringW(ByVal dwData As Long) As String
  
   Dim tmp() As Byte
   Dim tmplen As Long
   
   If dwData <> 0 Then
   
      tmplen = lstrlenW(dwData) * 2
      
      If tmplen <> 0 Then
      
         ReDim tmp(0 To (tmplen - 1)) As Byte
         CopyMemory tmp(0), ByVal dwData, tmplen
         GetPointerToByteStringW = tmp
         
     End If
     
   End If
    
End Function


Private Sub List1_Click()
  List1.ToolTipText = List1.List(List1.ListIndex)
End Sub