1 ACCEPTED SOLUTION
Accepted Solutions
For all who would like the complete solution. This VBA function is heavily based on the VB script by William Quintero: Original VB script Take a look at his post first! You will need it to create the initial part (Box.prt) and the used UDF. It uses the same form layout:
The following function is triggered by the "Insert UDF" button.
Private Sub btnUpdate_Click()
Dim asyncConnection As IpfcAsyncConnection
Dim cAC As CCpfcAsyncConnection
Dim session As IpfcBaseSession
Dim Model As IpfcModel
Set asyncConnection = Nothing
On Error GoTo Try
Set cAC = New CCpfcAsyncConnection
Set asyncConnection = cAC.Connect(dbnull, dbnull, dbnull, dbnull)
Set session = asyncConnection.session
Set Model = session.CurrentModel
If Model Is Nothing Then
MsgBox ("Model not present")
End If
If (Not Model.Type = EpfcModelType.EpfcMDL_PART) And _
(Not Model.Type = EpfcModelType.EpfcMDL_ASSEMBLY) Then
MsgBox ("Model is not a solid")
End If
If SetDimensions(Model, txtLength.Text, txtWidth.Text, txtHeight.Text) Then
MsgBox "Dimensions Changed."
End If
Try:
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 asyncConnection Is Nothing Then
If asyncConnection.IsRunning Then
asyncConnection.Disconnect (1)
End If
End If
Else
asyncConnection.Disconnect (1)
End If
UserForm1.Hide
End Sub
Then that function triggers the actual UDF insert.
Public Function createHoleUDFInPart(ByVal placementModel As IpfcSolid, _
ByVal Name01 As String, _
ByVal csysName As String, _
ByVal DimX As Double, _
ByVal DimY As Double, _
ByVal Modell As IpfcModelItemOwner) _
As IpfcFeatureGroup
'Create Hole UDF In Part
'======================================================================
'Function : createHoleUDFInPart
'Purpose : This function places copies of a node UDF at a
' particular coordinate system location in a part. The
' node UDF is a cylinder cut centered at the coordinate
' system whose diameter is driven by the argument to the
' method. The method returns the Feature Group object
' created.
'======================================================================
Dim csys As IpfcCoordSystem
Dim cSystems As IpfcModelItems
Dim cBody As IpfcSolidBody
Dim i As Integer
Dim cUCCI As CCpfcUDFCustomCreateInstructions
Dim udfInstructions As IpfcUDFCustomCreateInstructions
Dim cSEL As CMpfcSelect
Dim csysSelection As IpfcSelection
Dim csysSelBody As IpfcSelection
Dim cREF As CCpfcUDFReference
Dim csysRefCoor As IpfcUDFReference
Dim csysRefMod As IpfcUDFReference
Dim cREFS As CpfcUDFReferences
Dim cVDIM As CCpfcUDFVariantDimension
Dim variantDimX As IpfcUDFVariantDimension
Dim variantDimY As IpfcUDFVariantDimension
Dim variantVals As CpfcUDFVariantValues
Dim group As IpfcFeatureGroup
On Error GoTo ErrorHandler
Set cSystems = Modell.ListItems(EpfcModelItemType.EpfcITEM_COORD_SYS)
Set cBody = placementModel.GetDefaultBody
For i = 0 To cSystems.Count - 1
If cSystems.Item(i).GetName = csysName Then
Set csys = cSystems.Item(i)
Exit For
End If
Next
If csys Is Nothing Then
MsgBox "Coordinate System not found in current Solid"
Exit Function
End If
'======================================================================
'Instructions for UDF creation
'======================================================================
Set cUCCI = New CCpfcUDFCustomCreateInstructions
Set udfInstructions = cUCCI.Create(Name01)
'======================================================================
'Make non variant dimensions blank to disable their display
'======================================================================
udfInstructions.DimDisplayType = EpfcUDFDimensionDisplayType.EpfcUDFDISPLAY_BLANK
'======================================================================
'Initialize the UDF reference and assign it to the instructions.
'The string argument is the reference prompt for the particular
'reference. This is defined while creating the UDF! Make sure you use
'the correct names.
'The first ref is to the coordinate system, the second is for the body.
'======================================================================
Set cSEL = New CMpfcSelect
Set csysSelection = cSEL.CreateModelItemSelection(csys, Nothing)
Set csysSelBody = cSEL.CreateModelItemSelection(cBody, Nothing)
Set cREF = New CCpfcUDFReference
Set csysRefCoor = cREF.Create("Reference Coordinate System", csysSelection)
Set csysRefMod = cREF.Create("Reference Body", csysSelBody)
Set cREFS = New CpfcUDFReferences
Call cREFS.Set(0, csysRefCoor)
Call cREFS.Set(1, csysRefMod)
udfInstructions.references = cREFS
'======================================================================
'Initialize the variant dimension and assign it to the instructions.
'The string argument is the dimension symbol for the variant dimension.
'This argument is the dimension of the original UDF.
'Again make sure you use the correct names/references.
'======================================================================
Set cVDIM = New CCpfcUDFVariantDimension
Set variantDimX = cVDIM.Create("d33", CDbl(DimX))
Set variantDimY = cVDIM.Create("d34", CDbl(DimY))
Set variantVals = New CpfcUDFVariantValues
Call variantVals.Set(0, variantDimX)
Call variantVals.Set(1, variantDimY)
udfInstructions.VariantValues = variantVals
'======================================================================
'We need the placement model for the UDF for the call to
'CreateUDFGroup(). If you were placing the UDF in a model other than
'the owner of the coordinate system, the placement would need to be
'provided separately.
'======================================================================
Set group = placementModel.CreateUDFGroup(udfInstructions)
Set createHoleUDFInPart = group
Exit Function
ErrorHandler:
MsgBox Err.Description & vbCrLf & Err.Number, vbExclamation
Set createHoleUDFInPart = Nothing
End Function
I also added the functions for the "Update Creo Parameters", defining the shape of the box.prt. First the function that is triggered by the "Update Creo parameters" button:
Private Sub btnInsertUDF_Click()
Dim asyncConnection As IpfcAsyncConnection
Dim cAC As CCpfcAsyncConnection
Dim session As IpfcBaseSession
Dim Model As IpfcModel
Dim Solid As IpfcSolid
Set asyncConnection = Nothing
On Error GoTo Try
Set cAC = New CCpfcAsyncConnection
Set asyncConnection = cAC.Connect(dbnull, dbnull, dbnull, dbnull)
Set session = asyncConnection.session
Set Model = session.CurrentModel
If Model Is Nothing Then
MsgBox ("Model not present")
End If
If (Not Model.Type = EpfcModelType.EpfcMDL_PART) And _
(Not Model.Type = EpfcModelType.EpfcMDL_ASSEMBLY) Then
MsgBox ("Model is not a solid")
End If
Set Solid = Model
If Not createHoleUDFInPart(Solid, txtUDF.Text, txtCS.Text, txtX.Text, txtY.Text, Model) Is Nothing Then
MsgBox "Hole Created."
End If
Try:
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 asyncConnection Is Nothing Then
If asyncConnection.IsRunning Then
asyncConnection.Disconnect (1)
End If
End If
Else
asyncConnection.Disconnect (1)
End If
UserForm1.Hide
End SubThis function then calls for another function setting the sizes:
Public Function SetDimensions(ByVal mModel As IpfcModel, _
ByVal dLength As Double, _
ByVal dDepth As Double, _
ByVal dHeight As Double) As Boolean
Dim px As IpfcParameterOwner
Dim p1 As IpfcParameter
Dim p2 As IpfcBaseParameter
Dim Mitem As CMpfcModelItem
Dim cSolid As IpfcSolid
Dim pv1 As IpfcParamValue
Dim Param As Object
Set Param = CreateObject("Scripting.Dictionary")
Param.Add "LENGTH", dLength
Param.Add "DEPTH", dDepth
Param.Add "HEIGHT", dHeight
Set px = mModel
For i = 0 To Param.Count - 1
Set p1 = px.GetParam(Param.Keys()(i))
Set p2 = p1
Set Mitem = New CMpfcModelItem
Set pv1 = Mitem.CreateDoubleParamValue(CDbl(Param.Items()(i)))
p2.Value = pv1
Next i
Set cSolid = mModel
Call cSolid.Regenerate(Nothing)
SetDimensions = True
End Function
A number of improvements can/should be made: First the connection to Creo is done within the "button" functions, this should be a dedicated function creating or closing the the connection. Other things are the 'fixed' references to form elements and UDF references. However this is the first time and I think is works pretty well.
