Template] Create a new model by changing the dimensions - 작업중

□ Key Features

• Registering a Template Model
• Register the dimension names you want to change
• Change the model's dimension values
• Save with drawing as new model

□ Template Data Management Sheet

• Enter the template model location
• Enter the template model name
• Enter the dimension name you want to change

[Template_Data Sheet ]

□ User Template Sheet

• Enter a new Part file name
• Enter new dimension value
• Click the save button

[Template Sheet]

1. Open Button

• Open the Creo file defined in the Template_Data Sheet
• Import Creo Dimension names and values ​​defined in Template_Data Sheet into Excel.
• Get the Description content from Template_Data Sheet and display it in Excel.

2. What designers need to input

• New Name :  ex) korea100.prt
• Part Number : ex) 200-k300
• Part Name : ex) This is a test
• Designer : ex) mike

3. Apply Button

• Change creo model and parameter values.

4. Save Button

• Select a save location and save it.

5. Clear Button

• Deletes the entered content.

□ Template Data Management Sheet & User Template Sheet

• You can add or delete dimension names in the "Template Data Management Sheet".
• You can also change and add dimension names.
• Please refer to the figure below for how to define dimension names. Dimension names are always capitalized.

[dimension name]

---

I coded the program by creating blocks using user sub and function. Please modify and use as needed.

▷ Open Button Code

1. Module code that connects to the Creo program

Option Explicit
Public asynconn As New pfcls.CCpfcAsyncConnection
Public conn As pfcls.IpfcAsyncConnection
Public BaseSession As pfcls.IpfcBaseSession
Public Sub CreoConnt02()
    On Error GoTo ErrorHandler '// Setting up an error handler
    
        '// Creo 연결 설정
        Set conn = asynconn.Connect("", "", "", 5)
    
        '// Creo Connection Settings
    On Error Resume Next '// Keep code execution going even when an exception occurs
        
        Set BaseSession = conn.Session
        If Err.Number <> 0 Then
            MsgBox "Failed to import Creo session. Check your connection status." & vbCrLf & _
                   "Error message: " & Err.Description, vbCritical, "error"
            Err.Clear
            Exit Sub
        End If
    On Error GoTo ErrorHandler '// Revert back to default error handling
           
ErrorHandler:
   ' ToolkitNotFound Special handling of error messages
    If InStr(Err.Description, "XToolkitNotFound") > 0 Then
        MsgBox "Make sure Creo is running.", vbCritical, "error"
        Exit Sub
    End If
End Sub

 

2. User-developed function to get dimension names

When you enter a dimension name, a dimension object is retrieved from the model.

Function GetBaseDimension(DimensionName As String) As IpfcBaseDimension
    
    Dim Modelowner As IpfcModelItemOwner
    Dim modelitem As IpfcModelItem
    
    Set Modelowner = Model
    Set modelitem = Modelowner.GetItemByName(EpfcModelItemType.EpfcITEM_DIMENSION, DimensionName)
    
    If Not modelitem Is Nothing Then
        Set GetBaseDimension = modelitem
    Else
        Set GetBaseDimension = Nothing
    End If
    
End Function

 

3.Opens a Creo model from the folder location defined 
    in the "Template Data Management Sheet" and displays the model's dimension values.

