domain.bas

功能强大的API

Option Explicit

Private Type NETRESOURCE
   dwScope                             As Long
   dwType                              As Long
   dwDisplayType                       As Long
   dwUsage                             As Long
   pLocalName                          As Long
   pRemoteName                         As Long
   pComment                            As Long
   pProvider                           As Long
End Type

Private Declare Function WNetOpenEnum _
   Lib "mpr.dll" Alias "WNetOpenEnumA" _
   (ByVal dwScope As Long, _
   ByVal dwType As Long, _
   ByVal dwUsage As Long, _
   lpNetResource As Any, _
   lppEnumHwnd As Long) As Long

Private Declare Function WNetEnumResource _
   Lib "mpr.dll" Alias "WNetEnumResourceA" _
   (ByVal pEnumHwnd As Long, _
   lpcCount As Long, _
   lpBuffer As NETRESOURCE, _
   lpBufferSize As Long) As Long

Private Declare Function WNetCloseEnum _
   Lib "mpr.dll" _
   (ByVal p_lngEnumHwnd As Long) As Long

Private Declare Function NetUserGetInfo _
   Lib "netapi32.dll" _
   (ServerName As Byte, _
   Username As Byte, _
   ByVal Level As Long, _
   Buffer As Long) As Long
   
Private Declare Function StrLenA _
   Lib "kernel32" Alias "lstrlenA" _
   (ByVal Ptr As Long) As Long
   
Private Declare Function StrCopyA _
   Lib "kernel32" Alias "lstrcpyA" _
   (ByVal RetVal As String, _
   ByVal Ptr As Long) As Long

Private Const MAX_RESOURCES            As Long = 256
Private Const RESOURCE_GLOBALNET       As Long = &H2&
Private Const RESOURCETYPE_ANY         As Long = &H0&
Private Const RESOURCEUSAGE_ALL        As Long = &H0&
Private Const NO_ERROR                 As Long = 0&
Private Const RESOURCE_ENUM_ALL        As Long = &HFFFF

Public Sub GetDomains(lst As Object)

Dim p_avntDomains                   As Variant
Dim p_lngLoop                       As Long
Dim p_lngNumItems                   As Long

p_avntDomains = EnumDomains()

On Error Resume Next
p_lngNumItems = UBound(p_avntDomains)
On Error GoTo 0

If p_lngNumItems > 0 Then
   For p_lngLoop = 1 To p_lngNumItems
      lst.AddItem p_avntDomains(p_lngLoop)
   Next p_lngLoop
End If

End Sub

Private Function EnumDomains() As Variant

Dim p_lngRtn                        As Long
Dim p_lngEnumHwnd                   As Long
Dim p_lngCount                      As Long
Dim p_lngLoop                       As Long
Dim p_lngBufSize                    As Long
Dim p_astrDomainNames()             As String
Dim p_atypNetAPI(0 To MAX_RESOURCES) As NETRESOURCE

' ------------------------------------------
' First time thru, we are just getting the root level
' ------------------------------------------
p_lngEnumHwnd = 0&
p_lngRtn = WNetOpenEnum(dwScope:=RESOURCE_GLOBALNET, _
   dwType:=RESOURCETYPE_ANY, _
   dwUsage:=RESOURCEUSAGE_ALL, _
   lpNetResource:=ByVal 0&, _
   lppEnumHwnd:=p_lngEnumHwnd)

If p_lngRtn = NO_ERROR Then
   p_lngCount = RESOURCE_ENUM_ALL

   p_lngBufSize = UBound(p_atypNetAPI) * Len(p_atypNetAPI(0))
   p_lngRtn = WNetEnumResource(pEnumHwnd:=p_lngEnumHwnd, _
      lpcCount:=p_lngCount, _
      lpBuffer:=p_atypNetAPI(0), _
      lpBufferSize:=p_lngBufSize)

End If

If p_lngEnumHwnd <> 0 Then
   Call WNetCloseEnum(p_lngEnumHwnd)
End If

' ------------------------------------------
' Now we are going for the second level,
'     which should contain the domain names
' ------------------------------------------
p_lngRtn = WNetOpenEnum(dwScope:=RESOURCE_GLOBALNET, _
   dwType:=RESOURCETYPE_ANY, _
   dwUsage:=RESOURCEUSAGE_ALL, _
   lpNetResource:=p_atypNetAPI(0), _
   lppEnumHwnd:=p_lngEnumHwnd)

If p_lngRtn = NO_ERROR Then
   p_lngCount = RESOURCE_ENUM_ALL

   p_lngBufSize = UBound(p_atypNetAPI) * Len(p_atypNetAPI(0))
   p_lngRtn = WNetEnumResource(pEnumHwnd:=p_lngEnumHwnd, _
      lpcCount:=p_lngCount, _
      lpBuffer:=p_atypNetAPI(0), _
      lpBufferSize:=p_lngBufSize)

   If p_lngCount > 0 Then
      ReDim p_astrDomainNames(1 To p_lngCount) As String
      For p_lngLoop = 0 To p_lngCount - 1
         p_astrDomainNames(p_lngLoop + 1) = _
         PointerToAsciiStr(p_atypNetAPI(p_lngLoop).pRemoteName)
      Next p_lngLoop
   End If
End If

If p_lngEnumHwnd <> 0 Then
   Call WNetCloseEnum(p_lngEnumHwnd)
End If

' ------------------------------------------
' Set the return value
' ------------------------------------------
EnumDomains = p_astrDomainNames

End Function

Private Function PointerToAsciiStr(ByVal xi_lngPtrToString _
  As Long) As String

On Error Resume Next         ' Don't accept an error here

Dim p_lngLen                        As Long
Dim p_strStringValue                As String
Dim p_lngNullPos                    As Long
Dim p_lngRtn                        As Long

p_lngLen = StrLenA(xi_lngPtrToString)
If xi_lngPtrToString > 0 And p_lngLen > 0 Then
   p_strStringValue = Space$(p_lngLen + 1)
   p_lngRtn = StrCopyA(p_strStringValue, xi_lngPtrToString)
   p_lngNullPos = InStr(p_strStringValue, Chr$(0))
   If p_lngNullPos > 0 Then
      PointerToAsciiStr = Left$(p_strStringValue, _
         p_lngNullPos - 1) 'Lose the null terminator...
   Else
      'Just pass the string...
      PointerToAsciiStr = p_strStringValue 
   End If
Else
   PointerToAsciiStr = ""
End If

End Function