Sub Main

Dim PCDapp As Object
Dim PCDpart As Object
Dim Cmds As Object
Dim Cmd As Object
Dim PointData As Object
Dim Fcmd As Object
Dim RmPart As Object
Dim Algn As Object
Dim RmCmd As Object
Dim RmFcmd As Object
Dim RmAlgn As Object
Dim objMatrix As Object

Set PCDapp = CreateObject("PCDLRN.Application")
Set PCDpart = PCDapp.ActivePartProgram
Set Cmds = PCDpart.Commands
Set PointData = CreateObject("PCDLRN.PointData")
Set objMatrix = CreateObject("PCDLRN.DmisMatrix")

Dim mX, mY, mZ, mI, mJ, mK, mI2, mJ2, mK2
Dim tX, tY, tZ, tI, tJ, tK, tI2, tJ2, tK2

Dim RmPartName, MachName, ProbeFile, AlgnID, RmAlgnID
Dim FilePath

FilePath = PCDpart.Path & "RM_PartPrograms\"

MachName = PCDapp.Machines.Item(1).Name
ProbeFile = PCDapp.DefaultProbeFile

Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
If Not(fs.FolderExists(FilePath)) Then
    retval = fs.CreateFolder(FilePath)
  End If
RmPartName = FilePath & "RM_" & PCDpart.Name

If Not(fs.FileExists(RmPartName)) Then
  Set RmPart = PCDapp.PartPrograms.Add(RmPartName, MM, "Offline", ProbeFile)
  Cmds.InsertionPointAfter Cmds.Item(2)
  Set Cmd = Cmds.Add(ATTACH_PROGRAM, True)
  Cmd.ID = "RM"
  retval = Cmd.PutText(RmPartName, FILE_NAME, 0)
  Set Cmd = Nothing
Else
  Set RmPart = PCDapp.PartPrograms.Open(RmPartName, "Offline")
End If  

