■ 프로그램 기능 소개
어셈블 파일을 활성화 하고, 어셈블 파일을 구성 하는 서브 어셈블 및 Part 파일의 이름 및 수량을 자동으로 카운트 합니다. Creo 파일안에 있는 Parameter 값을 가져오고, 수정 하고 저장 할수 있게 만들것 입니다
주의 사항 >
1. 어셈블 파일의 Parameter "DESIGNER"를 정의 해야 합니다. 반드시 "string" 타입으로 정의 해야 합니다.
2. View 이름이 "ISOVIEW" 로 저장 되어 있어야 합니다. 만일 없으면 "Deafault"로 저장 됩니다.
■ 프로그램 실행 결과
"새로 고침"을 실행 합니다.
■ 프로그램 소스
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
'VBA, VB.NET For Creo' 카테고리의 다른 글
현재 활성화 된 파일 상태 표시 및 BACKUP () (0) | 2022.09.26 |
---|---|
활성화된 어셈블 정보 (Parameter Value) #2 (0) | 2022.09.24 |
활성화된 모델의 정보 (Parameter Value) #2 (0) | 2022.09.20 |
활성화된 모델의 정보 (Parameter Value) #1 (0) | 2022.09.19 |
Creo Dimension을 Regenerate 하는 코드 (0) | 2022.09.19 |