在目录中创建一个文件夹，然后将文件从另一个文件复制到新文件夹中

Question

我正在为我工​​作的地方创建一个新的数据库。 它正在为工作创建报价。 当我单击“保存”按钮时，它会保存报价并打开一个新文件夹，该文件夹的名称从表单的三个字段中获取。 我希望它从目录中的另一个文件夹导入文件或将文件复制到新创建的文件夹。

我尝试使用copyfolder函数，它确实将文件复制，但是复制到保存所有引号的主文件夹中，而不是复制到新创建的文件夹中。

    On Error GoTo btnOK_Click_Error

    Const strParent = "C:\Users\r.jones\Desktop\Quotes\ "
    Dim Strquotenumber As String
    Dim Strsite As String
    Dim StrprojDesc As String
    Dim strFolder As String
    Dim Strspace As String

    Strspace = Space(1) & "- "

    Strquotenumber = Me.QuoteNumber
    Strsite = Me.Txtsite
    StrprojDesc = Me.Project_Description

    strFolder = strParent & Strquotenumber & Strspace & Strsite & Strspace & StrprojDesc
    If Dir(strFolder, vbDirectory) = "" Then MkDir strFolder


    Shell "explorer.exe " & strFolder, vbNormalFocus

    If Me.Dirty Then DoCmd.RunCommand acCmdSaveRecord
    DoCmd.Close acForm, Me.Name
    DoCmd.OpenForm "Frmquotebook"

btnOK_Click_Exit:
    Exit Sub

btnOK_Click_Error:
    MsgBox "Error" & " In Attempting To Create New Folder. All Fields Must Be Filled In." & vbCrLf_
    Cancel = True
    Resume btnOK_Click_Exit

是否有可能这样做，因为我无法在上面找到任何东西。

谢谢您的帮助。

Answer 1

这是我使用的一些文件系统例程，包装了Scripting.FileSystemObject对象：

Public Function FileExists(FileName As String) As Boolean
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    FileExists = fso.FileExists(FileName)
End Function

Public Sub DeleteFile(FileName As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If FileExists(FileName) Then fso.DeleteFile FileName, True
End Sub

Public Sub CopyFile(Source As String, Destination As String, Optional force As Boolean = False)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    If FileExists(Source) Then
        fso.CopyFile Source, Destination, force
    End If
End Sub

Public Sub CreateFolder(Folder As String)
    Dim fso As Object
    Dim Position As Integer
    Dim TempFolder As String
    Dim Folders As Object
    Dim strArr() As String
    Dim i As Integer
    Position = 0
    TempFolder = ""
    strArr = Split(Folder, "\")
    Set fso = CreateObject("Scripting.FileSystemObject")
    For i = 0 To UBound(strArr)
        If Not fso.FolderExists(TempFolder & strArr(i) & "\") Then
            Set Folders = fso.GetFolder(TempFolder).subFolders
            Folders.Add (strArr(i))
        End If
        TempFolder = TempFolder & strArr(i) & "\"
    Next

End Sub

Answer 2

您将需要遍历源目录中的每个文件，并将其复制到目标目录中

Sub CopyFilesInDirectoryToFolder(SourceDirectory As String, DestinationDirectory As String)
    Dim fileName As String
    If Not Right(SourceDirectory, 1) = Application.PathSeparator Then SourceDirectory = SourceDirectory & Application.PathSeparator
    If Not Right(DestinationDirectory, 1) = Application.PathSeparator Then DestinationDirectory = DestinationDirectory & Application.PathSeparator
    fileName = Dir(SourceDirectory)
    Do While Len(fileName) > 0
        CopyFile SourceDirectory & fileName, DestinationDirectory & fileName
        fileName = Dir()
    Loop
End Sub