활성화된 어셈블 정보 (Parameter Value) #1

■ 프로그램 기능 소개

어셈블 파일을 활성화 하고, 어셈블 파일을 구성 하는 서브 어셈블 및 Part 파일의 이름 및  수량을 자동으로 카운트 합니다. Creo 파일안에 있는 Parameter 값을 가져오고, 수정 하고 저장 할수 있게 만들것 입니다

 

주의 사항 >

1. 어셈블 파일의 Parameter "DESIGNER"를 정의 해야 합니다.  반드시 "string" 타입으로 정의 해야 합니다.  

2. View 이름이 "ISOVIEW" 로 저장 되어 있어야 합니다. 만일 없으면 "Deafault"로 저장 됩니다.

[ VBA 엑셀 파일 ]

■ 프로그램 실행 결과

"새로 고침"을 실행 합니다.

 

[ Creo 어셈블 파일 ]

 

[ 프로그램 실행 ]

 

 

 

 

 

■ 프로그램 소스

1. Main

 

Public useAsm As IpfcAssembly
Public pathArray As New Collection

Sub Newmodel()
     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
        
        'config.pro 옵션
        Call oSession.SetConfigOption("mass_property_calculate", "automatic")
        Call oSession.SetConfigOption("regen_failure_handling", "resolve_mode")
      
        'Current Designer Parameter Value
        Dim oParamDesigner As IpfcBaseParameter: Set oParamDesigner = oParamOwner.GetParam(Cells(3, "B"))
        
        If oParamDesigner Is Nothing Then
           
           conn.Disconnect (2)
           MsgBox " < DESIGNER > Parameter를 정의 하십시요"
           Exit Sub ' error 발생시 프로그램 종료
        
        End If
        
        Dim oParamValue As IpfcParamValue: Set oParamValue = oParamDesigner.Value
        Cells("3", "C") = oParamValue.StringValue
        
        'Model Name
        Cells(1, "C") = oModel.Filename: Cells(6, "B") = oModel.Filename
        Cells(6, "A") = 1: Cells(6, "C") = 1 ' 번호 : 수량
        
        'Model Path Name
        Cells(2, "C") = oSession.GetCurrentDirectory
        
        'Create Current DATE
        Dim oCreoDate As Date: oCreoDate = Now
        Cells(4, "C") = 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_01
        
        Cells(1, "F") = pathArray.count + 1
             
        Call oSession.SetConfigOption("mass_property_calculate", "by_request")
        Call oSession.SetConfigOption("regen_failure_handling", "no_resolve_mode")
 
        MsgBox ("총 파일 수량은 : " & pathArray.count + 1 & " 개 입니다")
    
    conn.Disconnect (2)
    
    'Cleanup
    Set asynconn = Nothing
    Set conn = Nothing
    Set session = Nothing
    Set Model = 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

 

 

2. 사용자 함수 ( PTC 자료 입니다)

 

'===========================================================================================
'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

 

 

3. 중복 Creo 파일 Count 

 

Sub Duplicate_01()
    
    Dim rng As Range, C As Range
    Dim dc As New Collection
    Set rng = Range("z5", Cells(Rows.count, "z").End(xlUp))

   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 + 6, "B") = dc(i) 'File Name
    Next

    For i = 1 To dc.count
        Cells(i + 6, "C") = WorksheetFunction.CountIf(rng, Cells(i + 6, "B")) ' 중복 수량 카운트
        Cells(i + 6, "A") = i + 1 'Number Count
    Next

Columns("Z").Delete
End Sub

 

 

4. JPG 변환 프로시져

 

