Rename text file based on first line of text - vba

Question

I have a list of text files (all different names.txt, but small files).
I want to rename them based on the first line of text in the file.
Some files have a few enters before the text. So the code returns with a (blank).txt.
Sub RenameTextFile()
Const SpecialCharacters As String = "\,/,:,*,?,<,>,|,""," ' Modify this as neccesary
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, MyFile, FileName, TextLine
Dim char As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set fol = fso.GetFolder("C:\Research syntheses - Meta analysis\Txt files ECS\out\")
For Each fil In fol.Files
FileName = fil
Set MyFile = fso.OpenTextFile(FileName, ForReading)
Do While MyFile.AtEndOfStream <> True
Do
Dim tmpLine As String
TextLine = MyFile.ReadLine
tmpLine = RemoveWhiteSpace(TextLine)
If Len(tmpLine) = 0 Then
TextLine = tmpLine
End If
Loop Until Len(TextLine) > 0
MyFile.Close
For Each char In Split(SpecialCharacters, ",")
TextLine = Replace(TextLine, char, "")
Next
fil.Name = TextLine & ".txt"
Exit Do
Loop
MyFile.Close
Next fil
End Sub

Answer 1

You could add another loop to your code like that
Sub RenameTextFile()
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, MyFile, FileName, TextLine
Set fso = CreateObject("Scripting.FileSystemObject")
Set fol = fso.GetFolder("d:\tmp\")
For Each fil In fol.Files
FileName = fil
Set MyFile = fso.OpenTextFile(FileName, ForReading)
Do While MyFile.AtEndOfStream <> True
Do
Dim tmpLine As String
TextLine = MyFile.ReadLine
tmpLine = removeWhiteSpace(TextLine)
If Len(tmpLine) = 0 Then
TextLine = tmpLine
End If
Loop Until Len(TextLine) > 0
MyFile.Close
If isValidFilename(Trim(TextLine)) Then
On Error Resume Next
fil.Name = Trim(TextLine) & ".txt"
On Error Goto 0
Else
MsgBox "Renaming: " & fil.Name & " -to- " & Trim(TextLine) & " failed", vbCritical + vbOKOnly, "Invalid Filename"
End If
Exit Do
Loop
MyFile.Close
Next fil
End Sub
On the long run you need to think about kind of error handling as a file with the same name might already exist. And my extra loop will also fail in case one of the files only contains empty lines.
Update By the OP's comment I strongly guess that some of the files contain white spaces at the beginning and the OP is not aware of that. One can use the following function (taken from here) to remove these
'Add a reference to Microsoft VBScript Regular Expressions 5.5
Public Function RemoveWhiteSpace(ByVal target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
This will remove also white spaces from textline even if you want to keep them as the empty spaces in the line of your picture.
Update 2: In order to avoid invalid filename add the following function
Function isValidFilename(ByVal FileName As String) As Boolean
'PURPOSE: Determine If A Given Excel File Name Is Valid
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
With New RegExp
.Pattern = "[\\/:\*\?""<>\|\[\]]"
ValidFileName = Not .Test(FileName)
End With
End Function
I modified the main procedure.