Saving PCDMIS file at end of program

Sub Main (PN As String, OP As String, SN As String, RPTTIME As String, RPTDATE As String, PRG As String, PRG_TYPE As String)

Dim App As Object
Dim Part As Object
Dim Cmds As Object
Dim Cmd As Object

' Initialize PC-DMIS
Set App = CreateObject("PCDLRN.Application")
    If App Is Nothing Then
        MsgBox "PC-DMIS initialization error!",48, "Error!"
        Exit Sub
    Else
        Set Part = App.ActivePartProgram
        If Part Is Nothing Then
            MsgBox "Part Program not opened!", 48, "Error!"
            Exit Sub
        Else
            Set Cmds = Part.Commands
            If Cmds Is Nothing Then
                MsgBox "Pointer to commands not valid!", 48, "Error!"
                Exit Sub
            End If
        End If
    End If


Dim CrntName As String
Dim NewName As String

CrntName = Part.FullName
'MsgBox(CrntName)

Newname = PRG & PN & "\RESULTS\" & OP & "\" & PN & "_" & OP & "_" & PRG_TYPE & "_" & SN & "_" & RPTDATE & "_" & RPTTIME & ".PRG"
'MsgBox(Newname)

Dim Retval As Boolean
retval = Part.SaveAs(newname)  


' Cleanup
Set Cmd = Nothing
Set Cmds = Nothing
Set Part = Nothing
Set App = Nothing
End Sub

Set Part_Num = Part.GetVariableValue ("PN")
PN = Part_Num.doublevalue

' Add 1 to the file name, until an unused name is reached
Sub Increment(Filename As String, FilePath As String)

  Dim p As Integer
  Dim NewNumber As Integer

  Do
    p = InStr(1, UCase(FileName), ".PRG")
    If (p > 0) Then
      FileName = left(FileName, p-1)
    End If

    p = Len(FileName)
    While (p > 0) And (Instr(1, "0123456789", Mid(FileName, p, 1)) > 0)
      p = p - 1
    Wend

    NewNumber = Val(Right(FileName, Len(FileName)-p))

    FileName = Left(FileName, p) + Str(NewNumber + 1)  + ".PRG"

  On Error Resume Next
  Loop Until (FileLen(FilePath + FileName) = 0)
  On Error GoTo 0

End Sub

' Increment the file name and save
' NOTE: It's the prog with the new name that is open in
' PC-DMIS after this.

Sub IncrSave(FilePath As String)

  Dim FileName As String
  Dim DmisApp As Object
  Dim DmisPart As Object

' Connect to PC-DMIS
  Set DmisApp = CreateObject("PCDLRN.Application")
  Set DmisPart = DmisApp.ActivePartProgram

  FileName = DmisPart.Name

' Make sure the path ends in "\"
  If Len(FilePath) > 0 Then
    If Mid(FilePath, Len(FilePath),1) <> "\" Then
      FilePath = FilePath + "\"
    End If
  End If

' Increment the name and save the program
  Increment FileName, FilePath
  DmisPart.SaveAs FilePath + FileName

' finish
  Set DmisPart = Nothing
  Set DmisApp = Nothing

End Sub

' Just for testing
Sub Main
  IncrSave("C:\TEMP")
End Sub

' Displays an inputbox telling the user To enter a serial number
' Or other information that will be concatenated To the partprogram
' Name (partname) And saved In the current partprogram folder.
'
' ORIGINAL CODE by vpt.se 2010
'
' Modified by Doug To just concatenate the date And time
' And To take the serialization number from ASSIGN/SRN="xxx" in the program And Input it into this one
'
Sub Main()
Dim PCDApp, PCDPartPrograms, PCDPartProgram
Set PCDApp = CreateObject("PCDLRN.Application")
Set PCDPartPrograms = PCDApp.PartPrograms
Set PCDPartProgram = PCDApp.ActivePartProgram

Dim setCrntName As String 
Set Serial = PCDPartProgram.GetVariableValue ("SRN")
Dim SerialNo As String

SerialNo = Serial.StringValue


' my added code
HR = HOUR(NOW)
MN = MINUTE(NOW)
SEC = SECOND(NOW)
MON = MONTH(NOW)
DY = DAY(NOW)
YR = YEAR(NOW)
'my added code

'added Mar 13, 2014 testing creating directory Name from date.

Select Case MON
    Case "1"
       MonthName="JAN"
    Case "2"
       MonthName ="FEB"
    Case "3"
       MonthName="MAR"
    Case "4"
       MonthName="APR"
    Case "5"
      MonthName="MAY"
    Case "6"
      MonthName="JUN"
    Case "7"
      MonthName="JUL"
    Case "8"
      MonthName="AUG"
    Case "9"
      MonthName="SEP"
    Case "10"
      MonthName="OCT"
    Case "11"
      MonthName="NOV"
    Case "12"
      MonthName="DEC"
End Select


' MsgBox DY & MonthName & YR

setCrntName = PCDPartProgram.FullName

'my change In VPT.SE's code
newname = PCDPartProgram.Path & "RESULTS\" &  PCDPartProgram.PartName & " - " & DY & MonthName & YR & " - " & SerialNo & ".PRG"
'my change In code

retval = PCDPartProgram.SaveAs(newname)
retval = PCDPartProgram.SaveAs(setCrntName)

' Cleanup
Set PCDPartProgram = Nothing
Set PCDPartPrograms = Nothing
Set PCDApp = Nothing
End Sub