Playing with OpenAsTextStream

Sub ParseFile()
Dim fsys As FileSystemObject, fsfile As File, stream As TextStream

    'Set FileSystemObject variables (Early binding)
    Set fsys = New FileSystemObject
    Set fsfile = fsys.GetFile(sFolderName & sParseFile)
    Set stream = fsfile.OpenAsTextStream(1, 0)

End Sub

Sub ParseFile()
Dim fsys As Object, fsfile As Object, stream As Object

    'Set FileSystemObject variables (Late binding)
    Set fsys = CreateObject("Scripting.FileSystemObject")
    Set fsfile = fsys.GetFile(sFolderName & sParseFile)
    Set stream = fsfile.OpenAsTextStream(1, 0)

End Sub

Option Explicit

Sub ParseFile()
'**************************************************************************
' Code written by Nick Hodge 12th March 2008
'V1.0 into production same day. versions below.
'V1.1 added error handling and check for file name ending in 'E' (13/3/2007)
'V1.2 added checking for * as first character of line and change it to <li>
'for an html bullet, also strip out line starting Ship Wt. (13/3/2007)
'**************************************************************************

'Navigate to a folder and the code will iterate over any text files taking the first
'line with text in it and assigning it to the strLine1 variable. It does the same for
'second and third lines and then assigns them to columns 1, 2, 3 in a new workbook
'laying them out in proper field/record format for importing to web
'File format should have item number as first line (no matter if blank lines above
'Product title on second line, no matter if blanks above and rest of copy after that

'File and folder name variables
Dim sFullPathFilename As String, sFolderName As String, sParseFile As String
'New workbook and worksheet variables
Dim wb As Workbook, wks As Worksheet
'Counter to count iterations, used in row placement on sheet and counter for postion
'of slash in path name (before filename)
Dim lCounter As Long, lSlashPosition As Long, iwksCount As Integer
'Filesytem object variables to hold file, textstream, etc.
Dim fsys As FileSystemObject, fsfile As File, stream As TextStream
'Variable to hold lines of text for later assignment to worksheet
Dim strLine1 As String, strLine2 As String, strLine3 As String, strTemp As String
'Booleans to stop loop after line 1 found, etc.
Dim bLine1Fnd As Boolean, bLine2Fnd As Boolean

On Error GoTo errHandler

'Get folder to use by clicking on file
sFullPathFilename = Application.GetOpenFilename("Text Files, *.txt", , "Select any file in the folder")

'Check to see selection made
If sFullPathFilename = "False" Then
    MsgBox "You must click on any file in the folder", vbOKOnly, "No Folder Selected"
    Exit Sub
End If

'Get position of last slash and parse folder from this
lSlashPosition = InStrRev(sFullPathFilename, "\", -1)
If lSlashPosition = 0 Then
    MsgBox "We cannot recognise the folder name, exiting procedure", vbOKOnly + vbExclamation, "Error"
    Exit Sub
End If

'Open workbook and set variables
Set wb = Workbooks.Add
Set wks = wb.Worksheets("Sheet1")

'Change sheet name
wks.Name = "Data"

'Switch off application events
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
   
'Delete surplus worksheets
With wb
    For iwksCount = .Worksheets.Count To 1 Step -1
        If .Worksheets(iwksCount).Name <> "Data" Then
        .Worksheets(iwksCount).Delete
        End If
    Next iwksCount
End With

'Set headings and bold
With wks
    .Range("A1").Value = "ItemNo"
    .Range("B1").Value = "Title"
    .Range("C1").Value = "WebText"
    .Rows("1:1").Font.Bold = True
End With

sFolderName = Left(sFullPathFilename, lSlashPosition)

'Start iteration of folder using folder name and files ending in E.txt
sParseFile = Dir(sFolderName & "*E.txt")

'Intialise counter to 2 which starts it on second row, below titles
lCounter = 2

'Do for each file Dir function is called recursively and returns "" when no more files match
Do While sParseFile <> ""

'Initialise booleans
bLine1Fnd = False
bLine2Fnd = False

    'Set FileSystemObject variables (Late binding)
    Set fsys = CreateObject("Scripting.FileSystemObject")
    Set fsfile = fsys.GetFile(sFolderName & sParseFile)
    Set stream = fsfile.OpenAsTextStream(1, 0)

    'Do so long as the endoffile marker is false, sets first line of text
    'Accounts for blank lines
    Do While stream.AtEndOfStream = False
            Do While bLine1Fnd = False
            strTemp = stream.ReadLine
                If strTemp <> "" Then
                    strLine1 = strTemp
                    bLine1Fnd = True
                    strTemp = ""
                End If
            Loop
            'sets second line of text, accounts for blank lines
            Do While bLine2Fnd = False
            strTemp = stream.ReadLine
                If strTemp <> "" Then
                    strLine2 = strTemp
                    bLine2Fnd = True
                    strTemp = ""
                End If
            Loop
            'Once 1st and 2nd lines are full then take averything else, line by line
            strTemp = stream.ReadLine
            'Check if line is ship wt., if so discard
                If Left(UCase(strTemp), 6) = "* SHIP" Then strTemp = ""
                'Build 3rd lines changing * to <li> for html bullet, else just add the next line to the copy
                If strTemp <> "" Then
                    If Left(strTemp, 1) = "*" Then
                        strTemp = "<li>" & Mid(strTemp, 2, Len(strTemp) - 1)
                        strLine3 = strLine3 & strTemp & Chr(10)
                    Else
                        strLine3 = strLine3 & strTemp & Chr(10)
                    End If
                End If
                
    Loop
    
    'Close stream and release object variables
    stream.Close

    Set stream = Nothing
    Set fsfile = Nothing
    Set fsys = Nothing
    
    'Assign the strings to worksheet
    With wks
        .Cells(lCounter, 1).Value = strLine1
        .Cells(lCounter, 2).Value = strLine2
        .Cells(lCounter, 3).Value = Left(strLine3, Len(strLine3) - 1)
        .Columns.AutoFit
        .Columns(3).ColumnWidth = 200
        .Rows.AutoFit
    End With
    
    'Clear strings for next iteration
    strLine1 = ""
    strLine2 = ""
    strLine3 = ""
    
    'Increment counter so text is placed on next row
    lCounter = lCounter + 1

    'Start next iteration of files in folder
    sParseFile = Dir()

Loop
    
    'Turn application events back on
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

MsgBox " Successfully parsed " & lCounter - 2 & " *.txt files" & Chr(13) & "From " & sFolderName, _
    vbInformation + vbOKOnly, "Parsed Successfully"

Exit Sub

'Error handling routine to exit gracefully
errHandler:

MsgBox "There has been an error, please advise add-in creator" & Chr(13) & _
    "The routine failed on: " & sParseFile, vbOKOnly + vbCritical

If Not wb Is Nothing Then
    wb.Close SaveChanges:=False
End If

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

Exit Sub

End Sub