반응형
□ 프로그램 소개
Sheet (PRO_DATA)의 값을 이용하여, 모델을 변경 하는 기능 입니다. 모델의 치수 이름과 Sheet (PRO_DATA)의 치수 이름은 동일해야 합니다. Sheet (PRO_DATA)의 치수 이름은 추가 할수 있습니다. Sheet (PRO_DATA)의 SQ Size는 추가 할수 있습니다. Sheet (PRO_DATA)의 SQ Size의 이름은 변경 할수 있습니다. 하지만 이름의 문자 개수는 "4"자리로 제한 합니다. 또한 SQ Size는 60개로 제한 합니다.
설계 표준 데이터 값으로, 기존 모델을 변경 하여 새로운 모델을 생성 할수 있습니다.
설계의 시점을 처음이 아니라. 1/2 지점 부터 시작 할수 있습니다.
변경 가능한 영역을 표준화 된 데이터(경험치 또는 측정된 값...)를 활용하여, 모든 설계자가 강제적으로 사내 표준 사용 하도록 하는 기능 입니다.
수년간 아래와 기능과 Template 모델을 사용한다면, 치수를 추적 할수 있고, 사용 된 값을 분류 하고, 변경된 값을 그래프 차트로 만들수 있습니다 (시각화). 데이타 라벨링이 가능 합니다. AI 학습 데이터를 쌓을수 있습니다.
TIP)
Template 모델은 3D와 2D로 구성 할수 있습니다. 2D는 공차 값을 갖습니다. 물론 3D도 공차 값을 갖을 수 있습니다.
Template 모델은 어셈블로도 가능 합니다. Skeleton Part를 사용 한다면, 어셈블 모델을 변경 할수 있습니다.
Sample Model (Creo 9.0) & Excel VBA
TOOLBOX_VBA_DataSheet.xlsm
0.06MB
□ 프로그램 동작 순서
1. Creo에서 샘플 모델을 Open 합니다.
2. VBA 프로그램을 실행 합니다.
1) 제공된 엑셀 VBA 파일을 Open 합니다.
2) 현재_통합_문서의 "Workbook_Open" 프로시져가 실행 됩니다
3. VBA 프로그램의 "새로고침" 메뉴를 클릭 합니다>
1) Open 된 모델의 이름, 작업 폴더, 치수 값을 표시 합니다
2) 모듈 "Open_Template_File" 프로시져가 실행 됩니다
4. SQ Size를 선택 합니다
1) 실행된 "Workbook_Open" 프로시져의 기능이 사용 됩니다
5. New File Name 이름 입력후, "파일 생성"을 버튼을 클릭 합니다
1) 현재 작업 폴더에 저장 됩니다. 입력된 이름으로 저장 됩니다.
2) 치수 값이 변경되어 저장 됩니다
3) 모듈 "Create_New_File"이 사용 됩니다
참고 사이트
동영상
"Workbook_Open" Procedure CODE
Private Sub Workbook_Open()
Dim DimensionName As Long
'Dim SQName As Long
Dim i As Long
'Dim j As Long
'//Dimension Name Count
DimensionName = Worksheets("PRO_DATA").Cells(1, Columns.Count).End(xlToLeft).Column
DimensionName = DimensionName - 1
For i = 0 To DimensionName - 1
Worksheets("Program01").Cells(13, i + 4) = Worksheets("PRO_DATA").Cells(1, i + 2)
Next i
'//SQ Size Name
'SQName = Worksheets("PRO_DATA").Cells(Rows.Count, "A").End(xlUp).Row
'SQName = SQName - 1
'//Dimension Name Display
'Dim ModelDimensionName() As Variant
'ReDim ModelDimensionName(SQName)
'For j = 0 To SQName - 1
'ModelDimensionName(j) = Array(Worksheets("PRO_DATA").Cells(j + 2, 1))
'Next j
'///////////////////////////////////Drop Box
Dim WS As Worksheet
Dim cell As Range
Dim listString As String
Set WS = Worksheets("PRO_DATA")
'// Build the list string by iterating through SQName range
For Each cell In WS.Range("A2", WS.Cells(Rows.Count, "A").End(xlUp))
listString = listString & cell.Value & "," '// Add each cell value to the list string, separated by comma
Next cell
'// Remove the trailing comma from the list string
listString = Left(listString, Len(listString) - 1)
'// Check for errors in list string
If InStr(listString, ",") = 0 Then
MsgBox "List string cannot be empty or contain only one value."
Exit Sub
End If
'// Replace commas with another delimiter if necessary
If Len(listString) > 255 Then
MsgBox "List string is too long. Please reduce the number of items or use a different delimiter."
Exit Sub
End If
'// Set the validation with the built list string
Worksheets("Program01").Range("F9").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=listString
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
MsgBox "ToolBOX VBA : 환영 합니다.", vbInformation, "www.idt21c.com"
End Sub
"Create_New_File" Procedure CODE
Regenerate 기능은 Mapkey로 실행 합니다.
Option Explicit
Sub SQDimension()
Application.EnableEvents = False
'// Dimension Change
Dim CellSQName As String
CellSQName = Worksheets("Program01").Cells(9, "F")
Dim DimensionValueCount As Long
Dim SQNameCount As Long
'//DimensionValueCount
DimensionValueCount = Worksheets("PRO_DATA").Cells(2, Columns.Count).End(xlToLeft).Column
DimensionValueCount = DimensionValueCount - 1
'//SQNameCount
SQNameCount = Worksheets("PRO_DATA").Cells(Rows.Count, "A").End(xlUp).Row
SQNameCount = SQNameCount - 1
Dim K As Long '//(→)
Dim l As Long '//(↓)
For l = 0 To SQNameCount - 1
If CellSQName = Worksheets("PRO_DATA").Cells(l + 2, "A") Then
For K = 0 To DimensionValueCount - 1
Worksheets("Program01").Cells(14, K + 4) = Worksheets("PRO_DATA").Cells(l + 2, K + 2)
Next K
End If
Next l
End Sub
Sub Create_New()
On Error GoTo RunError
Application.EnableEvents = False
'// New File Nmae
Dim NewFileName As String
NewFileName = Cells(5, "D")
If NewFileName = "" Then
MsgBox "File 이름을 입력 하십시요"
Exit Sub
End If
'// Sheet(PRO_DATA) Input
SQDimension
'// Check if "Program01" worksheet exists
If Not WorksheetExists("Program01") Then
MsgBox "Worksheet 'Program01' not found.", vbExclamation, "Error"
Exit Sub
End If
Dim asynconn As New pfcls.CCpfcAsyncConnection
Dim conn As pfcls.IpfcAsyncConnection
'// Check Creo Connect
Set conn = asynconn.Connect("", "", ".", 5)
If conn Is Nothing Then
MsgBox "An error occurred while starting a new Creo Parametric Session", vbInformation, "www.idt21c.com"
Exit Sub
End If
Dim BaseSession As pfcls.IpfcBaseSession
Dim model As pfcls.IpfcModel
Dim Newmodel As pfcls.IpfcModel
Dim NewModelDescriptor As New CCpfcModelDescriptor
Dim ModelDescriptor As IpfcModelDescriptor
Dim Window As pfcls.IpfcWindow
Dim Solid As IpfcSolid
Set BaseSession = conn.Session
Set model = BaseSession.CurrentModel
Set Solid = model
'// New Model Create & Open
Set Newmodel = model.CopyAndRetrieve(NewFileName, Null)
Set ModelDescriptor = NewModelDescriptor.CreateFromFileName(NewFileName)
Set Window = BaseSession.OpenFile(ModelDescriptor)
Set model = Window.model
'// Open 모델 활성화
Window.Activate
'// Window Repaint
Set Window = BaseSession.CurrentWindow
Window.Repaint
'// Dimension Update
Dim NewDimensionNameCount As Long
Dim i As Long
NewDimensionNameCount = Worksheets("Program01").Cells(13, Columns.Count).End(xlToLeft).Column
NewDimensionNameCount = NewDimensionNameCount - 3 '// "D13". "E13", "F13". . .
Dim Modelowner As IpfcModelItemOwner
Dim BaseDimension As IpfcBaseDimension
Set Modelowner = model
For i = 0 To NewDimensionNameCount - 1
Set BaseDimension = Modelowner.GetItemByName(EpfcModelItemType.EpfcITEM_DIMENSION, Cells(13, i + 4))
BaseDimension.DimValue = Cells(14, i + 4)
Next i
Window.Activate
'// SET Regenerate
'Dim RegenInstructions As New CCpfcRegenInstructions
'Dim Instrs As IpfcRegenInstructions
'Set Instrs = RegenInstructions.Create(False, False, Nothing)
'// Regenerate 실행
'Call Solid.Regenerate(Instrs)
'Call Solid.Regenerate(Instrs)
'// Regenerate Mapkey
Dim vbamacro As String
vbamacro = "mapkey kg ~ Activate `main_dlg_cur` `page_Model_control_btn` 0;\" & _
"mapkey(continued) ~ Command `ProCmdRegenPart`;"
BaseSession.RunMacro (vbamacro)
'// Window Repaint
Set Window = BaseSession.CurrentWindow
Window.Repaint
'// Save changed model
model.Save
MsgBox "새로운 모델이 생성되었습니다!", vbInformation, "www.idt21c.com"
conn.Disconnect (2)
'// Cleanup
Set asynconn = Nothing
Set conn = Nothing
Set BaseSession = Nothing
Set model = Nothing
Exit Sub
RunError:
If Err.Number <> 0 Then
MsgBox "Process Failed: An error occurred." & vbCrLf & _
"Error No: " & CStr(Err.Number) & vbCrLf & _
"Error Description: " & Err.Description & vbCrLf & _
"Error Source: " & Err.Source, vbCritical, "Error"
If Not conn Is Nothing Then
If conn.IsRunning Then
conn.Disconnect (2)
End If
End If
End If
End Sub
Function WorksheetExists(shtName As String) As Boolean
On Error Resume Next
WorksheetExists = Not Worksheets(shtName) Is Nothing
On Error GoTo 0
End Function
"Open_Template_File" Procedure CODE
Option Explicit
Sub Open_template()
On Error GoTo RunError
Application.EnableEvents = False
'// Check if "Program01" worksheet exists
If Not WorksheetExists("Program01") Then
MsgBox "Worksheet 'Program01' not found.", vbExclamation, "Error"
Exit Sub
End If
Dim asynconn As New pfcls.CCpfcAsyncConnection
Dim conn As pfcls.IpfcAsyncConnection
'// Check Creo Connect
Set conn = asynconn.Connect("", "", ".", 5)
If conn Is Nothing Then
MsgBox "An error occurred while starting a new Creo Parametric Session", vbInformation, "www.idt21c.com"
Exit Sub
End If
Dim BaseSession As pfcls.IpfcBaseSession
Dim model As pfcls.IpfcModel
Set BaseSession = conn.Session
Set model = BaseSession.CurrentModel
'// Current Model Information
Worksheets("Program01").Cells(2, "D") = BaseSession.GetCurrentDirectory
Worksheets("Program01").Cells(3, "D") = model.Filename
'// Display template model dimension values
Dim Modelowner As IpfcModelItemOwner
Dim modelitems As IpfcModelItems
Dim Dimensionlitem As IpfcModelItem
Dim BaseDimension As IpfcBaseDimension
Dim DimensionNameCount As Long
Set Modelowner = model
Set modelitems = Modelowner.ListItems(EpfcModelItemType.EpfcITEM_DIMENSION)
DimensionNameCount = Worksheets("Program01").Cells(13, Columns.Count).End(xlToLeft).Column
DimensionNameCount = DimensionNameCount - 3 '// "A13". "B13", "C13" (3ea)
Dim i As Long
Dim j As Long
For i = 0 To DimensionNameCount - 1
For j = 0 To modelitems.Count - 1
Set Dimensionlitem = modelitems(j)
If Cells(13, i + 4) = Dimensionlitem.GetName Then '// Compare dimension names
Set BaseDimension = modelitems(j)
Cells(14, i + 4) = BaseDimension.DimValue
End If
Next j
Next i
'// Null value check
For i = 0 To DimensionNameCount - 1
If Cells(14, i + 4).Value = "" Then
Cells(14, i + 4) = "DIM 없음"
End If
Next i
'// PRO_DATA Get dimension values from Sheet
MsgBox "Template 모델 치수를 가져왔습니다.!", vbInformation, "www.idt21c.com"
conn.Disconnect (2)
' Cleanup
Set asynconn = Nothing
Set conn = Nothing
Set BaseSession = Nothing
Set model = Nothing
Exit Sub
RunError:
If Err.Number <> 0 Then
MsgBox "Process Failed: An error occurred." & vbCrLf & _
"Error No: " & CStr(Err.Number) & vbCrLf & _
"Error Description: " & Err.Description & vbCrLf & _
"Error Source: " & Err.Source, vbCritical, "Error"
If Not conn Is Nothing Then
If conn.IsRunning Then
conn.Disconnect (2)
End If
End If
End If
End Sub
Function WorksheetExists(shtName As String) As Boolean
On Error Resume Next
WorksheetExists = Not Worksheets(shtName) Is Nothing
On Error GoTo 0
End FunctionExcel VBA 파일을 업데트 하였습니다.
SQSize를 선택하면 실시간으로 치수값이 변경 됩니다
Inquire : lionkk@idt21c.com
'VBA For Creo' 카테고리의 다른 글
| Creo 7.0 부터 "regen_failure_handling" 옵션을 사용 할 수 없습니다 (0) | 2024.04.11 |
|---|---|
| 변수 선언 : CREO 활성화된 Window 연결 (0) | 2024.04.10 |
| #3 데이터를 선택하여, 모델을 변경 하기 (0) | 2024.04.03 |
| #2 데이터를 선택하여, 모델을 변경 하기 (0) | 2024.04.01 |
| #1 데이터를 선택하여, 모델을 변경 하기 (0) | 2024.03.30 |
