Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
With Application.FileSearch Ersatz für Word Makro
zurück: Buchstaben- und Zahlenwert in Textbox trennen weiter: Pfad in Titelleiste Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Antwort Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
Planet_Jen
Gast


Verfasst am:
24. Apr 2014, 11:26
Rufname:

With Application.FileSearch Ersatz für Word Makro - With Application.FileSearch Ersatz für Word Makro

Nach oben
       Version: Office 2013

Liebe VBA-Profis!

Ich habe das bereits bekannte Problem, dass ich ein Word 97 Makro ins 21. Jahrhundert katapultieren soll (Word2013). Leider wurde ja die Application.FileSearch abgeschlatet. Ich habe mich natürlich bereits durch das Forum gewühlt, bin aber kein Profi und beiße mir nun seit drei Wochen die Zähne aus.

Aufgabe des Makros:

Wenn der Dateiname festgelegt wird, soll das gesamtes Verzeichnis und Unterordner durchsuchen werden, um zu schauen, ob sie schon existiert, damit sie im Zweifel nicht überschrieben wird.

Hier die Stelle, wo es hapert:

Code:
    With Application.FileSearch
        .NewSearch
        .LookIn = oRdner & jAhr & "\" & Left(aZsuch, 2)
        '.FileName = aZsuch: fZ = Val(Mid(aZsuch, 8))
        .FileType = msoFileTypeWordDocuments
        fZ = Val(Mid(aZsuch, 8))
    fSex = .Execute
        If .Execute > 0 Then
         For i = 1 To .FoundFiles.Count
            sName = SplitFileFromPath(.FoundFiles(i))


Das gesamte Makro sieht wie folgt aus:

Code:

Sub az()


dAtei = "": aZsuch = ""
jAhr = Right(Date$, 4)
oRdner = Laufwerk()
nIchtl = 0
    If ActiveDocument.Paragraphs.Count > 20 Then nIchtl = 1
With Selection
    .GoTo What:=wdGoToLine, Which:=wdGoToFirst, Count:=2
    .EndKey Unit:=wdLine, Extend:=wdExtend
    .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    .EndKey Unit:=wdLine
    .TypeText Text:="  "
End With

Aktenzeichen:
mLdg = "Bitte geben Sie ein Aktenzeichen ein:"
    tItel = "Aktenzeichen eingeben"
    dAtei = InputBox(mLdg, tItel, , 5500, 3300)
dAtei = Trim(dAtei): aZsuch = dAtei
If Mid(dAtei, 5, 1) <> "/" Or Mid(dAtei, 8, 1) <> "." Then
    MsgBox _
    ">>  " & dAtei & "  <<" & ZS & ZS & _
    "kann nicht automatisch gespeichert werden!", _
    16, "Abbruch": dAtei = "? AZ ?": GoTo einrichten
End If

aZsuch = Format(Mid(dAtei, 6, 6), FORM)

eRw = 1

    With Application.FileSearch
        .NewSearch
        .LookIn = oRdner & jAhr & "\" & Left(aZsuch, 2)
        '.FileName = aZsuch: fZ = Val(Mid(aZsuch, 8))
        .FileType = msoFileTypeWordDocuments
        fZ = Val(Mid(aZsuch, 8))
    fSex = .Execute
        If .Execute > 0 Then
         For i = 1 To .FoundFiles.Count
            sName = SplitFileFromPath(.FoundFiles(i))
 
         If sName = aZsuch Then
         PlayWinSound ssHinweis
         Test = MsgBox("Schriftsatz " & ">> " & aZsuch & _
         ZS & "ist bereits vorhanden!" & ZS & ZS & ZS & _
         "Soll unter  " & ">> " & Left(aZsuch, 6) & "-" & (eRw + fZ) & _
         ZS & "abgespeichert werden?" & ZS & ZS & ZS & ZS & _
         "        Nein = " & aZsuch & _
         " wird überschrieben!" _
         , 3 + 32, "Achtung!")

        Select Case Test
         Case 6
          With Selection
            .GoTo What:=wdGoToLine, Which:=wdGoToFirst, Count:=2
            .EndKey Unit:=wdLine, Extend:=wdExtend
            .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
            .TypeBackspace
            .EndKey Unit:=wdLine
            .TypeText Text:="-" & (eRw + fZ)
           End With: aZsuch = Left(aZsuch, 6) & "-" & (eRw + fZ): fZ = fZ + 1: i = 0
         Case 7
              GoTo einrichten
         Case 2
              dAtei = "? AZ ?": GoTo einrichten
         End Select
        End If
       Next
      End If
    End With
   
