hexagon logo

Vector changing script?

Hey all, been lurking the forums for a few months now, finally hit a wall where the search function just doesn't cut it. I mean, I'm sure I'm not the only person to have this issue, but I guess I'm just failing at using the right search terms.
Anywho, after fighting for months with management, they finally agreed that we should be measuring our check jigs and assigned me the task. The problem with that is, most of our check jigs are for wire bending operations and are basically thin grooves cut out of MDF, so essentially 2D. Our tooling dept. has only 2D DWGs for the router path lines and nothing else. (you should see the drawings for their weld fixtures... ugh) I found out that if I try to make autofeature lines and attempt to measure a jig, it for some reason snaps the lines to the cad nominals instead of the actual measurement. I'm dead certain that there's a better way around it, but the best workaround that I've figured out is constructing lines out of vector points. It technically works, with the caveat that I have to manually change all the vectors to 0,0,1, and many jigs require over 80 vector points, and I have about 300 different jigs to measure.
So, manually doing that to every vector point takes up about 95% of the programming time for each jig, so naturally I thought, "hey, I'm not too bad at VBA, I'm sure I could figure out a script to do it for me." Oh, how wrong I was...
After a couple days of tinkering, I finally figured out how to actually select a command and change its vector values, so far so good. Now, let's try to make a loop for a given range of points, aaaannd.... I can't understand exactly why or how to circumvent it, but when I try to select the next command, or at least I falsely think I am, it changes the name of the current command instead!

Is there any way that I can loop through a group of features to change their vectors with script, or is there a better way that I just don't know about?

Hopefully the code isn't too sloppy to read, I've been just randomly throwing code at the problem at this point.

Sub Main()

Dim PCDapp As pcdlrn.Application
Dim App As Object
Set App = CreateObject("PCDLRN.Application")

Dim Part As Object
Set Part = App.ActivePartProgram

Dim Ew As Object
Set Ew = Part.EditWindow

Dim Cmds As Object
Set Cmds = Part.Commands
Dim Cmd As Object
Set Cmd = Cmds.Item

Ew.Visible = True

Dim feattype As String
Dim FirstFeature, LastFeature As Integer
feattype = ("pnt")
FirstFeature = 8
LastFeature = 18
'FeatType = InputBox("Enter feature type:")
'FirstFeature = InputBox("type in first feature number:")
'LastFeature = InputBox("type in last feature number:")

Dim StartCmd As Object
Set StartCmd = Cmds.Item(feattype & FirstFeature)

Dim EndCmd As Object
Set EndCmd = Cmds.Item(feattype & LastFeature)

Dim FeatList As Long
FeatList = LastFeature - FirstFeature

Dim coll As Collection
Set coll = New Collection

Dim i As Integer
For i = 1 To FeatList
coll.Add StartCmd.ID
FirstFeature = FirstFeature + 1
StartCmd = feattype & FirstFeature
Next

For i = 1 To coll.count
Cmds.SetCurrentCommand coll(i)
Set Cmd = coll(i)
Ew.SelectCommand

If Cmd.ID = StartCmd And Cmd.ID <> EndCmd Then
retval = Cmd.PutText("0", THEO_I, 0)
retval = Cmd.PutText("0", THEO_J, 0)
retval = Cmd.PutText("1", THEO_K, 0)
Ew.UnselectAll
End If
Next

End Sub


