AW: Prüfen, ob Datei von einem anderen User geöffnet ist
18.02.2025 12:54:00
Ulf
Hi,
braucht Admin-Rechte:
Option Explicit
Private Const MAX_PREFERRED_LENGTH As Long = -1
Private Type FILE_INFO_3
fi3_id As Long
fi3_permissions As Long
fi3_num_locks As Long
fi3_pathname As Long
fi3_username As Long
End Type
Private Const PERM_FILE_READ = &H1 'user has read access
Private Const PERM_FILE_WRITE = &H2 'user has write access
Private Const PERM_FILE_CREATE = &H4 'user has create access
Private Declare Function NetFileEnum Lib "Netapi32" _
(ByVal servername As Long, _
ByVal basepath As Long, _
ByVal username 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.dll" _
(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
Public strDateienOffen() As String
Public Function GetFileConnections(sServer As String) As Long
Dim bufptr As Long
Dim dwServer As Long
Dim dwEntriesread As Long
Dim dwTotalentries As Long
Dim dwResumehandle As Long
Dim dwDomain As Long
Dim fi3 As FILE_INFO_3
Dim success As Long
Dim nStructSize As Long
Dim cnt As Long
Dim strTemp As String
Const NERR_SUCCESS As Long = 0&
Const ERROR_MORE_DATA As Long = 234&
If Len(sServer) = 0 Then
sServer = vbNullString
Else
sServer = "\\" & sServer & vbNullString
End If
dwServer = StrPtr(sServer)
nStructSize = LenB(fi3)
success = NetFileEnum(dwServer, 0&, 0&, 3, bufptr, MAX_PREFERRED_LENGTH, dwEntriesread, dwTotalentries, dwResumehandle)
If success = NERR_SUCCESS And success > ERROR_MORE_DATA Then
For cnt = 0 To dwEntriesread - 1
CopyMemory fi3, ByVal bufptr + (nStructSize * cnt), nStructSize
ReDim Preserve strDateienOffen(cnt)
strDateienOffen(cnt) = GetPointerToByteStringW(fi3.fi3_username) & vbTab & GetPermissionType(fi3.fi3_permissions) & vbTab & GetPointerToByteStringW(fi3.fi3_pathname)
Next
GetFileConnections = dwEntriesread
End If
Call NetApiBufferFree(bufptr)
End Function
Public Function GetPointerToByteStringW(ByVal dwData As Long) As String
Dim strTemp() As Byte
Dim tmplen As Long
If dwData > 0 Then
tmplen = lstrlenW(dwData) * 2
If tmplen > 0 Then
ReDim strTemp(0 To (tmplen - 1)) As Byte
CopyMemory strTemp(0), ByVal dwData, tmplen
GetPointerToByteStringW = strTemp
End If
End If
End Function
Private Function GetPermissionType(ByVal dwPermissions As Long) As String
Dim strTemp As String
If dwPermissions And PERM_FILE_READ Then
strTemp = "read "
End If
If dwPermissions And PERM_FILE_WRITE Then
strTemp = strTemp & "write "
End If
If dwPermissions And PERM_FILE_CREATE Then
strTemp = strTemp & "create "
End If
GetPermissionType = strTemp & "access"
End Function
'Ggf. ANPASSEN
Public Sub untersuchen() 'ByVal strComputer As String, ByVal strFile As String)
Dim strFile As String
Dim strComputer As String
Dim lngAnzahl As Long
Dim lngZähler As Long
'ANPASSEN !!!
strComputer = "B350"
strFile = "mehrbenutzer.xlsx"
lngAnzahl = GetFileConnections(strComputer)
If lngAnzahl Then
For lngZähler = 0 To lngAnzahl - 1
If InStr(1, LCase(strDateienOffen(lngZähler)), strFile, vbTextCompare) Then
MsgBox "Offen:" & vbCrLf & strDateienOffen(lngZähler)
Exit Sub
End If
Next
End If
MsgBox "Nicht offen"
End Sub
hth
Ulf