einrichten:
  ActiveDocument.ActiveWindow.Caption = aZsuch & _
  " - N I C H T  GESPEICHERT!"
 
fZ = 19
With Selection
    .HomeKey Unit:=wdStory
    .MoveDown Unit:=wdLine, Count:=8
    .Find.ClearFormatting
    .Find.Text = "^t"
    .Find.Forward = True
      If .Find.Execute = True Then
         .EndKey Unit:=wdLine, Extend:=wdExtend
         .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
         .TypeBackspace
      End If
    .GoTo What:=wdGoToLine, Which:=wdGoToFirst, Count:=9, Name:=""
    .ParagraphFormat.TabStops.ClearAll
        ActiveDocument.DefaultTabStop = CentimetersToPoints(0)
    .ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(13.2) _
        , Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
    .EndKey Unit:=wdLine
    .TypeText Text:=vbTab
End With
With ActiveDocument.Bookmarks
     .Add Range:=Selection.Range, Name:="aktz"
     .DefaultSorting = wdSortByName
     .ShowHidden = False
End With
With Selection
    .TypeText Text:=dAtei
        If nIchtl = 1 Then fZ = 18: GoTo ende
    .EndKey Unit:=wdStory
       For i = 1 To 6
         .TypeParagraph
       Next
    .GoTo What:=wdGoToLine, Which:=wdGoToFirst, Count:=fZ, Name:=""
    .TypeParagraph
    .Style = ActiveDocument.Styles("vgu-text")
    .MoveDown Unit:=wdLine
    .EndKey Unit:=wdStory, Extend:=wdExtend
    .Delete Unit:=wdCharacter, Count:=1
   
ende:
    .HomeKey Unit:=wdStory
    .MoveDown Unit:=wdLine, Count:=fZ
      If nIchtl = 0 Then
        .MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
        .Delete Unit:=wdCharacter, Count:=1
          Else
      End If
     
End With

End Sub


1000 Dank für eure Hilfe!!!
r.mueller
Gast


Verfasst am:
24. Apr 2014, 12:01
Rufname:

AW: With Application.FileSearch Ersatz für Word Makro - AW: With Application.FileSearch Ersatz für Word Makro

Nach oben
       Version: Office 2013

Hallo

Code:

Option Explicit

'Dieses Modul kann um nach Files / directorys auf Laufwerken zu suchen in
'Projekte eingebunden werden.

'GetAllFiles:
'Es werden zwei Arrays ausgegeben
 'xFiles$()          'Array enthält alle gefundenen File
 'lngFileAttributes&() 'Array enthält die zu den File gehörenden Atribute

'in der Do Loop Schleife   K E I N   DoEvent einfügen!
' (Ärger wen du mehrmals auf das Start Button kommst)

Private Declare Function GetLogicalDrives _
       Lib "kernel32" () As Long

Private Declare Function GetDriveType _
       Lib "kernel32" Alias "GetDriveTypeA" _
       (ByVal lpRootPathName As String) As Integer

Private Declare Function GetLogicalDriveStrings _
       Lib "kernel32" Alias "GetLogicalDriveStringsA" _
      (ByVal nBufferLength As Long, _
       ByVal lpBuffer As String) As Long
       
       
Private Declare Function FindFirstFile Lib "kernel32" _
        Alias "FindFirstFileA" (ByVal lpFileName As String, _
        lpFindFileData As WIN32_FIND_DATA) As Long
       
Private Declare Function FindNextFile Lib "kernel32" _
        Alias "FindNextFileA" (ByVal hFindFile As Long, _
        lpFindFileData As WIN32_FIND_DATA) As Long
       
Private Declare 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 lngAttrib&
 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)
  lngAttrib& = 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(hFile)

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 lngAttrib&
 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)
  lngAttrib& = 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(hFile)

