Hi Piet,
Try this:
Private Sub Command0_Click()
Dim appWord As Word.Application
Dim iCounter As Integer
Dim oRng As Range
Dim oTbl As Table
Dim oCel As Cell
Dim rsAddr As DAO.Recordset
Dim strContents As String
Set appWord = New Word.Application
appWord.Documents.Open "C:\AddressList.doc"
Set rsAddr = DBEngine(0)(0).OpenRecordset("Addressbook", dbOpenTable, dbAppendOnly)
iCounter = 0
With appWord.ActiveDocument
For Each oTbl In .Tables
For Each oCel In oTbl.Range.Cells
Set oRng = oCel.Range
With oRng
.MoveEnd Unit:=wdCharacter, Count:=-1
Do While Asc(.Characters.Last) = 11 Or Asc(.Characters.Last) = 13 Or _
Asc(.Characters.Last) = 32 Or Asc(.Characters.Last) = 160
.MoveEnd Unit:=wdCharacter, Count:=-1
Loop
Do While Asc(.Characters.First) = 11 Or Asc(.Characters.First) = 13 Or _
Asc(.Characters.First) = 32 Or Asc(.Characters.First) = 160
.MoveStart Unit:=wdCharacter, Count:=1
Loop
End With
strContents = oRng.Text
If strContents <> "" Then
iCounter = iCounter + 1
With rsAddr
.AddNew
.Fields("Address") = strContents
.Update
End With
End If
Next oCel
Next oTbl
End With
rsAddr.Close
appWord.ActiveDocument.Close
Set rsAddr = Nothing
Set docWord = Nothing
appWord.Quit
Set appWord = Nothing
MsgBox "Job's done", vbOKOnly
DoCmd.OpenTable "Addressbook", acViewNormal
End Sub
Three things worth noting are that the code:
1. processes all tables in the document - you may want to change that.
2. loops through the cells collection rather than going by row & column. It can be done this way because Word processes the cells
collection by column within row anyway.
3. uses two loops to strip off any leading & trailing spaces (Chr 32 & Chr 160) and linefeeds/carriage returns (Chr 11 & Chr 13).
Apart from meaning you don't then need to trim the result, doing it this way also takes of any combination/permutation of those
leading & trailing characters.
--
Cheers
macropod
[MVP - Microsoft Word]
Hi Piet,
To extract just the cell contents without the cell delimiter, you'd use something like:
Dim oRng as Range
Set oRng = ThisDocument.Tables(1).Cell(1, 1).Range
oRng.MoveEnd Unit:=wdCharacter, Count:= -1
If the cell is empty, oRng.Txt will return "".
MacroPod,
Thanks a mil! Got *most* of it working....
here's the code (and try not to laugh!)
Private Sub Command0_Click()
Dim appWord As Word.Application
Dim docWord As Word.Document
Dim iCounter As Integer
Dim iRow As Integer, iColumn As Integer
Dim oRng As Range
Dim strContents As String
Dim rsAddr As DAO.Recordset
'Set oRng = ThisDocument.Tables(1).Cell(1, 1).Range
'oRng.MoveEnd Unit:=wdCharacter, Count:=-1
Set appWord = New Word.Application
appWord.documents.Open "C:\AddressList.doc"
Set docWord = appWord.ActiveDocument
Set rsAddr = DBEngine(0)(0).OpenRecordset("Addressbook",
dbOpenTable, dbAppendOnly)
For iRow = 1 To docWord.Tables(1).Rows.Count
For iColumn = 1 To docWord.Tables(1).Columns.Count
Set oRng = docWord.Tables(1).Cell(iRow, iColumn).Range
If iRow = docWord.Tables(1).Rows.Count And iColumn =
docWord.Tables(1).Columns.Count Then
oRng.MoveEnd unit:=wdCharacter, Count:=-1
Else
oRng.MoveEnd unit:=wdCharacter, Count:=-2
End If
strContents = Trim(oRng.Text)
If strContents <> "" Then
'iCounter = iCounter + 1
rsAddr.AddNew
rsAddr.Fields("Address") = strContents
rsAddr.Update
End If
Next iColumn
Next iRow
rsAddr.Close
appWord.ActiveDocument.Close
Set rsAddr = Nothing
Set docWord = Nothing
appWord.Quit
Set appWord = Nothing
'MsgBox "Job's done", vbOKOnly
DoCmd.OpenTable "Addressbook", acViewNormal
End Sub
The part that fails is that it crops the last character off the last
non-empty cell's contents and then inserts another one with non-
printable characters. It looks like the label template has some extra
spaces in it or something. Any idea how to deal with that part?
Oh, near forgot... what's the delimiter between lines inside the
individual cells? I need to use it to parse the label into separate
lines.
Thanks!
Pieter
