Automating word through excel

[atr140]

All,

I am trying to piece through a word document line by line, and write that info to a excel worksheet. I found some code to piece through a word doc however I am having some issue altering the code as I am unfamiliar with Word VBA.

See below for code:

I am sending a path to this sub to open the word doc. I have the oDoc dim outside the routine for use in other routines.


Sub OpenWordDoc(strPath As String)

'Open an existing Word Document from Excel
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
' Should open as the forefront
objWord.Activate
'Change the directory path and file name to the location
'of the document you want to open from Excel
Set oDoc = objWord.Documents.Open(strPath)

Call LoopingText


objWord.Quit
End Sub


I am then using the following code to loop through the word document and add each line to a string 'outputStr'. This sub is causing me issue. This sub was originally the routine written for Word.


Sub LoopingText() ''()
'Will move to the end of each line in the document and move the text to match
'Declare variables
Dim outputStr As String
Dim currLine As String
Dim endChar As String
Dim numOfLines As Integer
'Count the number of non blank lines in current document
numOfLines = oDoc.BuiltinDocumentProperties("NUMBER OF LINES")
oDoc.Activate

'Move to start of document
Selection.HomeKey Unit:=wdStory
'Start the loop - looping once for each line
For x1 = 1 To numOfLines
'Move to start of line
Selection.HomeKey Unit:=wdLine
'Select entire line and copy into variable currLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
currLine = Selection.Range.Text
'Remove final character (line break) from currLine
currLine = Left(currLine, (Len(currLine) - 1))

outputStr = outputStr & currLine

'Move down one line
Selection.MoveDown Unit:=wdLine, Count:=1
'Move to the next part of the loop
Next x1
End Sub


The line Selection.HomeKey Unit:=wdStory is causing an error:

Run-time '438' Object does not support this property or method.

I have tried:

oDoc.Selection.HomeKey Unit:=wdStory

oDoc.HomeKey Unit:=wdStory

Any help would be really appreciated. Thanks

[macropod]

Try:

Sub OpenWordDoc(StrDocNm As String)
'Note: A reference to the Word library must be set, via Tools|References
Dim wdApp As New Word.Application, wdDoc As Word.Document, StrTxt As String
If Dir(StrDocNm) = "" Then Exit Sub
Set wdDoc = wdApp.Documents.Open(Filename:=StrDocNm, ReadOnly:=False, AddToRecentFiles:=False)
With wdDoc
'process the document
StrTxt = Replace(Replace(Replace(.Range.Text, Chr(11), "¶"), Chr(12), "¶"), vbCr, "¶")
'close
.Close SaveChanges:=False
End With

wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
End Sub
Simply replace the ¶ characters with whatever you want in place of the paragraph breaks, line breaks, & section breaks.

[gmayor]

The line Selection.HomeKey Unit:=wdStory is causing an error:
Run-time '438' Object does not support this property or method.
Withoiut looking to then merits of the code, but simply to address the error message - when using LateBinding to the Word object as in your code, you cannot use Word specific values such as wdStory. You must use instead the numeric equivalents of such commands. The enumeration value for wdStory is 6.

Paul's code example uses early binding to the Word object and so may be used with such values. There are advantages and disadvantages to both approaches. Programming is easier with early binding. Late binding makes the code more transportable - especially between different Office versions.

FWIW Paul's code could also be used with late binding

Sub OpenWordDoc(StrDocNm As String)
'Note: Late binding no reference to the Word library required
Dim wdApp As Object, wdDoc As Object, StrTxt As String, bStart As Boolean
If Dir(StrDocNm) = "" Then Exit Sub
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
bStart = True
End If
On Error GoTo 0
Set wdDoc = wdApp.Documents.Open(FileName:=StrDocNm, ReadOnly:=False, AddToRecentFiles:=False)
With wdDoc
'process the document
StrTxt = Replace(Replace(Replace(.Range.Text, Chr(11), "¶"), Chr(12), "¶"), vbCr, "¶")
'close
.Close SaveChanges:=False
End With
If bStart Then wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
End Sub

[atr140]

Paul & Graham,

Thank you both for the solutions. They work a treat. Thank you for the more detailed response Graham; I will be sure to keep that in mind.

Aaron