Iimage 버튼을 클릭하면 자동으로 "파일 이름"과 동일한 JPG 파일이 생성 되고 "ISOVIEW" 셀에 이미지가 자동으로 삽입 됩니다. PART 파일에 "ISOVIEW" 뷰가 저장 되어 있어야 합니다. "Initialization" 버튼을 클릭하면 이미지와 함께 모든 내용이 사라집니다.
VBA EXCEL FILE
CREO 6.0 FILE
■ 소스 코드
Sub Newmodel()
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 Model As IpfcModel: Set Model = session.CurrentModel
'config.pro 옵션
Call session.SetConfigOption("mass_property_calculate", "automatic")
Call session.SetConfigOption("regen_failure_handling", "resolve_mode")
'Model Path Name
Cells(4, "C") = session.GetCurrentDirectory
'Model File Name
Cells(6, "B") = Model.Filename
'SET Regenerate
Dim RegenInstructions As New CCpfcRegenInstructions
Dim oInstrs As IpfcRegenInstructions: Set oInstrs = RegenInstructions.Create(True, True, Nothing)
Dim Solid As IpfcSolid: Set Solid = Model
Call Solid.Regenerate(oInstrs)
Call Solid.Regenerate(oInstrs)
'현재 모델의Parameter들 모으기
Dim oPowner As pfcls.IpfcParameterOwner: Set oPowner = Model
Dim oParams As IpfcParameters: Set oParams = oPowner.ListParams()
Dim oParam As IpfcBaseParameter
Dim oParamValue As IpfcParamValue
Dim oParamName As IpfcNamedModelItem
Dim i As Long
For i = 0 To oParams.count - 1
Set oParam = oParams(i)
Set oParamValue = oParam.Value
Set oParamName = oParam
If oParamName.name = "PART_NO" Then
Cells(6, "D") = oParamValue.StringValue
ElseIf oParamName.name = "PART_NAME" Then
Cells(6, "E") = oParamValue.StringValue
ElseIf oParamName.name = "MASS_NAME" Then
Cells(6, "F") = oParamValue.StringValue
End If
Next i
'GRAVITY Feature 개체 정의
Dim oModelItemOwner As IpfcModelItemOwner: Set oModelItemOwner = Model
Dim oModelItem As IpfcModelItem
Set oModelItem = oModelItemOwner.GetItemByName(EpfcModelItemType.EpfcITEM_FEATURE, "GRAVITY")
Dim oParameterOwner As IpfcParameterOwner: Set oParameterOwner = oModelItem
'Local Parameter Name : "mass"
Dim oParametermass As IpfcParameter: Set oParametermass = oParameterOwner.GetParam("mass")
Dim oBaseParametermass As IpfcBaseParameter: Set oBaseParametermass = oParametermass
Dim oParamValuemass As IpfcParamValue: Set oParamValuemass = oBaseParametermass.Value
Cells(6, "G") = oParamValuemass.DoubleValue
Call session.SetConfigOption("mass_property_calculate", "by_request")
Call session.SetConfigOption("regen_failure_handling", "no_resolve_mode")
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
Sub modelinitialzation()
'Cells clear
Cells(4, "C").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
Sub jpg_trans()
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 owindow As IpfcWindow: Set owindow = session.GetModelWindow(oModel)
'Activate the new window before jpg (Good practice)
owindow.Activate
'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
' View
Dim oViewOwner As IpfcViewOwner: Set oViewOwner = session.CurrentModel
Dim oIpfcView As IpfcView: Set oIpfcView = oViewOwner.RetrieveView("isoview")
Dim oJpgfilename As String: oJpgfilename = oModel.FullName & ".JPG"
'jpg image location
session.ChangeDirectory ("C:\idt\images")
'jpg image 변환 실행
Call owindow.ExportRasterImage(oJpgfilename, instructions)
'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(6, "C")
Rows("6").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
'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
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
By : lionkk@idt21c.com
'VBA For Creo' 카테고리의 다른 글
| 활성화된 어셈블 정보 (Parameter Value) #2 (0) | 2022.09.24 |
|---|---|
| 활성화된 어셈블 정보 (Parameter Value) #1 (0) | 2022.09.23 |
| 활성화된 모델의 정보 (Parameter Value) #1 (0) | 2022.09.19 |
| Creo Dimension을 Regenerate 하는 코드 (0) | 2022.09.19 |
| 측정 Feature의 매개변수 값 가져오기 #3 (1) | 2022.09.16 |
