Re: Moment
07.06.2002 08:44:22
andré
sowas änliches hab ich auch grad gebaut, nur das ich die dateien dann etwas komplizierter duchsuche. (das steht zwischen den kommentarzeilen) aber die suchroutine (supercool!!!) kannst du ja verwenden. es ginge garantiert auch einfacher mit appication.filesearch aber ich habs so gemacht dann kann ichs später vielleicht auch mal in VB einsetzen.viel Spaß
Option Explicit
Dim Such As String
Dim Pfad As String
Private Type DB
Pfad As String
Indx As Long
Ebene As Integer
End Type
Dim FolderDB() As DB
Dim Indx As Long 'zähler für speipfad
Dim Ebene As Integer 'zähler für Ordnerebene
Dim i As Long
Dim LstEin As String
Dim ActSh As Worksheet
Dim ActRe As Range
Dim TmpStr As String
Dim Msg
Dim Suchtxt As String
Dim Ersetztxt As String
Private Sub cmd_Click()
Msg = MsgBox("Prozess für den Ordner:" & Chr(13) + Chr(10) & txt_Pfad.Text & Chr(13) + Chr(10) & "starten?", 4404, "Prozess starten")
If Msg = 7 Then
Exit Sub
End If
lst.Clear
Erase FolderDB()
ReDim FolderDB(0)
Indx = 0
Ebene = 0
Suchtxt = txt_suchtxt.Text
Ersetztxt = txt_ersetztxt.Text
FolderDB(0).Pfad = txt_Pfad.Text
FolderDB(0).Indx = 0
FolderDB(0).Ebene = 0
While FolderDB(0).Pfad <> ""
Pfad = FolderDB(0).Pfad
Indx = FolderDB(0).Indx
Ebene = FolderDB(0).Ebene
Such = Dir(Pfad, vbDirectory)
While Such <> ""
If Such <> ".." And Such <> "." Then
If GetAttr(Pfad & Such) = 16 Then
'wenn ordner
LstEin = ""
For i = 0 To Ebene - 1
LstEin = LstEin & "| "
Next i
LstEin = LstEin & "|-|" & Such
lst.AddItem LstEin, Indx
For i = 1 To UBound(FolderDB())
If FolderDB(i).Indx > Indx Then
FolderDB(i).Indx = FolderDB(i).Indx + 1
End If
Next i
ReDim Preserve FolderDB(UBound(FolderDB()) + 1)
FolderDB(UBound(FolderDB())).Pfad = Pfad & Such & "\"
FolderDB(UBound(FolderDB())).Indx = Indx + 1
FolderDB(UBound(FolderDB())).Ebene = Ebene + 1
Indx = Indx + 1
Else
'wenn datei
'-----------------------------------------------------datei bearbeiten-----------------------------
If InStr(Such, ".xls") Then
Application.ScreenUpdating = False
Workbooks.Open Filename:=Pfad & Such, UpdateLinks:=0
Application.DisplayAlerts = False
For Each ActSh In Worksheets
ActSh.Activate
ActiveSheet.Unprotect ("qmp")
For Each ActRe In ActSh.UsedRange.Cells
ActRe.Activate
If ActRe.HasFormula Then
If InStr(ActRe.Formula, Suchtxt) Then
ActRe.Formula = Replace(ActRe.Formula, Suchtxt, Ersetztxt)
End If
End If
Next ActRe
ActiveSheet.Protect "qmp", DrawingObjects:=True, Contents:=True, Scenarios:=True
Next ActSh
Application.DisplayAlerts = False
ActiveWorkbook.Save
ActiveWindow.Close
Application.ScreenUpdating = True
End If
'-----------------------------------------------------datei bearbeiten ende-----------------------------
LstEin = ""
For i = 0 To Ebene - 1
LstEin = LstEin & "| "
Next i
LstEin = LstEin & "|-" & Such
lst.AddItem LstEin, Indx
For i = 1 To UBound(FolderDB())
If FolderDB(i).Indx > Indx Then
FolderDB(i).Indx = FolderDB(i).Indx + 1
End If
Next i
Indx = Indx + 1
End If
End If
Such = Dir
Wend
For i = 1 To UBound(FolderDB())
FolderDB(i - 1).Pfad = FolderDB(i).Pfad
FolderDB(i - 1).Indx = FolderDB(i).Indx
FolderDB(i - 1).Ebene = FolderDB(i).Ebene
Next i
If UBound(FolderDB()) > 0 Then
ReDim Preserve FolderDB(UBound(FolderDB()) - 1)
Else
FolderDB(0).Pfad = ""
End If
Wend
MsgBox "erfolgreich abgeschlossen", , "Meldung"
End Sub