Crear Firmas de Outlook

[BARCORE]

Set fso = CreateObject("Scripting.FileSystemObject")
Set objRootFolder = fso.GetFolder("C:\callfirmas\firmanueva")
Set objSubFolders = objRootFolder.SubFolders
For Each objFolder In objSubFolders
Set objRootFolder1 = fso.GetFolder("C:\callfirmas\firmanueva\" & objFolder.Name )
Set objSubFolders1 = objRootFolder1.SubFolders
For Each objFolder1 In objSubFolders1
' msgbox objFolder.Name & " " & objFolder1.Name

' abre DOC y guarda en HTM, RTF y TXR
Set objWord = CreateObject("Word.Application")
Rutafirmafuente = "C:\callfirmas\firmanueva\" & objFolder.Name & "\" & objFolder1.Name & "\" & objFolder1.Name & ".doc"
if fso.fileexists(Rutafirmafuente) then
Set objDoc = objWord.Documents.Open(Rutafirmafuente)
objWord.Visible = false
Rutafirmadestino = "C:\callfirmas\Perfiles\" & objFolder.Name & "\" & objFolder1.Name
rutafinal= rutafirmadestino & "\Datos de programa\Microsoft\Signatures"
If FSO.FolderExists(rutafirmadestino & "\Application Data\Microsoft\Signatures") then rutafinal = rutafirmadestino & "\Application Data\Microsoft\Signatures"
msgbox rutafinal
objDoc.SaveAs(rutafinal & "\" & objFolder1.Name & ".htm"),8
objDoc.SaveAs(rutafinal & "\" & objFolder1.Name & ".rtf"),6
objDoc.SaveAs(rutafinal & "\" & objFolder1.Name & ".txt"),2
objWord.Quit
msgbox "revisar " & objFolder.Name & " " & objFolder1.Name
end if
Next
Next