Trying to make a macro to archive old versions if they exist before saving

[Radioaktivitat]

Hi y'all,

I'm trying to add a new function to a macro we're currently using at work.

Currently, if used on a drawing, it takes information on a Userform (Revision, Date, etc.) and creates a filename with it then saves it as a PDF in a subfolder named "PDF". What I'm trying to accomplish is, prior to saving, check if a file with the same base name already exists and, if it does, move said file to an "Archive" subfolder within the "PDF" subfolder.



Here's what I was thinking (Code is removed before and after for added clarity) :

Code: Select all

Filepath = Left(swDraw.GetPathName, InStrRev(swDraw.GetPathName, "\"))

If Dir(Filepath & "PDF", vbDirectory) = "" Then  here
	MkDir Filepath + "PDF" 
	End If
Filepath = Filepath + "PDF\" 

Set swCustPropMgr = swModel.Extension.CustomPropertyManager("")
   swCustPropMgr.Get3 "Révision", False, "", Value 

Filename = Mid(swDraw.GetPathName, InStrRev(swDraw.GetPathName, "\") + 1)
Filename = Left(Filename, Len(Filename) - 7)

If TextBox3.Value <> "" Then
	theRev = "_Rev " & TextBox3.Value
	End If
'
If CheckBox1.Value = True Then
	Formatdate = Format(Now(), "YYYYMMDD")
	Formatdate = "_" & Formatdate
	End If

If TextBox1.Value <> "" Then
	Pref = TextBox1.Value & "_"
	End If

If TextBox2.Value <> "" Then
	Suff = "_" & TextBox2.Value
	End If

Code: Select all

FilenameFinal = Pref & Filename & Suff & theRev & Formatdate & ".pdf"

boolstatus = swExportPDFData.SetSheets(swExportData_ExportSpecifiedSheets, varSheetName)
swExportPDFData.ViewPdfAfterSaving = False
Dim swCustProp As CustomPropertyManager
Set swCustProp = swModelDocExt.CustomPropertyManager("")
boolstatus = swModelDocExt.SaveAs(Filepath & FilenameFinal, 0, 0, swExportPDFData, lErrors, lWarnings)

UserForm1.Hide

Where the split in code is, I'd add something like this:

Code: Select all

If Dir(Filepath & "Archive", vbDirectory) = "" Then ' Change Sub folder Name here
    MkDir Filepath + "Archive" ' Change Sub folder Name here
    End If

FilepathArchive = Filepath + "Archive\" ' Change Sub folder Name here

If IsNumeric(TextBox3.Value) = True then

    Set RevExist = 0

    While RevExist <= TextBox3.Value

        FilenameExisting = Filename & "_Rev " & RevExist & (SOMETHING TO ACT AS A JOKER FOR ALL PREVIOUS DATES) & ".pdf"

        Set fso = CreateObject("Scripting.FileSystemObject")

        If fso.FileExists(FilenameExisting)
        
            Call fso.CopyFile Filepath, FilepathArchive
        
        Else
    
        RevExist = RevExist + 1
    
    Wend
    
    Else
    
    RevNames = Array("A", "B", "C", "D", "E", "F", "G","H", "J")

        For Each Revs In RevNames
    
            FilenameExisting = Filename & "_Rev " & Revs & (SOMETHING TO ACT AS A JOKER FOR ALL PREVIOUS DATES) & ".pdf"

            Set fso = CreateObject("Scripting.FileSystemObject")

            If fso.FileExists(FilenameExisting)
        
                Call fso.CopyFile Filepath, FilepathArchive
        
            Else
    
        Next

Anyway to make it work somehow? Any help is appreciated especially regarding the date issue.

[Ömür Tokman]

Not a solution but just an idea. The save as command queries the existing same name and opens a window to save it to a different location if it exists.
Maybe.

[Radioaktivitat]

Not a solution but just an idea. The save as command queries the existing same name and opens a window to save it to a different location if it exists.
Maybe.

Might be worth exploring but since the "new" file would have a different name (New date & [possibly but not necessarily with internal revisions] new revision number) I'm not sure how you'd make the save as query recognize it as the same name.

It would work if you save twice on the same day. But this is more intended for cases where you do a revision based on a customer review of your drawing sometimes weeks after the fact so no way (other than opening the folder and checking which is counter productive to creating a macro) to know what previous date to look for.

And since this would be a new macro, I also want it to auto-archive multiple instances / previous revisions of the drawing if need be. Say you're at revision D then revisions 0, A, B, and C would all be in the pdf file so the new macro would archive them all leaving only Rev D.

[Ömür Tokman]

Might be worth exploring but since the "new" file would have a different name (New date & [possibly but not necessarily with internal revisions] new revision number) .......

Maybe you'd like to try it.
You can call these codes as a function before saving.
Or you can return a value and use it in the main page.
Call gettingfilenames()

Code: Select all

Dim ds, dc, f, fn, Filename, Selection
Sub Main
Call gettingfilenames()
If  Selection=1 Then
save pdf folder
Else
save Archive folder
End If
End Sub

Sub gettingfilenames() 'Function gettingfilenames()


Filename = "sub-punch-1.SLDPRT" 'enter the name of the file to be saved here.You will use it for comparison.

Set ds = CreateObject("Scripting.FileSystemObject") 'Create a repository to store folder names
Set f = ds.GetFolder(Variable containing the address of the folder) 'enter the folder address to be queried here.
Set dc = f.Files 'collect filenames into a repository

For Each Folder In dc 'compare all the names in the repository (folder) with the name you want to save.
fn = Folder.Name
Debug.Print "Folder Name: " & fn

If fn = Filename Then 'If the file name you want to save has the same name, set the folder selection variable to 1.
Selection = 1
End If

Next
Debug.Print " selection variable: " & Selection
Debug.Print " filename variable: " & Filename

If Selection = 1 Then 'if selection is 1 (if same name) save in Archive folder and not in PDF folder.
MsgBox "There is a file with the same name!" 'Write the codes to save it to the archive folder here.
Else
MsgBox "There is no other file with the same name!" 'Write the codes you will save in the pdf folder here.
End If

End Sub 'End Function

[Radioaktivitat]

Here's where I'm at now. My issue is the wildcards I think. Because files have a date after the name and I don't want to check every possible combination I'm trying to implement a wildcard system after the base name. It also doesn't move the "old" existing file from pdf to archive. Either it doesn't register the wildcard and therefore doesn't detect that the file exists or I'm not using the right function to move the files.

Code: Select all

If Dir(Filepath & "PDF", vbDirectory) = "" Then ' Change Sub folder Name here
    MkDir Filepath + "PDF" ' Change Sub folder Name here
    End If

Filepath = Filepath + "PDF\" ' Change Sub folder Name here

Set swCustPropMgr = swModel.Extension.CustomPropertyManager("")
   swCustPropMgr.Get3 "Révision", False, "", Value 'Change here the var revision "Rev."

Filename = Mid(swDraw.GetPathName, InStrRev(swDraw.GetPathName, "\") + 1)
Filename = Left(Filename, Len(Filename) - 7)

If TextBox3.Value <> "" Then
    theRev = "_Rev " & TextBox3.Value
    End If

If CheckBox1.Value = True Then
    Formatdate = Format(Now(), "YYYYMMDD")
    Formatdate = "_" & Formatdate
    End If

If TextBox1.Value <> "" Then
    Pref = TextBox1.Value & "_"
    End If

If TextBox2.Value <> "" Then
    Suff = "_" & TextBox2.Value
    End If

Code: Select all

Dim FilepathArchive As String
Dim FilepathExisting As String
Dim RevExist As Integer
Dim RevNames, Revs As Variant
Dim ds, dc, f, fn, Selection


If Dir(Filepath & "Archive", vbDirectory) = "" Then ' Change Sub folder Name here
    MkDir Filepath + "Archive" ' Change Sub folder Name here
    End If

FilepathArchive = Filepath + "Archive\" ' Change Sub folder Name here

Set fso = CreateObject("Scripting.FileSystemObject")
Set ds = CreateObject("Scripting.FileSystemObject")

FilepathExisting = Filepath
     
FilenameExisting = Filename & "%.pdf"

Set f = ds.GetFolder(FilepathExisting)
        
Set dc = f.Files
        
For Each Folder In dc 'compare all the names in the repository (folder) with the name you want to save.
	fn = Folder.Name
	Debug.Print "Folder Name: " & fn
        
	If fn = FilenameExisting Then 'If the file name you want to save has the same name, set the folder selection variable to 1.
		Selection = 1
	End If
        
Next
        
Debug.Print " selection variable: " & Selection
Debug.Print " filename variable: " & Filename
        
If Selection = 1 Then 'if selection is 1 (if same name) move to Archive folder
	Call fso.MoveFile(FilepathExisting, FilepathArchive)
Else
End If

Code: Select all

FilenameFinal = Pref & Filename & Suff & theRev & Formatdate & ".pdf"

boolstatus = swExportPDFData.SetSheets(swExportData_ExportSpecifiedSheets, varSheetName)
swExportPDFData.ViewPdfAfterSaving = False
Dim swCustProp As CustomPropertyManager
Set swCustProp = swModelDocExt.CustomPropertyManager("")
boolstatus = swModelDocExt.SaveAs(Filepath & FilenameFinal, 0, 0, swExportPDFData, lErrors, lWarnings)

[Radioaktivitat]

I seem to have figured it out!

Thank you for your help! My issue with wildcard was that

If fn = FilenameExisting

doesn't work with wildcards because it's looking for an exactly identical value. What fixed it was

If fn Like FilenameExisting

Here's the working code. Still plenty of testing to be done before company implementation but so far so good.

Code: Select all

Filepath = Left(swDraw.GetPathName, InStrRev(swDraw.GetPathName, "\"))

If Dir(Filepath & "PDF", vbDirectory) = "" Then ' Change Sub folder Name here
    MkDir Filepath + "PDF" ' Change Sub folder Name here
    End If

Filepath = Filepath + "PDF\" ' Change Sub folder Name here

Set swCustPropMgr = swModel.Extension.CustomPropertyManager("")
   swCustPropMgr.Get3 "Révision", False, "", Value 'Change here the var revision "Rev."

Filename = Mid(swDraw.GetPathName, InStrRev(swDraw.GetPathName, "\") + 1)
Filename = Left(Filename, Len(Filename) - 7)

If TextBox3.Value <> "" Then
    theRev = "_Rev " & TextBox3.Value
    End If

If CheckBox1.Value = True Then
    Formatdate = Format(Now(), "YYYYMMDD")
    Formatdate = "_" & Formatdate
    End If

If TextBox1.Value <> "" Then
    Pref = TextBox1.Value & "_"
    End If

If TextBox2.Value <> "" Then
    Suff = "_" & TextBox2.Value
    End If

Dim FilepathArchive As String
Dim FilepathExisting As String
Dim RevExist As Integer
Dim RevNames, Revs As Variant
Dim ds, dc, f, fn, Selection
Dim FSO As Object, sourceFolder As Object, Folder As Object
Dim sourceFilePath As String, destinationFilePath As String

If Dir(Filepath & "Archive", vbDirectory) = "" Then ' Change Sub folder Name here
    MkDir Filepath + "Archive" ' Change Sub folder Name here
    End If

FilepathArchive = Filepath + "Archive\" ' Change Sub folder Name here

Set FSO = CreateObject("Scripting.FileSystemObject")
Set ds = CreateObject("Scripting.FileSystemObject")

FilepathExisting = Filepath
     
FilenameExisting = Filename & "*.pdf"

Set f = ds.GetFolder(FilepathExisting)
        
Set dc = f.Files
        
For Each Folder In dc 'compare all the names in the repository (folder) with the name you want to save.
    fn = Folder.Name
    Debug.Print "Folder Name: " & fn
        
    If fn Like FilenameExisting Then 'If the file name you want to save has the same name, set the folder selection variable to 1.
        sourceFilePath = Folder.Path
        destinationFilePath = FilepathArchive '& "\" & FilenameExisting
        FSO.MoveFile Source:=sourceFilePath, Destination:=destinationFilePath
        'MsgBox "File exists"

    End If
        
Next

FilenameFinal = Pref & Filename & Suff & theRev & Formatdate & ".pdf"

boolstatus = swExportPDFData.SetSheets(swExportData_ExportSpecifiedSheets, varSheetName)
swExportPDFData.ViewPdfAfterSaving = False
Dim swCustProp As CustomPropertyManager
Set swCustProp = swModelDocExt.CustomPropertyManager("")
boolstatus = swModelDocExt.SaveAs(Filepath & FilenameFinal, 0, 0, swExportPDFData, lErrors, lWarnings)

UserForm1.Hide