Sie sind aktuell nicht angemeldet.

Funktionen: Einloggen  |  Neu registrieren  |  Suchen

Re: Netzwerk erkennen?
Autor: Sascha
Datum: 07.12.01 17:01
'deklaration Private Declare Function WNetAddConnection2 Lib "mpr.dll" Alias _ "WNetAddConnection2A" (lpNetResource As NETRESOURCE, ByVal _ lpPassword As String, ByVal lpUserName As String, ByVal _ dwFlags As Long) As Long Private Declare Function WNetOpenEnum Lib "mpr.dll" Alias _ "WNetOpenEnumA" (ByVal dwScope As Long, ByVal dwType As _ Long, ByVal dwUsage As Long, lpNetResource As Any, lphEnum _ As Long) As Long Private Declare Function WNetEnumResource Lib "mpr.dll" Alias _ "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, _ lpBuffer As NETRESOURCE, lpBufferSize As Long) As Long Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum _ As Long) As Long Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _ (lpTo As Any, lpFrom As Any, ByVal lLen As Long) Private Declare Sub CopyMemByPtr Lib "kernel32" Alias _ "RtlMoveMemory" (ByVal lpTo As Long, ByVal lpFrom As Long, _ ByVal lLen As Long) Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" _ (ByVal lpString1 As String, ByVal lpString2 As Any) As Long Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" _ (ByVal lpString As Any) As Long 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 Type NETRESOURCE_REAL dwScope As Long dwType As Long dwDisplayType As Long dwUsage As Long sLocalName As String sRemoteName As String sComment As String sProvider As String End Type Const RESOURCE_CONNECTED As Long = &H1& Const RESOURCE_GLOBALNET As Long = &H2& Const RESOURCE_REMEMBERED As Long = &H3& Const RESDTYPE_DIRECTORY& = &H9 Const RESDTYPE_DOMAIN& = &H1 Const RESDTYPE_FILE& = &H4 Const RESDTYPE_GENERIC& = &H0 Const RESDTYPE_GROUP& = &H5 Const RESDTYPE_NETWORK& = &H6 Const RESDTYPE_ROOT& = &H7 Const RESDTYPE_SERVER& = &H2 Const RESDTYPE_SHARE& = &H3 Const RESDTYPE_SHAREADMIN& = &H8 Const RESOURCETYPE_ANY As Long = &H0& Const RESOURCETYPE_DISK As Long = &H1& Const RESOURCETYPE_PRINT As Long = &H2& Const RESOURCETYPE_UNKNOWN As Long = &HFFFF& Const RESOURCEUSAGE_ALL As Long = &H0& Const RESOURCEUSAGE_CONNECTABLE As Long = &H1& Const RESOURCEUSAGE_CONTAINER As Long = &H2& Const RESOURCEUSAGE_RESERVED As Long = &H80000000 Const NO_ERROR = 0 Const ERROR_MORE_DATA = 234 Const RESOURCE_ENUM_ALL As Long = &HFFFF ' setze dies in einen timer mit ca 500 ms Private Function GetNetRessources() As Collection Const MAX_RESOURCES = 256 Const NOT_A_CONTAINER = -1 Dim bFirstTime As Boolean Dim lRet&, hEnum&, lCnt&, lMin&, lLen&, L&, lBufSize&, lLastIx& Dim nRem$, F$ Dim ResList As Collection Dim uNetApi(0 To MAX_RESOURCES) As NETRESOURCE Dim uNet() As NETRESOURCE_REAL Set ResList = New Collection bFirstTime = True '### Ressourcen Auslesen Do If bFirstTime Then lRet = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, _ RESOURCEUSAGE_ALL, ByVal 0&, hEnum) bFirstTime = False Else If uNet(lLastIx).dwUsage And RESOURCEUSAGE_CONTAINER Then lRet = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, _ RESOURCEUSAGE_ALL, uNet(lLastIx), hEnum) Else lRet = NOT_A_CONTAINER hEnum = 0 End If lLastIx = lLastIx + 1 End If If lRet = NO_ERROR Then lCnt = RESOURCE_ENUM_ALL Do lBufSize = UBound(uNetApi) * Len(uNetApi(0)) / 2 lRet = WNetEnumResource(hEnum, lCnt, uNetApi(0), lBufSize) If lCnt > 0 Then ReDim Preserve uNet(0 To lMin + lCnt - 1) _ As NETRESOURCE_REAL For L = 0 To lCnt - 1 uNet(lMin + L).dwScope = uNetApi(L).dwScope uNet(lMin + L).dwType = uNetApi(L).dwType uNet(lMin + L).dwDisplayType = uNetApi(L).dwDisplayType uNet(lMin + L).dwUsage = uNetApi(L).dwUsage If uNetApi(L).pLocalName Then lLen = lstrlen(uNetApi(L).pLocalName) uNet(lMin + L).sLocalName = Space$(lLen) CopyMem ByVal uNet(lMin + L).sLocalName, _ ByVal uNetApi(L).pLocalName, lLen End If If uNetApi(L).pRemoteName Then lLen = lstrlen(uNetApi(L).pRemoteName) uNet(lMin + L).sRemoteName = Space$(lLen) CopyMem ByVal uNet(lMin + L).sRemoteName, _ ByVal uNetApi(L).pRemoteName, lLen End If If uNetApi(L).pComment Then lLen = lstrlen(uNetApi(L).pComment) uNet(lMin + L).sComment = Space$(lLen) CopyMem ByVal uNet(lMin + L).sComment, _ ByVal uNetApi(L).pComment, lLen End If If uNetApi(L).pProvider Then lLen = lstrlen(uNetApi(L).pProvider) uNet(lMin + L).sProvider = Space$(lLen) CopyMem ByVal uNet(lMin + L).sProvider, _ ByVal uNetApi(L).pProvider, lLen End If Next L End If lMin = lMin + lCnt Loop While lRet = ERROR_MORE_DATA End If If hEnum Then L = WNetCloseEnum(hEnum) Loop While lLastIx < lMin '### Auswerten If UBound(uNet) > 0 Then For L = 0 To UBound(uNet) Select Case uNet(L).dwDisplayType Case RESDTYPE_DIRECTORY: nRem = "Ordner" Case RESDTYPE_DOMAIN: nRem = "Domäne" Case RESDTYPE_FILE: nRem = "Datei" Case RESDTYPE_GENERIC: nRem = "Generic" Case RESDTYPE_GROUP: nRem = "Gruppe" Case RESDTYPE_NETWORK: nRem = "Netzwerk" Case RESDTYPE_ROOT: nRem = "Root" Case RESDTYPE_SERVER: nRem = "Rechner" Case RESDTYPE_SHARE: nRem = "Freigabe" Case RESDTYPE_SHAREADMIN: nRem = "Freigaben Admin" End Select If nRem = "Rechner" Then ' namen in datenbank schreiben Dim name21 As String name21 = SplitString(uNet(L).sRemoteName, "\", 2) 'Call openclientDb 'Set dy = db.OpenRecordset("select * from clienten") 'dy.AddNew 'dy.Fields("client") = name21 'dy.update If w <> 0 Then Load Option1(w) werte1 = w - 1 Option1(w).Top = Option1(werte1).Top + 250 Option1(w).Visible = True End If Option1(w).Caption = name21 w = w + 1 End If '### Formatieren und speichern F = uNet(L).sRemoteName & uNet(L).sComment F = F & Space(35 - Len(F)) & nRem ResList.Add F Next L End If Set GetNetRessources = ResList ' db.Close End Function achte dabei das du eine options box erstellen muss die den index 0 hatt

Netzwerk erkennen?	65	Andy	07.12.01 16:54
Re: Netzwerk erkennen?	64	Sascha	07.12.01 17:01
Danke Sascha!!	39	Andy	07.12.01 17:16

Sie sind nicht angemeldet! Um auf diesen Beitrag zu antworten oder neue Beiträge schreiben zu können, müssen Sie sich zunächst anmelden. Einloggen  |  Neu registrieren

Funktionen:  Zum Thema  |  Gesamtübersicht

Suchen