Copy file PDF/DWG/DXF from local server to a PC specific folder

[luca_061088]

SEARCH AND COPY.xlsm

Hi all

I've an Excel file with VBA macro inside...I use this file to search and copy specific files into a local nas server.

The problem is that the macro is configured to search in a specific location on the server nas

"\\nas01\Archivio Disegni\DV1\"

But I want the macro to search both in "Archivio Disegni" and also in its sub folders... As you can see on the atthached file, the sSourcePath is

sSourcePath = "\\nas01\Archivio Disegni\DV1\"

, so it is set to search in the specific DV! folder in Archivio Disegni,...and I "simply" want the macro to search in both in "Archivio Disegni" and also in its sub folders...all the file i'll serach has unique name, such as DV0001 and so on...every file I search has a unique name, so it's impossible to have duplicate file errors etc

The excel file is then set to return "not exist" if the file does not exist on the server, or PDF copied if it exists, etc as you can see in the attached file. but this is already working

This is the macro I have

Sub CopyDWG()
    Dim iRow As Integer         ' ROW COUNTER.
    Dim sSourcePath As String
    Dim sDestinationPath As String
    Dim sFileType As String
   
    Dim bContinue As Boolean
   
    bContinue = True
    iRow = 5
   
    ' THE SOURCE AND DESTINATION FOLDER WITH PATH.
    sSourcePath = "\\nas01\Archivio Disegni\DV1\"
    sDestinationPath = "C:\Users\luca\Desktop\DRW\"
   
    sFileType = ".dwg"      ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
 
    ' LOOP THROUGH COLUMN "D" TO PICK THE FILES.
    While bContinue
   
        If Len(Range("A" & CStr(iRow)).Value) = 0 Then    ' DO NOTHING IF THE COLUMN IS BLANK.
            MsgBox "Process executed" ' DONE.
            bContinue = False
        Else
            ' CHECK IF FILES EXISTS.
           
            If Len(Dir(sSourcePath & Range("A" & CStr(iRow)).Value & sFileType)) = 0 Then
                Range("D" & CStr(iRow)).Value = "Does Not Exists"
                Range("D" & CStr(iRow)).Font.Bold = True
            Else
                Range("D" & CStr(iRow)).Value = "DWG Copied"
                Range("D" & CStr(iRow)).Font.Bold = False
           
                If Trim(sDestinationPath) <> "" Then
                    Dim objFSO
                    Set objFSO = CreateObject("scripting.filesystemobject")
                   
                    ' CHECK IF DESTINATION FOLDER EXISTS.
                    If objFSO.FolderExists(sDestinationPath) = False Then
                        MsgBox sDestinationPath & " Does Not Exists"
                        Exit Sub
                    End If
                   
                    ' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
                    objFSO.CopyFile Source:=sSourcePath & Range("A" & CStr(iRow)).Value & _
                        sFileType, Destination:=sDestinationPath
                   
                  End If
            End If
        End If
     
       iRow = iRow + 1      ' INCREMENT ROW COUNTER.
    Wend
End Sub

Can someone help me with this, I cannot find any solution since i'm not that good with VBA.

Thanks all
Best Regards
Luca

[dangelor]

Not tested, but possibly...

Sub Not_Tested_on_Network()
    Dim sSourcePath As String, sDestinationPath As String
    Dim sFileType As String, iCol As Long
    Dim v As Variant, d As Object, k As Variant, fso As Object
    Dim rg As Range, i As Long
    
    sSourcePath = "\\nas01\Archivio Disegni\DV1\" 'CHANGE AS NEEDED
    sDestinationPath = "C:\Users\luca\Desktop\DRW\" 'CHANGE AS NEEDED
    sFileType = "pdf" 'CHANGE AS NEEDED
    
    'Get column to write to
    Select Case sFileType
        Case "pdf"
            iCol = 2
        Case "dfx"
            iCol = 3
        Case "dwg"
            iCol = 4
    End Select
    
    'Get all files including sub folders (fullnames)
    v = fn_FileList(sSourcePath, sFileType)
    
    'Add fullnames and filenames to dictionary
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set d = CreateObject("Scripting.Dictionary")
    For Each k In v
        d.Add fso.getfilename(k), k
    Next k
    
    'Get partial filenames to search
    Set rg = Sheets("Foglio1").Range(Cells(5, 1), Cells(Rows.Count, 1).End(xlUp))
    For i = 1 To rg.Rows.Count
        If d.exists(rg.Cells(i, 1) & "." & sFileType) Then
            rg.Cells(i, iCol) = sFileType & " exists"
            fso.copyfile d(rg.Cells(i, 1) & "." & sFileType), sDestinationPath
        Else
            rg.Cells(i, iCol) = sFileType & " does not exist"
        End If
    Next i
