A program that displays the status of all features in a Creo Part file

□ How to display the feature status

It works like this:
1. Get the IDs of all features in the model
2. Displays the status of features

[ VBA Program ]

TOOLBOX_VBA_PROGRAM09.xlsm

0.03MB

 

▷ VAB  Code

Option Explicit
Sub Features_status()
    On Error GoTo RunError
    
    Application.EnableEvents = False
    
    '// Check if "Program09" worksheet exists
    If Not WorksheetExists("Program09") Then
        MsgBox "Worksheet 'Program09' not found.", vbExclamation, "Error"
        Exit Sub
    End If
    
    Dim asynconn As New pfcls.CCpfcAsyncConnection
    Dim conn As pfcls.IpfcAsyncConnection
    
    '// Check Creo Connect
    Set conn = asynconn.Connect("", "", ".", 5)
    
    If conn Is Nothing Then
        MsgBox "An error occurred while starting a new Creo Parametric Session", vbInformation, "www.idt21c.com"
        Exit Sub
    End If

    Dim BaseSession As pfcls.IpfcBaseSession
    Dim model As pfcls.IpfcModel

    Set BaseSession = conn.session
    Set model = BaseSession.CurrentModel
    
    '// Current Model Information
    Worksheets("Program09").Cells(2, "E") = BaseSession.GetCurrentDirectory
    Worksheets("Program09").Cells(3, "E") = model.Filename
    
    '// List of features of the current model
    Dim ModelItemOwner As IpfcModelItemOwner
    Dim FeatureItems As IpfcModelItems
    Dim Feature As IpfcFeature
    Dim i As Integer
    Dim rowNum As Integer
    
    Set ModelItemOwner = model
    Set FeatureItems = ModelItemOwner.ListItems(EpfcModelItemType.EpfcITEM_FEATURE)
    
    rowNum = 5 ' 시작 행
    
    For i = 0 To FeatureItems.Count - 1
            Set Feature = FeatureItems.item(i)
            
            If Not IsNull(Feature.Number) Or Feature.Status <> 0 Then
                
                Cells(rowNum, "C") = FeatureItems.item(i).ID
                Cells(rowNum, "D") = Feature.Number
                Cells(rowNum, "E") = Feature.Status
                rowNum = rowNum + 1
                
            End If

            
    Next i
    
    '// Cell Number
    Dim rng As Range
    Dim rn As Long
    Dim lookupValue As Variant
    Dim lookupRange As Range
    Dim result As Variant
    
    Set rng = Worksheets("Program09").Range("C5", Worksheets("Program09").Cells(Worksheets("Program09").Rows.Count, "C").End(xlUp))
    rn = rng.Rows.Count
    
    
    Set lookupRange = Worksheets("Program09").Range("I5:J12")
    
    For i = 0 To rn - 1
        Cells(i + 5, "B") = i + 1
        lookupValue = Cells(i + 5, "E").Value
        
        '// VLOOKUP 함수 사용
        result = Application.WorksheetFunction.VLookup(lookupValue, lookupRange, 2, True)

        '// 결과를 원하는 위치에 할당
        Cells(i + 5, "F") = result
        
        
    Next i
    
    
    MsgBox "Displayed Feature Number", vbInformation, "ToolBOX VBA"
    
    conn.Disconnect (2)
    
    ' Cleanup
    Set asynconn = Nothing
    Set conn = Nothing
    Set BaseSession = Nothing
    Set model = Nothing
    
Exit Sub

RunError:
    If Err.Number <> 0 Then
        MsgBox "Process Failed: An error occurred." & vbCrLf & _
               "Error No: " & CStr(Err.Number) & vbCrLf & _
               "Error Description: " & Err.Description & vbCrLf & _
               "Error Source: " & Err.Source, vbCritical, "Error"
        If Not conn Is Nothing Then
            If conn.IsRunning Then
                conn.Disconnect (2)
            End If
        End If
    End If
End Sub

Function WorksheetExists(shtName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Not Worksheets(shtName) Is Nothing
    On Error GoTo 0
End Function

 

---

영업문의 : lionkk@idt21c.com
카카오 채널 : http://pf.kakao.com/_fItAxb