alt klasördeki tüm .Rtf dosyalarını .doc dosyasına çevirme

[budabej]

Merhaba,
bir sürü iç içe alt klasör haline bulunan klasörler içinde .Rtf formatındaki dosyayı açıp,izin ver diyip farklı kaydet farklı kaydet diyerek aynı isimle kaydetmesini istiyorum. farklı kaydet olarak SaveAs2 FileName kısmını öğrendim . ama alt klasörlerde dosyaları bulamadım. yardımcı olabilri misiniz?

 

[halit3]

bu kodu bir dene

Dim Say
Dim dosyalar(50000)
Dim dosyalar2(50000)
Sub mevcut_dosyaları_bul4()

Set klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not klasor Is Nothing Then
Kaynak = klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

Say = 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Liste1 (Kaynak)

For i = 1 To Say
Dim objWord As Word.Application
Dim docWord As Word.Document
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Yol = dosyalar(i)
Set docWord = objWord.Documents.Open(Filename:=Yol, ReadOnly:=True)

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

klasor = fL.GetParentFolderName(dosyalar(i))
dosya = fL.GetBaseName(dosyalar(i))

[COLOR="Red"]docWord.SaveAs Filename:=klasor & "\" & dosya & ".doc", FileFormat:=0[/COLOR]
docWord.Close False
objWord.Quit

Set docWord = Nothing
Next i

Set klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub


Private Sub Liste1(Yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.GetFolder(Yol).Files
uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_adi = fL.GetBaseName(dosya)
If uzanti = "rtf" Then
Say = Say + 1
dosyalar(Say) = dosya
dosyalar2(Say) = dosya.Name
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(Yol).SubFolders
Liste1 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub