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

■ 프로그램 기능

creo 프로그램을 1개만 실행 시킵니다. Total Assemble 파일을 Open 합니다. 활성화 상태 입니다.

 

1. 새로 고침

현재 활성화된 어셈블 파일 및 저장된 폴더 이름을 표시 합니다. 어셈블의 매개변수 "Designer"를 검색하고, 값을 표시 합니다. "새로 고침"을 실행한 날짜 및 시간을 표시 합니다. File Count 는 Total Assemble  파일 포함 모든 조립된 파일을 카운트 합니다. (중복 파일도 카운트 합니다)

 

어셈블 파일을 카운트 하는 방법은 PTC의 VBA 코드를 사용 하였습니다. CELL "Z5"에 모든 CREO 파일 이름이 표시되고,

중복 데이터를 카운트 하여 "A6 ~C6"까지  표시 합니다.

 

2. Image

creo 배경 화면을 사용자가 변경 해야 합니다.  File Name에서 확장자만 잘라 "E6"에 표시 합니다. 이미지 파일은 "C:\IDT\IMAGES" 폴더에 저장됩니다. 이미지 파일 저장 위치는 프로그램 코드를 수정 하여, 변경 가능 합니다.

 

3. Parameter

 

"PART_NO", "PART_NAME"는 CREO 모델이 가지고 있는 매개 변수 입니다.  "PART_NAME" 이후에 매개변수를 추가 할수 있습니다, 

 

만일 Creo 파일안에  "PART_NO", "PART_NAME"기 없으면, 프로그램이 자동으로 매개변수를 만들고, 값을 "입력 필요"로 저장 합니다. 한번더 "Parameter" 기능을 수행 하면 각각의 모델에 저장 되어 있는 값을 표시 합니다

 

 

Creo VBA 엑셀로 만든 파일은 데이터 베이스 입니다. Creo 파일의 정보를 실시간으로 가져올수 있습니다.

그래프 차트로 쉽게 시각화 할수 있습니다. 또한  Creo VBA 엑셀로 만든 파일은 전문 데이터 베이스 프로그램에 데이터를 보낼수 있습니다. 

 

Creo VBA 엑셀 프로그램을 활용하여, 작은 설계 단위의 자동화를 할수 있습니다. 예를 들어 엑셀로 만든 설계 검증 Sheet에 다양한 Parameter 값을 자동으로 가져올수 있고, 이미지를 추가 할수 있습니다. 치수 값등의 조합을 자동으로 변경하여, 측정 값을 자동 변경 가능 합니다. 이러한 내용은 그래프 차트로 시각화할 수 있습니다.

 

■ 프로그램 소스

최적화 상태의 코드는 아닙니다. 지속적으로 코드 수정을 진행 할것 입니다.

 

 

공통 변수

Public useAsm As IpfcAssembly
Public pathArray As New Collection

 

1. 새로 고침  프로시져

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

'===========================================================================================
'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_01()
    
    Dim rng As Range, C As Range
    Dim dc As New Collection
    Set rng = Range("Z6", 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, dc(i)) ' 중복 수량 카운트
        Cells(i + 6, "A") = i + 1 'Number Count
    Next

Columns("Z").Delete
End Sub

 

2. Image 프로시져

 

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

 

3. parameter 프로시져

 

Sub parametersave()
    
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: Set oModel = session.CurrentModel


    'Parlist의 사용자 Parameter 개수 및 이름
    Dim oColumnscount As Long: oColumnscount = Cells(5, Columns.count).End(xlToLeft).Column
    oColumnscount = oColumnscount - 7 ' Parameter Count
    
    
    'Parlist 파일 개수 및 이름
    Dim rng As Range: Set rng = Range("B6", Cells(Rows.count, "B").End(xlUp))
    
    'Creo File Open
    Dim oModelDescriptorCreate As New CCpfcModelDescriptor
    Dim oModelDescriptor As IpfcModelDescriptor
    Dim owindow As IpfcWindow
    
    
    Dim k As Long
    Dim oCreoFileName 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 oParamValue01 As IpfcParamValue
    Dim oParamName As IpfcNamedModelItem
    Dim oModel As pfcls.IpfcModel
    
    
    Dim i As Long
      
       
    For k = 1 To rng.count
        
        ' Current Creo File Open
        oCroeCellName = Cells(k + 5, "B")
        Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(oCroeCellName)
        Set owindow = oSession.OpenFile(oModelDescriptor)
        
        owindow.Activate
              
        
        Set oModel = oSession.CurrentModel
        
   
 
            For i = 1 To oColumnscount
            
                Dim oCellsParamName As String: oCellsParamName = Cells(5, 7 + i).Value
                Set oParamOwner = oModel
                Set oBaseParameter = oParamOwner.GetParam(oCellsParamName)
                
                  
                    If oBaseParameter Is Nothing Then
                    
                          Cells(k + 5, i + 7) = "not"
                          
                          Set oParamValue = oParamObject.CreateStringParamValue("입력 필요")
                          Set oBaseParameter = oParamOwner.CreateParam(oCellsParamName, oParamValue)
                          
                        
                     Else
                           
                          Set oParamValue01 = oBaseParameter.Value
                          Cells(k + 5, i + 7) = oParamValue01.StringValue
                        
                    End If
                            
                       
            Next i
            
            
         owindow.Close
    
    Next k

   
        Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(Cells(1, "C")) ' Total Assembly Open
        Set owindow = oSession.OpenFile(oModelDescriptor)
        
        owindow.Activate
   
        
  
    '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 vbamacro()
    
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: Set oModel = oSession.CurrentModel
    
    Dim vbamacro As String
    
    vbamacro = "vmat@MAPKEY_LABELfg;~ Close `main_dlg_cur``appl_casc`;mapkey(continued) ~ Command `ProCmdMmModelProperties`;mapkey(continued) ~ Activate `mdlprops_dlg` `MATERIAL_lay_Controls.push_Change.lay_instance`;"
  
       
    oSession.RunMacro (vbamacro)
       
    
    '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

 

 

4. 초기화 프로시져

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

 

 

 

by : lionkk@idt21c.com

---