반응형
Creo Part List 프로그램
자동으로 번호, 이미지, 파일 이름, 매개 변수를 표시 하는 프로그램 입니다. 반드시 어셈블 모델을 open 한후에 실행 해야 합니다.
Creo와 VBA 연결
Sub Part_List()
Dim asynconn As New pfcls.CCpfcAsyncConnection
Dim conn As pfcls.IpfcAsyncConnection
Dim session As pfcls.IpfcBaseSession
On Error GoTo RunError
Set conn = asynconn.Connect("", "", ".", 5)
Set session = conn.session
Dim model As IpfcModel
Set model = session.CurrentModel
Set useAsm = model
Range("D2").Value = model.filename
Set pathArray = listEachLeafComponentPath(useAsm)
'======================================================================================
'이 함수는 어셈블리의 모든 구성 요소 ('리프')에 대한 모든 ComponentPath의 배열을 반환합니다.
'======================================================================================
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
'===================================================================
'이 함수는 어셈블리 구조의 모든 수준을 재귀 적으로 방문하는 데 사용됩니다.
'===================================================================
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("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 + 4, "c") = dc(i)
Next
For i = 1 To dc.Count
Cells(i + 4, "e") = WorksheetFunction.CountIf(rng, Cells(i + 4, "C"))
Cells(i + 4, 1) = i
Next
End Sub
JPG 파일 변환 하기
'파일 jpg 변수 정의
Dim instructions As IpfcRasterImageExportInstructions
Dim imageExtension As String
Dim rasterHeight As Double, rasterWidth As Double
rasterHeight = 5
rasterWidth = 5
Dim dotsPerInch As Integer, imageDepth As Integer
dotsPerInch = EpfcDotsPerInch.EpfcRASTERDPI_100
imageDepth = EpfcRasterDepth.EpfcRASTERDEPTH_24
Dim oViewOwner As IpfcViewOwner
Dim oIpfcView As IpfcView
Dim creJPEG As New CCpfcJPEGImageExportInstructions
Dim JPEGInstrs As IpfcJPEGImageExportInstructions
Set JPEGInstrs = creJPEG.Create(rasterWidth, rasterHeight)
Set instructions = JPEGInstrs
'jpg 파일 붙여넣기
Dim Osheet As Worksheet: Set Osheet = ActiveSheet
Dim Orangeimg As Range
Dim oImagepic As Shape
Dim oJpgfilename As String
'Model 타입 알아보기
Dim Modeltype As Integer
For k = 1 To oNamerng
oCroeCellName = Cells(k + 4, "C")
Set ModelDescriptor = ModelDescriptorCreate.CreateFromFileName(oCroeCellName)
Set window = session.OpenFile(ModelDescriptor)
window.Activate
Set Model = session.CurrentModel
Set Powner = Model
Modeltype = Model.Type
If Modeltype = 0 Then
Cells(k + 4, "D") = "ASM"
ElseIf Modeltype = 1 Then
Cells(k + 4, "D") = "PART"
Else
Cells(k + 4, "D") = ""
End If
For p = 0 To 2
Set param = Powner.GetParam(oParameterName(p))
If Not param Is Nothing Then
Set paramValue = param.Value
oParameterValue(p) = paramValue.StringValue
Cells(k + 4, p + 6) = oParameterValue(p)
End If
Next p
Set oViewOwner = session.CurrentModel
Set oIpfcView = oViewOwner.RetrieveView("isoview")
Set JPEGInstrs = creJPEG.Create(rasterWidth, rasterHeight)
Set instructions = JPEGInstrs
oJpgfilename = Model.FullName & ".JPG"
session.ChangeDirectory ("D:\IDT\IMAGES")
Call window.ExportRasterImage(oJpgfilename, instructions)
Cells(k + 4, "B").Select
Set oImagepic = Osheet.Shapes.AddPicture("D:\IDT\IMAGES" & "\" & oJpgfilename, _
False, True, ActiveCell.Left + 1, ActiveCell.Top + 1, ActiveCell.Width - 2, ActiveCell.Height - 2)
session.ChangeDirectory (oForderName)
window.Close
Next k
프로그램 소스
Public useAsm As IpfcAssembly
Public pathArray As New Collection
Sub Part_List()
Dim asynconn As New pfcls.CCpfcAsyncConnection
Dim conn As pfcls.IpfcAsyncConnection
Dim session As pfcls.IpfcBaseSession
Dim mdlname
On Error GoTo RunError
Set conn = asynconn.Connect("", "", ".", 5)
Set session = conn.session
'Cells 초기화
Range(Cells(5, "A"), Cells(Rows.Count, "A")).EntireRow.Delete
Dim Model As IpfcModel
Set Model = session.CurrentModel
Set useAsm = Model
Range("d2").Value = Model.filename
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
'파일 open 변수 정의
Dim oNamerng As Integer: oNamerng = Cells(Rows.Count, "C").End(xlUp).Row - 4
Dim ModelDescriptorCreate As New CCpfcModelDescriptor
Dim ModelDescriptor As IpfcModelDescriptor
Dim window As IpfcWindow
'파일 매개변 변수 정의
Dim Powner As pfcls.IpfcParameterOwner
Dim param As IpfcBaseParameter
Dim paramValue As IpfcParamValue
Dim oParameterName(2) As String
oParameterName(0) = "PART_NO"
oParameterName(1) = "PART_NAME"
oParameterName(2) = "MATERIAL"
Dim oParameterValue(2) As String
oParameterValue(0) = "PART_NO_value"
oParameterValue(1) = "PART_NAME_value"
oParameterValue(2) = "MATERIAL_value"
'파일 jpg 변수 정의
Dim instructions As IpfcRasterImageExportInstructions
Dim imageExtension As String
Dim rasterHeight As Double, rasterWidth As Double
rasterHeight = 5
rasterWidth = 5
Dim dotsPerInch As Integer, imageDepth As Integer
dotsPerInch = EpfcDotsPerInch.EpfcRASTERDPI_100
imageDepth = EpfcRasterDepth.EpfcRASTERDEPTH_24
Dim oViewOwner As IpfcViewOwner
Dim oIpfcView As IpfcView
Dim creJPEG As New CCpfcJPEGImageExportInstructions
Dim JPEGInstrs As IpfcJPEGImageExportInstructions
Set JPEGInstrs = creJPEG.Create(rasterWidth, rasterHeight)
Set instructions = JPEGInstrs
'jpg 파일 붙여넣기
Dim Osheet As Worksheet: Set Osheet = ActiveSheet
Dim Orangeimg As Range
Dim oImagepic As Shape
Dim oJpgfilename As String
'Model 타입 알아보기
Dim Modeltype As Integer
For k = 1 To oNamerng
oCroeCellName = Cells(k + 4, "C")
Set ModelDescriptor = ModelDescriptorCreate.CreateFromFileName(oCroeCellName)
Set window = session.OpenFile(ModelDescriptor)
window.Activate
Set Model = session.CurrentModel
Set Powner = Model
Modeltype = Model.Type
If Modeltype = 0 Then
Cells(k + 4, "D") = "ASM"
ElseIf Modeltype = 1 Then
Cells(k + 4, "D") = "PART"
Else
Cells(k + 4, "D") = ""
End If
For p = 0 To 2
Set param = Powner.GetParam(oParameterName(p))
If Not param Is Nothing Then
Set paramValue = param.Value
oParameterValue(p) = paramValue.StringValue
Cells(k + 4, p + 6) = oParameterValue(p)
End If
Next p
Set oViewOwner = session.CurrentModel
Set oIpfcView = oViewOwner.RetrieveView("isoview")
Set JPEGInstrs = creJPEG.Create(rasterWidth, rasterHeight)
Set instructions = JPEGInstrs
oJpgfilename = Model.FullName & ".JPG"
session.ChangeDirectory ("D:\IDT\IMAGES")
Call window.ExportRasterImage(oJpgfilename, instructions)
Cells(k + 4, "B").Select
Set oImagepic = Osheet.Shapes.AddPicture("D:\IDT\IMAGES" & "\" & oJpgfilename, _
False, True, ActiveCell.Left + 1, ActiveCell.Top + 1, ActiveCell.Width - 2, ActiveCell.Height - 2)
session.ChangeDirectory (oForderName)
window.Close
Next k
RunError:
If Err.Number <> 0 Then
MsgBox "Process Failed : Unknown error occured." + 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("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 + 4, "C") = dc(i)
Next
For i = 1 To dc.Count
Cells(i + 4, "E") = WorksheetFunction.CountIf(rng, Cells(i + 4, "C"))
Cells(i + 4, "A") = i
Next
Columns("Z").Delete
End Sub
PART LIST PROGRAM BY IDT_v3.xlsm
0.10MB
비즈니스 문의 : lionkk@idt21c.com
'VBA For Creo' 카테고리의 다른 글
| Connecting to a Creo Parametric Process (0) | 2021.03.03 |
|---|---|
| CREO 파일 타입 알아보기 (0) | 2021.02.18 |
| 가로*세로*높이 사이즈 알아보기 (0) | 2021.02.16 |
| 재질 파일 설정 (0) | 2021.02.15 |
| 무게와 관련된 매개변수 (0) | 2021.02.15 |
