VBA 中的代码以弹出输入框、选择一个文件夹并删除 DOCX 文件

Question

我正在尝试制作一个转换 .要.DOCX的 RTF 文件。我已经设法完成了这一部分。现在，我想添加一个输入框来删除.同一文件夹中的 RTF 文件。

我不想每次必须创建一个新文件夹时都手动输入位置。

有没有办法拥有.运行程序时删除了同一文件夹中的RTF文件

或

有没有办法在输入框中选择位置。

法典：

Sub ChangeRTFTODOCXOrTxtOrRTFOrHTML()
'with export to PDF in Word 2007
    Dim fs As Object
    Dim oFolder As Object
    Dim tFolder As Object
    Dim oFile As Object
    Dim strDocName As String
    Dim intPos As Integer
    Dim locFolder As String
    Dim fileType As String
    Dim locFolderKill As String
    On Error Resume Next
    locFolder = InputBox("Enter the folder path to RTFs", "File Conversion", "")
    Select Case Application.Version
        Case Is < 12
            Do
                fileType = UCase(InputBox("Change rtf to TXT, RTF, HTML, DOCX", "File Conversion", "DOCX"))
            Loop Until (fileType = "TXT" Or fileType = "RTF" Or fileType = "HTML" Or fileType = "DOCX")
        Case Is >= 12
            Do
                fileType = UCase(InputBox("Change rtf to TXT, RTF, HTML, DOCX or PDF(2007+ only)", "File Conversion", "DOCX"))
            Loop Until (fileType = "TXT" Or fileType = "RTF" Or fileType = "HTML" Or fileType = "PDF" Or fileType = "DOCX")
    End Select
    Application.ScreenUpdating = False
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fs.GetFolder(locFolder)
    'Set tFolder = fs.CreateFolder(locFolder & "Converted")
    'Set tFolder = fs.GetFolder(locFolder & "Converted")
    For Each oFile In oFolder.Files
        Dim d As Document
        Set d = Application.Documents.Open(oFile.Path)
        strDocName = ActiveDocument.Name
        intPos = InStrRev(strDocName, ".")
        strDocName = Left(strDocName, intPos - 1)
        ChangeFileOpenDirectory tFolder
        Select Case fileType
        Case Is = "DOCX"
            strDocName = strDocName & ".DOCX"
            ActiveDocument.SaveAs FileName:=strDocName, FileFormat:=wdFormatXMLDocument
        Case Is = "TXT"
            strDocName = strDocName & ".txt"
            ActiveDocument.SaveAs FileName:=strDocName, FileFormat:=wdFormatText
        Case Is = "RTF"
            strDocName = strDocName & ".rtf"
            ActiveDocument.SaveAs FileName:=strDocName, FileFormat:=wdFormatRTF
        Case Is = "HTML"
            strDocName = strDocName & ".html"
            ActiveDocument.SaveAs FileName:=strDocName, FileFormat:=wdFormatFilteredHTML
        Case Is = "PDF"
            strDocName = strDocName & ".pdf"
            ' *** Word 2007 users - remove the apostrophe at the start of the next line ***
            'ActiveDocument.ExportAsFixedFormat OutputFileName:=strDocName, ExportFormat:=wdExportFormatPDF
        End Select
        d.Close
        ChangeFileOpenDirectory oFolder
    Next oFile
    Application.ScreenUpdating = True
'This is where I want to insert the InputBox to delete the .RFT files.

    On Error Resume Next
    Kill "C:UsersmaciasaDesktopmain testtest RFTs*.rtf"
    On Error GoTo 0
End Sub

1. 列表项

Answer 1

您可以使用这样的东西来允许用户以更用户友好的方式选择文件夹：

编辑 - 添加了删除文件

Sub Tester()
    Dim folderDialog As FileDialog, fld As String, numDel
    Set folderDialog = Application.FileDialog(msoFileDialogFolderPicker)
    folderDialog.AllowMultiSelect = False
    'user picked a folder?
    If folderDialog.Show() Then
        fld = folderDialog.SelectedItems(1)
        numDel = DeleteFiles(fld, "*.rtf")
        MsgBox numDel & " files deleted from: " & vbLf & fld
    End If
End Sub
Function DeleteFiles(theFolder As String, fileType As String) As Long
    Dim f, col As New Collection, rv As Long
    If Right(theFolder, 1) <> Application.PathSeparator Then
        theFolder = theFolder & Application.PathSeparator
    End If
    'collect all matching files in the folder
    f = Dir(theFolder & fileType, vbNormal)
    Do While f <> ""
        col.Add theFolder & f
        f = Dir()
    Loop
    rv = col.Count
    For Each f In col
       Kill f
    Next f
    DeleteFiles = rv '<<return number of files deleted
End Function