0

docx ファイルに変換したい doc ファイルが多数ありました。

この変換を自動的に行うための本当に良い方法がないことを発見しました。

これを行うために使用した方法を提出しましたが、おそらく他の方法があります。

4

1 に答える 1

1

私は役立つかもしれないいくつかのことを見つけました：

マイクロソフト バルク コンバーター

シンプルな Microsoft Word マクロ

しかし、提供されたマクロには満足できませんでした。ネストされたファイルも変換するには、再帰的なものが必要でした。だから私はそうするためにそれを拡大しました。

Sub SaveAllAsDOCX()

    'Search #EXT to change the extensions to save to docx

    Dim strDocName As String
    Dim strPath As String
    Dim oDoc As Document
    Dim fDialog As FileDialog
    Dim intPos As Integer

    'Create a folder dialog
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .Title = "Select root folder and click OK"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then
            MsgBox "Cancelled By User", , "List Folder Contents"
            Exit Sub
        End If

    'Select root folder
    strPath = fDialog.SelectedItems.Item(1)

    'Ensure the Folder Name ends with a "\"
    If Right(strPath, 1) <> "\" Then strPath = strPath + "\"

End With

'Close any open documents
If Documents.Count > 0 Then
    Documents.Close SaveChanges:=wdPromptToSaveChanges
End If

'remove any quotes from the folder string
If Left(strPath, 1) = Chr(34) Then
    strPath = Mid(strPath, 2, Len(strPath) - 2)
End If

'begin recusion
recurse (strPath)

End Sub

'This method controls the recusion
Function recurse(folder As String)

    'save all the files in the current folder
    SaveFilesInFolder (folder)

    'get all the subfolders of the current folder
    Dim folderArray
    folderArray = GetSubFolders(folder)

    'Loop through all the non-empty elements for folders
    For j = 1 To UBound(folderArray)
        If folderArray(j) <> "" Then
            'begin recusion on subfolder
            recurse (folder & folderArray(j) & "\")
        End If
    Next
End Function

'Saves all files with listed extensions
Function SaveFilesInFolder(folder As String)

    'List of extensions to look for #EXT
    Dim strFilename As String
    extsArray = Array("*.rtf", "*.doc")

    'Loop through extensions
    For i = 0 To (UBound(extsArray))

        'select the 1st file with the current extension
        strFilename = Dir(folder & extsArray(i), vbNormal)

        'double check the current extension (don't to resave docx files)
        Dim ext As String
        ext = ""
        On Error Resume Next
        ext = Right(strFilename, 5)

        If ext = ".docx" Or ext = "" Then
            'Don't need to resave files in docx format
    Else
        'Save the current file in docx format
        While Len(strFilename) <> 0
            Set oDoc = Documents.Open(folder & strFilename)
            strDocName = ActiveDocument.FullName
            intPos = InStrRev(strDocName, ".")
            strDocName = Left(strDocName, intPos - 1)
            strDocName = strDocName & ".docx"
            oDoc.SaveAs FileName:=strDocName, _
                FileFormat:=wdFormatDocumentDefault
            oDoc.Close SaveChanges:=wdDoNotSaveChanges

            strFilename = Dir
        Wend
    End If
    Next

    strFilename = ""
End Function

'List all the subfolders in the current folder
Function GetSubFolders(RootPath As String)
    Dim FS As New FileSystemObject
    Dim FSfolder As folder
    Dim subfolder As Variant


    Set FSfolder = FS.GetFolder(RootPath)

    'subfolders is variable length
    Dim subfolders() As String
    ReDim subfolders(1 To 10)

    Dim i As Integer
    i = LBound(subfolders)
    For Each subfolder In FSfolder.subfolders
        subfolders(i) = subfolder.Name

        'increase the size of subfolders if it's needed
        i = i + 1
        If (i >= UBound(subfolders)) Then
            ReDim subfolders(1 To (i + 10))
        End If

    Next subfolder

    Set FSfolder = Nothing

    GetSubFolders = subfolders

End Function

ええ、私はそれがたくさんのコードであることを知っています。:)

于 2013-03-28T20:05:58.720 に答える