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")

Dim CAD AS Object 
Set CAD = pcdpartprogram.CadModel

'-------------------------------------------------------------------------------------------------------------------------
' 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_prg
source_path_prg = pcdpartprogram.fullname
'MsgBox(source_path_prg)

'-------------------------------------------------------------------------------------------------------------------------
' Findet den vollen Namen des originalen CADs (mit Pfad & Dateiendung)
' Gets the full Name of the original CAD (with path & file extension)
'-------------------------------------------------------------------------------------------------------------------------
Dim source_path_cad
source_path_cad = Left(source_path_prg,Len(source_path_prg)-4) & ".CAD"
'MsgBox(source_path_cad)

'-------------------------------------------------------------------------------------------------------------------------
' Definiert das Hauptverzeichniss für den Archiv Speicherpfad
' Defines the root folder for the archive path
'-------------------------------------------------------------------------------------------------------------------------
strpath = "W:\TEST\20_Messmaschinen\Hexagon\10_Messprogramme\90_AutoArchiv\"
'MsgBox(strpath)

'-------------------------------------------------------------------------------------------------------------------------
' 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 artikel As Object
Set artikel = pcdpartprogram.getvariablevalue("V_ARTIKEL")
strartikel = artikel.stringvalue
'MsgBox(strartikel)

Dim pa As Object
Set pa = pcdpartprogram.getvariablevalue("V_PA")
strpa = pa.stringvalue
'MsgBox(strpa)

Dim operation As Object
Set operation = pcdpartprogram.getvariablevalue("V_OPERATIONSSCHRITT")
stroperation = operation.stringvalue
'MsgBox(stroperation)

Dim teil As Object
Set teil = pcdpartprogram.getvariablevalue("V_TEIL")
strteil = teil.stringvalue
'MsgBox(strteil)

strteilformat = Format(strteil%, "0000")
'MsgBox(strteilformat)

Dim toleranz As Object
Set toleranz = pcdpartprogram.getvariablevalue("V_OOT")
strtoleranz = toleranz.stringvalue
'MsgBox(stroperation)

'-------------------------------------------------------------------------------------------------------------------------
' 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

strpath = strpath & "\" & strartikel
'MsgBox(strpath)

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

strpath = strpath & "\" & strpa
'MsgBox(strpath)

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

strpath = strpath & "\" & stroperation
'MsgBox(strpath)

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

'-------------------------------------------------------------------------------------------------------------------------
' Generiert das aktuelle Datum & Uhrzeit
' Generates the current date & time
'-------------------------------------------------------------------------------------------------------------------------
datetime = format(now(),"YYYYMMDDHHNNSS")
'MsgBox(datetime)

'-------------------------------------------------------------------------------------------------------------------------
' Generiert den vollen Archiv Namen für das Messprogramm & CAD (mit Pfad & Dateiendung)
' Generates the full archive name for the part program & CAD (with path & file extension)
'-------------------------------------------------------------------------------------------------------------------------
dest_path_prg = strpath & "\" & strartikel & "_" & strpa & "_" & stroperation & "_T" & strteilformat & "_" & strtoleranz & "_" & datetime & ".prg"
'MsgBox(dest_path_prg)

dest_path_cad = strpath & "\" & strartikel & "_" & strpa & "_" & stroperation & "_T" & strteilformat & "_" & strtoleranz & "_" & datetime & ".cad"
'MsgBox(dest_path_cad)

'-------------------------------------------------------------------------------------------------------------------------
' Kopiert das original Messprogramm & CAD in das Archiv
' Copies the original part program & CAD to the archive
'-------------------------------------------------------------------------------------------------------------------------
fso.copyfile source_path_prg, dest_path_prg

If Not Dir(source_path_cad) = "" Then
fso.copyfile source_path_cad, dest_path_cad
End If

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


End Sub