Importing data from MS Word to Access (1 Viewer)

[sbrown106]

Hi

I'm new to this website and have been advised to move my question to the VBA forum from Access. I tried to insert the link
but then could not post the thread so removed it.

Sorry about this but I am new to VBA, I know a bit but stuck on how to do this - so if anybody could help me with this please.

I have hundreds of forms as MS Word documents in the format below and would like to import them into Access.
So that the data in each form comes under one common field heading, so for example, there will be one top row in excel with
titles, Date of Birth, Phone Number etc. and all the data from the remaining forms falls under these headings. The original document doesn't contain
fields for entering , text input is just typed after the colon.

I am thinking, it may be that I create a table of this in Excel first and then pull this into Access

Is it possible to do something like this? are there similar examples somewhere I can view?

Thanks for any help. I've been doing it all manually at the moment copying and pasting so it would be great if
there was some way of speeding this up.

 

[bastanu]

Should be fairly easy to do, you need to use sequential "keywords" and extract the data between them. I have a free utility (http://forestbyte.com/ms-access-utilities/fba-outlook-email-parser-importer/) that you can download and adapt. You would need to set up the field template than do a loop through your files and import them.

Cheers,

 

[Pat Hartman]

If they are already saved as .txt, then open them using standard VBA I/O and read each line. You can ignore empty lines but anomalies will be a problem. For example "Company Name" isn't followed by a colon. Here's the outline of a procedure you can use. You will need to add the code that is specific to what you want to do with the file. I left the DAO stuff from my app in place so you have an example. Substitute your names in the Set statements and in the .AddNew

This is a cut and paste to give you an idea of what you need to do. It will not work as is. You need to customize it.

Public Sub ImportKSS(frm As Form)
    Dim db As DAO.Database
    Dim qd As DAO.QueryDef
    Dim tdD As DAO.TableDef     'Drawing
    Dim rsD As DAO.Recordset
    Dim FileNum As Long

   On Error GoTo ImportKISS_Error

    'strFullFileName = "C:\Data\DrawingProject\ExtractSamples\BS-2525_MIS_list.kss"
    strFullFileName = frm.txtPath
'Open recordsets
    Set db = CurrentDb()
    Set tdD = db.TableDefs!tblDrawings
    Set rsD = tdD.OpenRecordset(dbOpenDynaset, dbSeeChanges)

    FileNum = FreeFile
    Close FileNum
    Open strFullFileName For Input As FileNum
    DoEvents
    Do While Not EOF(FileNum)
        Line Input #FileNum, strLine
        Debug.Print strLine
    '''''Your code to parse line goes here   
    ''' this is a sample of populating a record using DAO.  Move the values to variables

    rsD.AddNew
        rsD!JobID = JobID
        rsD!DrawingNum = vDrawingNum
        rsD!DrawingPfx = vDrawingPfx
        rsD!DrawingSfx = vDrawingSfx
        rsD!FullDwgName = CurFullDwgNum     '(vDrawingPfx + "-") & vDrawingNum & ("-" + vDrawingSfx)
        rsD!DrawingTypeID = 9      'default type imported from KSS file
        rsD!Quantity = strDrec(5)
        rsD!AssemblyMark = strDrec(3)
        rsD!PartMark = strDrec(4)
        rsD!Desc = strDrec(11)
        rsD!UpdateBy = Environ("UserName")
        rsD!UpdateDT = Now()
        'DrawingID = rsD!DrawingID  'only works for Jet/ACE
    rsD.Update
    
    Loop
ImportKISS_Exit:

    rsD.Close
    Close FileNum
    Exit Sub

ImportKISS_Error:
    Select Case Err.Number
        Case 3022
            Resume Drec_Exit
        Case 9      'subscript out of range
            Resume Next
        Case Else
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ImportKISS of Module Module1"
            Resume ImportKISS_Exit
            Resume Next
    End Select
End Sub

 

[sbrown106]

If they are already saved as .txt, then open them using standard VBA I/O and read each line. You can ignore empty lines but anomalies will be a problem. For example "Company Name" isn't followed by a colon. Here's the outline of a procedure you can use. You will need to add the code that is specific to what you want to do with the file. I left the DAO stuff from my app in place so you have an example. Substitute your names in the Set statements and in the .AddNew

This is a cut and paste to give you an idea of what you need to do. It will not work as is. You need to customize it.

Public Sub ImportKSS(frm As Form)
    Dim db As DAO.Database
    Dim qd As DAO.QueryDef
    Dim tdD As DAO.TableDef     'Drawing
    Dim rsD As DAO.Recordset
    Dim FileNum As Long

   On Error GoTo ImportKISS_Error

    'strFullFileName = "C:\Data\DrawingProject\ExtractSamples\BS-2525_MIS_list.kss"
    strFullFileName = frm.txtPath
'Open recordsets
    Set db = CurrentDb()
    Set tdD = db.TableDefs!tblDrawings
    Set rsD = tdD.OpenRecordset(dbOpenDynaset, dbSeeChanges)

    FileNum = FreeFile
    Close FileNum
    Open strFullFileName For Input As FileNum
    DoEvents
    Do While Not EOF(FileNum)
        Line Input #FileNum, strLine
        Debug.Print strLine
    '''''Your code to parse line goes here  
    ''' this is a sample of populating a record using DAO.  Move the values to variables

    rsD.AddNew
        rsD!JobID = JobID
        rsD!DrawingNum = vDrawingNum
        rsD!DrawingPfx = vDrawingPfx
        rsD!DrawingSfx = vDrawingSfx
        rsD!FullDwgName = CurFullDwgNum     '(vDrawingPfx + "-") & vDrawingNum & ("-" + vDrawingSfx)
        rsD!DrawingTypeID = 9      'default type imported from KSS file
        rsD!Quantity = strDrec(5)
        rsD!AssemblyMark = strDrec(3)
        rsD!PartMark = strDrec(4)
        rsD!Desc = strDrec(11)
        rsD!UpdateBy = Environ("UserName")
        rsD!UpdateDT = Now()
        'DrawingID = rsD!DrawingID  'only works for Jet/ACE
    rsD.Update
   
    Loop
ImportKISS_Exit:

    rsD.Close
    Close FileNum
    Exit Sub

ImportKISS_Error:
    Select Case Err.Number
        Case 3022
            Resume Drec_Exit
        Case 9      'subscript out of range
            Resume Next
        Case Else
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ImportKISS of Module Module1"
            Resume ImportKISS_Exit
            Resume Next
    End Select
End Sub

Thanks Pat I will make the changes you mention and give it a go. Thanks for your time

 

[arnelgp]

that is a Text file?
the attached file is a Word document.
press Alt-F11 to go to VBA.
on Module, click inside Sub t() and press F5.
on Immediate window, it will show that you can
extract each line 1 by one.

 

[bastanu]

I use a table in Access to set up my template fields:

Then run the following sub:

Private Sub vcParseIndividualEmails()
Dim iPosStart As Integer, iPosEnd As Integer, iPos1 As Integer, iPos2 As Integer, lStart As Long, lCurrentStart As Long
Dim rstDownload As DAO.Recordset, db As DAO.Database, rstOnline As DAO.Recordset, sMessage As String
Dim rDownloadTemplate As DAO.Recordset, sField As String, SCurrentLabel As String, sNextLabel As String
Dim vData



Set db = CurrentDb
Set rDownloadTemplate = db.OpenRecordset("SELECT tmpOnlineEmailTemplate.* FROM tmpOnlineEmailTemplate ORDER BY [OnlineRowID];", dbOpenSnapshot)
Set rstDownload = db.OpenRecordset("tmpOnlineDownload", dbOpenSnapshot)
Set rstOnline = db.OpenRecordset("tblOnlineApplication_Imported", dbOpenDynaset, dbSeeChanges)


If rstDownload.RecordCount = 0 Then GoTo EXIT_PARSE

'let start looping the downloads
Do Until rstDownload.EOF
  'Lets add to rstOnline
    rstOnline.AddNew
    
        sMessage = Trim(rstDownload("Email_Body"))
        rDownloadTemplate.MoveFirst
        lCurrentStart = 1
        Do Until rDownloadTemplate.EOF
                          
            sField = Nz(rDownloadTemplate("FieldName"), "")
            SCurrentLabel = rDownloadTemplate("OnlineRowLabel")
            sNextLabel = rDownloadTemplate("NextRowLabel")
                                  
            lStart = InStr(lCurrentStart, sMessage, SCurrentLabel)
            iPosStart = InStr(lStart, sMessage, SCurrentLabel) + Len(SCurrentLabel)
            
            If rDownloadTemplate("NoData") = True Then GoTo NEXT_LINE
            
            If sNextLabel = "NONE_END_OF_APPLICATION" Then
                vData = Trim(Mid(sMessage, iPosStart))
            Else
                iPosEnd = InStr(lStart, sMessage, sNextLabel)
                vData = Trim(Mid(sMessage, iPosStart, iPosEnd - iPosStart))
            End If
            
            vData = vcCleanString(vData)
            
            rstOnline(sField) = vData
            
NEXT_LINE:
            lCurrentStart = iPosStart
           rDownloadTemplate.MoveNext
        Loop
    rstOnline("ProcessedBy") = fOSUserName
    rstOnline("ProcessedOn") = Now
    rstOnline("EmailBody") = rstDownload("Email_Body")
    rstOnline("EmailMAPI_ID") = rstDownload("MSGID")
    rstOnline.Update
    rstDownload.MoveNext
 
Loop


EXIT_PARSE:
Set db = Nothing
Set rstOnline = Nothing
Set rstDownload = Nothing
      
        
End Sub


Private Function vcCleanString(vToBeCleaned)
vcCleanString = Trim(vToBeCleaned)
vcCleanString = Replace(vcCleanString, ">", "")
If InStr(vcCleanString, "HYPERLINK") > 0 Then
    vcCleanString = Mid(vcCleanString, InStrRev(vcCleanString, Chr(34)) + 1)
End If

vcCleanString = SF_removeAll(vcCleanString, vbCrLf)
vcCleanString = Trim(Replace(vcCleanString, Chr(255), ""))
vcCleanString = Replace(vcCleanString, Chr(160), "")
vcCleanString = Trim(Replace(vcCleanString, Chr(10), ""))
vcCleanString = Trim(Replace(vcCleanString, Chr(13), ""))
vcCleanString = Trim(Replace(vcCleanString, vbTab, ""))

vcCleanString = SF_removeAll(vcCleanString, "(")
vcCleanString = SF_removeAll(vcCleanString, ")")
vcCleanString = Trim(SF_removeAll(vcCleanString, "--"))
If Right(vcCleanString, 1) = "-" Then vcCleanString = Left(vcCleanString, Len(vcCleanString) - 1)
'vcCleanString = Trim(Replace(vcCleanString, "-", ""))
'vcCleanString = Replace(vcCleanString, ":", "")


vcCleanString = Trim(vcCleanString)

End Function

Once to setup the template with the keywords and corresponding target table fields the job becomes trivial, simply loop through your folder where you store the files, import them then move them to a "Processed" subfolder or similar.

Attach is the file for reference if needed.
Cheers,