Zjištění všech serverů v doméně

Postup:
Option Explicit

Private Declare Function lstrlenW Lib "kernel32" _
   (ByVal lpString As Long) As Long
Private Declare Function NetServerEnum Lib "netapi32" _
   (strServername As Any, ByVal level As Long, _
   bufptr As Long, ByVal prefmaxlen As Long, _
   entriesread As Long, totalentries As Long, _
   ByVal servertype As Long, strDomain As Any, _
   resumehandle As Long) As Long
Private Declare Function NetApiBufferFree Lib "Netapi32.dll" _
   (ByVal lpBuffer As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias _
   "RtlMoveMemory" (Destination As Any, Source As Any, _
   ByVal Length As Long)

'Typy serverů
Private Const SV_TYPE_WORKSTATION = &H1
Private Const SV_TYPE_SERVER = &H2
Private Const SV_TYPE_SQLSERVER = &H4
Private Const SV_TYPE_DOMAIN_CTRL = &H8
Private Const SV_TYPE_DOMAIN_BAKCTRL = &H10
Private Const SV_TYPE_TIME_SOURCE = &H20
Private Const SV_TYPE_AFP = &H40
Private Const SV_TYPE_NOVELL = &H80
Private Const SV_TYPE_ALL = &HFFFFFFFF

Private Type SV_100
   platform As Long
   name As Long
End Type

'Tato procedura vrací pole serverů v doméně.
'Pokud není doména zadána, použije se lokální doména
'Pokud není zadán typ serveru, vyhledávají se SQL servery
Public Sub EnumDomainServers(saServers() As String, _
   Optional sDomainName As String = "Local", _
   Optional lType = SV_TYPE_SQLSERVER)

   Dim lRet As Long, lEntriesRead As Long, lTotalEntries As Long
   Dim lhResume As Long, lBufPtr As Long, lLevel As Long
   Dim lPrefMaxLen As Long, lThisEntry As Long, lptrStart As Long
   Dim abDomain() As Byte
   Dim tSv100 As SV_100

   lLevel = 100
   lPrefMaxLen = -1
   If Right$(sDomainName, 1) <> vbNullChar Then
      abDomain = sDomainName & vbNullChar
   End If

   lRet = NetServerEnum(ByVal 0&, lLevel, lptrStart, _
      lPrefMaxLen, lEntriesRead, lTotalEntries, lType, _
      abDomain(0), lhResume)

   If (lRet = 0 Or lRet = 234&) And lEntriesRead > 0 Then
      lBufPtr = lptrStart
      ReDim saServers(0 To lEntriesRead - 1)
      For lThisEntry = 0 To lEntriesRead - 1
         CopyMemory tSv100, ByVal lBufPtr, Len(tSv100)
         saServers(lThisEntry) = StrFromPtr(tSv100.name)
         lBufPtr = lBufPtr + Len(tSv100)
      Next
   Else
      Erase saServers
   End If

   Call NetApiBufferFree(lptrStart)

End Sub

Private Function StrFromPtr(ByVal lPtr As Long) As String

   Dim lLen As Long
   Dim abytBuf() As Byte

   lLen = lstrlenW(lPtr) * 2 - 1
   If lLen > 0 Then
      ReDim abytBuf(lLen)
      Call CopyMemory(abytBuf(0), ByVal lPtr, lLen)
      StrFromPtr = abytBuf
   End If

End Function

Příklad použití
Sub Test()

   Dim saServers() As String, sDomainName As String
   Dim lThisDomain As Long

   EnumDomainServers saServers, Environ$("USERDOMAIN")
   On Error GoTo ExitSub
   For lThisDomain = 0 To UBound(saServers)
      Debug.Print saServers(lThisDomain)
   Next

ExitSub:

End Sub

Zpět