title image


Smiley Schau mal dies ist eine recursive suche durch Verzeichnisse
Ist ein fetzen aus eine alten Projekt von mir müsste eigentlich reichen..Steuerelemente Hinzufügenund was anpassen an dein Projekt und an der Stelle wo umbenannt wird kannst du dann löschen...Option ExplicitDim SearchFlag As Integer ' Wird als Attribut beim Abbrechen usw. verwendet.Public CounterPublic AltPublic NeuPublic EndungPublic aFunction Exists(f As String) As Integer Dim n As Integer On Error GoTo handler n = FreeFile die Datei Open f For Input Shared As #n Close #e Close #n Exists = True Exit Functionhandler: Rem Wenn dieser Code ausgeführt wird, existiert die Datei nicht Exists = False Exit FunctionEnd FunctionPrivate Sub cmdExit_Click() If cmdExit.Caption = "&Beenden" Then End Else ' Wenn Abbrechen gewählt wurde, die Suche beenden. SearchFlag = False End IfEnd SubPrivate Sub cmdSearch_Click()' Initialisiere für die Suche. Rufe dann DirDiver auf, um rekursive Suche durchzuführen.Dim FirstPath As String, DirCount As Integer, NumFiles As IntegerDim result As Integer ' Prüfe, was der Benutzer zuletzt durchgeführt hat: If cmdSearch.Caption = "&Zurücksetzen" Then ' Wenn gerade zurückgesetzt wurde, initialisiere und beende. ResetSearch txtSearchSpec.SetFocus Exit Sub End If ' Aktualisiere dirList.Path, wenn es nicht das im Moment ausgewählte ' Verzeichnis ist. Führe anderenfalls die Suche durch. If dirList.Path dirList.List(dirList.ListIndex) Then dirList.Path = dirList.List(dirList.ListIndex) Exit Sub ' Beende, so daß der Benutzer vor der Suche die Liste ansehen kann. End If ' Setze die Suche fort. Picture2.Move 3840, 0 Picture1.Visible = False Picture2.Visible = True cmdExit.Caption = "Abbrechen" filList.Pattern = txtSearchSpec.Text FirstPath = dirList.Path DirCount = dirList.ListCount ' Beginne rekursive Verzeichnissuche. NumFiles = 0 ' Setze globalen foundfiles-Indikator. result = DirDiver(FirstPath, DirCount, "") filList.Path = dirList.Path cmdSearch.Caption = "&Zurücksetzen" cmdSearch.SetFocus cmdExit.Caption = "&Beenden"End SubFunction Rename(entry)On Error GoTo fehlRem normal ".jpg" oder soDim Temp_pfad As StringDim wo As IntegerDim Mldg As StringDim stil As StringDim titel As StringDim antwort As StringEndung = Right(entry, 4)Counter = Counter + 1Alt = entryNeu = dirList.Path & "\" & "Ro" & Counter & EndungWinSeek.Caption = "Benenne um" & Alt & " nach " & NeuName Alt As NeuGoTo endefehl:Mldg = "Möchten Sie fortfahren ?" ' Meldung definieren.stil = vbYesNo + vbCritical + vbDefaultButton2 ' Schaltflächen titel = "MsgBox-Demonstration" ' Titel definieren.antwort = MsgBox(Mldg, stil, titel) ' Meldende:End FunctionPrivate Function DirDiver(NewPath As String, DirCount As Integer, BackUp As String) As Integer' Führe rekursive Suche in den Verzeichnissen unterhalb von NewPath durch...' NewPath wird in dieser Rekursion durchsucht.' BackUp ist die Quelle dieser Rekursion.' DirCount ist die Anzahl der Unterverzeichnisse in diesem Verzeichnis.Static FirstErr As IntegerDim DirsToPeek As Integer, AbandonSearch As Integer, ind As IntegerDim OldPath As String, ThePath As String, entry As StringDim retval As Integer SearchFlag = True ' Setze Attribut, so daß der Benutzer unterbrechen kann. DirDiver = False ' Setze auf TRUE, wenn ein Fehler auftrat. retval = DoEvents() ' Prüfe auf Ereignisse (z.B. Abbrechen durch den Benutzer). If SearchFlag = False Then DirDiver = True Exit Function End If On Local Error GoTo DirDriverHandler DirsToPeek = dirList.ListCount ' Wieviele Verzeichnisse befinden sich unter diesem? Do While DirsToPeek > 0 And SearchFlag = True OldPath = dirList.Path ' Speichere den alten Pfad für die nächste Rekursion. dirList.Path = NewPath If dirList.ListCount > 0 Then ' Get to the node bottom. dirList.Path = dirList.List(DirsToPeek - 1) AbandonSearch = DirDiver((dirList.Path), DirCount%, OldPath) End If ' Gehe eine Verzeichnisebene nach oben. DirsToPeek = DirsToPeek - 1 If AbandonSearch = True Then Exit Function Loop ' Rufe Funktion auf, um die Dateien aufzuzählen. If filList.ListCount Then If LenB(dirList.Path) ThePath = dirList.Path ' Auf der Stammverzeichnisebene unverändert lassen... Else ThePath = dirList.Path + "\" ' anderenfalls ein "\" vor dem Verzeichnisnamen einfügen. End If For ind = 0 To filList.ListCount - 1 ' Füge passende Dateien in diesem Verzeichnis zum Listenfeld hinzu. entry = ThePath + filList.List(ind) lstFoundFiles.AddItem entry lblCount.Caption = Str(Val(lblCount.Caption) + 1) a = Rename(entry) Next ind End If Rem If BackUp "" Then ' Wenn ein übergeordnetes Verzeichnis vorhanden ist, wechsle in dieses Verzeichnis. Rem dirList.Path = BackUp Rem End If Exit FunctionDirDriverHandler: If Err = 7 Then ' Wenn kein freier Speicher vorhanden ist: nimm an, daß das Listenfeld voll ist. DirDiver = True ' Erstelle Msg und setze gelieferten Wert AbandonSearch. MsgBox "Das Listenfeld ist voll. Die Suche wird abgebrochen..." Exit Function ' Beachten, daß die EXIT-Prozedur ERR auf 0 zurücksetzt. Else ' Zeige anderenfalls eine Fehlermeldung an und beende das Programm. MsgBox Error End End IfEnd FunctionPrivate Sub DirList_Change() ' Aktualisiere das Datei-Listenfeld, so daß es mit dem Dir-Listenfeld übereinstimmt. filList.Path = dirList.PathEnd SubPrivate Sub DirList_LostFocus() dirList.Path = dirList.List(dirList.ListIndex)End SubPrivate Sub DrvList_Change() On Error GoTo DriveHandler dirList.Path = drvList.Drive Exit SubDriveHandler: drvList.Drive = dirList.Path Exit SubEnd SubPrivate Sub Form_Load() Picture2.Move 0, 0 Picture2.Width = WinSeek.ScaleWidth Picture2.BackColor = WinSeek.BackColor lblCount.BackColor = WinSeek.BackColor lblCriteria.BackColor = WinSeek.BackColor lblfound.BackColor = WinSeek.BackColor Picture1.Move 0, 0 Picture1.Width = WinSeek.ScaleWidth Picture1.BackColor = WinSeek.BackColorEnd SubPrivate Sub Form_Unload(Cancel As Integer) EndEnd SubPrivate Sub ResetSearch() ' Initialisiere erneut, bevor eine neue Suche beginnt. lstFoundFiles.Clear lblCount.Caption = 0 SearchFlag = False ' Attribut zeigt die im Moment durchgeführte Suche an. Picture2.Visible = False cmdSearch.Caption = "&Suchen" cmdExit.Caption = "&Beenden" Picture1.Visible = True dirList.Path = CurDir: drvList.Drive = dirList.Path ' Setze DOS-Pfad zurück. Counter = 0End SubPrivate Sub txtSearchSpec_Change() ' Aktualisiere Dateilistenfeld, wenn der Benutzer das Suchmuster ändert. filList.Pattern = txtSearchSpec.TextEnd SubPrivate Sub txtSearchSpec_GotFocus() txtSearchSpec.SelStart = 0 ' Markiere den aktuellen Eintrag. txtSearchSpec.SelLength = Len(txtSearchSpec.Text)End Sub

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: