Office: (Office 2003) Erste 8 Stellen aus Dateinamen auslesen

ebs17 · 23. März 2011

Nepumuk hat eine Ersatzklasse geschrieben, die Du übernehmen und fast genau so verwenden kannst: Alternative zum Filesearch

Immchen · 23. März 2011

Guten morgen,

das sieht ja ziemlich komplex aus. Was genau muss ich denn da übernehmen und vor allem: wo muss es hin? *Smilie

Viele Grüße
Imke

Immchen · 23. März 2011

Es tut mir leid, ich habe mir das alles noch einmal angeschaut, aber ich komme immer noch nicht weiter. *frown.gif*

Lanz Rudolf · 24. März 2011

Hallo

aber ich komme immer noch nicht weiter
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

wo genau kommst Du nicht Weiter !?

beim Filesearch oder ?????

Immchen · 24. März 2011

Hallo,

ja genau. Ich hätte das gerne als rekursive Suche, da es auch unter Office 2007 und höher laufen soll.
Da blicker ich leider nicht so durch... *frown.gif*

Lanz Rudolf · 24. März 2011

Hallo
lies einmal in Meine Doc
auf Seite 200 u. 201 (8.47 Dateien Rekursiv-Suchen) u. (8.48.1 Filesearch Ersatz)

ebs17 · 24. März 2011

Gezieltes Copy&Paste:
1) Du legst ein neues Klassenmodul an und nennst es "clsFileSearch"
Dort hinein kopierst Du ...
Code:

Option Explicit

Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32.dll" ( _
ByVal hFindFile As Long) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32.dll" ( _
ByRef lpFileTime As FILETIME, _
ByRef lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" ( _
ByRef lpFileTime As FILETIME, _
ByRef lpSystemTime As SYSTEMTIME) As Long

Private Enum FILE_ATTRIBUTE
FILE_ATTRIBUTE_READONLY = &H1
FILE_ATTRIBUTE_HIDDEN = &H2
FILE_ATTRIBUTE_SYSTEM = &H4
FILE_ATTRIBUTE_DIRECTORY = &H10
FILE_ATTRIBUTE_ARCHIVE = &H20
FILE_ATTRIBUTE_NORMAL = &H80
FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum

Private Const MAX_PATH = 260&
Private Const INVALID_HANDLE_VALUE = -1&

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type

Private mlngFileCount As Long
Private mudtFiles() As FILEINFO
Private mstrFolderPath As String
Private mstrExtension As String
Private mstrSearchLike As String
Private mblnSubFolders As Boolean
Private mblnCaseSenstiv As Boolean

Friend Property Get Files(lngIndex As Long) As FILEINFO
Files = mudtFiles(lngIndex)
End Property

Friend Property Get FileCount() As Long
FileCount = mlngFileCount
End Property

Friend Property Let FolderPath(strFolderPath As String)
mstrFolderPath = strFolderPath
End Property

Friend Property Let Extension(strExtension As String)
mstrExtension = strExtension
End Property

Friend Property Let SearchLike(strSearchLike As String)
mstrSearchLike = strSearchLike
End Property

Friend Property Let SubFolders(blnSubFolders As Boolean)
mblnSubFolders = blnSubFolders
End Property

Friend Property Let CaseSenstiv(blnCaseSenstiv As Boolean)
mblnCaseSenstiv = blnCaseSenstiv
End Property

Friend Function Execute(Optional enmSortBy As SORT_BY = Sort_by_None, _
Optional enmSortOrder As SORT_ORDER = Sort_Order_Ascending) As Long
Call FindFiles(mstrFolderPath)
If mlngFileCount > 1 And enmSortBy Sort_by_None Then _
Call prcSort(1, mlngFileCount, enmSortBy, enmSortOrder)
Execute = mlngFileCount
End Function

Private Sub FindFiles(ByVal strFolderPath As String)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
On Error GoTo ErrorHandling
If Right$(strFolderPath, 1) "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
If lngSearch INVALID_HANDLE_VALUE Then
Call GetFilesInFolder(strFolderPath)
If mblnSubFolders Then
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
If (strDirName ".") And (strDirName "..") Then _
Call FindFiles(strFolderPath & strDirName)
End If
Loop While FindNextFile(lngSearch, WFD)
End If
FindClose lngSearch
End If
Exit Sub
ErrorHandling:
MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehler"
End Sub

Private Sub GetFilesInFolder(ByVal strFolderPath As String)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFilename As String
Dim udtFiletime As FILETIME, udtSystemtime As SYSTEMTIME
On Error GoTo ErrorHandling
If Right$(strFolderPath, 1) "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & mstrExtension, WFD)
If lngSearch INVALID_HANDLE_VALUE Then
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) FILE_ATTRIBUTE_DIRECTORY Then
strFilename = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
If IIf(mblnCaseSenstiv, strFilename, LCase$(strFilename)) Like _
IIf(mblnCaseSenstiv, mstrSearchLike, LCase$(mstrSearchLike)) Then
mlngFileCount = mlngFileCount + 1
ReDim Preserve mudtFiles(1 To mlngFileCount)
With mudtFiles(mlngFileCount)
.strPath = strFolderPath & strFilename
.strFilename = strFilename
.lngSize = WFD.nFileSizeLow
FileTimeToLocalFileTime WFD.ftCreationTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.dmtDateCreate = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
FileTimeToLocalFileTime WFD.ftLastAccessTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.dmtLastAccess = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
FileTimeToLocalFileTime WFD.ftLastWriteTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.dmtLastModify = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
End With
End If
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
Exit Sub
ErrorHandling:
MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehler"
End Sub