End Sub
 Public Sub FindAllDirctory(xRoot$, xSearchDirctory$, xDirArray$())
 ' Sub gibt alle gefundene Dirctory zurück die den Kriterien in xSearchDirctory entsprechen
 ' xSearchDirctory$ = "*les??xx" '
 ' xSearchDirctory$ = "*vbp"  '"*.*"  ''Hier kannst du den gesuchten Dirctorynamen
                               'mit oder ohne Joker eintragen
 
 ReDim strAllDrivesName$(0)
 ReDim lngAllDrivesTypNr&(0)
 Dim strPath$
 Dim strInstanz&    'zählt die instanz der Recursiven Aufrufe
 ReDim lngFileAttributes&(0) 'array enthält die zu den File gehörenden Atribute
 ReDim xDirArray$(0)           'array enthält alle gefundenen File
 
 
 'xRoot$ = "h:\" 'od. Z.B. "C:\WINDOOFS\  'Hier kannst du den Suchbereich einschränken
                                         
 strPath$ = "*.*" 'darf nicht verändert werden sonst werden nicht alle gefunden

 Call GetAllDirctory(xRoot$, strPath$, xDirArray, lngFileAttributes, xSearchDirctory, (strInstanz))

 If UBound(xDirArray) > 0 Then
  ReDim Preserve xDirArray(UBound(xDirArray) - 1) 'entfernt das letzte noch leere Feld im Array
 End If

End Sub

Function AllDrives() As String
 'Funktion kann eingesetzt werden um alle Laufwerke zu ermitteln
 Dim strAllDrives$ 'Sting enthält alle Laufwerke
 Dim xBitMask&
 Dim xi&
 xBitMask& = GetLogicalDrives()
 For xi& = 1 To 30
  If xBitMask& Mod 2 ^ xi& Then
   xBitMask& = xBitMask& - xBitMask& Mod 2 ^ xi&
   AllDrives$ = AllDrives + Chr$(xi& + 64)
  End If
 Next
End Function

Sub AlleLaufwerke(strAllDrivesName$(), lngAllDrivesTypNr&())
 'AlleLaufwerke mit Namen und deren Typ ermitteln
 Dim strAllDrives$
 Dim xDrivesCount&
 Dim xi&
 Dim xtxt$
 Dim lpRootPathName$
 Dim xTyp$
 
 ReDim xDrives(0) As String
 ReDim xDriveType(0) As Integer
 strAllDrives = Space$(128)
  Call GetLogicalDriveStrings(Len(strAllDrives), strAllDrives)
   strAllDrives = Trim$(strAllDrives)
  xDrivesCount& = Len(strAllDrives) \ 4
  ReDim strAllDrivesName$(1 To xDrivesCount&)
  ReDim lngAllDrivesTypNr&(1 To xDrivesCount&)
 For xi& = 1 To xDrivesCount&
  strAllDrivesName$(xi&) = Mid$(strAllDrives, (xi& - 1) * 4 + 1, 1)
  lpRootPathName$ = Mid$(strAllDrives, (xi& - 1) * 4 + 1, 4)
  lngAllDrivesTypNr&(xi&) = GetDriveType(lpRootPathName$)
 Next
End Sub

Sub LWsAnzeigen(strAllDrivesName$(), lngAllDrivesTypNr&())
 'Nur als Demo
 Dim xi&
 Dim xtxt$
 For xi& = 1 To UBound(strAllDrivesName$())
  xtxt$ = xtxt$ & strAllDrivesName(xi&) & " " & DriveTypName$(lngAllDrivesTypNr&(xi&)) & Chr$(13)
 Next
 MsgBox xtxt$
End Sub
Function DriveTypName$(lngDriveTypNr&)
  Select Case lngDriveTypNr
   Case 0
    DriveTypName$ = "Unbekannt"
   Case 1
    DriveTypName$ = "Kein Wurzelverzeichnis"
   Case 2
    DriveTypName$ = "Auswechselbar"
   Case 3
    DriveTypName$ = "Festplatte"
   Case 4
    DriveTypName$ = "Netzlaufwerk"
   Case 5
    DriveTypName$ = "CD-Rom"
   Case 6
    DriveTypName$ = "RAM-Disk"
  End Select

End Function



Und dazu ein par Beispiele:
Code:

Sub AlleFilesImOrdnerUndUnterordnerInTabelleAusgebenMitGroesse()

Dim lngI As Long
Dim strRoot As String
Dim strFilePlatzhalter As String
Dim lngInstanz As Long    'zählt die instanz der Recursiven Aufrufe. Keinen Wert übergeben!
Dim strSearchFile As String
Dim wks As Worksheet

