'==============================================================================
' Code courtesy of UtterAccess Wiki
' http://www.utteraccess.com/wiki/index.php/Category:FunctionLibrary
'
' You are free to use this code in any application,
' provided this notice is left unchanged.
'
' NAME: ConvertToWordDoc
' DATE: 8/12/2011
' REV 1.0: Initial Release
'
' Converts an RTF (or any other word-openable file) to a word document
'
' Access 2002+ (or an InStrRev replacement for earlier versions)
' Requires MS Word installed on the machine, or
'   to run Word from an application server, comment out the GetObject() lines
'   and pass the second argument of the CreateObject() function as the server name
'
' Operates by creating an instance of Word, opening the file and saving
'   as a word doc.
'
' Returns True on success, False on error
'
' PARAMETERS:
'   sFileIn: Full path to the file to be converted to .doc
'   sFileOut: Full path of the converted file
'   bPromptOverwrite: True to prompt the overwriting of an existing FileOut
'   bDeleteSourceFile: True to delete the source file after converting
'==============================================================================
Public Function ConvertToWordDoc( _
     sFileIn As String, _
     sFileOut As String, _
     Optional bPromptOverwrite As Boolean = True, _
     Optional bDeleteSourceFile As Boolean = False _
     ) As Boolean
On Error GoTo Error_Proc
Dim Ret As Boolean
'=========================
 Dim oWord As Object             'the Word Application
 Dim sDocName As String          'name of the doc per oWord.Documents(index).Name
                                 'this is updated to the new filename after SaveAs
 Dim bKillExisting As Boolean    'True if overwriting an existing file
 Dim bWordWasOpen As Boolean     'True if word was already open (won't close app)
 Dim bDocAlreadyOpen As Boolean  'True if sDocName was already found (will msg and exit)
 Dim i As Integer                'various/counter
'=========================

 'make sure the sFileIn is valid
 If Len(Dir(sFileIn)) = 0 Then
   MsgBox "File: " & sFileIn & " not found", vbInformation, "File Not Found"
   GoTo Exit_Proc
 End If
 
 'prompt overwrite if required
 If Len(Dir(sFileOut)) <> 0 Then
   If bPromptOverwrite Then
     If MsgBox("Overwrite existing '" & sFileOut & "'?" _
               , vbInformation + vbOKCancel, "Confirm") = vbCancel Then
       GoTo Exit_Proc
     End If
     
     bKillExisting = True
   End If
 End If
 
 'get/create the word app
 On Error Resume Next
 Set oWord = GetObject(, "Word.Application")
 If Err.Number = 0 Then bWordWasOpen = True
 Err.Clear
 On Error GoTo Error_Proc
 If oWord Is Nothing Then
   Set oWord = CreateObject("Word.Application")
 End If
 
 'get the doc name to be opened and make sure there's not
 'a doc already opened with the same name
 sDocName = Right(sFileIn, Len(sFileIn) - InStrRev(sFileIn, "\"))
 If oWord.Documents.Count <> 0 Then
   For i = 1 To oWord.Documents.Count
     If oWord.Documents(i) = sDocName Then
       bDocAlreadyOpen = True
     End If
   Next
 End If
 
 'exit if doc is already open
 If bDocAlreadyOpen Then
   MsgBox "The Document '" & sDocName & "' must be closed to proceed", vbInformation, "Close Document"
   GoTo Exit_Proc
 End If
 
 'open the file
 oWord.Documents.Open _
     FileName:=sFileIn, _
     Visible:=False, _
     ReadOnly:=False, _
     AddToRecentFiles:=False
 DoEvents
 
 'save the file
 If bKillExisting Then
   Kill sFileOut
   DoEvents: DoEvents: DoEvents
 End If
 oWord.Documents(sDocName).SaveAs _
     FileName:=sFileOut, _
     FileFormat:=0, _
     AddToRecentFiles:=True
 DoEvents

 'update sDocName to the new file
 sDocName = Right(sFileOut, Len(sFileOut) - InStrRev(sFileOut, "\"))

 'close the file
 oWord.Documents(sDocName).Close
 
 'close the app if it wasn't already open
 If bWordWasOpen = False Then
   oWord.Quit
 End If
 
 If bDeleteSourceFile Then Kill sFileIn
 DoEvents
 
 Ret = True
'=========================
Exit_Proc:
 Set oWord = Nothing
 ConvertToWordDoc = Ret
 Exit Function
Error_Proc:
 MsgBox "Error: " & Trim(str(Err.Number)) & vbCrLf & _
   "Desc: " & Err.Description & vbCrLf & vbCrLf & _
   "Module: modFileConversions, Procedure: ConvertToWordDoc" _
   , vbCritical, "Error!"
 Resume Exit_Proc
 Resume
End Function