ToolBOX PartList 베타

■ PartList 프로그램 변경 내용

[Part List 프로그램 ]

1. 화면 구성

9행 : A1 ~ G1 까지는 고정 입니다. 변경 할수 없습니다."WEIGHT" - 무게,  "MATERIAL" - 재질을 정의하는 매개변수 입니다. CREO 모델에서 재질파일 지정이 되어 있어야 합니다.  재질파일 지정이 안되어 있으면 "NOT"으로 표시 됩니다. 어셈블 파일은 재질파일을 지정 할수 없습니다. "WEIGHT" - 무게 계산을 할수 없습니다. 

9행 : H1 ~ 부터는 PARAMETER 이름 입니다. 타입은 "문자"만 가능 합니다. 영문자 대문자로 추가 할수 있습니다. PARAMTER 이름을 변경 할수 있습니다.  한글은 추가 할 수 없습니다. 문자와 문자 사이 공란은 불가능 합니다.

2. 새로 고침

만일 CREO 모델 파일이 "WEIGHT", "MATERIAL" 및 추가한  PARAMETER 가 없으면 자동으로 추가 합니다.

• 소스 코드

Option Explicit
Public useAsm As IpfcAssembly
Public pathArray As New Collection
Sub A3PartListFileCheck()

On Error GoTo RunError
     
        Dim asynconn As New pfcls.CCpfcAsyncConnection
        Dim conn As pfcls.IpfcAsyncConnection: Set conn = asynconn.Connect("", "", ".", 5)
        Dim oSession As pfcls.IpfcBaseSession: Set oSession = conn.session
        Dim oModel As IpfcModel: Set oModel = oSession.CurrentModel
        Dim oParamOwner As pfcls.IpfcParameterOwner: Set oParamOwner = oModel     
      
        'Current Designer Parameter Value
        Dim oParamDesigner As IpfcBaseParameter: Set oParamDesigner = oParamOwner.GetParam(Cells(7, "A"))

        If oParamDesigner Is Nothing Then
           
           conn.Disconnect (2)
           MsgBox " 모델에 < DESIGNER > Parameter가 없습니다", vbInformation, "www.idt21c.com"
           Exit Sub ' error 발생시 프로그램 종료
        
        End If
            
        Dim oParamValue As IpfcParamValue: Set oParamValue = oParamDesigner.Value
        Cells("7", "D") = oParamValue.StringValue
      
        'Top Assmble Model Number
        Cells(10, "A") = 1
        'Top Assmble Model Type
        Cells(10, "B") = "ASM"
        'Top Assmble Model Name
        Cells(10, "C") = oModel.Filename
        'Top Assmble Model Count
        Cells(10, "D") = 1
        
        'Model Path Name
        Cells(4, "D") = oSession.GetCurrentDirectory
        
        'Create Current DATE
        Dim oCreoDate As Date: oCreoDate = Now
        Cells(8, "D") = oCreoDate
        
        Set useAsm = oModel
        Set pathArray = listEachLeafComponentPath(useAsm)
        Dim iCnt As Integer
        Dim eachPath As IpfcComponentPath
        
    For iCnt = 0 To (pathArray.Count - 1)
    
            Set eachPath = pathArray.Item(iCnt + 1)
            Dim mdl As IpfcModel
            Set mdl = eachPath.Leaf
            Dim CellNum As String
            CellNum = "z" + CStr(iCnt + 5)
            Range(CellNum).Value = mdl.Filename
            
    Next iCnt
    
        Call Duplicate_02
        
         ' File Type Count
        Dim rng As Range
        Set rng = Range("B10", Cells(Rows.Count, "B").End(xlUp))
    
        Cells(5, "D") = Application.CountIf(rng, "ASM")
        Cells(6, "D") = Application.CountIf(rng, "PRT")
        
        Call PartListparameter
        
        
        'Cells(1, "F") = pathArray.Count + 1
        MsgBox ("모델은 총 " & pathArray.Count + 1 & " 개의 파일 입니다"), vbInformation, "www.idt21c.com"
    
    conn.Disconnect (2)
    
    'Cleanup
    Set asynconn = Nothing
    Set conn = Nothing
    Set oSession = Nothing
    Set oModel = Nothing
    

