Send the text in a range to a word document

'Purpose : Sends the text in a range to a word application
'Inputs : rngSelection The range to send to a word document
'Outputs : Returns True on success.


Function WordSendRangeTo(rngSelection As Object, Optional sSaveToFile As String, Optional bShowWord As Boolean = False) As Boolean
Dim oWordApp As Object 'Early bound type = Word.Application
Dim oNewDoc As Object 'Early bound type = Word.Document
Dim oWordRange As Object 'Early bound type = Word.Range
Dim avVaules As Variant, vCell As Variant, sText As String

On Error GoTo ErrFailed
'Build up text to send to word document
avVaules = rngSelection.Value
For Each vCell In avVaules
sText = sText & vCell & " "
Next
sText = Trim$(sText)

'Create word objects
Set oWordApp = CreateObject("Word.Application")
Set oNewDoc = oWordApp.Documents.Add
Set oWordRange = oNewDoc.Words(1)

'Send text to word document
With oWordRange
.Text = sText
On Error Resume Next
Set .Font = rngSelection.Font
End With
On Error GoTo ErrFailed

'Save Document
If Len(sSaveToFile) Then
oNewDoc.SaveAs sSaveToFile
End If

If bShowWord Then
'Show Word
oWordApp.Visible = True
oWordApp.WindowState = 1 'wdWindowStateMaximize
Else
'Quit word
oWordApp.Quit
End If

WordSendRangeTo = True
GoTo ExitSub

ErrFailed:
'Error occurred
WordSendRangeTo = False

ExitSub:
'De-reference objects
Set oWordApp = Nothing
Set oNewDoc = Nothing
Set oWordRange = Nothing
End Function

'Demonstration routine
Sub Test()
WordSendRangeTo Selection, "C:\test.doc"
End Sub