这个rtf格式文件更改为.doc格式的代码为什么只能改一下?

ww0000

VBA Office 2007/2003 word批量将.rtf格式文件更改为.doc格式文件

此程序为美国之音的.rtf格式转换为手机offic可以识别的.doc格式文件专用。

首先得建立一个文件夹，将所有的.rtf文件放在一起。

Sub rtf2doc()
    Dim file As String
    Dim Text As String
    Dim median As String
    Dim median_4 As String
    Dim yinhao As String
    Dim n As Integer
    n = 1

    file = Dir("E:\English Studying\voa2009\txt\")     '依次获取当前工作簿路径下的txt文件名，先输入路径，依个人情况更改Dir中的路径

    Do Until Len(file) = 0
        median = file                                  '提取完整的文件名(含后缀.rtf)
        median_4 = Left(file, Len(file) - 4)           '提取局部的文件名(不含后缀.rtf)

        yinhao = """"
        text1 = yinhao & median & yinhao               '当前打开文件的文件名(含后缀.rtf)
        text2 = yinhao & median_4 & ".doc" & yinhao    '要保存的文件的文件名(含后缀.doc)

        ChangeFileOpenDirectory "E:\English Studying\voa2009\txt\"      '依个人情况更改打开路径
        Documents.Open FileName:=text1, _
                       ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
                       PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
                       WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
                       wdOpenFormatAuto, XMLTransform:=""
                       
        ChangeFileOpenDirectory "E:\English Studying\voa2009\tools\"    '依个人情况更改保存路径
        ActiveDocument.SaveAs FileName:=text2, FileFormat _
                                             :=wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
                              True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
                              False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
                              SaveAsAOCELetter:=False
        ActiveWindow.Close

        n = n + 1
        file = Dir
    Loop
End Sub



以上代码为什么不能批处理?

413191246se

楼主，你先把单个.rtf文档转换为.doc文档搞掂，然后，用我的——循环遍历文件夹_集成（宏）的第1个选项：键入 0，把单个.rtf转换为.doc文档的代码拷贝到 SingleDoc 宏中，屏蔽原来的旧代码，可以试试（请此前备份）：
Sub 循环遍历文件夹_集成()
    On Error Resume Next
    Dim fd As FileDialog, i As Long, doc As Document, p As String, e As Long, j As String, s As Long, t As Long
    If MsgBox("是否处理 Word 文档(*.doc)？（否则处理文本文档(*.txt)）", vbYesNo + vbExclamation, "循环遍历文件夹_集成") = vbYes Then t = 0 Else t = 1
input_select:
    j = InputBox("======请输入各个功能对应的数字！======" & vbCr & "0=示例代码（自定义）" & vbCr & "1=批量打印" & vbCr & "2=批量合并" & vbCr & "3=批量转换" & vbCr & "4=提取文件名", "循环遍历文件夹_集成", "1")
    If j = "" Then Exit Sub
    If j = 0 Then
        e = 0
    ElseIf j = 1 Then
        e = 1
    ElseIf j = 2 Then
        Documents.Add
        If MsgBox("合并文档之间是否插入分页符？", vbYesNo + vbExclamation, "循环遍历文件夹_集成") = vbYes Then s = 1 Else s = 0
        e = 2
    ElseIf j = 3 Then
        e = 3
    ElseIf j = 4 Then
        Documents.Add
        e = 4
    Else
        GoTo input_select
    End If
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
    Set fd = Nothing
    If MsgBox("是否处理文件夹 " & p & "？", vbYesNo + vbExclamation, "循环遍历文件夹_集成") = vbNo Then Exit Sub
    With Application.FileSearch
'        .NewSearch
        .LookIn = p
        .SearchSubFolders = True
        If t = 0 Then .FileName = "*.doc" Else .FileName = "*.txt"
'        .FileType = msoFileTypeAllFiles
        If .Execute > 0 Then
            For i = 1 To .FoundFiles.Count
                If e = 4 Then GoTo un_need
                If t = 0 Then Set doc = Documents.Open(FileName:=.FoundFiles(i)) Else Set doc = Documents.Open(FileName:=.FoundFiles(i), Encoding:=936)
un_need:
                If e = 0 Then
                    SingleDoc
                ElseIf e = 1 Then
                    doc.PrintOut
                    doc.Close savechanges:=wdDoNotSaveChanges
                ElseIf e = 2 Then
                    doc.Content.Copy
                    doc.Close
                    Selection.EndKey Unit:=wdStory
                    Selection.Paste
                    If s = 1 Then Selection.InsertBreak Type:=wdPageBreak
                ElseIf e = 3 Then
                    If t = 0 Then doc.SaveAs FileName:=Left(doc.FullName, Len(doc.FullName) - 4) & ".txt", FileFormat:=wdFormatText Else doc.SaveAs FileName:=Left(doc.FullName, Len(doc.FullName) - 4) & ".doc", FileFormat:=wdFormatDocument
                    doc.Close
                ElseIf e = 4 Then
                    ActiveDocument.Content.InsertAfter Text:=.FoundFiles(i) & vbCr
                End If
            Next i
            MsgBox "处理完毕！共处理 " & .FoundFiles.Count & " 个文件。", vbOKOnly + vbExclamation, "循环遍历文件夹_集成"
        Else
            MsgBox "未发现文件！", vbOKOnly + vbCritical, "循环遍历文件夹_集成": End
        End If
    End With
    If e = 4 Then ActiveDocument.Content.Find.Execute findtext:=".doc", replacewith:="", Replace:=wdReplaceAll: ActiveDocument.Content.Characters.Last.Delete
    If e = 2 Or e = 4 Then MsgBox "文档尚未保存！请自行保存！", vbOKOnly + vbExclamation, "循环遍历文件夹_集成"
End Sub
Sub SingleDoc()
    ActiveDocument.Content.Font.Color = wdColorRed
    ActiveDocument.Close savechanges:=wdSaveChanges
End Sub

413191246se

一次转换数量最好不要超过400，最好是 300 以下，否则，Word 可能会崩溃呢！--最好用高速电脑。

ww0000

413191246se 发表于 2015-6-1 23:41
楼主，你先把单个.rtf文档转换为.doc文档搞掂，然后，用我的——循环遍历文件夹_集成（宏）的第1个选项：键 ...

试了，很好用，非常感谢！