hexagon logo

Simple Rename script - needs work by anyone interested...

There was a question in another part of the forum for a way to rename features in program order. I found the source code of an old EditFeat.VB script in my archives, and have stripped anything VB6 from it, to make [the beginnings] of a script that can run in PC-DMIS Basic.

As it stands now, it renames all POINTS, LINES, CIRCLES, PLANES, CYLINDERS, and SPHERES - hardwired three letter name plus an incrementing number according to the type. It should be straightforward to remove unwanted parts of the script, or add blocks for other feature types. It should also be relatively easy to add a dialog and do selective renaming, but all that is left as exercises for the reader...


Sub Main

'  This is a program which goes through the entire current program And renames features
'      by their Type And also With an increment according To
'      the relative position In the part program.

    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

    Dim PointNum As Integer
    Dim LineNum As Integer
    Dim CircNum As Integer
    Dim PlaneNum As Integer
    Dim CylinderNum As Integer
    Dim ConeNum As Integer
    Dim SphereNum As Integer
    Dim DimensionNum As Integer
    Dim AlignmentNum As Integer

    Dim ContinueOn As String

    AllNum = 1
    PointNum = 1
    LineNum = 1
    CircNum = 1
    PlaneNum = 1
    CylinderNum = 1
    ConeNum = 1
    SphereNum = 1
    DimensionNum = 1
    AlignmentNum = 1

    Dim NewId As String

'  cycle through the commands In the program, performing the rename

   For Each Cmd In Cmds
        If Cmd.Feature = F_POINT Then
          NewId = "PNT" & PointNum
          Cmd.ID = NewId
          PointNum = PointNum + 1
        End If
        If Cmd.Feature = F_LINE Then
          NewId = "LIN" & LineNum
          Cmd.ID = NewId
          LineNum = LineNum + 1
        End If
        If Cmd.Feature = F_CIRCLE Then
          NewId = "CIR" & CircNum
          Cmd.ID = NewId
          CircNum = CircNum + 1
        End If
        If Cmd.Feature = F_PLANE Then
          NewId = "PLN" & PlaneNum
          Cmd.ID = NewId
          PlaneNum = PlaneNum + 1
        End If
        If Cmd.Feature = F_CYLINDER Then
          NewId = "CYL" & CylinderNum
          Cmd.ID = NewId
          CylinderNum = CylinderNum + 1
        End If
        If Cmd.Feature = F_SPHERE Then
          NewId = "SPH" & SphereNum
          Cmd.ID = NewId
          SphereNum = SphereNum + 1
        End If
   Next Cmd

End

End Sub



Parents
  • Here is my finished code. It works great in 2021, but I'm getting a erro in 2017 when I run it:

    Runtime Error 429 ActiveX Component Can't Create Object

    Anyone know why I would get that error in 2017 and not in 2021?

    Sub pcdmis()
    
    Dim App As Object
    Set App = CreateObject("PCDLRN.Application")
    Dim PartProg As Object
    Set PartProg = App.ActivePartProgram
    Dim Cmds As Object
    Set Cmds = PartProg.Commands
    Dim Cmd As Object
    
    Dim old_item As String
    Dim new_item As String
    Dim row As Integer
    Dim col As Integer
    Dim last_row As Integer
    
    last_row = Cells(Rows.Count, 1).End(xlUp).row
    
    For row = 1 To last_row
        old_item = Cells(row, 1).Value
        new_item = Cells(row, 2).Value
    
        For Each Cmd In Cmds
            If Cmd.ID = old_item Then
                Cmd.ID = new_item
            End If
        Next Cmd
        
        PartProg.RefreshPart
        
    Next row
    
    End Sub
    
    
  • Are you running this in Excel or PC-DMIS? Looks like Excel?

    It could be that you need to add the reference to PC-DMIS in Excel for it to work.
Reply Children
No Data