Benutzernamen von bereits geöffneter Datei auslese

Set wkb = ThisWorkbook 'Workbooks(wkb) sFile = "Auswertung Artikelliste.xlsm" AusW = ThisWorkbook.Path & "\" & sFile If WkbExists(sFile) = False Then If Dir(AusW) = "" Then MsgBox "Datei " & AusW & " wurde nicht gefunden!" Exit Sub Else Workbooks.Open AusW Workbooks(sFile).Activate user1 = Workbooks(sFile).WriteReservedBy If ActiveWorkbook.ReadOnly = True Then MsgBox "Die Mappe 'Auswertung Artikelliste' ist von " & user1 & " geöffnet." & Chr( _ 10) & _ "Ein Übertrag ist daher nicht möglich." & Chr(10) & _ "Der Vorgang wird abgebrochen.", vbOKOnly, "Achtung!" Unload UserForm1 Exit Sub End If End If Else Workbooks(sFile).Activate user1 = Workbooks(sFile).WriteReservedBy If ActiveWorkbook.ReadOnly = True Then MsgBox "Die Mappe 'Auswertung Artikelliste' ist von " & user1 & " geöffnet." & Chr( _ 10) & _ "Ein Übertrag ist daher nicht möglich." & Chr(10) & _ "Der Vorgang wird abgebrochen.", vbOKOnly, "Achtung!" Unload UserForm1 Exit Sub End If End If

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
teste mal

Option Explicit
Sub TestMakro()
Dim strFile As String
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.InitialFileName = "*"
.Title = "Datei prüfen"
If .Show = -1 Then
strFile = .SelectedItems(1)
Pruefen strFile
End If
End With
End Sub
Private Sub Pruefen(strFileToOpen As String)
Do While IsFileOpen(strFileToOpen)
If MsgBox(strFileToOpen & " ist von " & LastUser(strFileToOpen) & " geöffnet." _
& vbLf & "Bitte schließen lassen.", _
vbOKCancel + vbInformation, "Datei geöffnet") = vbCancel Then End
Loop
End Sub
Function IsFileOpen(strFullPathFileName As String) As Boolean
'// VBA version to check if File is Open
'// We can use this for ANY FILE not just Excel!
'// Ivan F Moala
'// http://www.xcelfiles.com
Dim hdlFile As Long
'// Error is generated if you try
'// opening a File for ReadWrite lock >> MUST BE OPEN!
On Error GoTo FileIsOpen:
hdlFile = FreeFile
Open strFullPathFileName For Random Access Read Write Lock Read Write As hdlFile
IsFileOpen = False
Close hdlFile
Exit Function
FileIsOpen:
'// Someone has it open!
IsFileOpen = True
Close hdlFile
End Function
Function LastUser(strPath As String) As String
'// Code by Helen from http://www.
_
visualbasicforum.com/index.php?s=
'// This routine gets the Username of the File In Use
'// Credit goes to Helen for code & Mark for the idea
'// Insomniac for xl97 inStrRev
'// Amendment 25th June 2004 by IFM
'// : Name changes will show old setting
'// : you need to get the Len of the Name stored just before
'// : the double Padded Nullstrings
Dim strXl As String
Dim strFlag1 As String, strflag2 As String
Dim i As Integer, j As Integer
Dim hdlFile As Long
Dim lNameLen As Byte
strFlag1 = Chr(0) & Chr(0)
strflag2 = Chr(32) & Chr(32)
hdlFile = FreeFile
Open strPath For Binary As #hdlFile
strXl = Space(LOF(hdlFile))
Get 1, , strXl
Close #hdlFile
j = InStr(1, strXl, strflag2)
#If Not VBA6 Then
'// Xl97
For i = j - 1 To 1 Step -1
If Mid(strXl, i, 1) = Chr(0) Then Exit For
Next
i = i + 1
#Else
'// Xl2000+
i = InStrRev(strXl, strFlag1, j) + Len(strFlag1)
#End If
'// IFM
lNameLen = Asc(Mid(strXl, i - 3, 1))
LastUser = Mid(strXl, i, lNameLen)
End Function

Gruß
Rudi

Option Explicit Public Function IsFileLocked(PathName As String) As Boolean On Error GoTo ErrHandler Dim i As Integer If Dir(PathName, vbNormal) "" Then i = FreeFile() Open PathName For Random Access Read Write Lock Read Write As #i Lock i 'Redundant but let's be 100% sure Unlock i Close i Else Err.Raise 53 End If ExitProc: On Error GoTo 0 Exit Function ErrHandler: Select Case Err.Number Case 70 'Unable to acquire exclusive lock IsFileLocked = True Case Else MsgBox "Error " & Err.Number & " (" & Err.Description & ")" End Select Resume ExitProc End Function Sub guckste() MsgBox IsFileLocked("D:\A\tess.zip") End Sub

Beliebteste Forumthreads (12 Monate)

Benutzernamen von bereits geöffneter Datei auslese

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

22 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Benutzernamen von bereits geöffneter Datei auslese

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

22 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread