Thema: Dateinamen einlesen, Texte editieren

StandardModule: Modul1

Sub ListFiles()
   Dim sPath As String
   Dim iCounter As Integer
   sPath = GetDirectory("Verzeichnis auswählen:")
   If sPath = "" Then Exit Sub
   Range("A2:A65536").ClearContents
   With Application.FileSearch
      .NewSearch
      .Filename = "*.dxf"
      .LookIn = sPath
      .Execute
      .MatchTextExactly = True
      For iCounter = 1 To .FoundFiles.Count
         Cells(iCounter + 1, 1).Value = Dir(.FoundFiles(iCounter))
      Next iCounter
   End With
   Range("H1").Value = sPath
End Sub

Sub SearchAndChange()
   Dim FSO As Object
   Dim oFile As Object
   Dim oOFile As Object
   Dim oStrm As Object
   Dim oOStrm As Object
   Dim iRow As Integer
   Dim sTxt As String, sSource As String, sTarget As String
   Set FSO = New Scripting.FileSystemObject
   If IsEmpty(Range("H1")) Or IsEmpty(Range("H2")) Then
      Beep
      MsgBox "Quell- oder Zielverzeichnis fehlen!"
      Exit Sub
   End If
   iRow = 2
   Do Until IsEmpty(Cells(iRow, 1))
      sSource = Range("H1").Value & "\" & Cells(iRow, 1).Value
      sTarget = Range("H2").Value & "\" & Cells(iRow, 4).Value
      Set oFile = FSO.GetFile(sSource)
      Set oStrm = oFile.OpenAsTextStream(ForReading)
      sTxt = oStrm.ReadAll
      oStrm.Close
      If InStr(sTxt, Cells(iRow, 2).Value) Then
         sTxt = Replace(sTxt, Cells(iRow, 2).Value, Cells(iRow, 3).Value)
         FSO.CreateTextFile sTarget, True
         Set oOFile = FSO.GetFile(sTarget)
         Set oOStrm = oOFile.OpenAsTextStream(ForWriting)
         oOStrm.Write sTxt
         oOStrm.Close
      Else
         Cells(iRow, 5).Value = False
      End If
      MsgBox sTxt
      iRow = iRow + 1
   Loop
   Set FSO = Nothing
End Sub

StandardModule: Modul2

Public Type BROWSEINFO
   hOwner As Long
   pidlRoot As Long
   pszDisplayName As String
   lpszTitle As String
   ulFlags As Long
   lpfn As Long
   lParam As Long
   iImage As Long
End Type

Declare Function SHGetPathFromIDList Lib "shell32.dll" _
   Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
   ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
   Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetDirectory(Optional msg) As String
   Dim bInfo As BROWSEINFO
   Dim Path As String
   Dim r As Long, x As Long, pos As Integer
   bInfo.pidlRoot = 0&
   If IsMissing(msg) Then
      bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
   Else
      bInfo.lpszTitle = msg
   End If
   bInfo.ulFlags = &H1
   x = SHBrowseForFolder(bInfo)
   Path = Space$(512)
   r = SHGetPathFromIDList(ByVal x, ByVal Path)
   If r Then
      pos = InStr(Path, Chr$(0))
      GetDirectory = Left(Path, pos - 1)
   Else
      GetDirectory = ""
   End If
End Function

Beiträge aus dem Excel-Forum zu den Themen Extern und VBScript