AW: Arbeitsmappe freigeben bei mehreren Dateien prüfen
06.10.2010 10:30:21
welga
Hallo,
eventuell hilft folgender Code:
Option Explicit
Private Function FileSearchFSO(ByRef Files As Variant, ByVal InitialPath As String, Optional _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object
Set mobjFSO = CreateObject("Scripting.FileSystemObject")
Set mfsoFolder = mobjFSO.GetFolder(InitialPath)
On Error Resume Next
For Each mfsoFile In mfsoFolder.Files
If Not mfsoFile Is Nothing Then
If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Files(UBound(Files)) = mfsoFile
End If
End If
Next
If SubFolders Then
For Each mfsoSubFolder In mfsoFolder.SubFolders
FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Sub testen()
Dim strfolder As String, strExt As String
Dim result
Dim l, a
strfolder = fncBrowseForFolder
If strfolder = "" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strExt = "xls" 'gesuchte Dateiendung
result = FileSearchFSO(a, strfolder & "\", "*." & strExt & "*", True)
If result 0 Then
For l = 0 To UBound(a)
Workbooks.Open (a(l))
If ActiveWorkbook.MultiUserEditing Then 'ist Datei freigegeben?
ActiveWorkbook.ExclusiveAccess
End If
ActiveWorkbook.Close
Next l
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Gruß