EXCEL VBA ruft die Funktion FindClose auf und stürzt ab
Hallo,
Betriebssystem: Windows 10 Prof (21H1)
Office: MS Office Professional Plus 2019
PROBLEM:
Diese Funktionen, speziell die hier:
Wenn die aufgerufen wird, schließt sich Excel instant.
Das ganze geht von diesem Sub aus:
FRAGE:
Was ist das Problem?
Oder gibt's eine andere Lösung für das Problem?
LG Peacer
Betriebssystem: Windows 10 Prof (21H1)
Office: MS Office Professional Plus 2019
PROBLEM:
Diese Funktionen, speziell die hier:
Public Declare PtrSafe Function FindClose Lib "kernel32" (ByVal _
hFindFile As Long) As Long
Wenn die aufgerufen wird, schließt sich Excel instant.
Das ganze geht von diesem Sub aus:
Option Explicit
Public Declare PtrSafe Function GetLogicalDrives _
Lib "kernel32" () As Long
Public Declare PtrSafe Function GetDriveType _
Lib "kernel32" Alias "GetDriveTypeA" _
(ByVal lpRootPathName As String) As Integer
Public Declare PtrSafe Function GetLogicalDriveStrings _
Lib "kernel32" Alias "GetLogicalDriveStringsA" _
(ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Public Declare PtrSafe Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" (ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare PtrSafe Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" (ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare PtrSafe Function FindClose Lib "kernel32" (ByVal _
hFindFile As Long) As Long
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Const MAX_PATH = 259
Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nxFilesizeHigh As Long
nxFilesizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_COMPRESSED = &H800
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100
Sub GetAllFiles(ByVal Root$, ByVal strPath$, ByRef Field$(), ByRef lngFileAttributes&(), ByVal strSearchFile$, ByVal strInstanz&)
'Findet alle (auch Hidden und System) strSearchFile$ im angegebenen Root
'Procedur wird Recursiv aufgerufen
Dim File$, hFile&, FD As WIN32_FIND_DATA
Dim SFile$, ShFile&, SFD As WIN32_FIND_DATA
Dim xAttrib&
Dim SRoot$
strInstanz = strInstanz + 1
If Right(Root, 1) <> "\" Then Root = Root & "\"
If strInstanz = 1 Then
SRoot = Root
ShFile = FindFirstFile(SRoot & strSearchFile$, SFD)
If ShFile > 0 Then
Do
SFile = Left(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1)
If Not (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
If (SFile <> ".") And (SFile <> "..") Then
Field(UBound(Field)) = SRoot & SFile
lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes
ReDim Preserve Field(0 To UBound(Field) + 1)
ReDim Preserve lngFileAttributes&(0 To UBound(Field))
End If
End If
Loop While FindNextFile(ShFile, SFD)
End If
End If
hFile = FindFirstFile(Root & strPath, FD)
If hFile = 0 Then Exit Sub
Do
File = Left(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1)
xAttrib& = FD.dwFileAttributes
If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
If (File <> ".") And (File <> "..") Then
SFile = File
SRoot = Root
GetAllFiles Root & File, strPath, Field, lngFileAttributes, strSearchFile$, (strInstanz)
If Right(SFile, 1) <> "\" Then SFile = SFile & "\"
SRoot = SRoot & SFile
ShFile = FindFirstFile(SRoot & strSearchFile$, SFD)
If ShFile > 0 Then
Do
SFile = Left(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1)
If Not (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
If (SFile <> ".") And (SFile <> "..") Then
Field(UBound(Field)) = SRoot & SFile
lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes
ReDim Preserve Field(0 To UBound(Field) + 1)
ReDim Preserve lngFileAttributes&(0 To UBound(Field))
End If
End If
Loop While FindNextFile(ShFile, SFD)
End If
End If
Call FindClose(ShFile)
End If
Loop While FindNextFile(hFile, FD)
Call FindClose(ShFile)
End Sub
Sub GetAllDirctory(ByVal Root$, ByVal strPath$, ByRef Field$(), ByRef lngFileAttributes&(), ByVal strSearchFile$, ByVal strInstanz&)
'Findet alle (auch Hidden und System) strSearchFile$ im angegebenen Root
'Procedur wird Recursiv aufgerufen
Dim File$, hFile&, FD As WIN32_FIND_DATA
Dim SFile$, ShFile&, SFD As WIN32_FIND_DATA
Dim xAttrib&
Dim SRoot$
strInstanz = strInstanz + 1
If Right(Root, 1) <> "\" Then Root = Root & "\"
If strInstanz = 1 Then
SRoot = Root
ShFile = FindFirstFile(SRoot & strSearchFile$, SFD)
If ShFile > 0 Then
Do
SFile = Left(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1)
If (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
If (SFile <> ".") And (SFile <> "..") Then
Field(UBound(Field)) = SRoot & SFile
lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes
ReDim Preserve Field(0 To UBound(Field) + 1)
ReDim Preserve lngFileAttributes&(0 To UBound(Field))
End If
End If
Loop While FindNextFile(ShFile, SFD)
End If
End If
hFile = FindFirstFile(Root & strPath, FD)
If hFile = 0 Then Exit Sub
Do
File = Left(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1)
xAttrib& = FD.dwFileAttributes
If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
If (File <> ".") And (File <> "..") Then
SFile = File
SRoot = Root
GetAllDirctory Root & File, strPath, Field, lngFileAttributes, strSearchFile$, (strInstanz)
If Right(SFile, 1) <> "\" Then SFile = SFile & "\"
SRoot = SRoot & SFile
ShFile = FindFirstFile(SRoot & strSearchFile$, SFD)
If ShFile > 0 Then
Do
SFile = Left(SFD.cFileName, InStr(SFD.cFileName, Chr(0)) - 1)
If (SFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
If (SFile <> ".") And (SFile <> "..") Then
Field(UBound(Field)) = SRoot & SFile
lngFileAttributes(UBound(Field)) = SFD.dwFileAttributes
ReDim Preserve Field(0 To UBound(Field) + 1)
ReDim Preserve lngFileAttributes&(0 To UBound(Field))
End If
End If
Loop While FindNextFile(ShFile, SFD)
End If
End If
Call FindClose(ShFile)
End If
Loop While FindNextFile(hFile, FD)
Call FindClose(ShFile)
End Sub
FRAGE:
Was ist das Problem?
Oder gibt's eine andere Lösung für das Problem?
LG Peacer
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 2059302939
Url: https://administrator.de/forum/excel-vba-ruft-die-funktion-findclose-auf-und-stuerzt-ab-2059302939.html
Ausgedruckt am: 27.12.2024 um 04:12 Uhr