RTF to DOC conversion

' Script program to convert RTF to DOC.
' Paste code in a notepad. Save as anyname.vbs
' Close notepad
' double click to run. Will require WSH 5.6 for win2K or win98
' Win XP is already WSH 5.6

'###########################################################
'# Coded by Emilio de Leon 2 Jan 2006 in VBscript.Double click to run.
'# put this script into any folder requiring RTF conversion to DOC
'###########################################################

'Start of Script
Option Explicit
On Error Resume Next
Dim Response
Dim anRTForDOCisOpen_Flag
dim nominatedFolder
dim fso
dim oApp
set oApp = createobject("Word.Application")
Set fso = CreateObject("Scripting.FileSystemObject")

nominatedFolder =fso.GetAbsolutePathName ("convertRTF2DOC.vbs")

nominatedFolder = Left(nominatedFolder, Len(nominatedFolder)-19)
Response = MsgBox("Instruction:" & vbCrLf & _
"Place a copy of this program in any folder that" & _
" contains .rtf files that you want to convert to .doc files." _
& vbCrLf & _
"Please CLOSE all .rtf files to be converted to .doc files." _
& " And CLOSE all related .doc file with similar name as the .rtf. " _
& vbCrLf & "Double click on the program to start it and get this" & _
"initial window message prompt." & vbCrLf & vbCrLf & _
"Note:"&vbCrLf & _
"This program will completely replace the RTF files with DOC files." _
& vbCrLf & vbCrLf & "This program's current folder is " _
& nominatedFolder _
& vbCrLf & vbCrLf & vbCrLf & _
"Press OK button to continue with the conversion.", vbOKCancel, _
"RTF to DOC")

If Response <> 2 Then

ShowFolderList(nominatedFolder) ' call procedure

End if
oApp.Quit
set oApp = nothing
Set fso = nothing
Set nominatedFolder = nothing
' End of Script

'**************sub procedure*******************
'this sub procedure is copied from Peter Jamieson post
'Thanks for inspiring me to expand your original script
sub convertRTFtoDOC(pathWithRTFfilename)
dim newpathFilename 'as string
dim oDoc 'as object

newpathFilename = pathWithRTFfilename
' the ,0 parameter means do not confirm conversions
set oDoc = oApp.Documents.Open(newpathFilename,0)
'remove .rtf and replace with .doc as the new filename
newpathFilename = Left(newpathFilename, _
Len(newpathFilename) - 4) & ".doc"
' the 0 parameter means use .doc format
oDoc.SaveAs newpathFilename, 0
oDoc.close ' Important to close the .doc file

End sub

'************sub procedure********************
Sub ShowFolderList(folderspec)
Dim fs, f, f1, fc, s, i
i = 0
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
'loop & capture RTF & send to another sub for conversion to DOC
For Each f1 in fc

verifyIfRTForDOCopen (f1.name)
if (anRTForDOCisOpen_Flag = true) then
exit sub
end if

if (f1.type = "Rich Text Format") then

convertRTFtoDOC f1

s = s & f1.name
s = s & vbCrLf 'visualbasicCarriageLineFeed
f1.Delete True ' True force delete of read only file
i = i + 1 'count how many .rtf files

end if
Next

' release memory use by object - not needed anymore.
Set fs = nothing
Set f = nothing
Set fc = nothing


If s = "" then
MsgBox "No .rtf file have been found in the folder " & folderspec & _
vbCrLf & vbCrLf & "Press OK button to EXIT."
else
MsgBox s & vbCrLf & i & " .rtf file converted to .doc file."
end if
Set nominatedFolder = nothing
End Sub


'*********************sub procedure***********************
sub verifyIfRTForDOCopen (f1dotname)

Dim colTasks , objTask, strName1,strName2
Set colTasks = oApp.Tasks
anRTForDOCisOpen_Flag = false

For Each objTask in colTasks

strName1 = Lcase(objTask.Name)
strName2 = Lcase(Left(f1dotname,Len(f1dotname) - 4))

If (Instr(strName1,strName2) >= 1) Then
MsgBox f1dotname & " is left open. Please close this file. " _
& vbCrLf & vbCrLf & _
"This program is halted!!! " & _
"Please Close all RTF and related DOC file before restarting program."
_
, 0,"You have forgotten to close a file!!!"

anRTForDOCisOpen_Flag = true

exit sub
End If
Next
End sub

.

Loading