RunError:

    If Err.Number <> 0 Then
        MsgBox "Process Failed : Unknown error occurred." + Chr(13) + _
                "Error No: " + CStr(Err.Number) + Chr(13) + _
                "Error: " + Err.Description, vbCritical, "Error"

        If Not conn Is Nothing Then
            If conn.IsRunning Then
                conn.Disconnect (2)
            End If
        End If
    End If

End Sub

'======================================================================================================
'This function returns an array of all ComponentPath's to all component parts ('leafs') in an assembly.
'======================================================================================================
Public Function listEachLeafComponentPath(ByVal assemblyIn As IpfcAssembly) As Collection

    Dim startLevel As New Cintseq
    Dim i As Integer
    
    Set pathArray = New Collection
    Set useAsm = assemblyIn
    
    Call listSubAsmComponents(startLevel)
  
    Dim compPaths() As IpfcComponentPath
    
    ReDim compPaths(pathArray.Count)
    
        For i = 0 To (pathArray.Count - 1)
                Set compPaths(i) = pathArray.Item(i + 1)
        Next i
        
    Set listEachLeafComponentPath = pathArray


End Function

'================================================================================
'This function is used to recursively visits all levels of the assembly structure.
'================================================================================
Private Function listSubAsmComponents(ByVal currentLevel As Cintseq)
    Dim currentComponent As IpfcSolid
    Dim currentComponentModel As IpfcModel
    Dim currentPath As IpfcComponentPath
    Dim componentFeat As IpfcModelItem
    Dim subComponents As IpfcFeatures
    Dim Compids As New Cintseq
    Dim CMpfcAssembly_ As New CMpfcAssembly
    Dim i, id, level As Integer
    
    
        level = currentLevel.Count
        
                '======================================================================
                'Special case, level is 0 for the top level assembly.
                '======================================================================
            If level > 0 Then
                Set currentPath = CMpfcAssembly_.CreateComponentPath(useAsm, currentLevel)
                Set currentComponent = currentPath.Leaf
                Set currentComponentModel = currentPath.Leaf
                
                Else
                    
                    Set currentComponent = useAsm
                    Set currentComponentModel = useAsm
                    
            End If
              
              
            If (currentComponentModel.Type = EpfcMDL_PART) And (level > 0) Then
                    pathArray.Add currentPath
                Else
                
                If Not currentPath Is Nothing Then
                    pathArray.Add currentPath
                End If
                
                
                    '======================================================================================================================
                    'Find all component features in the current component object. Visit each (adjusting the component id paths accordingly).
                    '======================================================================================================================
                    
                    Set subComponents = currentComponent.ListFeaturesByType(False, EpfcFeatureType.EpfcFEATTYPE_COMPONENT)
                        
                        For i = 0 To (subComponents.Count - 1)
                            If (subComponents.Item(i).Status = EpfcFeatureStatus.EpfcFEAT_ACTIVE) Then 'Collect only Active Components
                                Set componentFeat = subComponents.Item(i)
                                id = componentFeat.id
                                currentLevel.Set level, id
                                Call listSubAsmComponents(currentLevel)
                            End If
                        Next i
            End If
            '======================================================================
            'Clean up current level of component ids before returning up one level.
            '======================================================================
            If Not level = 0 Then
            currentLevel.Remove level - 1, level
            End If
      
End Function

Sub Duplicate_02()
    
    Dim rng As Range, C As Range
    Dim dc As New Collection
    Set rng = Range("Z5", Cells(Rows.Count, "Z").End(xlUp))
    
    Dim i As Long

On Error Resume Next

    For Each C In rng
        If Len(C) Then
            dc.Add Trim(C), CStr(Trim(C))
        End If
    Next
    
On Error GoTo 0

    For i = 1 To dc.Count
        Cells(i + 10, "C") = dc(i) 'File Name
    Next

    For i = 1 To dc.Count
        Cells(i + 10, "D") = WorksheetFunction.CountIf(rng, Cells(i + 10, "C")) ' 중복 수량 카운트
        Cells(i + 10, "A") = i + 1 'Number Count
        Cells(i + 10, "B") = Right(UCase(Cells(i + 10, "C")), 3) 'File Type 표시
    Next

