Data Extraction with Excel VBA from .msg files

Disclaimer: I am a beginner with VBA.

I started off trying to create a VBA code that would extract certain text from a folder full of .msg files (Outlook 2007) and put them in a a blank workbook.

After a lot of google it seemed to me that its impossible to get a text stream to parse from msg files. So I tried to save a few of the msg files as txt files and used the following code on it. It worked fine!

Now the challenge is, I tried a code to batch rename the extension of the .msg files to .txt files. Just renaming the files (Not SaveAs txt) results in files with a lot of garbage headers in the file and the code doesn't work.

Please help me with some code which would either:
A> create a text stream directly from .msg files OR
B> copy the legible section of the renamed files into a temporary txt file for parsing OR
C> modify the code to work in spite of the garbage headers OR
D> any other ideas to make this work that I didn't think of.

Please check the attached zip files with all the working files.

Sub CRMIDCollate()

Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim wkbk As Workbook
Dim wks As Worksheet

'change to point at the folder to check
MyPath = Worksheets(1).TextBox1.Text

If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath & "\"
End If

'just in case the path isn't correct.
On Error Resume Next
    myFile = Dir(MyPath & "*.txt")
On Error GoTo 0

If myFile = "" Then
    MsgBox "no files found"
    Exit Sub
End If

'get the list of files
fCtr = 0
Do While myFile <> ""
    fCtr = fCtr + 1
    ReDim Preserve myFiles(1 To fCtr)
    myFiles(fCtr) = myFile
    myFile = Dir()
Loop

If fCtr > 0 Then
    'some housekeeping
    myStrings = Array(LCase("Following are the Single Sign On login details for "), LCase("SSO User ID: "), LCase("Password: "))
    
    TotalExpectedValues = UBound(myStrings) - LBound(myStrings) + 1
    
    Set wks = Workbooks.Add(1).Worksheets(1)
    wks.Range("a1").Resize(1, TotalExpectedValues).Value = Array("Name", "CRM ID", "Password")
    
    For fCtr = LBound(myFiles) To UBound(myFiles)
        Call DoTheWork(MyPath & myFiles(fCtr), wks)
    Next fCtr
    
    wks.UsedRange.Columns.AutoFit
End If

End Sub


Sub DoTheWork(myFileName As String, wks As Worksheet)

Dim myNumber As Long
Dim myLine As String
Dim FileNum As Long
Dim oRow As Long
Dim FoundValues As Long
Dim iCtr As Long

With wks
    oRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With

wks.Cells(oRow, "A").Resize(1, TotalExpectedValues).Value = "Error"

FileNum = FreeFile
Close FileNum
Open myFileName For Input As FileNum

FoundValues = 0

Do While Not EOF(FileNum)
Line Input #FileNum, myLine
myLine = Trim(myLine) 'get rid of all leading/trailing spaces
For iCtr = LBound(myStrings) To UBound(myStrings)
If LCase(Left(myLine, Len(myStrings(iCtr)))) = myStrings(iCtr) Then
FoundValues = FoundValues + 1
wks.Cells(oRow, "A").Offset(0, iCtr).Value = Mid(myLine, Len(myStrings(iCtr)) + 1)
End If
If FoundValues = TotalExpectedValues Then
Exit For
End If
Next iCtr
Loop

Close FileNum

End Sub

BTW... If I have to use the renamed .txt files, then the garbage is before line 10 and after line 40. Can this code be modified to read only between line 10 & 40? That might work...