If you've modified the code and there is a problem with it, how is it useful for me to look at where you got it from? What if your modifications are the problem?
Have you created a new file and imported all the objects from the old database?
Thanks again for your time and effort
The only modification i did was in fact the following:
Dim myDoc As New Word.Document
Set app = New Word.Application
Set myDoc = app.Documents.Open(FileName:=oPath & FileArray(i), Visible:=False)
And changing Application.Updating to Application.Echo
Otherwise the code is exactly the same
This code is put in a module in MS Access, the database is db.accdb containing one table called "Data", in that table there is one Field named "Subject name" with data type of that field set to "Text" and I am importing data from multiple word files each containing a form field called "pid"
The error occurs when I try to import fields containing large amount of data, I tried coping the data manually to the table and I get a similar error "The text is too long to be edited", but if i change the field type to Memo and copy the same data manually it works fine, however wen running the VBA code with the field type set to Memo the whole DB freezes
Any suggestions please?
I am posting the entire code down here:
Sub ExtractInfo()
Dim oPath As String
Dim FileArray() As String
Dim oFileName As String
Dim i As Long
Dim vConnection As New ADODB.Connection
Dim vRecordSet As New ADODB.Recordset
Dim myDoc As New Word.Document
Dim FiletoKill As String
Dim Lab As String
Set app = New Word.Application
oPath = GetPathToUse
If oPath = "" Then
MsgBox "A folder was not selected"
Exit Sub
End If
'Call function to create a processed forms folder
CreateProcessedDirectory oPath
oFileName = Dir$(oPath & "*.doc")
ReDim FileArray(1 To 10) 'User a number larger the expected number of files to process
Do While oFileName <> ""
i = i + 1
FileArray(i) = oFileName
'Get the next file name
oFileName = Dir$
Loop
If i = 0 Then
MsgBox "The selected folder did not contain any forms to process."
Exit Sub
End If
'Resize and preserve the array
ReDim Preserve FileArray(1 To i)
Application.Echo False
vConnection.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source=C:\Documents and Settings\Administrator\Desktop\My project\Test110721\db.accdb;"
vConnection.Open
vRecordSet.Open "Data", vConnection, adOpenKeyset, adLockOptimistic
vConnection.Execute "DELETE * FROM Data"
For i = 1 To UBound(FileArray)
Set myDoc = app.Documents.Open(FileName:=oPath & FileArray(i), Visible:=False)
FiletoKill = oPath & myDoc
vRecordSet.AddNew
With myDoc
If .FormFields("pid").Result <> "" Then _
vRecordSet("Subject no") = .FormFields("pid").Result
.SaveAs oPath & "Processed\" & .Name
.Close
Kill FiletoKill
End With
Next i
vRecordSet.Update
vRecordSet.Close
vConnection.Close
Set vRecordSet = Nothing
Set vConnection = Nothing
Application.Echo True
End Sub
Private Function GetPathToUse() As Variant
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select Folder containing the completed form documents to and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
GetPathToUse = ""
Set fDialog = Nothing
Exit Function
End If
GetPathToUse = fDialog.SelectedItems.Item(1)
If Right(GetPathToUse, 1) <> "\" Then GetPathToUse = GetPathToUse + "\"
End With
End Function
Sub CreateProcessedDirectory(oPath As String)
'Requires Reference to Microsoft Scripting Runtime
Dim Path As String
Dim FSO As FileSystemObject
Path = oPath
Dim NewDir As String
Set FSO = CreateObject("Scripting.FileSystemObject")
NewDir = Path & "Processed"
If Not FSO.FolderExists(NewDir) Then
FSO.CreateFolder NewDir
End If
End Sub
Regards
Ammarhs
