AW: Prüfen ob Mappe bereits geöffnet
07.07.2022 10:41:45
Fennek
Hier mein Archiv zu diesem Thema:
https://highlight-pc.de/knowledge-base/excel-2010-2016-datei-wird-ueber-netzlaufwerk-schreibgeschuetzt-geoeffnet/
'Prüfung, ob Datei verfügbar und geschlossen ist
Const Pfad As String = "C:\temp\" 'backslash am Ende
Dim FSO As Object
'Reference to Word.Application 0 Then
'Debug.Print FL.Name
i = i + 1
Cells(i, 1) = FL.Name
If fn_Lock(FL.Name) Then Cells(i, 2) = "closed" Else Cells(i, 2) = "open"
If fn_Tilde(FL.Name) Then Cells(i, 3) = "closed" Else Cells(i, 3) = "open"
If fn_API(FL.Name) Then Cells(i, 4) = "closed" Else Cells(i, 4) = "open"
If fn_Task(FL.Name) Then Cells(i, 5) = "closed" Else Cells(i, 5) = "open"
End If
Next
End Sub
Function fn_Lock(ByVal file) As Boolean 'True = closed
On Error Resume Next
ff = FreeFile
Open (Pfad & file) For Binary Access Read Lock Read As #ff
Close #ff
If Err.Number = 0 Then
fn_Lock = True
Else
fn_Lock = False
End If
Err.Clear
End Function
Function fn_Tilde(ByVal file) As Boolean
If Left(file, 2) = "~$" Then fn_Tilde = False: Exit Function
If Dir(Pfad & "~$" & file, vbHidden) = vbNullString Then
fn_Tilde = True
Else
fn_Tilde = False
End If
End Function
Function fn_API(ByVal file) As Boolean
If FindWindow(vbNullString, file & " - Excel") = 0 Then
fn_API = True
Else
fn_API = False
End If
End Function
Function fn_Task(ByVal file) As Boolean
Dim Ts As Task
fn_Task = True
For Each Ts In Tasks
If InStr(1, Ts.Name, file, vbTextCompare) > 0 Then fn_Task = False
Next Ts
End Function
================= Volti ====================
Private Declare PtrSafe Function EnumWindows Lib "user32" ( _
ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetWindowTextA Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal lpString As String, _
ByVal cch As Long) As Long
Dim sWindowTextFrac As String
Dim bIsOpen As Boolean
Sub Test()
Debug.Print IsFileClosed("MyTool*.xls")
End Sub
Function IsFileClosed(sWindowTitle As String) As Boolean
sWindowTextFrac = sWindowTitle & "*Excel*"
Call EnumWindows(AddressOf EnumWindowProc, 0)
IsFileClosed = bIsOpen
End Function
Private Function EnumWindowProc(ByVal hwnd As LongPtr, lParam As LongPtr) As Long
' Scannt alle Fenster durch
Dim sWinTxt As String * 260
Call GetWindowTextA(hwnd, sWinTxt, 260) ' Fenstertext holen
If sWinTxt Like sWindowTextFrac & "*" Then
bIsOpen = False: EnumWindowProc = 0 ' Scannen abbrechen
Else
bIsOpen = True: EnumWindowProc = 1 ' Weiterscannen
End If
End Function
geöffnete Datei löschen:
With ThisWorkbook
.ChangeFileAccess xlReadOnly 'xlReadWrite
Kill .FullName
.Close False
End With
Debug.Print WB.WriteReservedBy, WB.ReadOnlyRecommended,
############## winmgmts #############
Sub T_FileOpen()
Debug.Print Excel_File_in_use_by("C:\Users\User\Desktop\Liste_EML_Adr.xlsx")
End Sub
Function Excel_File_in_use_by(FilePath As String) As String
Dim strTempFile As String
Dim iPos As Integer, iRetVal As Integer
Dim objFSO As Object, objWMIService As Object, objFileSecuritySettings As Object, objSD As Object
iPos = InStrRev(FilePath, "\")
strTempFile = Left(FilePath, iPos - 1) & "\~$" & Mid(FilePath, iPos + 1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strTempFile) Then
Set objWMIService = GetObject("winmgmts:")
Set objFileSecuritySettings = objWMIService.Get("Win32_LogicalFileSecuritySetting='" & strTempFile & "'")
iRetVal = objFileSecuritySettings.GetSecurityDescriptor(objSD)
If iRetVal = 0 Then
Excel_File_in_use_by = objSD.Owner.Name
Else
Excel_File_in_use_by = "unknown"
End If
Set objWMIService = Nothing
Set objFileSecuritySettings = Nothing
Set objSD = Nothing
Else
Excel_File_in_use_by = vbNullString
End If
Set objFSO = Nothing
End Function