使用vba

Question

我正在尝试弄清楚如何使用MS Access表单中的VBA代码正确移动网络共享上的文件夹。

目前我正在尝试使用FileSystemObject.MoveFolder方法但仍然遇到“Permissions Denied”错误。

我引用了这个问题，但没有一个最重要的建议有效。 Permission denied on CopyFile in VBS

我已经通过在本地计算机上使用此函数对MoveFolders验证了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

Answer 1

我尝试使用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

Answer 2

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

注意wait在这里很重要，没有暂停，这将无效。另请注意仅在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