End Sub

Function fn_FileList(sPath As String, sFileType As String)

    'Gets all filenames from path and sub folders with named extension
    fn_FileList = Split(CreateObject("WScript.Shell") _
                    .exec("%ComSpec% /c dir /a-d /s /b """ & sPath & "*." & sFileType & "*""""") _
                    .stdout.readall, vbCrLf)
End Function

[luca_061088]

Not tested, but possibly...

Sub Not_Tested_on_Network()
    Dim sSourcePath As String, sDestinationPath As String
    Dim sFileType As String, iCol As Long
    Dim v As Variant, d As Object, k As Variant, fso As Object
    Dim rg As Range, i As Long
    
    sSourcePath = "\\nas01\Archivio Disegni\DV1\" 'CHANGE AS NEEDED
    sDestinationPath = "C:\Users\luca\Desktop\DRW\" 'CHANGE AS NEEDED
    sFileType = "pdf" 'CHANGE AS NEEDED
    
    'Get column to write to
    Select Case sFileType
        Case "pdf"
            iCol = 2
        Case "dfx"
            iCol = 3
        Case "dwg"
            iCol = 4
    End Select
    
    'Get all files including sub folders (fullnames)
    v = fn_FileList(sSourcePath, sFileType)
    
    'Add fullnames and filenames to dictionary
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set d = CreateObject("Scripting.Dictionary")
    For Each k In v
        d.Add fso.getfilename(k), k
    Next k
    
    'Get partial filenames to search
    Set rg = Sheets("Foglio1").Range(Cells(5, 1), Cells(Rows.Count, 1).End(xlUp))
    For i = 1 To rg.Rows.Count
        If d.exists(rg.Cells(i, 1) & "." & sFileType) Then
            rg.Cells(i, iCol) = sFileType & " exists"
            fso.copyfile d(rg.Cells(i, 1) & "." & sFileType), sDestinationPath
        Else
            rg.Cells(i, iCol) = sFileType & " does not exist"
        End If
    Next i
End Sub

Function fn_FileList(sPath As String, sFileType As String)

    'Gets all filenames from path and sub folders with named extension
    fn_FileList = Split(CreateObject("WScript.Shell") _
                    .exec("%ComSpec% /c dir /a-d /s /b """ & sPath & "*." & sFileType & "*""""") _
                    .stdout.readall, vbCrLf)
End Function

Hi dangelor, the code does give me any error, but seems he wont search and copy anything...he always give me pdf does not exist. Even if I change the source path. And I'm sure the file exist in the Archivio Disegni folder or subfolders

[dangelor]

Run this code and let me know if any filenames are listing in the message box.

Function fn_FileList(sPath As String, sFileType As String)

    'Gets all filenames from path and sub folders with named extension
    fn_FileList = Split(CreateObject("WScript.Shell") _
    .exec("%ComSpec% /c dir /a-d /s /b """ & sPath & "*." & sFileType & "*""""") _
    .stdout.readall, vbCrLf)
End Function

Sub Test()
    Dim v As Variant, sSourcePath As String, sFileType As String, s As String

    sSourcePath = "\\nas01\Archivio Disegni\DV1\"
    sFileType = "pdf"
    
    For Each v In fn_FileList(sSourcePath, sFileType)
        s = s & v & vbCrLf
    Next v
    MsgBox s
End Sub

[luca_061088]

Yes, a list with some files appears

I retryed to run the code, changing the destination path as I see that was incorrect, and the macro run correctly, it copy the files...but...if I put in sSourcePath only

\\nas01\Archivio Disegni\

without specifying any subfolders, the macro wont copy any files...it seems that the macro does not search even in the subfolders of the Archivio Disegni....the excel returns me "pdf does not exist" in the dedicated cells of the excel file...it seems that it does not take into account any subfolders of Archivio Disegni

but if I run the macro with

"\\nas01\Archivio Disegni\DV1\"

in the sSourcePath, for example, the macro run correctly copying the listed files

the macro should be able to search both in the Archivio Disegni and also in its subfolders... Eventually it would also be sufficient for the macro to search only in the Archivio Disegni subfolders as a last chance if we can't figure it out I hope I explained myself correctly

I don't want to disturb you too much, in fact I thank you for your availability

[dangelor]

I guess that shell doesn't work on a network. I'll see if I can come up with a different approach.

[luca_061088]

I also have this code

Option Explicit
Const sSourcePath = "\\nas01\Archivio Disegni\"
Const sDestinationPath = "C:\Users\l.dalise\Desktop\DRW\"
Dim objFSO     As Object
Dim SubFolder  As Object
Dim FileType   As String
Dim Colonna    As String
Dim iRow       As Long
Dim bContinue  As Boolean

Sub CopyDWG()
    FileType = ".dwg"
    Colonna = "D"
    CopyFiles sSourcePath, sDestinationPath, FileType, Colonna
    MsgBox "Process executed"
    Set objFSO = Nothing
End Sub

Sub CopyDXF()
    FileType = ".dxf"
    Colonna = "C"
    bContinue = True
    CopyFiles sSourcePath, sDestinationPath, FileType, Colonna
    MsgBox "Process executed"
    Set objFSO = Nothing
End Sub

Sub CopyPDF()
    FileType = ".pdf"
    Colonna = "B"
    bContinue = True
    CopyFiles sSourcePath, sDestinationPath, FileType, Colonna
    MsgBox "Process executed"
    Set objFSO = Nothing
End Sub

Public Sub CopyFiles(ByVal sSourcePath As String, ByVal sDestinationPath As String, sFileType As String, sColonna As String)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False
    'verifica se esiste la cartella destinazione
    If Trim(sDestinationPath) <> "" Then
        If objFSO.FolderExists(sDestinationPath) = False Then
            MsgBox sDestinationPath & " Does Not Exists"
            Exit Sub
        End If
    End If
    'ciclo su tutte le sotto cartelle
    For Each SubFolder In objFSO.GetFolder(sSourcePath).SubFolders
        iRow = 5
        bContinue = True
        CopyFiles SubFolder & "\", sDestinationPath, FileType, Colonna
    Next SubFolder
    'ciclo su tutti i nomi
    While bContinue
        If Len(Range("A" & CStr(iRow)).Value) = 0 Then
            bContinue = False
        Else
            If Range(sColonna & CStr(iRow)).Value <> "File Copied" Then 'se risulta già copiato non ripetere l'elaborazione
                'solo diagnostica perché file non trovato
                If Len(Dir(sSourcePath & Range("A" & CStr(iRow)).Value & sFileType)) = 0 Then '<- qui va in errore: 52 quando il nas è scollegato
                    Range(sColonna & CStr(iRow)).Value = "Does Not Exists"
                    Range(sColonna & CStr(iRow)).Font.Bold = True
                Else
                    'con copiatura e diagnostica per file trovato
                    objFSO.CopyFile Source:=sSourcePath & Range("A" & CStr(iRow)).Value & sFileType, Destination:=sDestinationPath
                    Range(sColonna & CStr(iRow)).Value = "File Copied"
                    Range(sColonna & CStr(iRow)).Font.Bold = False
                End If
            End If
        End If
        iRow = iRow + 1
    Wend
    Application.ScreenUpdating = True
    
End Sub

that seems to work, the problem with this is the space in the Archivio Disegni name that gives me an error, in fact if I change the path with example "\\nas01\scanner" it works, and the macro search for files in all its subfolders. Maybe there is a way to not let the macro read the space in the path Archivio Disegni... maybe this can help you in some way

[AliGW]

Administrative Note:

Welcome to the forum.

We would very much like to help you with your query, however it has been brought to our attention that the same query has been posted on one or more other forums and you have not told us about this. You are required to do so.

Please see Forum Rule #3 about cross-posting and adjust accordingly. Read this to understand why we (and other sites like us) consider this to be important: https://excelguru.ca/a-message-to-forum-cross-posters/

(Note: this requirement is not optional. As yo are new here, I shall do it for you this time: https://www.forumexcel.it/forum/thre...6/#post-511038)

[luca_061088]

Hi AliGW

I have read all the rules and I apologize for what happened. I posted on this forum after I had confirmation on the other forum you mentioned from Moderator alfrimpa on 7 December 2022 within the post itself. I didn't think I had to post the post from the other forum as a link here as well.

Thanks for the notice and I apologize again

[luca_061088]

hello dangelor is there any news on this? I take this opportunity to wish you a Merry Christmas