Thanks in advance!
Parents
  • Good Day,

    I wrote a little bit together
    maybe that helps
    check it out

    (this works only with Vector points)

    Sub Main()
    ' Dim something ---------------------------
      Dim App As Object
      Set App = CreateObject("PCDLRN.Application")
      Dim Part As Object
      Set Part = App.ActivePartProgram
      Dim Cmds As Object
      Set Cmds = Part.Commands
      Dim Cmd As Object
      Set Cmd = Nothing
    
    ' get name --------------------------------
      Set Cmd = Cmds.CurrentCommand 'gives the command under the cursor
    
      If Cmd.Type <> 752 Then 'EW_GROUP_START = 752
        GoTo ExitunDim ' exit if not a pcDMIS-Group
      End If
    
    
    ' search Commands to change ---------------------------
      ' CONTACT_SURFACE_POINT_FEATURE 603
      ' CONTACT_VECTOR_POINT_FEATURE 602
      ' MEASURED_POINT 201
    
    Do
      If Cmd.Type = 602 Then 'CONTACT_VECTOR_POINT_FEATURE = 602
    
        Cmd.Marked = True
        RetVal = Cmd.PutText("0", THEO_I, 0) 'set nominal
        RetVal = Cmd.PutText("0", THEO_J, 0) 'set nominal
        RetVal = Cmd.PutText("1", THEO_K, 0) 'set nominal
    
        RetVal = Cmd.PutText("0", MEAS_I, 0) 'deletes old measured
        RetVal = Cmd.PutText("0", MEAS_J, 0) 'deletes old measured
        RetVal = Cmd.PutText("1", MEAS_K, 0) 'deletes old measured
    
        RetVal = Cmd.PutText("0", TARG_I, 0) 'set target
        RetVal = Cmd.PutText("0", TARG_J, 0) 'set target
        RetVal = Cmd.PutText("1", TARG_K, 0) 'set target
    
      End If
    
      RetVal = Cmd.Next
    Loop Until Cmd.Type = 753 'EW_GROUP_END = 753
    
    ' done ---------------------------
      Part.RefreshPart
    
    
    ' unDim something ---------------------------
    ExitunDim:
      Set Cmd = Nothing
      Set Cmds = Nothing
      Set Part = Nothing
      Set App = Nothing
    End Sub
    
Reply
  • Good Day,

    I wrote a little bit together
    maybe that helps
    check it out

    (this works only with Vector points)

    Sub Main()
    ' Dim something ---------------------------
      Dim App As Object
      Set App = CreateObject("PCDLRN.Application")
      Dim Part As Object
      Set Part = App.ActivePartProgram
      Dim Cmds As Object
      Set Cmds = Part.Commands
      Dim Cmd As Object
      Set Cmd = Nothing
    
    ' get name --------------------------------
      Set Cmd = Cmds.CurrentCommand 'gives the command under the cursor
    
      If Cmd.Type <> 752 Then 'EW_GROUP_START = 752
        GoTo ExitunDim ' exit if not a pcDMIS-Group
      End If
    
    
    ' search Commands to change ---------------------------
      ' CONTACT_SURFACE_POINT_FEATURE 603
      ' CONTACT_VECTOR_POINT_FEATURE 602
      ' MEASURED_POINT 201
    
    Do
      If Cmd.Type = 602 Then 'CONTACT_VECTOR_POINT_FEATURE = 602
    
        Cmd.Marked = True
        RetVal = Cmd.PutText("0", THEO_I, 0) 'set nominal
        RetVal = Cmd.PutText("0", THEO_J, 0) 'set nominal
        RetVal = Cmd.PutText("1", THEO_K, 0) 'set nominal
    
        RetVal = Cmd.PutText("0", MEAS_I, 0) 'deletes old measured
        RetVal = Cmd.PutText("0", MEAS_J, 0) 'deletes old measured
        RetVal = Cmd.PutText("1", MEAS_K, 0) 'deletes old measured
    
        RetVal = Cmd.PutText("0", TARG_I, 0) 'set target
        RetVal = Cmd.PutText("0", TARG_J, 0) 'set target
        RetVal = Cmd.PutText("1", TARG_K, 0) 'set target
    
      End If
    
      RetVal = Cmd.Next
    Loop Until Cmd.Type = 753 'EW_GROUP_END = 753
    
    ' done ---------------------------
      Part.RefreshPart
    
    
    ' unDim something ---------------------------
    ExitunDim:
      Set Cmd = Nothing
      Set Cmds = Nothing
      Set Part = Nothing
      Set App = Nothing
    End Sub
    
Children
No Data