Set wks = Worksheets.Add 'Fürs Beispiel ein neues Sheet
'oder:
'Set wks = Worksheets("Tabelle3") ' Beispiel ein bestimmtes Sheet
'wks.UsedRange.EntireRow.Delete 'vorher leeren

ReDim lngFileAttributes(0) As Long 'array enthält die zu den Files gehörenden Atribute
ReDim strFiles(0) As String        'array enthält alle gefundenen File

strRoot = "D:\Test\" 'Beispiel Anpassen!!!
'strRoot = "C:\" 'Beispiel Anpassen
strFilePlatzhalter = "*.*" 'darf nicht verändert (!!!) werden sonst werden nicht alle gefunden

strSearchFile = "*.xls" ' oder zB: "*.xls"  "*.*" (alle Files)  ''Hier kannst du den gesuchten Filenamen
                               '  mit oder ohne Joker zb: "Test.doc"  eintragen

Call GetAllFiles(strRoot, strFilePlatzhalter, strFiles, lngFileAttributes, strSearchFile, (lngInstanz))

'Beispiel Die gefundenen Files in Sheet schreiben
Application.ScreenUpdating = False
If UBound(strFiles) > 0 Then
 ReDim Preserve strFiles(0 To UBound(strFiles) - 1) 'das letzte ist immer leer
 For lngI = LBound(strFiles) To UBound(strFiles)
  wks.Cells(lngI + 1, 2) = strFiles(lngI)
  wks.Cells(lngI + 1, 1) = FileLen(strFiles(lngI))
 Next
Else
 wks.Cells(1, 2).Value = "Nichts gefunden!"
End If
Application.ScreenUpdating = True
End Sub


     
 Sub AlleUnterOrdnerInEinerSheetAusgeben()
 
  'Alle UnterOrdner in einer Tabelle ausgeben
 Dim strDirArray$()
 Dim strRoot$
 Dim strSearchDirctory$
 Dim xi&
 
 strRoot = "C:\Windows"  'Beispiel
 strSearchDirctory = "*.*"  'Beispiel auch: "Mein Ordner" Oder "Ordner*.*"
 
 Call FindAllDirctory(strRoot, strSearchDirctory, strDirArray())
 
 Application.ScreenUpdating = False
 For xi = 0 To UBound(strDirArray)
  ThisWorkbook.Worksheets(3).Cells(xi + 1, 1).Value = strDirArray(xi)
 Next
 Application.ScreenUpdating = True
 
 End Sub


Sub AlleLaufwerkeAnzeigen()
 
 ReDim strAllDrivesName$(0)
 ReDim lngAllDrivesTypNr&(0)
 
 Dim xi&
 Dim strTxt$
 Call AlleLaufwerke(strAllDrivesName(), lngAllDrivesTypNr())
 
 For xi& = 1 To UBound(strAllDrivesName$())
  strTxt$ = strTxt$ & strAllDrivesName(xi&) & " " & DriveTypName$(lngAllDrivesTypNr&(xi&)) & Chr$(13)
 Next
 MsgBox strTxt$
 
End Sub



Gruß
r.mueller
Planet_Jen
Gast


Verfasst am:
24. Apr 2014, 12:39
Rufname:

AW: With Application.FileSearch Ersatz für Word Makro - AW: With Application.FileSearch Ersatz für Word Makro

Nach oben
       Version: Office 2013

Vielen Dank für die schnelle Antwort!!!

Leider bin ich überfordert. Sad

Das scheint ja auf Excel gemünzt zu sein, habe jetzt worksheet immer ersetzt durch document, aber nun meckert er, weil die Variable nicht mehr definiert ist.

Ich steh wohl auf dem Schlauch... Was kann ich tun?
Vielen vielen Dank!

Hier mal mein Versuch... Wink

Code:
Sub AlleFilesImOrdnerUndUnterordnerInTabelleAusgebenMitGroesse()

Dim lngI As Long
Dim strRoot As String
Dim strFilePlatzhalter As String
Dim lngInstanz As Long    'zählt die instanz der Recursiven Aufrufe. Keinen Wert übergeben!
Dim strSearchFile As String
Dim doc As Document

