AW: Verschieben von Ordnern - Alles zu?
19.10.2021 19:25:03
Ordnern
Hallo Andreas,
teste mal:
Option Explicit
Public Sub Beispiel()
Const FOLDER_PATH As String = "G:\Eigene Dateien\Eigene Excelbeispiele\" 'Anpassen. Backslash am Ende nicht löschen!!!
Dim astrFolders() As String, strFilename As String
Dim vntFolder As Variant
astrFolders = GetFolders(FOLDER_PATH)
For Each vntFolder In astrFolders
strFilename = Dir$(vntFolder & "*.*")
Do Until strFilename = vbNullString
If IsFileOpen(vntFolder & strFilename) Then
Call MsgBox("Folgende Datei ist noch geöffnet:" & vbLf & vbLf & _
vntFolder & strFilename, vbExclamation, "Hinweis")
Exit Sub
End If
strFilename = Dir$
Loop
Next
Call MsgBox("Alle Dateien sind geschlossen.", vbInformation, "Information")
End Sub
Private Function GetFolders(ByVal pvstrPath As String) As String()
Dim astrFolders() As String
Dim strFolder As String, strPath As String
Dim ialngIndex1 As Long, ialngIndex2 As Long
ReDim Preserve astrFolders(ialngIndex1)
astrFolders(ialngIndex1) = pvstrPath
ialngIndex1 = 1
ialngIndex2 = 1
strPath = pvstrPath
Do
strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
Do Until strFolder = vbNullString
If strFolder "." And strFolder ".." Then
If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
ReDim Preserve astrFolders(0 To ialngIndex1)
astrFolders(ialngIndex1) = strPath & strFolder & "\"
ialngIndex1 = ialngIndex1 + 1
End If
End If
strFolder = Dir$
Loop
If ialngIndex1 = ialngIndex2 Then Exit Do
strPath = astrFolders(ialngIndex2)
ialngIndex2 = ialngIndex2 + 1
Loop
GetFolders = astrFolders
End Function
Private Function IsFileOpen(ByVal pvstrPath As String) As Boolean
Dim intFilenumber As Integer
intFilenumber = FreeFile
On Error Resume Next
Open pvstrPath For Random Access Read Lock Read Write As #intFilenumber
IsFileOpen = Not Err.Number = 0
Close #intFilenumber
End Function
Gruß
Nepumuk