Sub jpg_trans()
    
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
     
    'jpg 변환 옵션변수 정의
    Dim rasterHeight As Double: rasterHeight = 22
    Dim rasterWidth As Double: rasterWidth = 17
                        
    Dim JPEGImageExportCreate As New CCpfcJPEGImageExportInstructions
    Dim oJPEGExport As IpfcJPEGImageExportInstructions
    Set oJPEGExport = JPEGImageExportCreate.Create(rasterHeight, rasterWidth)
    Dim instructions As IpfcRasterImageExportInstructions
    Set instructions = oJPEGExport
    
    instructions.dotsPerInch = EpfcDotsPerInch.EpfcRASTERDPI_100
    instructions.imageDepth = EpfcRasterDepth.EpfcRASTERDEPTH_8


    'Parlist 파일 개수 및 이름
    Dim rng As Range: Set rng = Range("B6", Cells(Rows.count, "B").End(xlUp))
    
    Dim oModelDescriptorCreate As New CCpfcModelDescriptor
    Dim oModelDescriptor As IpfcModelDescriptor
    Dim owindow As IpfcWindow
    
    
    Dim i As Long
    Dim oCreoFileName As String
    
    For i = 1 To rng.count
        
        oCroeCellName = Cells(i + 5, "B")
        Cells(i + 5, "E") = Right(UCase(oCroeCellName), 3) 'File Type
        Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(oCroeCellName)
        Set owindow = oSession.OpenFile(oModelDescriptor)
        
        owindow.Activate
        
        
        Dim oModel As pfcls.IpfcModel: Set oModel = oSession.CurrentModel

        
        ' View
        Dim oViewOwner As IpfcViewOwner: Set oViewOwner = oSession.CurrentModel
        Dim oIpfcView As IpfcView: Set oIpfcView = oViewOwner.RetrieveView("isoview")
        
        
        If oIpfcView Is Nothing Then
        
            Set oIpfcView = oViewOwner.RetrieveView("default")
            
        End If
        
        Dim oJpgfilename As String: oJpgfilename = oModel.FullName & ".JPG"
    
        'jpg image location
        oSession.ChangeDirectory ("C:\idt\images")
    

        'jpg image 변환 실행
        Call owindow.ExportRasterImage(oJpgfilename, instructions)
        
        owindow.Close
         
        'jpg image Insert
        name = oJpgfilename
        str2 = "C:\idt\images\" & oJpgfilename
        ret = Dir(str2)
    
        If ret <> "" Then
            Set Pic = ActiveSheet.Pictures.Insert(str2)
            Set Imagecell = Cells(5 + i, "D")
        
            Cells(5 + i, "D").RowHeight = 100
        
            With Pic
                .ShapeRange.LockAspectRatio = msoFalse
                .Left = Imagecell.Left + 1
                .Top = Imagecell.Top + 1
                .Width = Imagecell.Width - 1
                .Height = Imagecell.Height - 1
            End With
        
        End If
     
   Next i
   
        Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(Cells(1, "C")) ' Total Assembly Open
        Set owindow = oSession.OpenFile(oModelDescriptor)
        
        owindow.Activate
   
        MsgBox ("JPG 변환 : " & rng.count & " 개를 완료 하였습니다")
   
    'Disconnect with Creo
    conn.Disconnect (2)
    
    'Cleanup
    Set asynconn = Nothing
    Set conn = Nothing
    Set session = Nothing
    Set Model = Nothing
       
    
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

Sub parametersave()
    
On Error GoTo RunError
    Dim asynconn As New pfcls.CCpfcAsyncConnection
    Dim conn As pfcls.IpfcAsyncConnection: Set conn = asynconn.Connect("", "", ".", 5)
    Dim session As pfcls.IpfcBaseSession: Set session = conn.session
    Dim oModel As pfcls.IpfcModel: Set oModel = session.CurrentModel
    Dim oParamOwner As pfcls.IpfcParameterOwner: Set oParamOwner = oModel

    'Cells Parameter Value
    Dim oPartNoValue As String: oPartNoValue = Cells(6, "D").Value
    Dim oPartNameValue As String: oPartNameValue = Cells(6, "E").Value
  

    'Creo Parameter
    Dim ParamObject As New CMpfcModelItem
    Dim oCellsPartNo As pfcls.IpfcParamValue: Set oCellsPartNo = ParamObject.CreateStringParamValue(oPartNoValue)
    Dim oCellsPartName As pfcls.IpfcParamValue: Set oCellsPartName = ParamObject.CreateStringParamValue(oPartNameValue)
    Dim oPartNoParam As pfcls.IpfcBaseParameter: Set oPartNoParam = oParamOwner.GetParam("PART_NO")
    Dim oPartNameParam As pfcls.IpfcBaseParameter: Set oPartNameParam = oParamOwner.GetParam("PART_NAME")

    oPartNoParam.Value = oCellsPartNo
    oPartNameParam.Value = oCellsPartName
     
  
    'Disconnect with Creo
    conn.Disconnect (2)
    
    'Cleanup
    Set asynconn = Nothing
    Set conn = Nothing
    Set session = Nothing
    Set Model = Nothing
       
    
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

 

 

5. Clear 프로시져

Sub modelinitialzation()

            'Cells clear
            Cells(1, "C").Select: Selection.ClearContents
            Cells(2, "C").Select: Selection.ClearContents
            Cells(3, "C").Select: Selection.ClearContents
            Cells(4, "C").Select: Selection.ClearContents
            Cells(1, "F").Select: Selection.ClearContents
            Range(Cells(6, "A"), Cells(Rows.count, "A")).EntireRow.Delete
            
            'Cells imge Clear
            Dim Pic As Object
            For Each Pic In ActiveSheet.Pictures
                Pic.Delete
            Next Pic

End Sub

 

 

 

PART LIST V2.xlsm

0.06MB