Option Compare Database

Sub Process_NPD_Questionnaire()
'
' Process_NPD_Questionnaire Macro
' Macro recorded 1/30/2003 by e06824

'Sub ShowFolderList(folderspec)
    Dim fs, f, f1, fc, s, ft, ts, ft1, ft2
    Dim fn As String, fo As String, fn2 As String, fn1 As String
    Dim full_text As String, head As String, tail As String, name As String, temp As String
    Dim b_q(25) As Integer, e_q(25) As Integer, e_name As Integer, i As Integer
    Dim b_title As Integer, e_title As Integer, b_ph As Integer, e_ph As Integer
    Dim b_email As Integer, e_email As Integer
    Dim dir_resp As String, dir_td As String, dir_td1 As String, dir_td2 As String
    Dim slash As Integer, posn As Integer


   'Directory pointers for responses, text export, text export part2
     dir_resp = "C:\Documents and Settings\A33115\My Documents\CCJC_2007_ICD_No Spill Lid.doc\"
     dir_td = "C:\Documents and Settings\A33115\My Documents\CCJC_2007_GSF_Idea_No Spill Lid.doc\"
     dir_td1 = "C:\Documents and Settings\A33115\My Documents\Integrated_Concept_Definition_v8.doc\"
     dir_td2 = "C:\Documents and Settings\A33115\My Documents\Gate_Summary_Form_v8.doc\"
    
    'Create FileSystemobject / Folder / Files
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(dir_resp)
    Set fc = f.Files
    
    'Cycle through each file in folddf
    For Each f1 In fc
         fo = f1
         'Find the filename (excluding path)
         slash = LastOccurrence(fo, "\")
         posn = InStr(slash + 1, f1, ".doc", vbTextCompare)
         'Create the text export file names (p1 & p2)
         fn = Mid(fo, slash + 1, posn - slash - 1) & ".txt"
         fn1 = Mid(fo, slash + 1, posn - slash - 1) & "_p1.txt"
         fn2 = Mid(fo, slash + 1, posn - slash - 1) & "_p2.txt"
         Debug.Print "Source: " & f1 & vbCrLf
         Debug.Print "Title: " & Mid(fo, slash + 1, posn - slash - 1); "    Slash: " & slash & "     Suffix: " & posn & "    Target: " & fn & vbCrLf
'        s = s & f1.Name
'        s = s & vbCrLf

'Sub ChangeOpenPath()
    'ChangeFileOpenDirectory Dir:="dir_resp"


        
        'Point to the source directory
        ChangeFileOpenDirectory (dir_resp)
        
        'Open the respective word doc
        Documents.Open FileName:=fo, ConfirmConversions:=False, _
        ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=wdOpenFormatAuto
        With Options
            .LocalNetworkFile = False
            .AllowFastSave = False
            .BackgroundSave = True
            .CreateBackup = False
            .SavePropertiesPrompt = False
            .SaveInterval = 0
            .SaveNormalPrompt = False
            .DisableFeaturesbyDefault = False
        End With
        
        'Set it to save as form data only
        With ActiveDocument
            .ReadOnlyRecommended = False
            .EmbedTrueTypeFonts = False
            .SaveFormsData = True            '<<<<<<<< Key Setting >>>>>>>>>
            .SaveSubsetFonts = False
            .DoNotEmbedSystemFonts = True
            .Password = ""
            .WritePassword = ""
            .DisableFeatures = False
            .EmbedSmartTags = True
            .SmartTagsAsXMLProps = False
            .EmbedLinguisticData = True
        End With
        Application.DefaultSaveFormat = "Text"  '<<<<<<<< File Format >>>>>>>>>
        
        'Change to the target directory & save all fields
        ChangeFileOpenDirectory (dir_td)
        ActiveDocument.SaveAs FileName:=fn, FileFormat:= _
            wdFormatText, LockComments:=False, Password:="", AddToRecentFiles:=True, _
            WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
             SaveNativePictureFormat:=False, SaveFormsData:=True, SaveAsAOCELetter:= _
            False, Encoding:=1252, InsertLineBreaks:=False, AllowSubstitutions:=False _
            , LineEnding:=wdCRLF
        ActiveDocument.Close
            
        
        'Read text created (all fields)
        Set ft = fs.GetFile(dir_td & fn)
        Set ts = ft.OpenAsTextStream(1, 0)
        full_text = ts.ReadAll
        'Debug.Print full_text & vbCrLf
        
        'Find the tail / beyond question 12
        e_name = InStr(2, full_text, Chr$(34), vbTextCompare)
        name = Left(full_text, e_name)
        Debug.Print "Name: " & name & " End: " & e_name & vbCrLf
        b_title = e_name + 2
        e_title = InStr(b_title + 1, full_text, Chr$(34), vbTextCompare)
        Debug.Print "Title: " & Mid(full_text, b_title, e_title - b_title + 1)
        b_ph = e_title + 2
        e_ph = InStr(b_ph + 1, full_text, Chr$(34), vbTextCompare)
        Debug.Print "Phone: " & Mid(full_text, b_ph, e_ph - b_ph + 1)
        b_email = e_ph + 2
        e_email = InStr(b_email + 1, full_text, Chr$(34), vbTextCompare)
        Debug.Print "email: " & Mid(full_text, b_email, e_email - b_email + 1)
        b_p1 = InStr(e_email + 1, full_text, Chr$(34), vbTextCompare)
        e_p1 = InStr(b_p1 + 1, full_text, Chr$(34), vbTextCompare)
        Debug.Print "P1: " & Mid(full_text, b_p1, e_p1 - b_p1 + 1)
        b_p2 = InStr(e_p1 + 1, full_text, Chr$(34), vbTextCompare)
        e_p2 = InStr(b_p2 + 1, full_text, Chr$(34), vbTextCompare)
        Debug.Print "P2: " & Mid(full_text, b_p2, e_p2 - b_p2 + 1)
        e_q(0) = e_p2
        For i = 1 To 23
            b_q(i) = InStr(e_q(i - 1) + 1, full_text, Chr$(34), vbTextCompare)
            e_q(i) = InStr(b_q(i) + 1, full_text, Chr$(34), vbTextCompare)
            Debug.Print "Q" & i & ": " & Mid(full_text, b_q(i), e_q(i) - b_q(i) + 1)
        Next i
        Debug.Print "B_Q12: " & b_q(12) & "   E_Q12: " & e_q(12)
                
        'Get the head
        head = Left(full_text, e_q(12))
        Debug.Print "Tail: " & tail
        
        'Write the head to a new file
        ChangeFileOpenDirectory (dir_td1)
        Set ft1 = fs.CreateTextFile(fn1, True)
        Set ft1 = fs.GetFile(fn1)
        Set ts = ft1.OpenAsTextStream(2, 0)
        ts.Writeline (head)
        ts.Close
        
        'Get the tail
        tail = Right(full_text, Len(full_text) - e_q(12))
        Debug.Print "Tail: " & tail
        
        'Write the tail to a new file
        ChangeFileOpenDirectory (dir_td2)
        Set ft2 = fs.CreateTextFile(fn2, True)
        Set ft2 = fs.GetFile(fn2)
        Set ts = ft2.OpenAsTextStream(2, 0)
        ts.Writeline (name & tail)
        ts.Close
        
    Next 'Next file in folder!!
End Sub

'

Function LastOccurrence(strSearchString As String, _
    strLastOccurrence As String) As Integer

    Dim intVal As Integer, intLastPos As Integer

    'Find the first occurrence of the specified character
    intVal = InStr(strSearchString, strLastOccurrence)
    
    'Find each next occurrence of the specified character
    Do Until intVal = 0
        'Keep track of the last position found
        intLastPos = intVal
        intVal = InStr(intLastPos + 1, strSearchString, strLastOccurrence)
    Loop
    
    'Return the last position found
    LastOccurrence = intLastPos

End Function