Columns("Z").Delete
End Sub

Sub PartListparameter()
    
On Error GoTo RunError

    Dim asynconn As New pfcls.CCpfcAsyncConnection
    Dim conn As pfcls.IpfcAsyncConnection: Set conn = asynconn.Connect("", "", ".", 5)
    Dim oSession As pfcls.IpfcBaseSession: Set oSession = conn.session
    Dim oModel As pfcls.IpfcModel

    'Parlist의 사용자 Parameter 개수 및 이름
    Dim oColumnscount As Long: oColumnscount = Cells(9, Columns.Count).End(xlToLeft).Column
    
    'Parlist 파일 개수 및 이름
    Dim rng As Range: Set rng = Range("C10", Cells(Rows.Count, "C").End(xlUp))
    
    'Creo File Open
    Dim oModelDescriptorCreate As New CCpfcModelDescriptor
    Dim oModelDescriptor As IpfcModelDescriptor
    Dim owindow As IpfcWindow
    
    
    Dim i, j As Long
    Dim oCroeCellName As String '********
    
    'Parameter 정의
    Dim oParamOwner As pfcls.IpfcParameterOwner
    Dim oBaseParameter As IpfcBaseParameter
    Dim oParameter  As IpfcParameter
    Dim oParamObject As New CMpfcModelItem
    Dim oParamValue As New CpfcParamValue
    Dim oCreoParamValue As IpfcParamValue
    Dim oParamName As IpfcNamedModelItem

    Dim oCellsParamName As String
       
    For i = 0 To rng.Count - 1
        
        ' Current Creo File Open
        oCroeCellName = Cells(i + 10, "C")
        Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(oCroeCellName)
        Set owindow = oSession.OpenFile(oModelDescriptor)
        
        owindow.Activate
              
        Set oModel = oSession.CurrentModel
 
            For j = 0 To oColumnscount - 6
            
                oCellsParamName = Cells(9, j + 6).Value
                Set oParamOwner = oModel
                Set oBaseParameter = oParamOwner.GetParam(oCellsParamName)
                
                  
                    If Not oBaseParameter Is Nothing Then
                                 
                          Set oCreoParamValue = oBaseParameter.Value
                          
                          If oCreoParamValue.discr = 0 Then
                          
                             Cells(i + 10, j + 6) = oCreoParamValue.StringValue
                          
                          ElseIf oCreoParamValue.discr = 3 Then
                          
                             Cells(i + 10, j + 6) = oCreoParamValue.DoubleValue
                          
                          End If
                    Else
                          
                          If Cells(9, j + 6) = "WEIGHT" Then
                            Set oParamValue = oParamObject.CreateDoubleParamValue(0)
                            Set oBaseParameter = oParamOwner.CreateParam(Cells(9, j + 6), oParamValue)
                          
                          Else
                            Set oParamValue = oParamObject.CreateStringParamValue("")
                            Set oBaseParameter = oParamOwner.CreateParam(Cells(9, j + 6), oParamValue)
                          
                          End If
                            
                    End If

            Next j
            
            
         owindow.Close
    
    Next i

   
        Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(Cells(10, "C")) ' Total Assembly Open
        Set owindow = oSession.OpenFile(oModelDescriptor)
        
        owindow.Activate
          
Exit Sub
    
RunError:
    If Err.Number <> 0 Then
        MsgBox "Process Failed : Unknown error occurred." + Chr(13) + _
                "Error No: " + CStr(Err.Number) + Chr(13) + _
                "Error: " + Err.Description, vbCritical, "Error"
        If Not conn Is Nothing Then
            If conn.IsRunning Then
                conn.Disconnect (2)
            End If
        End If
    End If

End Sub

 

3.  PARAMETER SAVE

엑셀에서 입력한 PARAMETER 값을 모델로 저장 합니다. 단, "WEIGHT", "MATERIAL"은 사용자가 저장 할 수 없습니다.
모델에서 재질 파일 변경 하고,  "Metal Calculator" 버튼을  누르면, 다시 계산 합니다.

• 소스 코드

