asked on

VBA folder copy - destination folder duplicates

In Access 2010/2013 VBA I'm using this function as a way to copy files in a foider to another folder - and first time run it works fine - but second time run, if the folder already exists, the target folder is then created inside the already existing target folder - I cannot figure out whats wrong :) ?

VBCopyFolder "H:\Tools\PH\", "C:\Users\Michael\AppData\Roaming\PH", True

Private Const FO_MOVE As Long = &H1
Private Const FO_COPY As Long = &H2
Private Const FO_DELETE As Long = &H3
Private Const FO_RENAME As Long = &H4
Private Const FOF_MULTIDESTFILES As Long = &H1
Private Const FOF_CONFIRMMOUSE As Long = &H2
Private Const FOF_SILENT As Long = &H4
Private Const FOF_RENAMEONCOLLISION As Long = &H8
Private Const FOF_NOCONFIRMATION As Long = &H10
Private Const FOF_WANTMAPPINGHANDLE As Long = &H20
Private Const FOF_CREATEPROGRESSDLG As Long = &H0
Private Const FOF_ALLOWUNDO As Long = &H40
Private Const FOF_FILESONLY As Long = &H80
Private Const FOF_SIMPLEPROGRESS As Long = &H100
Private Const FOF_NOCONFIRMMKDIR As Long = &H200


Public Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Long
    hNameMappings As Long
    lpszProgressTitle As Long
End Type

Public Sub VBCopyFolder(ByRef strSource As String, ByRef strTarget As String, bOverWrite As Boolean) ', bAllowUndo As Boolean)
    Dim op As SHFILEOPSTRUCT
    Dim lngFlags As Long

    With op
        .wFunc = FO_COPY
        .pTo = strTarget
        .pFrom = strSource
        If bOverWrite = True Then
            lngFlags = FOF_SIMPLEPROGRESS Or FOF_NOCONFIRMATION
        Else
            lngFlags = FOF_SIMPLEPROGRESS
        End If
        
         .fFlags = lngFlags
    End With
    
    SHFileOperation op
End Sub

Open in new window

ASKER CERTIFIED SOLUTION

Fabrice Lambert

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Mik Mak

ASKER

Yes, I've been implementing this in the meantime :)

Sub CopyFiles(ByRef strSourceFolder As String, ByRef strDestFolder As String, bOverWrite As Boolean) ', bAllowUndo As Boolean)
    Dim fso As Scripting.FileSystemObject
    Dim fld As Scripting.Folder
    Dim fils As Scripting.Files
    Dim fil As Scripting.File
    Dim strFileName As String

    On Error GoTo err_Proc

    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FolderExists(strDestFolder) Then
        MkDir strDestFolder
    End If
    
    If Not fso.FolderExists(strSourceFolder) Then GoTo exit_Proc
    
    Set fld = fso.GetFolder(strSourceFolder)

    For Each fil In fld.Files
        fso.CopyFile fil.Path, strDestFolder & fil.Name, bOverWrite
    Next

exit_Proc:
    Set fil = Nothing
    Set fils = Nothing
    Set fld = Nothing
    Set fso = Nothing
    Exit Sub
err_Proc:
    Debug.Print Err.Description
    GoTo exit_Proc
End Sub

Open in new window