Set doc = Document.Add 'Fürs Beispiel ein neues Sheet
'oder:
'Set wks = Worksheets("Tabelle3") ' Beispiel ein bestimmtes Sheet
'wks.UsedRange.EntireRow.Delete 'vorher leeren

ReDim lngFileAttributes(0) As Long 'array enthält die zu den Files gehörenden Atribute
ReDim strFiles(0) As String        'array enthält alle gefundenen File

strRoot = "C:\Users\..." 'Beispiel Anpassen!!!
'strRoot = "C:\" 'Beispiel Anpassen
strFilePlatzhalter = "*.*" 'darf nicht verändert (!!!) werden sonst werden nicht alle gefunden

strSearchFile = "*.*" ' oder zB: "*.xls"  "*.*" (alle Files)  ''Hier kannst du den gesuchten Filenamen
                               '  mit oder ohne Joker zb: "Test.doc"  eintragen

Call GetAllFiles(strRoot, strFilePlatzhalter, strFiles, lngFileAttributes, strSearchFile, (lngInstanz))

'Beispiel Die gefundenen Files in Sheet schreiben
Application.ScreenUpdating = False
If UBound(strFiles) > 0 Then
 ReDim Preserve strFiles(0 To UBound(strFiles) - 1) 'das letzte ist immer leer
 For lngI = LBound(strFiles) To UBound(strFiles)
  wks.Cells(lngI + 1, 2) = strFiles(lngI)
  wks.Cells(lngI + 1, 1) = FileLen(strFiles(lngI))
 Next
Else
 wks.Cells(1, 2).Value = "Nichts gefunden!"
End If
Application.ScreenUpdating = True
End Sub
r.mueller
Gast


Verfasst am:
24. Apr 2014, 15:16
Rufname:

AW: With Application.FileSearch Ersatz für Word Makro - AW: With Application.FileSearch Ersatz für Word Makro

Nach oben
       Version: Office 2013

Hallo
hab dirs mal angepasst
Code:

Sub AlleFilesImOrdnerUndUnterordnerInTabelleAusgebenMitGroesse()

 Dim lngI As Long
 Dim strRoot As String
 Dim strFilePlatzhalter As String
 Dim lngInstanz As Long    'zählt die instanz der Recursiven Aufrufe. Keinen Wert übergeben!
 Dim strSearchFile As String
 Dim doc As Document


 Set doc = Documents.Add 'Fürs Beispiel ein neues Sheet
 'oder:
 'Set wks = Worksheets("Tabelle3") ' Beispiel ein bestimmtes Sheet
 'wks.UsedRange.EntireRow.Delete 'vorher leeren

 ReDim lngFileAttributes(0) As Long 'array enthält die zu den Files gehörenden Atribute
 ReDim strFiles(0) As String        'array enthält alle gefundenen File

 'strRoot = "C:\Users\..." 'Beispiel Anpassen!!! Keine Zeichen nach dem: \ !!!!!
 strRoot = "C:\Users\" 'Beispiel Anpassen!!! Keine Punkte nach dem: \ !!!!!
 'strRoot = "C:\" 'Beispiel Anpassen
 strFilePlatzhalter = "*.*" 'darf nicht verändert (!!!) werden sonst werden nicht alle gefunden

 'strSearchFile = "*.*" ' oder zB: "*.xls"  "*.*" (alle Files)  ''Hier kannst du den gesuchten Filenamen
 strSearchFile = "*.docx" ' oder zB: "*.doc", "*.docx",  "*.*" (alle Files)  ''Hier kannst du den gesuchten Filenamen
                                '  mit oder ohne Joker zb: "Test*.doc"  eintragen

 Call GetAllFiles(strRoot, strFilePlatzhalter, strFiles, lngFileAttributes, strSearchFile, (lngInstanz))

 'Beispiel Die gefundenen Files in Doc schreiben
 Application.ScreenUpdating = False
 If UBound(strFiles) > 0 Then
  ReDim Preserve strFiles(0 To UBound(strFiles) - 1) 'das letzte ist immer leer
  For lngI = LBound(strFiles) To UBound(strFiles)
   doc.Range(doc.Range.End - 1, doc.Range.End).Text = FileLen(strFiles(lngI)) & vbTab
   doc.Range(doc.Range.End - 1, doc.Range.End).Text = strFiles(lngI) & vbCrLf
   'wks.Cells(lngI + 1, 2) = strFiles(lngI)
   'wks.Cells(lngI + 1, 1) = FileLen(strFiles(lngI))
  Next
 Else
  doc.Range(doc.Range.End - 1, doc.Range.End).Text = "Nichts gefunden!"
  'wks.Cells(1, 2).Value = "Nichts gefunden!"
 End If
 Application.ScreenUpdating = True
 End Sub


Gruß
r.mueller
theoS
WORD/Excel Erfahren und VBA Bastler


Verfasst am:
26. Apr 2014, 00:53
Rufname: theo

AW: With Application.FileSearch Ersatz für Word Makro - AW: With Application.FileSearch Ersatz für Word Makro

Nach oben
       Version: Office 2013

Dieses FileSearch hat wohl was gehabt.
Ich hatte diese Funktion ja manuell schon sehr gerne gehabt, weil sie besser und schneller war als die Windowssuche mit dem Hund Surprised)
Die Lösung von r.mueller ist wohl die umfassende Lösung, ich erschrecke aber immer vor diesem ganze Rattenschwanz - oder sollte ich -schnauze dazu sagen, die man da vorneweg als Code einbauen muss.

Für das Problem das sich hier stellt, hab ich mal einen Versuch gemacht, einen in einer Excel-Seite angefangenen Codeschnipsel rekursiv zu machen.
Also bei mir hats alle Dateien (mit oder ohne Filter, je nach Einstellung) auch aus den Unterordnern ausgelesen. (War ganz schon anstrengend, die Testbedingungen herzustellen Surprised))
Würd mich mal interessieren, obs das auch bei anderen tut.

Code:
Option Explicit
Sub Test() 'Ersatz für Application.FileSearch entwickeln und testen
Dim Pfad As String 'Startpfad
Dim Daten As New Collection 'gesammelte Ergebinsse
Dim Eintrag
'die folgenden Zeilen nur wenn eine manuelle Ordnerauswahl erfolgen soll
'Dim fiPi As FileDialog, fiIt, fi
'Set fiPi = Application.FileDialog(msoFileDialogFolderPicker)
'With fiPi
'.AllowMultiSelect = True
' If .Show = -1 Then
' End If
'End With
'For Each fi In fiPi.SelectedItems
'fiIt = fi
'Next fi
'Pfad = fiIt
'Pfad = CurDir '=ActiveDocument.Path  'ThisWorkbook.Path 'wenn dieses Programm unter Excel läuft 'Pfad = ActiveDocument.Path 'falls es unter Word laufen soll
Pfad = ActiveDocument.Path
Call FileList(Daten, Pfad, "*.do*", True) 'Alles im aktuellen Ordner incl. Unterordner
If Daten.Count = 0 Then
MsgBox ("In Ordner " & Pfad & " Nichts gefunden.")
Exit Sub
End If
Dim i
i = 1
For Each Eintrag In Daten 'Testausgabe im Direktbereich (Funktionen: siehe voriger Abschnitt)
Debug.Print Daten(i) 'Pfadname_von(Eintrag) & " " & Dateiname_von(Eintrag) 'hier könnten dann Ihre weiteren Befehle stehen '... '...
i = i + 1
Next Eintrag
'Set fiPi = Nothing
End Sub


Sub FileList(Daten As Collection, Pfad As String, _
Optional Filter As String = "", _
Optional SubDIR As Boolean = False)
'Inhalt eines Ordners ermitteln
'Lösung mit dem Befehl Dir() ohne Rekursion '
'Optionaler Parameter Filter: z. B. "*.xl*" für Excel-Dateien ' oder "*.doc*" für Word-Dateien
' ohne diesen Parameter werden auch Ordnernamen mit ausgegeben '
'Optionaler Parameter SubDIR: True : mit Suche von Unterordnern '
' False : keine Suche in Unterordnern
Dim OneItem As String, Xitem As String
Filter = Trim(Filter)
If Right$(Pfad, 1) <> "\" Then Pfad = Pfad & "\" 'ersten Eintrag im Ordner lesen

    If SubDIR Or (SubDIR = False And Filter = "") Then
    'hier werden erst mal die Unterordner bestimmt
    Xitem = Dir(Pfad & "", vbDirectory)
    While Xitem <> ""
    If Xitem <> "." And Xitem <> ".." Then
        Dim shnuB, OrdnerDaten As New Collection 'nimmt die U-Ordner auf
        On Error Resume Next 'qad Lösung, weil sonst bei manchen Dateien Unfug entsteht
        'will hier aber nur Ordner haben
        shnuB = GetAttr(Pfad & Xitem)
            If shnuB = 16 Then OrdnerDaten.Add (Pfad & Xitem)
    End If
    Xitem = Dir 'nächsten Eintrag im Ordner lesen
    Wend
   
    End If 'Eintrag verarbeiten u. nächsten Eintrag lesen
     OneItem = Dir(Pfad & Filter, vbDirectory)
