VBA 打开资源管理器对话框，select txt 文件，并添加一个 header 即没有文件路径的文件名

Question

I have 100's of text files named correctly, but I need the name of the text file added into the first row (thus shifting the existing data down to the second row) with " on either side of the name.

The text files are over multiple folders, so I need to be able to open an explorer dialogue first to select multiple text files and add the new header row to every one.

Any help would be hugely appreciated as I cannot find the answer anywhere on google!

Tom

My attempt, but doesnt really work becaue 1. I have to set the directory, and 2. I need to have the filename with " either side, for example "Line1":

Sub ChangeRlnName()

    'the final string to print in the text file
    Dim strData As String
    'each line in the original text file
    Dim strLine As String
    Dim time_date As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    'Get File Name
    Filename = FSO.GetFileName("C:\Users\eflsensurv\Desktop\Tom\1.txt")
    
    'Get File Name no Extension
    FileNameWOExt = Left(Filename, InStr(Filename, ".") - 1)
    
    strData = ""
    time_date = Format(Date, "yyyymmdd")
    'open the original text file to read the lines
    Open "C:\Users\eflsensurv\Desktop\Tom\1.txt" For Input As #1
    'continue until the end of the file
    
    
    While EOF(1) = False
    'read the current line of text
    Line Input #1, strLine
    'add the current line to strData
    strData = strData + strLine & vbCrLf
    Wend
    
    'add the new line
    strData = FileNameWOExt + vbLf + strData
    Close #1
    'reopen the file for output
    Open "C:\Users\eflsensurv\Desktop\Tom\1.txt" For Output As #1
    Print #1, strData
    Close #1

End Sub

Answer 1

Try something like this:

Sub Tester()
    Dim colFiles As Collection, f
    
    'get all txt files under specified folder
    Set colFiles = GetMatches("C:\Temp\SO", "*.txt")
    
    'loop files and add the filename as a header
    For Each f In colFiles
        AddFilenameHeader CStr(f)
    Next f
End Sub


Sub AddFilenameHeader(fpath As String)
    Dim base, content
    With CreateObject("scripting.filesystemobject")
        base = .GetBaseName(fpath) 'no extension
        
        With .OpenTextFile(fpath, 1)
            'get any existing content
            If Not .AtEndOfStream Then content = .readall()
            .Close
        End With
        DoEvents
        'overwrite existing content with header and previous content
        .OpenTextFile(fpath, 2, True).write """" & base & """" & vbCrLf & content
    End With
End Sub

'Return a collection of file paths given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr, fpath
    Dim colFiles As New Collection
    Dim colSub As New Collection
    
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder
    
    Do While colSub.Count > 0
        
        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1
        
        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
        
        fpath = fldr.Path
        If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
        f = Dir(fpath & filePattern) 'Dir is faster...
        Do While Len(f) > 0
            colFiles.Add fpath & f
            f = Dir()
        Loop
    Loop
    Set GetMatches = colFiles
End Function