Sub main()


'*************************************************************************************************************************
' Basierend auf dem "AUTOARCHIVE.BAS" Script von NinjaBadger (JON WOOD)
' Based On the "AUTOARCHIVE.BAS" script from NinjaBadger (JON WOOD)
' https://www.pcdmisforum.com/forum/pc-dmis-enterprise-metrology-software/pc-dmis-code-samples/390021-auto-archive-freebie
'*************************************************************************************************************************


'-------------------------------------------------------------------------------------------------------------------------
' Erstellt die Objekte
' Create the objects
'-------------------------------------------------------------------------------------------------------------------------
Dim pcdapp As Object
Set pcdapp = createobject("pcdlrn.application")

Dim pcdpartprogram As Object
Set pcdpartprogram = pcdapp.activepartprogram

Dim fso As Object
Set fso = createobject("scripting.filesystemobject")


'-------------------------------------------------------------------------------------------------------------------------
' Speichert das originale Messprogramm 
' Saves the original part program
'-------------------------------------------------------------------------------------------------------------------------
pcdpartprogram.save


'-------------------------------------------------------------------------------------------------------------------------
' Findet den vollen Namen des originalen Messprogramms (mit Pfad & Dateiendung)
' Gets the full Name of the original part program (With path & file extension)
'-------------------------------------------------------------------------------------------------------------------------
Dim source_path
source_path = pcdpartprogram.fullname


'-------------------------------------------------------------------------------------------------------------------------
' Findet die PC-DMIS Variablen für den Archiv Speicherpfad und Dateinamen
' Gets the PC-DMIS variables For the archive path And file Name
'-------------------------------------------------------------------------------------------------------------------------
Dim pathname As Object
Set pathname=pcdpartprogram.getvariablevalue("V_ARCHIV_PFAD")

strpath=pathname.stringvalue


Dim partname As Object
Set partname=pcdpartprogram.getvariablevalue("V_ARCHIV_NAME")

strpart=partname.stringvalue


'-------------------------------------------------------------------------------------------------------------------------
' Prüft ob der Archiv Speicherpfad existiert & erstellt ihn wenn nicht
' Checks If the archive path exists And creates it If Not
'-------------------------------------------------------------------------------------------------------------------------
Dim fsofolder As Object

If Not fso.folderexists(strpath) Then
Set fsofolder = fso.createfolder(strpath)
End If


'-------------------------------------------------------------------------------------------------------------------------
' Generiert den vollen Archiv Namen (mit Pfad & Dateiendung)
' Generates the full archive Name (With path & file extension)
'-------------------------------------------------------------------------------------------------------------------------
dest_path = strpath & "\" & strpart & "_" & format(now(),"YYYYMMDDHHNNSS") & ".prg"
'MsgBox(dest_path)


'-------------------------------------------------------------------------------------------------------------------------
' Kopiert die Originaldatei In das Archiv
' Copies the original file To the archive
'-------------------------------------------------------------------------------------------------------------------------
fso.copyfile source_path, dest_path


'-------------------------------------------------------------------------------------------------------------------------
' Räumt auf
' Tidies up
'-------------------------------------------------------------------------------------------------------------------------
Set fso = Nothing
Set pcdpartprogram = Nothing
Set pcdapp = Nothing


End Sub