Avail update remaining file to new folder
Attribute VB_Name = "CopyNew_toNewLoc"
Option Explicit
Const vbqt = """"
Const reREvitFileMatch As String = "^[^.]+\.(?!\d+\.)(rvt|rfa|rft|rte|txt)$"
Private Sub GetMissingFiles()
Dim ws As Worksheet
Dim wsFN As Worksheet
Dim oT As ListObject
Dim I As Integer
Dim fso As New FileSystemObject
Dim oFold As Folder
Dim RE As New RegExp
Dim Filelist As New Collection
Dim strSrc As String ''source folder
Dim strRefComp As String ''compare folder
Dim strDest As String ''destination
Dim ttl As Integer
Dim newRow As ListRow
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Set ws = Application.ActiveWorkbook.Worksheets("Files")
Set wsFN = Application.ActiveWorkbook.Worksheets("Source")
Set oT = ws.ListObjects(1)
' Loop through and delete all rows in the table
For I = oT.ListRows.Count To 1 Step -1
oT.ListRows(I).Delete
Next I
Application.EnableEvents = True
''Newpath = =pfp([@oldFP],"Families Downloaded from Mfr",dest)
With RE
.Global = True
.IgnoreCase = True
.MultiLine = True
.Pattern = reREvitFileMatch
End With
strSrc = wsFN.Range("Source")
strDest = wsFN.Range("Destination")
strRefComp = wsFN.Range("Compare")
''check source for files mathicng non-backup revit files
Set oFold = fso.GetFolder(strSrc)
recurseMatching fso, RE, oFold, Filelist
ttl = Filelist.Count ''snapshot of number of files
''Check compare folder - remove matching files and remaining will go to destination...
ofoldRemovePresentInDest fso, Filelist, strSrc, strRefComp
'ws.Activate
For I = 1 To Filelist.Count
Set newRow = oT.ListRows.Add(AlwaysInsert:=True)
oT.DataBodyRange.Cells(I, 1) = Filelist(I)
Next I
''FileList is all files in source that are not in destination
If Filelist.Count = 0 Then GoTo All_Synchronized
CopyFilesDown fso, Filelist, strSrc, strDest ''use fso to build folders and copy files down
GoTo GetMissingFiles_Cleanup
All_Synchronized:
MsgBox "All " & ttl & " files synchronized.", vbOKOnly + vbInformation, "Done"
GetMissingFiles_Cleanup:
With Application
.EnableEvents = True
.Calculation = xlCalculationSemiautomatic
.StatusBar = "Completed " & Format(Date + Time, "YYYY-MM-DD HH:mma/p")
End With
End Sub
Private Sub CopyFilesDown(ByRef fso As FileSystemObject, ByRef Filelist As Collection, strSrc As String, strDest As String)
Dim ofile As Variant
Dim strFile As String
Dim strFPfrom As String
Dim strFPto As String
Dim strFN As String
Dim cmd As String
Dim I As Integer
Dim ttl As Integer
Dim objShell As WshShell '' wshell3
Set objShell = CreateObject("WScript.Shell")
ttl = Filelist.Count
''trying to use robocopy to retain owner and time stamps. Ownership won't copy but rest is good.
For I = 1 To Filelist.Count ''Each ofile In Filelist
strFile = "": strFN = "": strFPfrom = "": strFPto = ""
strFile = Filelist(I) & ""
strFN = vbqt & GetFN(strFile) & vbqt
strFPfrom = vbqt & GetFP(strFile) & vbqt
strFPto = vbqt & pFP(GetFP(strFile), strSrc, strDest) & vbqt
FolderBuild strFPto, fso ''make sure folders are made
cmd = ""
cmd = "Robocopy " & strFPfrom & " " & strFPto & " " & strFN
cmd = cmd & " /COPY:DTXA" ''cannot /COPYALL or DATSO NTFS has error issue with security
If Left(strFPto, 1) = vbqt Then strFPto = Split(strFPto, vbqt)(1) ''Remove wrap quotes
If Left(strFN, 1) = vbqt Then strFN = Split(strFN, vbqt)(1) ''Remove wrap quotes
If Not fso.FileExists(strFPto & "\" & strFN) Then
objShell.Run "cmd /c " & cmd, 0, True
End If
Application.StatusBar = "Files remaining to copy: " & ttl - I
Next I
End Sub
Private Sub recurseMatching(ByRef fso As FileSystemObject, ByRef RE As RegExp, ByRef oFolder As Folder, ByRef Filelist As Collection)
Dim oFoldS As Folder
Dim ofile As File
''scan for files to add
For Each ofile In oFolder.Files
If RE.Test(ofile.Name) Then
Filelist.Add (ofile.Path)
End If
Next ofile
Application.StatusBar = "Files gathered: " & Filelist.Count ''update status bar
For Each oFoldS In oFolder.SubFolders
recurseMatching fso, RE, oFoldS, Filelist
Next oFoldS
End Sub
Private Sub ofoldRemovePresentInDest(ByRef fso As FileSystemObject, ByRef Filelist As Collection, strSrc As String, strRefComp As String)
Dim strPFP As String
Dim strFrom As String
Dim strTo As String
Dim I As Integer
For I = Filelist.Count To 1 Step -1
strFrom = "": strFrom = Filelist(I)
''get partial path by stripping source
strPFP = "": strPFP = Right(strFrom, Len(strFrom) - Len(strSrc) - 1)
strTo = "": strTo = strRefComp & "\" & strPFP
If fso.FileExists(strTo) Then
Filelist.Remove (I)
End If
Application.StatusBar = "Deducting reference Files: " & Filelist.Count & " remaining." ''update status bar
Next I
End Sub
''----------------------------------------------
Function GetFP(rng As String) As String
Dim x
Dim I
x = Split(rng, "\")
For I = 0 To UBound(x) - 1
GetFP = GetFP & x(I)
GetFP = GetFP & "\"
Next I
If Right(GetFP, 1) = "\" Then
GetFP = Left(GetFP, Len(GetFP) - 1)
End If
End Function
''----------------------------------------------
Function GetFN(rng As String) As String
Dim x
Dim I
x = Split(rng, "\")
GetFN = x(UBound(x))
End Function
''----------------------------------------------
Function pFP(fp As String, strMatch As String, strFPNew As String) As String
On Error GoTo pfp_err:
Dim I As Integer
If Right(strFPNew, 1) = "\" Then strFPNew = Left(strFPNew, Len(strFPNew) - 1) ''strip off trailing "\"
I = Len(fp) - (InStr(LCase(fp), LCase(strMatch)) + Len(strMatch))
If I < 0 Then ''strfpnew is in root of new folder''
pFP = strFPNew
Else
pFP = strFPNew & "\" & Right(fp, I)
End If
Exit Function
pfp_err:
pFP = "Err"
End Function
Function FolderBuild(ByVal fp As String, ByRef fso As FileSystemObject) As Folder ''creates folder if it doesn't exist
Dim strXpath As String
Dim x, I
If fso.FileExists(fp) Then ''Use File to get folders
fp = fso.GetFile(fp).ParentFolder.Name ''get folder name
End If
If fso.FolderExists(fp) Then ''as folder -
Set FolderBuild = fso.GetFolder(fp) ''get folder and return
Exit Function ''Exit funciton with folder set
End If
If Left(fp, 1) = vbqt Then fp = Right(fp, Len(fp) - 1)
If Right(fp, 1) = vbqt Then fp = Left(fp, Len(fp) - 1)
x = Split(fp, "\") ''Split to rebuild path
''otherwise we need to create the subfolders one by one
strXpath = x(0)
''''''''''''''''Create subfolderrs''''''''''''''''''''
For I = 1 To UBound(x)
strXpath = strXpath & "\" & x(I) ''build next segment of folder path
If Not fso.FolderExists(strXpath) Then ''incrementally make filepath
fso.CreateFolder strXpath ''folder didn't exist
End If
Next I
Set FolderBuild = fso.GetFolder(strXpath)
End Function
Sub SetMeta()
Dim objShell As New Shell32.Shell ''Microsoft Shell Controls and Automation
Dim objFolder ''As Folder
Dim objFile ''
''Set objshell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace("I:\Temp\Studio ID Tools\Revit Library\2023 Initiatives\Families Downloaded from Mfr")
Set objFile = objFolder.ParseName("Catalog - Acoustics.0003.rvt")
'' Add custom property
objFile.ExtendedProperty("IN") = "Catalog"
'' Save changes
objFolder.Items.InvokeVerb ("Apply Properties")
End Sub
Comments
Post a Comment