Question

我最近发布了试图找出如何使用Windows复制文件通知通过VBA复制/粘贴某些文件的方法。我发现我的脚本有效，但它是从我想要复制它们的位置复制文件，并将它们粘贴到我想复制的位置（正好相反）。任何人都可以向我解释原因吗？这是我的代码：

Private Sub Main()

'***************************************************************************
' Personal details
'***************************************************************************

    'Ask if the user wants to continue
    If MsgBox("Do you wish to continue (Outlook will close)?", vbYesNo + vbQuestion) = vbNo Then
        ThisWorkbook.Close
        End
    End If

        'Close Outlook so it doesn't interfere with the file copy
        strComputer = "."
        Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
        Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process Where Name = 'Outlook.exe'")
        For Each objProcess In colProcessList
            Set objOutlook = CreateObject("Outlook.Application")
            objOutlook.Quit
        Next

        If Len(Dir("\\[NetDrive]\[EmpNum]$\")) <> 0 Then
            If Len(Dir("C:\Users\[EmpNum]\Documents\Outlook Files\")) <> 0 Then

                    'Taken from multiple examples
                    'http://www.mrexcel.com/forum/excel-questions/238407-progress-bar-copying-file.html

                    Dim FromPath As Variant
                    Dim ToPath As Variant

                    FromPath = "C:\Users\[EmpNum]\Documents\Outlook Files\"  '<< Change for implicit reference
                    ToPath = "\\[NetDrive]\[EmpNum]$\Personal Folder Backup"    '<< Change for implicit reference

                    Application.Wait (Now + TimeValue("0:00:05"))       'Delay to allow Outlook to close

                    Set objShell = CreateObject("Shell.Application")
                    '//The source Folder to CopyFrom:
                    Set objFolder = objShell.Namespace(FromPath)

                    '//The source Folder to CopyTo:
                    objFolder.CopyHere ToPath, &H10&

                    Set objShell = Nothing
                    Set objFolder = Nothing

                    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
            Else
                MsgBox "Personal folder location not found.  Please check your personal folder."
            End If
        Else
            MsgBox "Network location not available.  Check your shared drives for connection."
        End If

        Application.Quit

End Sub

我已删除和/或更改了一些个人详细信息，但除此之外，这完全是我的代码。

Answer 1

我不确定为什么这次有效，而且之前没有。但我修改了我的代码以阅读下面的内容，现在它突然正常工作：

Private Sub Main()

'***************************************************************************
'  Personal Information
'***************************************************************************

    'Ask if the user wants to continue
    If MsgBox("Do you wish to continue (Outlook will close)?", vbYesNo + vbQuestion) = vbNo Then
        ThisWorkbook.Close
        End
    End If

        'Close Outlook so it doesn't interfere with the file copy
        strComputer = "."
        Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
        Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process Where Name = 'Outlook.exe'")
        For Each objProcess In colProcessList
            Set objOutlook = CreateObject("Outlook.Application")
            objOutlook.Quit
        Next

        If Len(Dir("\\[NetDrive]\[EmpNum]$\")) <> 0 Then
            If Len(Dir("C:\Users\[EmpNum]\Documents\Outlook Files\")) <> 0 Then

                    'Taken from multiple examples
                    'http://www.mrexcel.com/forum/excel-questions/238407-progress-bar-copying-file.html

                    Dim FromPath As Variant
                    Dim ToPath As Variant

                    FromPath = "C:\Users\[EmpNum]\Documents\Outlook Files\"  '<< Change for implicit reference
                    ToPath = "\\[NetDrive]\[EmpNum]$\Personal Folder Backup\"    '<< Change for implicit reference

                    Application.Wait (Now + TimeValue("0:00:05"))       'Delay to allow Outlook to close

                    Set objShell = CreateObject("Shell.Application")
'                    '//The source Folder to CopyFrom:
'                    Set objFolder = objShell.Namespace(FromPath)
'
'                    '//The source Folder to CopyTo:
'                    objFolder.CopyHere ToPath, &H10&
'
'                    Set objShell = Nothing
'                    Set objFolder = Nothing

                       Set objFolder = objShell.Namespace(ToPath)

                       If (Not objFolder Is Nothing) Then
                           objFolder.CopyHere (FromPath)
                       End If

                       Set objFolder = Nothing
                       Set objShell = Nothing

                    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
            Else
                MsgBox "Personal folder location not found.  Please check your personal folder."
            End If
        Else
            MsgBox "Network location not available.  Check your shared drives for connection."
        End If

        Application.Quit

End Sub

我想唯一的区别是&H10&不再存在。

为什么objFolder.CopyHere复制“错误的方式？”

1 个答案: