Get unit information from part file

□ Unit information of the part file

• Get the names of the Part files in the working folder
• Display the unit names of the Part files.
• Display the units of length, weight, time, and temperature.

▷Program execution screen

---

▷ "CreoConnt01" Program

Option Explicit
Public asynconn As New pfcls.CCpfcAsyncConnection
Public conn As pfcls.IpfcAsyncConnection
Public BaseSession As pfcls.IpfcBaseSession
Public model As pfcls.IpfcModel
Public Sub CreoConnt01()
     
     '// connect creo model
     Set conn = asynconn.Connect(Null, Null, Null, Null)
     Set BaseSession = conn.Session
     Set model = BaseSession.CurrentModel
     
    '// creo model connection check
     If model Is Nothing Then
        MsgBox "There are No Active Creo Models", vbInformation, "korealionkk@gmail.com"
        Exit Sub
     End If
               
End Sub

 

▷ "PartGetUnits01" Program

Option Explicit
Sub PartGetUnits01()
    On Error GoTo RunError
    Application.EnableEvents = False

    '// Module Name : CreoVBAStart
    Call CreoVBAStart.CreoConnt01
    
    Dim stringseq As Istringseq
    Set stringseq = BaseSession.ListFiles("*.prt", 1, "")
    
    Dim i As Integer
    
    Dim fullPath As String
    Dim fileName As String
    Dim lastBackslash As Integer
    Dim fileVersionSeparator As Integer
    
    For i = 0 To stringseq.Count - 1
    
        Worksheets("GetUnit").Cells(i + 6, "A") = i + 1
        fullPath = stringseq(i)
        lastBackslash = InStrRev(fullPath, "\")
        fileName = Mid(fullPath, lastBackslash + 1)
        fileVersionSeparator = InStrRev(fileName, ".")
        fileName = Left(fileName, fileVersionSeparator - 1)
        Worksheets("GetUnit").Cells(i + 6, "B") = fileName
    
    Next i
    
    Dim rng As Range
    Set rng = Worksheets("GetUnit").Range("B6", Cells(Rows.Count, "B").End(xlUp))
    
    Dim j As Integer
     
    Dim CreateModelDescriptor As New CCpfcModelDescriptor
    Dim ModelDescriptor As IpfcModelDescriptor
    'Dim Window As IpfcWindow
    Dim CellFileName As String
    Dim Solid As IpfcSolid
    Dim UnitSys As IpfcUnitSystem

    For j = 0 To rng.Count - 1
    
        CellFileName = Worksheets("GetUnit").Cells(j + 6, "B")
        Set ModelDescriptor = CreateModelDescriptor.CreateFromFileName(CellFileName)
        Set model = BaseSession.RetrieveModel(ModelDescriptor) '// Importing a model into a Session
        'model.Display '// Activate the model
        'Set Window = BaseSession.GetModelWindow(model)
        'model.Display '// Activate the model
        'Window.Activate  '// Activate the new window
        
        Set Solid = model
        Set UnitSys = Solid.GetPrincipalUnits
        Worksheets("GetUnit").Cells(j + 6, "C") = UnitSys.Name
        
        If UnitSys.Type = 0 Then
        
            Worksheets("GetUnit").Cells(j + 6, "D") = UnitSys.GetUnit(EpfcUNIT_LENGTH).Name
            Worksheets("GetUnit").Cells(j + 6, "E") = UnitSys.GetUnit(EpfcUNIT_MASS).Name
            Worksheets("GetUnit").Cells(j + 6, "G") = UnitSys.GetUnit(EpfcUNIT_TIME).Name
            Worksheets("GetUnit").Cells(j + 6, "H") = UnitSys.GetUnit(EpfcUNIT_TEMPERATURE).Name
        
        Else
            
            Worksheets("GetUnit").Cells(j + 6, "D") = UnitSys.GetUnit(EpfcUNIT_LENGTH).Name
            Worksheets("GetUnit").Cells(j + 6, "F") = UnitSys.GetUnit(EpfcUNIT_FORCE).Name
            Worksheets("GetUnit").Cells(j + 6, "G") = UnitSys.GetUnit(EpfcUNIT_TIME).Name
            Worksheets("GetUnit").Cells(j + 6, "H") = UnitSys.GetUnit(EpfcUNIT_TEMPERATURE).Name
            
        End If
    Next j

MsgBox "Get unit name and value from part file.", vbInformation, "korealionkk@gmail.com"
    
    conn.Disconnect (2)
    
    '// Cleanup
    Set asynconn = Nothing
    Set conn = Nothing
    Set BaseSession = Nothing
    Set model = Nothing
    
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