Storing data from word doc to database and test word doc

[bplejic]

Hi all,
I'm trying to store scattered text data from several word docs to database MS Access and into test word document but at the end there is no data in databse or even in test word document. Macro is connecting to database and opening test word document without problems but somewhere else marco brakes down . Thank You very much for any help.
Here is code from macro :



Sub ExtractData()
Dim sDTE As String
Dim sSubject As String
Dim strFileName As String
Dim strPath As String
Dim FileArray() As String
Dim i As Long
Dim vConnection As New ADODB.Connection
Dim vRecordSet As New ADODB.Recordset
Dim oDoc As Word.Document
Dim dataDoc As Document
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
'Pick the folder with the letters
With fDialog
.Title = "Odaberite direktorij s zahtjevima i kliknite na gumb OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1)
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
strFileName = Dir$(strPath & "*.doc")
ReDim FileArray(1 To 1000) 'A number larger the expected number of replies
Do While strFileName <> ""
i = i + 1
FileArray(i) = strFileName
'Get the next file name
strFileName = Dir$
Loop
'Resize and preserve the array
ReDim Preserve FileArray(1 To i)
Application.ScreenUpdating = False
'Provide connection string for data using Jet Provider for Access database
vConnection.ConnectionString = "data source=C:\MagRad\Baza.mdb;" & _
"Provider=Microsoft.Jet.OLEDB.4.0;"
vConnection.Open
vRecordSet.Open "MyTable", vConnection, adOpenKeyset, adLockOptimistic
'Retrieve the data
vConnection.Execute "DELETE * FROM MyTable"
'Assign the name of the document to take the data
Documents.Open ("""C:\MagRad\Rez.doc""")
Set dataDoc = ActiveDocument
'Open the letters in turn
While strFileName <> ""
Set oDoc = Documents.Open(strPath & strFileName)
Selection.HomeKey wdStory 'Start from the top of the letter
With Selection.Find 'find the first string
.ClearFormatting
Do While .Execute(findText:="DTE/*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the found text to a variable and chop off
'the last character - '?'
sDTE = Left(Selection.Range, Len(Selection.Range) - 1)
Loop
End With
Selection.HomeKey wdStory 'Start from the top of the letter
With Selection.Find 'find the second string
.ClearFormatting
Do While .Execute(findText:="Subject :*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the second string to a variable and chop off
'the last character and the leading text
sSubject = Mid(Selection.Range, 10, Len(Selection.Range) - 10)
Loop
End With
'Switch to the data document and add the content of
'the variables to the blank row of the table
dataDoc.Activate
dataDoc.Save
If sDTE <> "" Then _
vRecordSet("DTE") = sDTE
If sSubject <> "" Then _
vRecordSet("Subject") = sSubject
vRecordSet.Update
With Selection
.EndKey wdStory
.MoveUp Unit:=wdLine, Count:=1
.MoveRight Unit:=wdCell, Count:=2 'Add a new blank row
.TypeText Text:=sDTE
.MoveRight Unit:=wdCell
.TypeText Text:=sSubject
End With
'Close the letter without saving
oDoc.Close SaveChanges:=wdDoNotSaveChanges
Set oDoc = Nothing
strFileName = Dir$()
Wend
vRecordSet.Close
vConnection.Close
Set vRecordSet = Nothing
Set vConnection = Nothing
Application.ScreenUpdating = True
End Sub

[Tinbendr]

Nothing jumps out at me.

I've never had consistant success using Selection on muiltiple documents.

I moved them into ranges for you.


Sub ExtractData2()
Dim sDTE As String
Dim sSubject As String
Dim strFileName As String
Dim strPath As String
Dim FileArray() As String
Dim i As Long
Dim vConnection As ADODB.Connection
Dim vRecordSet As ADODB.Recordset
Dim oDoc As Document
Dim Datadoc As Document
Dim fDialog As FileDialog
Dim Rng As Range
Dim NumRows As Integer
Set vConnection = New ADODB.Connection
Set vRecordSet = New ADODB.Recordset
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
'Pick the folder with the letters
With fDialog
.Title = "Odaberite direktorij s zahtjevima i kliknite na gumb OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1)
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
strFileName = Dir$(strPath & "*.doc")
ReDim FileArray(1 To 1000) 'A number larger the expected number of replies
Do While strFileName <> ""
i = i + 1
FileArray(i) = strFileName
'Get the next file name
strFileName = Dir$
Loop
'Resize and preserve the array
ReDim Preserve FileArray(1 To i)
Application.ScreenUpdating = False
'Provide connection string for data using Jet Provider for Access database
vConnection.ConnectionString = "data source=C:\MagRad\Baza.mdb;" & _
"Provider=Microsoft.Jet.OLEDB.4.0;"
vConnection.Open
vRecordSet.Open "MyTable", vConnection, adOpenKeyset, adLockOptimistic
'Retrieve the data
vConnection.Execute "DELETE * FROM MyTable"
'Assign the name of the document to take the data
Set Datadoc = Documents.Open("C:\MagRad\Rez.doc")
'Open the letters in turn
While strFileName <> ""
Set oDoc = Documents.Open(strPath & strFileName)
'Find the DTE text
Set Rng = oDoc.Range
With Rng.Find 'find the first string
.ClearFormatting
Do While .Execute(Findtext:="DTE/*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the found text to a variable and
'chop off the last character - '?'
Rng.SetRange 0, Len(Rng) - 1
sDTE = Rng.Text
Loop
End With
Set Rng = oDoc.Range 'Redefine range after find
With Rng.Find 'find the second string
.ClearFormatting
Do While .Execute(Findtext:="Subject :*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the second string to a variable and chop off
'the the leading text and last character.
Rng.SetRange 9, Len(Rng) - 1
sSubject = Rng.Text
Loop
End With
'Switch to the data document and add the content of
'the variables to the blank row of the table
'Datadoc.Activate
Datadoc.Save
If sDTE <> "" Then vRecordSet("DTE") = sDTE
If sSubject <> "" Then vRecordSet("Subject") = sSubject
vRecordSet.Update
With Datadoc.Tables(1).Range
.Rows.Add
.Cells(.Rows.Count, 1) = sDTE
.Cells(.Rows.Count, 2) = sSubject
End With
'Close the letter without saving
oDoc.Close SaveChanges:=wdDoNotSaveChanges
Set oDoc = Nothing
strFileName = Dir$()
Wend
vRecordSet.Close
vConnection.Close
Set vRecordSet = Nothing
Set vConnection = Nothing
Application.ScreenUpdating = True
End Sub

[bplejic]

Hi Tinbendr,
Thank You very much
You saved me

[bplejic]

Hi Tinbendr,
While Compiling Project I got Compile error Wrong number of arguments or invalid property assigment at line .Cells(.Rows.Count, 1) = sDTE.
Also I would like to save into a MS access table those Strings as Numbers so if You know how....
Thanks alot

[bplejic]

I tried to replace this:
.Cells(.Rows.Count, 1) = sDTE
with this:
.Rows(.Rows.Count).Cells(1) = sDTE

But now I'm getting Compile error Invalid use of property http://www.tipmaster.com/images/sadface.gif

[Tinbendr]

Oops, sorry!
With Datadoc.Tables(1)
.Range.Rows.Add
.Cells(.Rows.Count, 1).Range = sDTE
.Cells(.Rows.Count, 2).Range = sSubject
End With


I'm not sure I understand your other question.
save into a MS access table those Strings as Numbers

[bplejic]

Hi,
Now I got ERROR : Method or data member not found at the same place.
Maybe problem is in
CODE

Do While strFileName <> ""
i = i + 1
FileArray(i) = strFileName
'Get the next file name
strFileName = Dir$
Loop



This processes until strFileName IS ""

So, if I later use strFileName (which I do), it is..."". But I have to get a real filename (strFileName) back out of FileArray().


Our code is now :


Sub ExtractData()
Dim sDTE As String
Dim sSubject As String
Dim strFileName As String
Dim strPath As String
Dim FileArray() As String
Dim i As Long
Dim vConnection As ADODB.Connection
Dim vRecordSet As ADODB.Recordset
Dim oDoc As Document
Dim Datadoc As Document
Dim fDialog As FileDialog
Dim Rng As Range
Dim NumRows As Integer
Set vConnection = New ADODB.Connection
Set vRecordSet = New ADODB.Recordset
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
'Pick the folder with the letters
With fDialog
.Title = "Odaberite direktorij s zahtjevima i kliknite na gumb OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1)
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
strFileName = Dir$(strPath & "*.doc")
ReDim FileArray(1 To 1000) 'A number larger the expected number of replies
Do While strFileName <> ""
i = i + 1
FileArray(i) = strFileName
'Get the next file name
strFileName = Dir$
Loop
'Resize and preserve the array
ReDim Preserve FileArray(1 To i)
Application.ScreenUpdating = False
'Provide connection string for data using Jet Provider for Access database
vConnection.ConnectionString = "data source=C:\MagRad\Baza.mdb;" & _
"Provider=Microsoft.Jet.OLEDB.4.0;"
vConnection.Open
vRecordSet.Open "MyTable", vConnection, adOpenKeyset, adLockOptimistic
'Retrieve the data
vConnection.Execute "DELETE * FROM MyTable"
'Assign the name of the document to take the data
Set Datadoc = Documents.Open("C:\MagRad\Rez1.doc")
'Open the letters in turn
While strFileName <> ""
Set oDoc = Documents.Open(strPath & strFileName)
'Find the DTE text
Set Rng = oDoc.Range
With Rng.Find 'find the first string
.ClearFormatting
Do While .Execute(Findtext:="DTE/*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the found text to a variable and
'chop off the last character - '?'
Rng.SetRange 0, Len(Rng) - 1
sDTE = Rng.Text
Loop
End With
Set Rng = oDoc.Range 'Redefine range after find
With Rng.Find 'find the second string
.ClearFormatting
Do While .Execute(Findtext:="Subject :*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the second string to a variable and chop off
'the the leading text and last character.
Rng.SetRange 9, Len(Rng) - 1
sSubject = Rng.Text
Loop
End With
'Switch to the data document and add the content of
'the variables to the blank row of the table
'Datadoc.Activate
Datadoc.Save
If sDTE <> "" Then vRecordSet("DTE") = sDTE
If sSubject <> "" Then vRecordSet("Subject") = sSubject
vRecordSet.Update
With Datadoc.Tables(1)
.Range.Rows.Add
.Cells(.Rows.Count, 1).Range = sDTE
.Cells(.Rows.Count, 2).Range = sSubject
End With
'Close the letter without saving
oDoc.Close SaveChanges:=wdDoNotSaveChanges
Set oDoc = Nothing
strFileName = Dir$()
Wend
vRecordSet.Close
vConnection.Close
Set vRecordSet = Nothing
Set vConnection = Nothing
Application.ScreenUpdating = True
End Sub



Our Rez1.doc is empty .doc file, and our database table is looking like this

DTE
Subject



Thank You very much for help.
If I do something that will help to solve this problem I will tell You

[bplejic]

Ops
Our database table is looking something like this
____________
łDTEł Subject ł
ł-------------
ł___ł________ł

[Tinbendr]

Hi,
Now I got ERROR : Method or data member not found at the same place.
...
Our Rez1.doc is empty .doc file, That explains the error. The code needs a table in the Datadoc. We can add one at the start, or you can manually add it. I just assumed the table was in the rez1.doc.

Do you need to store the filenames in the array for some other purpose? It's really not needed. Remove this: ReDim FileArray(1 To 1000) 'A number larger the expected number of replies
Do While strFileName <> ""
i = i + 1
FileArray(i) = strFileName
Loop
But leave this 'Get the next file name
strFileName = Dir$

and remove this:ReDim Preserve FileArray(1 To i)
Then the Do While strFileName <> "" will continue the loop until all the files are read.

If you have to keep it for other reasons, then we'll have to take advantage of the FileArray and use it to step through the documents.

[bplejic]

Hi Tinbendr,
After creating table in .doc file rez1 and while Compiling Project I got Compile error Method or data member not found at line .Cells(.Rows.Count, 1) = sDTE.

[bplejic]

But when I remove part for putting data into doc file I still cannot see data in database table :-(
It is not so important that I get data in doc file. We can remove this part.
Important is that I get sSubject and sDTE into database table MyTable.
And if it is possible that I have them stored in table like numbers!
so in doc we have :


Subject :5


DTE/45617809106107

like some strings.

and in table, after runing macro we should have numbers so we can use that numbers later

DTE
Subject
45617809106107
5

Thank You
Best regards
Boris

[bplejic]

Sorry
I don't know how to put here table :-)
--------------------------
łDTE łSUBJECTł
ł-----------------ł---------ł
ł45617809106107 ł 5 ł
---------------------------

[bplejic]

I found out what was mistake :
NOT:
.Cells(....
BUT
.Cell(......

End it is still not working

[bplejic]

Now I pass debuging but macro failed to run.
I have no data in rez1.doc or into database.
Problem is somewhere in parsing strings - solution with range
Here is a new code

Sub ExtractData()
Dim sDTE As String
Dim sSubject As String
Dim strFileName As String
Dim strPath As String
Dim FileArray() As String
Dim i As Long
Dim vConnection As ADODB.Connection
Dim vRecordSet As ADODB.Recordset
Dim oDoc As Document
Dim Datadoc As Document
Dim fDialog As FileDialog
Dim Rng As Range
Dim NumRows As Integer
Set vConnection = New ADODB.Connection
Set vRecordSet = New ADODB.Recordset
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
'Pick the folder with the letters
With fDialog
.Title = "Odaberite direktorij s zahtjevima i kliknite na gumb OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1)
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
strFileName = Dir$(strPath & "*.doc")
ReDim FileArray(1 To 1000) 'A number larger the expected number or replies
Do While strFileName <> ""
i = i + 1
FileArray(i) = strFileName
'Get the next file name
strFileName = Dir$
Loop
'Resize and preserve the array
ReDim Preserve FileArray(1 To 1)
Application.ScreenUpdating = False
'Provide connection string for data using Jet Provider for Access database
vConnection.ConnectionString = "data source=C:\MagRad\Baza.mdb;" & _
"Provider=Microsoft.Jet.OLEDB.4.0;"
vConnection.Open
vRecordSet.Open "MyTable", vConnection, adOpenKeyset, adLockOptimistic
'Retrieve the data
vConnection.Execute "DELETE * FROM MyTable"
'Assign the name of the document to take the data
Set Datadoc = Documents.Open("C:\MagRad\Rez\Rez1.doc")
'Open the letters in turn
While strFileName <> ""
Set oDoc = Documents.Open(strPath & strFileName)
'Find the DTE text
Set Rng = oDoc.Range
With Rng.Find 'find the first string
.ClearFormatting
Do While .Execute(Findtext:="DTE/*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the found text to a variable and
'chop off the last character - '?'
Rng.SetRange 0, Len(Rng) - 1
sDTE = Rng.Text
Loop
End With
Set Rng = oDoc.Range 'Redefine range after find
With Rng.Find 'find the second string
.ClearFormatting
Do While .Execute(Findtext:="Subject :*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the second string to a variable and chop off
'the the leading text and last character.
Rng.SetRange 9, Len(Rng) - 1
sSubject = Rng.Text
Loop
End With
'Switch to the data document and add the content of
'the variables to the blank row of the table
'Datadoc.Activate
Datadoc.Save
If sDTE <> "" Then vRecordSet("DTE") = sDTE
If sSubject <> "" Then vRecordSet("Subject") = sSubject
vRecordSet.Update
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
With Datadoc.Tables(1)
.Rows.Add
.Cell(.Rows.Count, 1).Range.Text = Mid(sDTE, 1, Len(sDTE) - 1)
.Cell(.Rows.Count, 2).Range.Text = Mid(sSubject, 1, Len(sSubject) - 1)
End With
'Close the letter without saving
oDoc.Close SaveChanges:=wdDoNotSaveChanges
Set oDoc = Nothing
strFileName = Dir$()
Wend
vRecordSet.Close
vConnection.Close
Set vRecordSet = Nothing
Set vConnection = Nothing
Application.ScreenUpdating = True
End Sub