Type headerInfo
drInit As String
docType As String
Name As String
AcctNumber As String
ssn As String
DOS As String
End Type

Option Explicit
Dim hdrInfo As headerInfo
Dim lasthdrinfo As headerInfo
Dim MyPath As String
Dim myName As String
Dim sameSSN As Boolean
Dim sameDOS As Boolean

'Below is the button click 
Private Sub Command1_Click()
Command1.Enabled = False
Dim ff1 As Integer
Dim strText As String
Dim strLine As String
Dim hdrText As String
Dim counter As Long
Dim j As Integer
Dim fso As New FileSystemObject
MyPath = "C:\Parse\"
Const hdrStart As String = "VWC"

If Not Right$(MyPath, 1) = "\" Then MyPath = MyPath & "\"
'MyPath = MyPath & "*.txt"
strText = ""
myName = Dir(MyPath)   ' Retrieve the first entry.
PBar1.Min = 0
PBar1.Max = fso.GetFolder(MyPath).Files.Count
Label5(1).Caption = PBar1.Max

Do While myName <> ""   ' Start the loop.
DoEvents
   If myName <> "." And myName <> ".." Then
      If Not GetAttr(MyPath & myName) = vbDirectory Then
         Label5(0).Caption = myName
         ff1 = FreeFile
         DoEvents
         Open MyPath & myName For Input As #ff1
            strText = ""
        Do While Not EOF(ff1)
            Line Input #ff1, strLine
        If InStr(1, strLine, hdrStart) Then
'            lastSSN = hdrInfo.ssn
'            lastDOS = hdrInfo.DOS
            'If Not hdrInfo.ssn = "" And Not hdrInfo.DOS = "" Then writeData strText
            hdrText = ""
            hdrText = strLine
            counter = 0
            While counter < 6
                Line Input #ff1, strLine
                hdrText = hdrText & strLine & vbCrLf
                        
                Select Case counter
                
                'Case Is = 0, 1, 4
                Case Is = 1
                    getNameAcct strLine
                Case Is = 2
                    getSSN strLine
                    If InStr(1, strLine, hdrInfo.ssn) Then
                        sameSSN = True
                    End If
                    
                Case Is = 4
                    getDOSmdInit strLine
                    If InStr(1, strLine, hdrInfo.DOS) Then
                        sameDOS = True
                    End If
                Case Is = 5
                    If InStr(1, strLine, "CONTINUED") Then
                    While InStr(1, strLine, "CONTINUED") Or InStr(1, strLine, Chr$(13) & Chr$(11))
                        hdrText = hdrText & strLine
                        Line Input #ff1, strLine
                    Wend
                    End If
                    getDocType strLine
                Case Else
                    
                End Select
                        
                counter = counter + 1
            Wend
                If Len(lasthdrinfo.ssn) = 0 Then
                   With lasthdrinfo
                    .AcctNumber = hdrInfo.AcctNumber
                    .docType = hdrInfo.docType
                    .DOS = hdrInfo.DOS
                    .drInit = hdrInfo.drInit
                    .Name = hdrInfo.Name
                    .ssn = hdrInfo.ssn
                   End With
                End If
                If lasthdrinfo.ssn = hdrInfo.ssn And lasthdrinfo.DOS = hdrInfo.DOS Then
                    strText = strText & hdrText & vbCrLf
                    Line Input #ff1, strLine
                Else
                    writeData strText
                    With lasthdrinfo
                        .AcctNumber = hdrInfo.AcctNumber
                        .docType = hdrInfo.docType
                        .DOS = hdrInfo.DOS
                        .drInit = hdrInfo.drInit
                        .Name = hdrInfo.Name
                        .ssn = hdrInfo.ssn
                    End With
                    strText = ""
                    strText = hdrText & vbCrLf
                End If
                    
            End If
                strText = strText & strLine & vbCrLf
            Loop
            writeData strText
         Close #ff1
      End If
   End If
   PBar1.Value = PBar1.Value + 1
   myName = Dir
Loop

MsgBox "Finished!", vbInformation, "Attention!"
PBar1.Value = PBar1.Min
For j = Label5.LBound To Label5.UBound
    Label5(j).Caption = ""
Next
Command1.Enabled = True
Set fso = Nothing
End Sub

Private Sub writeData(textString As String)
Dim ff2 As Integer
Dim fso As New FileSystemObject
Dim saveFolder As String
Dim dateOfSvc As String
Dim docType As String
Dim drInit As String
Dim FLName As String
Dim actNum As String

ff2 = FreeFile
If Not Len(textString) = 0 Then
    With lasthdrinfo
    saveFolder = MyPath & Left$(myName, Len(myName) - Len(fso.GetExtensionName(myName))) & "_"
    If fso.FolderExists(saveFolder) = False Then MkDir saveFolder
    dateOfSvc = .DOS
    docType = .docType
    drInit = .drInit
    FLName = .Name
    actNum = .AcctNumber
    ReplChars drInit, dateOfSvc, docType, FLName, actNum
    'dateOfSvc = Replace(dateOfSvc, "/", "")
    'docType = Replace(.docType, "/", "")
        Open saveFolder & "\" & drInit & "_" & dateOfSvc & "_" & docType & "_" & FLName & "_" & actNum & ".doc" For Output As #ff2
            Print #ff2, textString
        Close #ff2
    End With
End If
Set fso = Nothing
End Sub

Private Sub getNameAcct(namAct As String)
Dim namStart As Integer
Dim actStart As Integer

namStart = InStr(1, namAct, "Name:")
hdrInfo.Name = Trim$(Mid$(namAct, namStart + 7, 32))
actStart = InStrRev(namAct, "Acct. #:")
hdrInfo.AcctNumber = Trim$(Mid$(namAct, actStart + 10, (Len(namAct) - actStart - 9)))

End Sub

Private Sub getSSN(ssn As String)
Dim ssnStart As Integer

ssnStart = InStrRev(ssn, "SSN:")
hdrInfo.ssn = Trim$(Mid$(ssn, ssnStart + 10, Len(ssn) - ssnStart - 9))
End Sub

Private Sub getDOSmdInit(DOSMD As String)
hdrInfo.DOS = Trim$(Mid$(DOSMD, 1, 24))
hdrInfo.drInit = Trim$(Mid$(DOSMD, 25, Len(DOSMD) - 20))
End Sub


Private Sub getDocType(docType As String)
hdrInfo.docType = Trim$(docType)
End Sub

Private Sub ReplChars(DI As String, DOS As String, docType As String, FLName As String, actNum As String)
Dim i As Integer
Dim x(9)
x(0) = "/"
x(1) = "\"
x(2) = ":"
x(3) = "*"
x(4) = "?"
x(5) = Chr(34)
x(6) = ">"
x(7) = "<"
x(8) = "|"

For i = 0 To 8 'Replaces Illegal filename chars
    DI = Replace(DI, x(i), "-")
    DOS = Replace(DOS, x(i), "-")
    docType = Replace(docType, x(i), "-")
    FLName = Replace(FLName, x(i), "-")
    actNum = Replace(actNum, x(i), "-")
Next
Erase x

End Sub