For Each Cmd In Cmds
  If Cmd.Marked = True Then 
          
    If Cmd.IsDCCFeature Then
      Cmds.SetCurrentCommand Cmd
      Cmds.InsertionPointAfter Cmd
      
      Set Algn = Cmds.CurrentAlignment.AlignmentCommand
      AlgnID = Algn.ID
      
      Set objMatrix = Algn.CadToPartMatrix      
      Set FCmd = Cmd.FeatureCommand
      Cmds.SetCurrentCommand FCmd.Parent
      
      FCmd.GetData PointData, FDATA_CENTROID, FDATA_THEO, FDATA_PART, AlgnID, PLANE_TOP
      objMatrix.TransformDataBack PointData, ROTATE_AND_TRANSLATE, PLANE_TOP
      tX = PointData.X
      tY = PointData.Y
      tZ = PointData.Z
      
      FCmd.GetData PointData, FDATA_VECTOR, FDATA_THEO, FDATA_PART, AlgnID, PLANE_TOP
      objMatrix.TransformDataBack PointData, ROTATE_AND_TRANSLATE, PLANE_TOP
      tI = PointData.I
      tJ = PointData.J
      tK = PointData.K
      
      FCmd.GetData PointData, FDATA_CENTROID, FDATA_MEAS, FDATA_PART, AlgnID, PLANE_TOP
      objMatrix.TransformDataBack PointData, ROTATE_AND_TRANSLATE, PLANE_TOP
      mX = PointData.X
      mY = PointData.Y
      mZ = PointData.Z
      
      FCmd.GetData PointData, FDATA_VECTOR, FDATA_MEAS, FDATA_PART, AlgnID, PLANE_TOP
      objMatrix.TransformDataBack PointData, ROTATE_AND_TRANSLATE, PLANE_TOP
      mI = PointData.I
      mJ = PointData.J
      mK = PointData.K
      
      RmPart.Commands.InsertionPointAfter RmPart.Commands.LastCommand
      Set RmCmd = RmPart.Commands.Add(GENERIC_CONSTRUCTION, True)
     
      Set RmFcmd = RmCmd.FeatureCommand     
      RmPart.Commands.SetCurrentCommand RmCmd
      
      If Not RmPart.Commands(1).AlignmentCommand Is Nothing Then
        Set RmAlgn = RmPart.Commands(1).AlignmentCommand
      Else
        Set RmAlgn = RmPart.Commands.CurrentAlignment.AlignmentCommand
      End If
      
      RmAlgnID = RmAlgn.ID
      
      If InStr(1, FCmd.ID, ".") > 0 Then
        RmFcmd.ID = Left(FCmd.ID, InStr(1, FCmd.ID, ".") - 1) & Right(FCmd.ID, Len(FCmd.ID) - InStr(1, FCmd.ID, "."))
      Else
        RmFcmd.ID = FCmd.ID
      End If
           
      Select Case Cmd.Feature
        
        Case F_CIRCLE
        RmFcmd.GenericType = GENERIC_CIRCLE
        RmFcmd.GenericDisplayMode = GENERIC_DISPLAY_DIAMETER
        RmFcmd.TheoDiam = FCmd.TheoDiam
        RmFcmd.MeasDiam = FCmd.MeasDiam
        
        Case F_POINT
        RmFcmd.GenericType = GENERIC_POINT
        
        Case F_CONE  
        RmFcmd.GenericType = GENERIC_CONE
        RmFcmd.GenericDisplayMode = GENERIC_DISPLAY_DIAMETER
        RmFcmd.TheoAngle = FCmd.TheoAngle
        RmFcmd.MeasAngle = FCmd.MeasAngle
        RmFcmd.TheoDiam = FCmd.TheoDiam
        RmFcmd.MeasDiam = FCmd.MeasDiam
        RmFcmd.TheoLength = FCmd.TheoLength
        RmFcmd.MeasLength = FCmd.MeasLength
        
        Case F_CYLINDER   
        RmFcmd.GenericType = GENERIC_CYLINDER
        RmFcmd.GenericDisplayMode = GENERIC_DISPLAY_DIAMETER
        RmFcmd.TheoDiam = FCmd.TheoDiam
        RmFcmd.MeasDiam = FCmd.MeasDiam
        RmFcmd.TheoLength = FCmd.TheoLength
        RmFcmd.MeasLength = FCmd.MeasLength
        
        Case F_LINE  
        RmFcmd.GenericType = GENERIC_LINE
        RmFcmd.TheoLength = FCmd.TheoLength
        RmFcmd.MeasLength = FCmd.MeasLength 
        
        Case F_PLANE 
        RmFcmd.GenericType =  GENERIC_PLANE 
        
        Case F_SLOT
        If FCmd.Parent.Type = AUTO_ROUND_SLOT Then   
          RmFcmd.GenericType = GENERIC_ROUND_SLOT
        ElseIf FCmd.Parent.Type = AUTO_SQUARE_SLOT Then
          RmFcmd.GenericType = GENERIC_SQUARE_SLOT
        End If
        
        RmFcmd.GenericDisplayMode = GENERIC_DISPLAY_DIAMETER
        
        FCmd.GetData PointData, FDATA_SLOT_VECTOR, FDATA_THEO, FDATA_PART, AlgnID, PLANE_TOP
        objMatrix.TransformDataBack PointData, ROTATE_AND_TRANSLATE, PLANE_TOP
        tI2 = PointData.I
        tJ2 = PointData.J
        tK2 = PointData.K
        
        FCmd.GetData PointData, FDATA_SLOT_VECTOR, FDATA_MEAS, FDATA_PART, AlgnID, PLANE_TOP
        objMatrix.TransformDataBack PointData, ROTATE_AND_TRANSLATE, PLANE_TOP
        mI2 = PointData.I
        mJ2 = PointData.J
        mK2 = PointData.K
        
        PointData.IJK tI2, tJ2, tK2
        Set objMatrix = RmAlgn.CadToPartMatrix
        objMatrix.TransformDataForward PointData, ROTATE_AND_TRANSLATE, PLANE_TOP
        RmFcmd.PutData PointData, FDATA_SLOT_VECTOR, FDATA_THEO, FDATA_PART, RmAlgnID, PLANE_TOP
        
        PointData.IJK mI2, mJ2, mK2
        objMatrix.TransformDataForward PointData, ROTATE_AND_TRANSLATE, PLANE_TOP
        RmFcmd.PutData PointData, FDATA_SLOT_VECTOR, FDATA_MEAS, FDATA_PART, RmAlgnID, PLANE_TOP
        
        RmFcmd.TheoDiam = FCmd.TheoDiam
        RmFcmd.MeasDiam = FCmd.MeasDiam
        RmFcmd.TheoLength = FCmd.TheoLength
        RmFcmd.MeasLength = FCmd.MeasLength
        
        Case F_SPHERE  
        RmFcmd.GenericType = GENERIC_SPHERE
        RmFcmd.GenericDisplayMode = GENERIC_DISPLAY_DIAMETER 
        RmFcmd.TheoDiam = FCmd.TheoDiam
        RmFcmd.MeasDiam = FCmd.MeasDiam 
        
        Case F_ELLIPSE
        RmFcmd.GenericType = GENERIC_CIRCLE
        RmFcmd.GenericDisplayMode = GENERIC_DISPLAY_DIAMETER
        RmFcmd.TheoDiam = FCmd.TheoDiam
        RmFcmd.MeasDiam = FCmd.MeasDiam
        
      End Select
      
      RmFcmd.GenericAlignMode = GENERIC_ALIGN_INDEPENDENT
      
      If FCmd.Inner = False Then
        RmFcmd.Inner = False
      Else
        RmFcmd.Inner = True
      End If
      
      Set objMatrix = RmAlgn.CadToPartMatrix
      
      PointData.XYZ tX, tY, tZ
      objMatrix.TransformDataForward PointData, ROTATE_AND_TRANSLATE, PLANE_TOP
      RmFcmd.PutData PointData, FDATA_CENTROID, FDATA_THEO, FDATA_PART, RmAlgnID, PLANE_TOP
      
      PointData.IJK tI, tJ, tK
      objMatrix.TransformDataForward PointData, ROTATE_AND_TRANSLATE, PLANE_TOP
      RmFcmd.PutData PointData, FDATA_VECTOR, FDATA_THEO, FDATA_PART, RmAlgnID, PLANE_TOP
      
      PointData.XYZ mX, mY, mZ
      objMatrix.TransformDataForward PointData, ROTATE_AND_TRANSLATE, PLANE_TOP
      RmFcmd.PutData PointData, FDATA_CENTROID, FDATA_MEAS, FDATA_PART, RmAlgnID, PLANE_TOP
      
      PointData.IJK mI, mJ, mK
      objMatrix.TransformDataForward PointData, ROTATE_AND_TRANSLATE, PLANE_TOP
      RmFcmd.PutData PointData, FDATA_VECTOR, FDATA_MEAS, FDATA_PART, RmAlgnID, PLANE_TOP
      
      retval = Cmd.PutText("RM:" & RmFcmd.ID, RMEASFEATIDX, 0)
      retval = Cmd.PutText("RM:" & RmFcmd.ID, RMEASFEATIDY, 0)
      retval = Cmd.PutText("RM:" & RmFcmd.ID, RMEASFEATIDZ, 0)
      
    End If 'If DCCFeature
  End If 'If Marked
   
Next Cmd

RmPart.Save
RmPart.Close 

'Cmds.InsertionPointAfter Cmds.LastCommand
'Set Cmd = Cmds.Add(BASIC_SCRIPT, True)
'retval = Cmd.PutText("D:\PCD_SCRIPTS\RELATIVEPARTPROGRAM2.BAS", FILE_NAME, 0)
'Cmd.ID = "RMEAS_PP"
'Cmd.Marked = True
'Cmd.ReDraw

'PCDpart.Activate

Set PCDapp = Nothing
Set PCDpart = Nothing
Set Cmds = Nothing
Set Cmd = Nothing
Set FCmd = Nothing
Set RmFcmd = Nothing
Set fs = Nothing
Set PointData = Nothing
Set RmPart = Nothing
Set Algn = Nothing
Set RmAlgn = Nothing
Set objMatrix = Nothing

End Sub