Private Sub prcSort(lngLBorder As Long, lngUBorder As Long, enmSortBy As SORT_BY, enmSortOrder As SORT_ORDER)
Dim lngIndex1 As Long, lngIndex2 As Long
Dim udtBuffer As FILEINFO, vntTemp As Variant
lngIndex1 = lngLBorder
lngIndex2 = lngUBorder
Select Case enmSortBy
Case Sort_by_Name: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strFilename
Case Sort_by_Path: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strPath
Case Sort_by_Size: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).lngSize
Case Sort_by_Last_Access: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastAccess
Case Sort_by_Last_Modyfy: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastModify
Case Sort_by_Date_Create: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtDateCreate
End Select
Do
Select Case enmSortBy
Case Sort_by_Name
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).strFilename < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp < mudtFiles(lngIndex2).strFilename
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While mudtFiles(lngIndex1).strFilename > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).strFilename
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Path
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).strPath < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp < mudtFiles(lngIndex2).strPath
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While mudtFiles(lngIndex1).strPath > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).strPath
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Size
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).lngSize < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp < mudtFiles(lngIndex2).lngSize
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While mudtFiles(lngIndex1).lngSize > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).lngSize
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Last_Access
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).dmtLastAccess < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp < mudtFiles(lngIndex2).dmtLastAccess
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While mudtFiles(lngIndex1).dmtLastAccess > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).dmtLastAccess
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Last_Modyfy
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).dmtLastModify < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp < mudtFiles(lngIndex2).dmtLastModify
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While mudtFiles(lngIndex1).dmtLastModify > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).dmtLastModify
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Date_Create
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).dmtDateCreate < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp < mudtFiles(lngIndex2).dmtDateCreate
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While mudtFiles(lngIndex1).dmtDateCreate > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).dmtDateCreate
lngIndex2 = lngIndex2 - 1
Loop
End If
End Select
If lngIndex1 lngIndex2
If lngLBorder < lngIndex2 Then Call prcSort(lngLBorder, lngIndex2, enmSortBy, enmSortOrder)
If lngIndex1 < lngUBorder Then Call prcSort(lngIndex1, lngUBorder, enmSortBy, enmSortOrder)
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

2) Du legst ein Standardmodul an mit Name "mdlErgFileSearch".
Da hinein kopierst Du ...
Code:

Option Explicit

Public Enum SORT_BY
Sort_by_None
Sort_by_Name
Sort_by_Path
Sort_by_Size
Sort_by_Last_Access
Sort_by_Last_Modyfy
Sort_by_Date_Create
End Enum

Public Enum SORT_ORDER
Sort_Order_Ascending
Sort_Order_Descending
End Enum

Public Type FILEINFO
strFilename As String
strPath As String
lngSize As Long
dmtLastAccess As Date
dmtLastModify As Date
dmtDateCreate As Date
End Type
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

3) Die Buttonklick-Prozedur lt. #29 wird wie folgt geändert:
Code:

Private Sub DeinButtonOderAndereAction_Click()
Dim objFileSearch As clsFileSearch
Dim sFile As String
Dim i As Long
Dim rs As DAO.Recordset
Dim db As Database

Set objFileSearch = New clsFileSearch
Set db = CurrentDb()
'// ** Lösche Daten **
db.Execute ("DELETE * from Tabelle1")

'// ** Beginne mit Suche **
With objFileSearch
.CaseSenstiv = True
.Extension = "*.xls"
.FolderPath = "C:\Temp\"
.SearchLike = "*"
.SubFolders = True
If .Execute(Sort_by_Size, Sort_Order_Descending) > 0 Then
Set rs = db.OpenRecordset("Tabelle1")
For i = 1 To .FileCount
With .Files(i)

'// ** Extrahiere Filename **
sFile = Left$(.strFilename, 8)

'// ** Extrahiere Sonderzeichen **
If InStr(1, sFile, "_") > 0 Then sFile = Split(sFile, "_")(0)
If InStr(1, sFile, " ") > 0 Then sFile = Split(sFile, " ")(0)
If InStr(1, sFile, ".") > 0 Then sFile = Split(sFile, ".")(0)

'// ** Neue Daten anfügen **
rs.AddNew
rs.Fields("Ergebnis") = sFile
rs.Update
End With
Next
rs.Close
Set rs = Nothing
End If
End With
Set db = Nothing
Set objFileSearch = Nothing
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Immchen · 24. März 2011

Super, genauso funktioniert es! *Smilie
Vielen, vielen Dank! *Smilie

Immchen · 24. März 2011

Hallo,

kann geschlossen werden, Danke! *Smilie

Office: (Office 2003) Erste 8 Stellen aus Dateinamen auslesen

Erste 8 Stellen aus Dateinamen auslesen

Erste 8 Stellen aus Dateinamen auslesen

Erste 8 Stellen aus Dateinamen auslesen

Erste 8 Stellen aus Dateinamen auslesen

Erste 8 Stellen aus Dateinamen auslesen - Similar Threads - Stellen Dateinamen auslesen

Endnoten bei Manuskript an beliebiger Stelle

Excel Tabelle online stellen

BrokenSort (Lücken der Daten bleiben an alter Stelle)

Erlaubte Zeichen an bestimmten Stellen von Strings

Dropdown verknüpfen mit festgelegten Ausgaben an anderer Stelle

Eingabemaske mit Bearbeitung an bestimmter Stelle

Wenn und Formel