'    OneItem = Dir(Pfad & Filter)
    While OneItem <> ""
    If OneItem <> "." And OneItem <> ".." Then
    'Ergebnisse sammeln:Pfad & Dateiname
'    Daten.Add (Pfad & OneItem)'wenn man den Pfad noch dazu haben will
     Daten.Add (OneItem)
    End If
OneItem = Dir 'nächsten Eintrag im Ordner lesen
Wend
Dim i
i = 1
If OrdnerDaten.Count <> 0 Then
For i = 1 To OrdnerDaten.Count
Call FileList(Daten, OrdnerDaten(i), Filter, True)
Next i
End If
End Sub


Auf der Seite ( http://www.klicktipps.de/excel-tipps-application-filesearch.php ) ist noch eine Lösung drauf, die das ScriptingFileObject verwendet und auch rekursiv arbeitet. Die sieht auch ganz interessant aus, hab ich aber noch nicht getestet

_________________
theo s.
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Word Serienbriefe: Einbinden Textmarken und Makro aus DOT-Datei in Serienbrief 0 hurganator 689 21. Feb 2012, 10:36
hurganator Einbinden Textmarken und Makro aus DOT-Datei in Serienbrief
Keine neuen Beiträge Word VBA Programmierung (Makros): Makro aktivieren 8 crstar77 65285 10. März 2011, 16:36
Gast Makro aktivieren
Keine neuen Beiträge Word Formate: Formatvorlagen suchen und ersetzen mit Makro 8 zausel 4042 09. Jan 2011, 18:09
elukas Formatvorlagen suchen und ersetzen mit Makro
Keine neuen Beiträge Word Formate: Word Formatvorlagen per Makro ändern 4 NightFog 6551 29. Jun 2005, 19:01
NightFog Word Formatvorlagen per Makro ändern
Keine neuen Beiträge Word VBA Programmierung (Makros): Makro beim Start ausführen? 3 Gast 7567 21. März 2005, 17:05
Drumatiker Makro beim Start ausführen?
Keine neuen Beiträge Word VBA Programmierung (Makros): Dokument neu speichern aber ohne Makro 1 Lara a 880 21. März 2005, 15:46
Gast Dokument neu speichern aber ohne Makro
Keine neuen Beiträge Word VBA Programmierung (Makros): Per Makro duplex drucken! - W97 3 Der Zivi 6352 03. März 2005, 15:35
Der Klaus Per Makro duplex drucken! - W97
Keine neuen Beiträge Word VBA Programmierung (Makros): Makro / VBA für Inhalte einfügen/Als Grafik(WMF) 2 CaBe 4949 13. Feb 2005, 19:01
CaBe Makro / VBA für Inhalte einfügen/Als Grafik(WMF)
Keine neuen Beiträge Word VBA Programmierung (Makros): Makro für Anfänger 1 Gast 4633 19. Jan 2005, 10:58
tessi Makro für Anfänger
Keine neuen Beiträge Word VBA Programmierung (Makros): Makro für Druckeinstellungen 1 HJP 2907 19. Dez 2004, 17:05
Günny Makro für Druckeinstellungen
Keine neuen Beiträge Word VBA Programmierung (Makros): mit Makro verknüpfte Dokumentvorlage nach Word 2003 migrier 1 Karl Heinz 1008 06. Dez 2004, 01:51
Lisa mit Makro verknüpfte Dokumentvorlage nach Word 2003 migrier
Keine neuen Beiträge Word VBA Programmierung (Makros): Makro zum Speichern jeder einzelnen Seite benötigt 1 Steve 905 11. Okt 2004, 14:48
Irgendwer Makro zum Speichern jeder einzelnen Seite benötigt
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: HTML CSS