使用vba跨网络移动文件夹

我试图找出如何使用MS Access表单中的VBA代码正确移动网络共享上的文件夹

目前，我正在尝试使用FileSystemObject.MoveFolder方法，但始终遇到“权限被拒绝”错误

我引用了这个问题，但上面的建议都不起作用。

通过使用此函数在本地计算机上移动文件夹，我已验证SourcePath和DestinationPath都有效。我还验证了这两个文件夹都具有相应的网络权限。见下文

所以我的问题是，有没有一种方法可以为FileSystemObject提供凭据？或者我应该使用完全不同的函数

编辑：

我已验证可以手动移动文件夹。我已经尝试了在源文件夹中包含和不包含文件的函数

我还尝试将源路径和目标路径硬编码到

FSO.MoveFolder

命令中

Private Sub Check6_AfterUpdate()

    On Error GoTo Err_DormantHandler
    Dim response As String
    Dim client As String
    Dim FSO As Object
    Dim fromPath As String
    Dim toPath As String
    Set FSO = CreateObject("Scripting.Filesystemobject")

    client = Me.CustomerName.Value
    fromPath = "P:\__Active_Clients\" & client
    toPath = "R:\Dormant_Clients\"

    If Me.Check6.Value = True Then
        response = MsgBox("Would you like to automatically move the " & client & " folder to the dormant folder?", vbYesNo)

        If response = vbYes Then
            If FSO.FolderExists(fromPath) = False Then
                MsgBox fromPath & " doesn't exist."
                Exit Sub
            End If
            If FSO.FolderExists(toPath) = False Then
                MsgBox toPath & " doesn't exist."
                Exit Sub
            End If

            FSO.MoveFolder source:=fromPath, destination:=toPath
            MsgBox "The customer folder has been moved to " & vbNewLine & toPath, vbOKOnly
        End If

        If response = vbNo Then
            MsgBox "The customer folder will NOT be moved to dormant"
            Exit Sub
        End If
    End If


Exit_DormantHandler:
    Exit Sub

Err_DormantHandler:
    MsgBox "Error# " & Err & vbNewLine & "Description: " & Error$
    Resume Exit_DormantHandler

End Sub

---

您可以尝试批处理文件路由，是否有权限错误？您需要脚本参考，但看起来您已经有了

注意，

等待

在这里很重要，如果没有暂停，这将不起作用。还要注意，尾随斜杠仅在newDir中，而不是在orig中

Sub Main()
    Dim origDir As String: origDir = "C:\Users\thomas.preston\Original"
    Dim newDir As String: newDir = "C:\Users\thomas.preston\Destination\"
    Dim batDir As String: batDir = "C:\Users\thomas.preston\Desktop"
    Dim contents As String

    If Not DirectoryExists(origDir) Then
        MsgBox "Directory deos not exist: " & vbCrLf & origDir
        Exit Sub
    Else
        contents = "move """ & origDir & """ """ & newDir & """"
        MakeBat batDir & "\" & "ILikeToLoveItMoveIt.bat", contents
        FireBat batDir & "\" & "ILikeToLoveItMoveIt.bat"
        Application.Wait DateAdd("S", 2, Now)
    End If

    If DirectoryExists(newDir & folderName(origDir)) = True Then MsgBox "Greeeeeeat success" Else MsgBox "doh"
    If FileExists(batDir & "\" & "ILikeToLoveItMoveIt.bat") = True Then Kill batDir & "\" & "ILikeToLoveItMoveIt.bat"
End Sub

Function folderName(ByRef origDir As String) As String
    folderName = Right(origDir, Len(origDir) - InStrRev(origDir, "\", , vbTextCompare))
End Function

Sub MakeBat(ByVal FileName As String, ByVal contents As String)
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile(FileName, True)
    a.WriteLine (contents)
    a.Close
End Sub

Function FireBat(ByRef FullName As String)
If dir(FullName, vbNormal) <> "" Then
    Call Shell(FullName, vbNormalFocus)
Else
    MsgBox "Bat not created"
End If
End Function

Function FileExists(ByVal FullPath As String) As Boolean
If dir(FullPath) <> "" Then
    FileExists = True
Else
    FileExists = False
End If
End Function

Function DirectoryExists(ByVal FullPath As String) As Boolean
If dir(FullPath, vbDirectory) <> "" Then
    DirectoryExists = True
Else
    DirectoryExists = False
End If
End Function

Sub-Main（）
Dim origDir As String:origDir=“C:\Users\thomas.preston\Original”
Dim newDir作为字符串：newDir=“C:\Users\thomas.preston\Destination\”
Dim batDir作为字符串：batDir=“C:\Users\thomas.preston\Desktop”
将内容设置为字符串
如果不存在目录（origDir），则
MsgBox“目录DEO不存在：”&vbCrLf&origDir
出口接头
其他的
contents=“move”&origDir&&newDir&&
MakeBat batDir&“\”和“ILikeToLoveItMoveIt.bat”，目录
FireBat batDir&“\”和“ILikeToLoveItMoveIt.bat”
Application.Wait DateAdd（“S”，2，Now）
如果结束
如果目录存在（newDir&folderName（origDir））=True，则MsgBox“greeeeat success”或MsgBox“doh”
如果文件存在（batDir&“\”和“ILikeToLoveItMoveIt.bat”）=True，则杀死batDir&“\”和“ILikeToLoveItMoveIt.bat”
端接头
函数folderName（ByRef origDir作为字符串）作为字符串
folderName=Right（origDir，Len（origDir）-InStrRev（origDir，“\”，vbTextCompare））
端函数
子MakeBat（ByVal文件名为字符串，ByVal内容为字符串）
设置fs=CreateObject（“Scripting.FileSystemObject”）
设置a=fs.CreateTextFile（文件名，True）
a、 WriteLine（目录）
a、 接近
端接头
函数FireBat（ByRef FullName作为字符串）
如果dir（全名，vbNormal）“，则
调用Shell（全名、vbNormalFocus）
其他的
MsgBox“未创建Bat”
如果结束
端函数
函数FileExists（ByVal FullPath为字符串）为布尔值
如果目录（完整路径）“，则
FileExists=True
其他的
FileExists=False
如果结束
端函数
函数DirectoryExists（ByVal FullPath为字符串）为布尔值
如果dir（完整路径，vbDirectory）“，则
DirectoryExists=True
其他的
DirectoryExists=False
如果结束
端函数

我会尝试使用windows中的

xcopy

：

Sub Test()
  XCopy "C:\source", "C:\destination\", elevated:=False
End Sub

Public Sub XCopy(source As String, destination As String, Optional elevated = False)
  Static shell As Object
  If shell Is Nothing Then Set shell = CreateObject("Shell.Application")

  Dim vArguments, vOperation
  vArguments = "/E /Y """ & source & """ """ & destination & """"
  vOperation = IIf(elevated, "runas", "")

  shell.ShellExecute "xcopy.exe", vArguments, "", vOperation, 0
End Sub

---

你能手动执行完全相同的移动吗？是的，我能。我手动移动它没有问题，可以尝试

FSO.MoveFolder source:=fromPath，destination:=toPath&client

我相信我以前尝试过，但我只是再次检查以确保。不走运。同样的错误你的客户变量的全文是什么？我同意并支持这种方法。它（至少）有两个优点：1）命令（DOS）提示符提供更好的反馈（IMHO）和2）外壳处理不会阻止VBA代码。这是一个有效的替代方法。感谢您提供解决方案