Einfache Funktion zum Auffinden von Server (Domain) Diese Funktion sucht den Server (Domain) über das Vorhandensein des Vergleichswertes (sFolder)
Autor:   Norbert Grimm	Bewertung:     [ Jetzt bewerten ]	Views:  8.510
ohne Homepage	System:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 6 Bewertung insgesamt: sehr gut Durchschnittliche Bewertung: 5.0 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Diese Funktion sucht den Server (Domain) über das Vorhandensein des Vergleichswertes (sFolder)

' Die Function (fsoMyServer_Ex) sucht den Server(Domain) über das Vorhandensein
' des Vergleichswertes (sFolder)
'
' Parameter
' sFolder <Byval>   : [optional] Verzeichnis
' sServer <ByRef>   : [Rückgabe] '\\MyServer' (String)
'                   :
'                   : > 0  , Server gefunden, Übereinstimmung
'                   : = 0  , ungültig
'
Function fsoMyServer_Ex(Optional ByRef sServer As String, _
  Optional ByVal sFolder As String) As Integer
 
  Dim B       As Boolean
  Dim iTyp    As Integer
  Dim nErr    As Long
  Dim errMsg  As String
  Dim sPath   As String
  Dim sServ   As String
  Dim fso     As Object
  Dim D       As Variant
 
  Const cFSO  As String = "Scripting.FileSystemObject"
 
  On Error GoTo Err_fso
 
  Set fso = CreateObject(cFSO)
 
  ' Vergleichswert
  If sFolder = "" Then
    sFolder = "\Firma\Daten"    ' default Verzeichnis
  Else
    sFolder = UCase(sFolder)
  End If
 
  With fso
    ' durchlaufe Auflistung Laufwerke
    For Each D In .Drives
 
      iTyp = D.DriveType
        ' nur Server    ' 0= UnKnownType
                        ' 1= Removable
                        ' 2= Festplatte [Fixed]
 
      If iTyp = 3 Then  ' 3= Server [Remote] (Domain)
                        ' 4= CDRom, 5= Ram
        sServ = D.ShareName
        sServ = UCase(sServ)
        sPath = sServ & sFolder
 
        If .FolderExists(sPath) Then
 
          ' vergleiche enthält 'sFold'
          If InStr(1, sPath, sFolder) Then
            sServer = sServ
            B = True
            Exit For
          End If
 
        End If
      End If
    Next D
  End With
  fsoMyServer_Ex = B
 
Exit_fso:
  Set fso = Nothing
  Exit Function
 
Err_fso:
  With Err
    nErr = .Number
    errMsg = .Description
    .Clear
  End With
  MsgBox nErr & vbCr & errMsg, vbCritical, "fsoMyServer_Ex"
  Resume Exit_fso
End Function