Option Explicit
Sub PartListParameterSave()

    On Error GoTo RunError
    
        Dim asynconn As New pfcls.CCpfcAsyncConnection
        Dim conn As pfcls.IpfcAsyncConnection: Set conn = asynconn.Connect("", "", ".", 5)
        Dim oSession As pfcls.IpfcBaseSession: Set oSession = conn.session
        Dim oModel As IpfcModel: Set oModel = oSession.CurrentModel
        Dim owindow As IpfcWindow
        
        'Parameter 정의
        Dim oParameterOwner As pfcls.IpfcParameterOwner
        Dim oBaseParameter As pfcls.IpfcBaseParameter
        Dim oCellBaseParameter As pfcls.IpfcBaseParameter
        Dim oModelBaseParameter As pfcls.IpfcBaseParameter
        Dim oParamValue As pfcls.IpfcParamValue
        Dim ocellParamValue As pfcls.IpfcParamValue
        Dim oModelParamValue As pfcls.IpfcParamValue
        Dim oParameter As IpfcParameter
        Dim oCMModelItem As New CMpfcModelItem

        
        Dim oParameterSting, oCroeCellName, oCellStringValue As String
        Dim oInteger As Integer
        Dim oDouble, oParameterDouble As Double
        
        'Creo File Name 정의
        Dim oModelDescriptorCreate As New CCpfcModelDescriptor
        Dim oModelDescriptor As IpfcModelDescriptor
        Dim oCreoModelParameterValue As IpfcBaseParameter:
        
        
    
        ' File List Count
        Dim rng As Range
        Set rng = Range("A10", Cells(Rows.Count, "A").End(xlUp))
        
        'Parameter List Count
        Dim oColumnscount As Long: oColumnscount = Cells(9, Columns.Count).End(xlToLeft).Column

        
        Dim i, j As Long
        
        
        For i = 0 To rng.Count - 1
        
             ' Current Creo File Open
                oCroeCellName = Cells(i + 10, "C")
                Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(oCroeCellName)
                Set owindow = oSession.OpenFile(oModelDescriptor)
        
                owindow.Activate
                
                Set oModel = oSession.CurrentModel
                Set oParameterOwner = oModel
                
                
                For j = 0 To oColumnscount - 8 ' Parameter Count
       
                  Set oBaseParameter = oParameterOwner.GetParam(Cells(9, j + 8))
         
                    If Len(Cells(i + 10, j + 8)) <> 0 Then
                      
                        Set oParamValue = oBaseParameter.Value
                        
                            If oParamValue.discr = 0 Then 'If parameter is string
                               oParameterSting = oParamValue.StringValue
                                
                                    If oParameterSting <> Cells(i + 10, j + 8) Then
                                       
                                       Set oParamValue = oCMModelItem.CreateStringParamValue(Cells(i + 10, j + 8))
                                       oBaseParameter.Value = oParamValue
                                       
                                    End If
                                    
                             ElseIf oParamValue.discr = 3 Then 'if parameter is Double
            
                                    oParameterDouble = oParamValue.DoubleValue
                                
                                       If oParameterDouble <> Cells(i + 10, j + 8) Then
                                        
                                       Set oParamValue = oCMModelItem.CreateDoubleParamValue(Cells(i + 10, j + 8))
                                       oBaseParameter.Value = oParamValue
                                       
                                       End If
                
                             End If
                        
                     End If
                
                  Next j

                owindow.Close
        Next i
        
        Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(Cells(10, "C")) ' Total Assembly Open
        Set owindow = oSession.OpenFile(oModelDescriptor)
        
        owindow.Activate
        
                
        
  conn.Disconnect (2)
       
        'Cleanup
        Set asynconn = Nothing
        Set conn = Nothing
        Set oSession = Nothing
        Set oModel = Nothing
    
RunError:

    If Err.Number <> 0 Then
        MsgBox "Process Failed : Unknown error occurred." + Chr(13) + _
                "Error No: " + CStr(Err.Number) + Chr(13) + _
                "Error: " + Err.Description, vbCritical, "Error"

        If Not conn Is Nothing Then
            If conn.IsRunning Then
                conn.Disconnect (2)
            End If
        End If
        
    End If
 End Sub

 

ToolBOX VBA 엑셀 파일

ToolBOx_vba_PARTLIST.xlsm

0.06MB

 

by lionkk@idt21c.com