반응형
Creo 어셈블에 포한된 부품들의 정보를 표시합니다.
1. Model Name
2. Model Image
3. Model Type
4. Model 수량
5. Parameter
Download
*** Skeleton File is automatically removed
Part List 프로그램 화면 입니다.
사용자 정의 구역은 모델에 저장하는 Parameter 입니다. 사용자 환경은 다릅니다.
Parameter 이름 및 타입은 변경 가능 하고, 추가도 가능 합니다.
예시) "Part Number " 항목에 대한 예시 입니다.
- Part Number (표시항목 입니다, 한글 가능 합니다) /
- PART_NO (Creo Parameter Name 입니다.) /
- String (Parameter Type 입니다.)
- 문자 타입은 "String"으로 정의 합니다 - 대 소문자 구분 합니다
- 실수 타입은 "Double"으로 정의 합니다. - 대 소문자 구분 합니다
- 정수 타입은 "integer"으로 정의 합니다. - 대 소문자 구분 합니다
■ "New" 버튼 기능
1. 활성화된 어셈블 파일의 이름을 표시 합니다.
2. 현재 작업 공간을 표시 합니다.
3. 현재 모델의 파일 이름들을 표시 합니다.
4. 정의된 Parameter 이름이 모델에 있는지 체크 합니다
1) 모델에 Parameter 이름이 없으면 생성 되고, 기존 값이 저장 됩니다,
2) 모델에 Parameter 이름이 있으면, 값을 불러 옵니다.
* 반드시 어셈블 파일이 Open 되어 있어야 합니다. Creo 화면에 어셈블 파일이 없으면, 스크립 오류메세지가 표시 됩니다
■ "JPG" 버튼 기능
1. 현재 모델의 이미지를 폴더에 저장 하고, 엑셀 파일에 표시 합니다. Creo에서 "ISOVIEW" 이름을 찾습니다
- 작업 속도가 문제 된다면, 기능을 사용 하지 마십시요
2. DATA 탭에 저장 폴더 위치가 정의 되어 있습니다.
■ "Save" 버튼 기능
1. Excel이 Paramter 값을 모델에 전달 하고, 모델을 저장 합니다.
■ "Clear " 버튼 기능
1. 엑셀에 있는 파일 내용을 모두 삭제 합니다
■ 사용 방업 동영상
Sub Creo_Connect() : Creo 모델과 엑셀 VBA를 연결 합니다
Option Explicit
Public useAsm As IpfcAssembly
Public pathArray As New Collection
Public asynconn As New pfcls.CCpfcAsyncConnection
Public conn As pfcls.IpfcAsyncConnection
Public oSession As pfcls.IpfcBaseSession
Public oModel As IpfcModel
Public oSolid As IpfcSolid
Public Sub Creo_Connect()
Application.EnableEvents = False
'//////////////////////////////////////////////////////////////////////////////////////////////////////
'// Creo Connect Check
'//////////////////////////////////////////////////////////////////////////////////////////////////////
On Error Resume Next
Set conn = asynconn.Connect("", "", ".", 5)
If conn Is Nothing Then
MsgBox "Error occurred while starting new Creo Parametric Session!", vbInformation, "www.idt21c.com"
Exit Sub
End If
'//////////////////////////////////////////////////////////////////////////////////////////////////////
Set oSession = conn.Session
'// Current Model
Set oModel = oSession.CurrentModel
Set oSolid = oModel
End Sub
Duplicate_02() : 중복 파일 제거
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 + 7, "A") = i + 1 '//Number Count
Cells(i + 7, "C") = dc(i) '//File Name
Cells(i + 7, "E") = WorksheetFunction.CountIf(rng, Cells(i + 7, "C")) ' //중복 수량 카운트
Cells(i + 7, "D") = Right(UCase(Cells(i + 7, "C")), 3) '// File Type
Next i
Columns("Z").Delete
End Sub
Sub PartListparameter() : 모델들의 Parameter 값 가져오기
Sub PartListparameter()
'// Number and name of user parameters in Part List
Dim oColumnscount As Integer: oColumnscount = Cells(6, Columns.Count).End(xlToLeft).Column - 5
'// Parlist file count and name
Dim rng As Range: Set rng = Range("C7", Cells(Rows.Count, "C").End(xlUp))
'// Creo File Open
Dim oCreateModelDescriptor As New CCpfcModelDescriptor
Dim oModelDescriptor As IpfcModelDescriptor
Dim oCreoFileName As String
Dim i, j As Integer
Dim oCroeCellName As String
'// Parameter definition
Dim oBaseParameter As pfcls.IpfcBaseParameter
Dim oParameterOwner As IpfcParameterOwner
Dim oParameter As IpfcParameter
Dim oParamValue As IpfcParamValue
Dim oCMModelItem As New CMpfcModelItem
Dim oModelitem As IpfcModelItem
Dim oCellsParameterName, oCellsParameterType As String
For i = 0 To rng.Count - 1
'// Current Creo File Open
oCreoFileName = Cells(i + 7, "C")
Set oModelDescriptor = oCreateModelDescriptor.CreateFromFileName(oCreoFileName)
Set oModel = oSession.RetrieveModel(oModelDescriptor) '// Load model with Session
oModel.Display '// Activate the model
Set oParameterOwner = oModel
For j = 0 To oColumnscount - 1
'// Get the Parameter of the model by the Parameter name in Excel
Set oBaseParameter = oParameterOwner.GetParam(Cells(5, j + 6))
'// Get Parameter type from Excel
oCellsParameterType = Cells(4, j + 6)
If oBaseParameter Is Nothing Then
If oCellsParameterType = "String" Then
Set oParamValue = oCMModelItem.CreateStringParamValue("not")
Cells(i + 7, j + 6) = "not"
ElseIf oCellsParameterType = "Double" Then
Set oParamValue = oCMModelItem.CreateDoubleParamValue(0)
Cells(i + 7, j + 6) = "0.0"
ElseIf oCellsParameterType = "True False" Then
Set oParamValue = oCMModelItem.CreateBoolParamValue(True)
Cells(i + 7, j + 6) = "True"
Else
Set oParamValue = oCMModelItem.CreateIntParamValue(0)
Cells(i + 7, j + 6) = 0
End If
Set oBaseParameter = oParameterOwner.CreateParam(Cells(5, j + 6), oParamValue)
Else
Set oParamValue = oBaseParameter.Value
If oParamValue.discr = 0 Then
Cells(i + 7, j + 6) = oParamValue.StringValue
ElseIf oParamValue.discr = 3 Then
Cells(i + 7, j + 6) = oParamValue.DoubleValue
ElseIf oParamValue.discr = "2" Then
Cells(i + 7, j + 6) = oParamValue.BoolValue
Else
Cells(i + 7, j + 6) = oParamValue.IntValue
End If
End If
Next j
Next i
oCreoFileName = Cells(5, "C")
Set oModelDescriptor = oCreateModelDescriptor.CreateFromFileName(oCreoFileName)
Set oModel = oSession.RetrieveModel(oModelDescriptor) '// Load model with Session
oModel.Display '// Activate the model
oModel.Save
End Sub
A3PartListJpgExport() : 부품들의 이미지 저장
Sub A3PartListJpgExport()
Application.ScreenUpdating = False
Call Creo_Connect
On Error GoTo RunError
'// Back Ground Color White
Dim BackgroundWhitemacro As String
BackgroundWhitemacro = "al_screen_cap @MAPKEY_LABEL스크린 샷을 찍기위해서 흰배경으로 변경;\mapkey(continued) ~ Select `main_dlg_cur` `appl_casc`;~ Close `main_dlg_cur` `appl_casc`;\mapkey(continued) ~ Command `ProCmdRibbonOptionsDlg` ;\mapkey(continued) ~ Select `ribbon_options_dialog` `PageSwitcherPageList` 1 `colors_layouts`;\mapkey(continued) ~ Open `ribbon_options_dialog` `colors_layouts.Color_scheme_optMenu`;\mapkey(continued) ~ Close `ribbon_options_dialog` `colors_layouts.Color_scheme_optMenu`;\mapkey(continued) ~ Select `ribbon_options_dialog` `colors_layouts.Color_scheme_optMenu` 1 `2`;\mapkey(continued) ~ Activate `ribbon_options_dialog` `OkPshBtn`;\mapkey(continued) ~ Command `ProCmdViewSpinCntr` 0;nCntr` 0;"
oSession.RunMacro (BackgroundWhitemacro)
Call oSession.SetConfigOption("display_planes", "no")
Call oSession.SetConfigOption("display_axes", "no")
Call oSession.SetConfigOption("display_coord_sys", "no")
Call oSession.SetConfigOption("display_points", "no")
Call oSession.SetConfigOption("display_annotations", "no")
Call oSession.SetConfigOption("display", "shadewithedges")
'// sheet scale
ActiveWindow.Zoom = 100
Application.ScreenUpdating = True
'// 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
' // Number of Part files
Dim rng As Range
Set rng = Range("C7", Cells(Rows.Count, "C").End(xlUp))
Dim oModelDescriptorCreate As New CCpfcModelDescriptor
Dim oModelDescriptor As IpfcModelDescriptor
Dim owindow As IpfcWindow
Dim i As Integer
Dim oCreoFileName, str2, ret As String
Dim Pic As Variant
Dim Imagecell As Range
'// ISOView rotation
Dim oViewOwner As IpfcViewOwner
Dim oIpfcView As IpfcView
Dim oJpgfilename As String, oJpgcheck As String
'// jpg image location
Dim FolderName As String
FolderName = Worksheets("data").Cells(17, "B")
oSession.ChangeDirectory (FolderName)
For i = 0 To rng.Count - 1
oCreoFileName = Cells(i + 7, "C")
Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(oCreoFileName)
Set owindow = oSession.OpenFile(oModelDescriptor)
owindow.Activate
Set oModel = oSession.CurrentModel
oJpgfilename = oModel.FullName & ".JPG"
'// ISOView rotation
Set oViewOwner = oSession.CurrentModel
Set oIpfcView = oViewOwner.RetrieveView("isoview")
If oIpfcView Is Nothing Then
Set oIpfcView = oViewOwner.RetrieveView("default")
End If
'// jpg image 변환 실행
Call owindow.ExportRasterImage(oJpgfilename, instructions)
owindow.Close
'// jpg image Insert
str2 = FolderName & "\" & oJpgfilename
ret = Dir(str2)
If ret <> "" Then
Set Pic = ActiveSheet.Pictures.Insert(str2)
Set Imagecell = Cells(i + 7, "B")
Cells(i + 7, "B").RowHeight = 50
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
oCreoFileName = Cells(5, "C")
Set oModelDescriptor = oModelDescriptorCreate.CreateFromFileName(oCreoFileName)
Set owindow = oSession.OpenFile(oModelDescriptor)
owindow.Activate
owindow.Refresh
MsgBox "All images have been loaded !", vbInformation, "www.idt21c.com"
'// Disconnect with Creo
conn.Disconnect (2)
'// Cleanup
Set asynconn = Nothing
Set conn = Nothing
Set oSession = Nothing
Set oModel = 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 modelparamsave() : 엑셀 입력된 부품들의 매개변수 값을 모델에 저장
Sub modelparamsave()
Application.EnableEvents = False
Call Creo_Connect
On Error GoTo RunError
'// Number and name of user parameters in Part List
Dim oColumnscount As Integer: oColumnscount = Cells(6, Columns.Count).End(xlToLeft).Column - 5
'// Parlist file count and name
Dim rng As Range: Set rng = Range("C7", Cells(Rows.Count, "C").End(xlUp))
'// Creo File Open
Dim oCreateModelDescriptor As New CCpfcModelDescriptor
Dim oModelDescriptor As IpfcModelDescriptor
Dim oCreoFileName As String
Dim i, j As Integer
'// Parameter definition
Dim oBaseParameter As pfcls.IpfcBaseParameter
Dim oParameterOwner As IpfcParameterOwner
Dim oParams As IpfcParameters
Dim oParam As IpfcParameter
Dim ParamObject As New CMpfcModelItem
Dim oParamValue As pfcls.IpfcParamValue
Dim oParamtype As String
Dim oInteger As Integer
Dim oDouble As Double
Dim oStringvalue As String
For i = 0 To rng.Count - 1
'// Current Creo File Open
oCreoFileName = Cells(i + 7, "C")
Set oModelDescriptor = oCreateModelDescriptor.CreateFromFileName(oCreoFileName)
Set oModel = oSession.RetrieveModel(oModelDescriptor) '// Load model with Session
oModel.Display '// Activate the model
Set oParameterOwner = oModel
For j = 0 To oColumnscount - 1
Cells(4, j + 6).Select
oParamtype = ActiveCell.Value '// Parameter Type
Set oParam = oParameterOwner.GetParam(Cells(5, j + 6)) '// Parameter Name
Set oBaseParameter = oParam
If oParamtype = "String" Then
Set oParamValue = ParamObject.CreateStringParamValue(Cells(i + 7, j + 6))
ElseIf oParamtype = "Integer" Then
Set oParamValue = ParamObject.CreateIntParamValue(Cells(i + 7, j + 6))
ElseIf oParamtype = "True False" Then
Set oParamValue = ParamObject.CreateBoolParamValue(Cells(i + 7, j + 6))
Else
Set oParamValue = ParamObject.CreateDoubleParamValue(Cells(i + 7, j + 6))
End If
oBaseParameter.Value = oParamValue
Next j
Next i
oCreoFileName = Cells(5, "C")
Set oModelDescriptor = oCreateModelDescriptor.CreateFromFileName(oCreoFileName)
Set oModel = oSession.RetrieveModel(oModelDescriptor) '// Load model with Session
oModel.Display '// Activate the model
oModel.Save
MsgBox "Parameters are saved!!!", vbInformation, "www.idt21c.com"
conn.Disconnect (2)
'Cleanup
Set asynconn = Nothing
Set conn = Nothing
Set oSession = Nothing
Set oModel = 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
data_clear01() : 엑셀의 데이터 영역을 Clear 합니다
Option Explicit
Sub data_clear01()
Application.ScreenUpdating = False
Range("C4:C5").ClearContents
Range("A7:T3000").ClearContents
'// image file removal code
Dim xPicRg As Range
Dim xPic As Picture
Dim xRg As Range
Set xRg = Range("B7:B3000")
For Each xPic In ActiveSheet.Pictures
Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
If Not Intersect(xRg, xPicRg) Is Nothing Then
xPic.Delete
End If
Next
Application.ScreenUpdating = True
End Sub
■ 사용 방법
By lionkk@idt21c.com
'VBA For Creo' 카테고리의 다른 글
| ChatGPT - CREO UDF 파일 불러오기 (0) | 2023.02.21 |
|---|---|
| Creo 라이브러리 관리 프로그램 (0) | 2023.02.21 |
| 도면이 가지고 있는 치수 값을 가지고 오기 #1 (0) | 2023.02.14 |
| 모델이 가지고 있는 치수 값을 가지고 오기 - 두번째 (0) | 2023.02.11 |
| Creo Feature Type 시각화 하기 (0) | 2023.02.10 |