Option Explicit
Dim Model As pfcls.IpfcModel
Dim CreateModelDescriptor As New CCpfcModelDescriptor
Dim ModelDescriptor As pfcls.IpfcModelDescriptor
Dim CreoModelName As String
Dim CreoModelPath As String
Dim DimensionName As String
Dim ws As Worksheet
Dim Dataws As Worksheet
Dim rng As Range
Dim i As Integer
Dim CreoWindow As pfcls.IpfcWindow
Sub OpenButton01()
   
     On Error GoTo RunError
     Application.EnableEvents = False
   
    '// Creo Connection
    Call CreoVBAStart02.CreoConnt02
    
    Set ws = ThisWorkbook.Worksheets("Template")
    Set Dataws = ThisWorkbook.Worksheets("Template_Data")
    Set rng = Dataws.Range("B6", Dataws.Cells(Rows.Count, "B").End(xlUp))

    CreoModelName = Dataws.Cells(4, "C") '// Template File Name
    CreoModelPath = Dataws.Cells(3, "C") '// Template Path

    For i = 0 To rng.Count - 1
        ws.Cells(i + 10, "E") = i + 1
        ws.Cells(i + 10, "F") = Dataws.Cells(i + 6, "B") '// Dimension Name
        ws.Cells(i + 10, "H") = Dataws.Cells(i + 6, "C") '// Dimension Description
    Next i
    
    Call BaseSession.ChangeDirectory(CreoModelPath & "\")
    
    Set ModelDescriptor = CreateModelDescriptor.CreateFromFileName(CreoModelName)
    Set Model = BaseSession.RetrieveModel(ModelDescriptor)
    Call Model.Display
    Set CreoWindow = BaseSession.GetModelWindow(Model)
    Call CreoWindow.Activate
    
     For i = 0 To rng.Count - 1
     
            DimensionName = ws.Cells(i + 10, "F")
            ws.Cells(i + 10, "G") = GetBaseDimension(DimensionName).dimValue '// Call BaseDimension function
     
     Next i
    
    MsgBox "The model has been opened.", vbInformation, "korealionkk@gmail.com"
    
    conn.Disconnect (2)

Cleanup:
    Set asynconn = Nothing
    Set conn = Nothing
    Set BaseSession = Nothing
    Set Model = Nothing

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

 

▷ Apply Button Code

Sub MpdelApply()

 On Error GoTo RunError
     Application.EnableEvents = False
     
     Dim Model As pfcls.IpfcModel
     Dim Solid As IpfcSolid
     Dim ParameterOwner As pfcls.IpfcParameterOwner
     Dim BaseParameter As pfcls.IpfcBaseParameter
     Dim ws As Worksheet
     Dim Dataws As Worksheet
     Dim rnga As Range, rngb As Range
     Dim i As Integer, j As Integer
     Dim Parameter As IpfcParameter
     Dim ParamValue As pfcls.IpfcParamValue
     Dim ParamObject As New CMpfcModelItem
      
      '// Creo Connection
     Call CreoVBAStart02.CreoConnt02
     
     Set Model = BaseSession.CurrentModel
     Set Solid = Model
     Set ws = ThisWorkbook.Worksheets("Template")
     Set Dataws = ThisWorkbook.Worksheets("Template_Data")
     Set rnga = Dataws.Range("E6", Dataws.Cells(Rows.Count, "E").End(xlUp))
     Set ParameterOwner = Model
     
     For i = 0 To rnga.Count - 1
     
          Set Parameter = ParameterOwner.GetParam(Dataws.Cells(i + 6, "E"))
          Set BaseParameter = Parameter
          Set ParamValue = ParamObject.CreateStringParamValue(ws.Cells(i + 10, "C"))
          BaseParameter.Value = ParamValue
          
     Next i
     
     '// SET Dimension Value
    Dim ModelItemOwner As IpfcModelItemOwner
    Dim modelitem As IpfcModelItem
    Dim BaseDimension As IpfcBaseDimension
    
    '// SET Regenerate
    Dim RegenInstructions As New CCpfcRegenInstructions
    Dim Instrs As IpfcRegenInstructions
    Dim Window As pfcls.IpfcWindow
    
    Set rngb = ws.Range("G10", ws.Cells(Rows.Count, "G").End(xlUp))
    Set ModelItemOwner = Model
    
    For j = 0 To rngb.Count - 1
    
            Set modelitem = ModelItemOwner.GetItemByName(EpfcModelItemType.EpfcITEM_DIMENSION, ws.Cells(j + 10, "F"))
            Set BaseDimension = modelitem
            BaseDimension.dimValue = ws.Cells(j + 10, "G")
    
    Next j
     
    Set Instrs = RegenInstructions.Create(False, False, Nothing)
    Set Window = BaseSession.CurrentWindow
    
    '// Regenerate
    Call Solid.Regenerate(Instrs)
    Window.Repaint
    
  MsgBox "modified the Creo model", vbInformation, "korealionkk@gmail.com"
    
    conn.Disconnect (2)

Cleanup:
    Set asynconn = Nothing
    Set conn = Nothing
    Set BaseSession = Nothing
    Set Model = Nothing

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

 

▷ Save Button Code

• You can select a folder or create a new folder using creo's UI.
• It will be saved with the new file name you entered in Cells(9,"C").
• IpfcSession.UISelectDirectory > IpfcBaseSession.ChangeDirectory > IpfcModel.CopyAndRetrieve > IpfcModel.Save

Sub MpdelsaveUI()

On Error GoTo RunError
     Application.EnableEvents = False
     
     Dim Session As IpfcSession
     Dim model As IpfcModel
     Dim CreateDirectorySelectionOptions As New CCpfcDirectorySelectionOptions
     Dim DirectorySelectionOptions As IpfcDirectorySelectionOptions
     Dim ws As Worksheet
     Dim NewPathName As String
     Dim NewMODEL As IpfcModel
     
     Call CreoVBAStart02.CreoConnt02 '// Creo Connection
     Set ws = ThisWorkbook.Worksheets("Template")
     Set DirectorySelectionOptions = CreateDirectorySelectionOptions.Create
     Set Session = BaseSession
     Set model = BaseSession.CurrentModel
     NewPathName = Session.UISelectDirectory(DirectorySelectionOptions)
     
     Call BaseSession.ChangeDirectory(NewPathName)
     Set NewMODEL = model.CopyAndRetrieve(ws.Cells(9, "C"), Null)
     NewMODEL.Save
          
     MsgBox "The Creo model has been saved with a new name.", vbInformation, "korealionkk@gmail.com"
    conn.Disconnect (2)

Cleanup:
    Set asynconn = Nothing
    Set conn = Nothing
    Set BaseSession = Nothing
    Set model = Nothing

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