-
Re: How to pattern Virtual parts?
For inserting multiple virtual components try these codes:
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim swPlaneFeature As SldWorks.Feature
Dim swPlane As SldWorks.RefPlane
Dim swAssem As SldWorks.AssemblyDoc
Dim i As Integer
Dim swVirtComp As SldWorks.Component2
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swSelMgr = swModel.SelectionManager
If swModel.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0) = False Then
Debug.Print "Failed to select Front plane; check feature name."
Exit Sub
End If
Set swPlaneFeature = swSelMgr.GetSelectedObject6(1, -1)
Set swPlane = swPlaneFeature.GetSpecificFeature2
Set swAssem = swModel
For i = 0 To 20
swAssem.InsertNewVirtualPart swPlane, swVirtComp
Next i
swAssem.ClearSelection2 True
End Sub
-
Re: How to pattern Virtual parts?
Thank you Deepak for your respond.
The code above creates the first instance of the part with the correct name and the rest of them just Part^2, Part^3 etc...Is there any way to correct this?
Please see the video below.
https://dl.dropboxusercontent.com/u/23443066/VirtParts.avi
Thank you.
-
Re: How to pattern Virtual parts?
Try these following one:
Also would suggest to upload the attachments here instead of external sites.
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim swPlaneFeature As SldWorks.Feature
Dim swPlane As SldWorks.RefPlane
Dim swAssem As SldWorks.AssemblyDoc
Dim i As Integer
Dim lResult As Long
Dim swVirtComp As SldWorks.Component2
Dim swSecondComp As SldWorks.Component2
Dim sVirtPart As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swSelMgr = swModel.SelectionManager
If swModel.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0) = False Then
Debug.Print "Failed to select Front plane; check feature name."
Exit Sub
End If
Set swPlaneFeature = swSelMgr.GetSelectedObject6(1, -1)
Set swPlane = swPlaneFeature.GetSpecificFeature2
Set swAssem = swModel
lResult = swAssem.InsertNewVirtualPart(swPlane, swVirtComp)
swVirtComp.Name2 = sVirtPart
If lResult = swInsertNewPartError_NoError Then
For i = 1 To 20
Set swSecondComp = swAssem.AddComponent5(swVirtComp.GetPathName, swAddComponentConfigOptions_CurrentSelectedConfig, "", False, "", 0.1, 0, 0)
Next i
End If
swAssem.ClearSelection2 True
End Sub
-
Re: How to pattern Virtual parts?
Thank you.
Now it`s working great!
Do you know the answer to my 2nd question about assigning custom properties to a virtual part?
Alex.
-
Re: How to pattern Virtual parts?
Insert these codes:
Dim Part As Object
Dim Errors As Long
Set Part = swApp.ActivateDoc3(swVirtComp.GetPathName, False, 1, Errors)
Set Part = swApp.ActiveDoc
Part.CustomInfo2(Part.GetActiveConfiguration.Name, "Description") = "New VALUE" 'This is for updating an existing property.
swApp.CloseDoc Part.GetTitle
after
swVirtComp.Name2 = sVirtPart
-
Re: How to pattern Virtual parts?
Finally I finished this code with the help of Bob Hanson. Thank you Bob.
Below is the working code, that checks if virtual part/pattern already exists, if it does it gets the qty and changes it to a new value. If it doesn`t exist it adds an instance and creates a linear pattern. Also it checks if the user typed 0(zero) in this case it deletes the virtual part.
Try
swModel = swApp.ActiveDoc
swAssem = CType(swModel, AssemblyDoc)
swSelMgr = swModel.SelectionManager
'checking for existence
Dim PatternFeature As Feature
PatternFeature = swAssem.FeatureByName(sVirtPart + "-Pattern")
Dim FeatureQty As Dimension 'weird ? qty is DIM?
Dim reVal As Integer
If Not PatternFeature Is Nothing Then
' checking if we need to delete the part
If vp_qty = 0 Then
If swModel.Extension.SelectByID2(sVirtPart + "^" + swModel.GetTitle + "-1@" + swModel.GetTitle, "COMPONENT", 0, 0, 0, False, 0, Nothing, 0) = False Then
Debug.Print("Failed to select part ; check feature name.")
Exit Sub
End If
' deleting the part
swModel.Extension.DeleteSelection2(swDeleteSelectionOptions_e.swDelete_Children)
swModel.ForceRebuild3(False)
Exit Sub
End If
FeatureQty = swModel.Parameter("D1@" + sVirtPart + "-Pattern")
reVal = FeatureQty.SetSystemValue3(vp_qty, swSetValueInConfiguration_e.swSetValue_InAllConfigurations, Nothing)
swModel.ForceRebuild3(False)
Exit Sub
End If
' choosing the plane to drop Virtual part on
If swModel.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0) = False Then
Debug.Print("Failed to select Front plane; check feature name.")
Exit Sub
End If
swPlaneFeature = swSelMgr.GetSelectedObject6(1, -1)
swPlane = swPlaneFeature.GetSpecificFeature2
lResult = swAssem.InsertNewVirtualPart(swPlane, swVirtComp)
' Assigning the name sVirtPart - is the part that User pick from Listbox 'sVirtPart = PartNumber(lbox_VParts.SelectedIndex) 'Dim swVirtComp As SldWorks.Component2 defined somewhere else
swVirtComp.Name2 = sVirtPart
Dim mDoc As ModelDoc2
Dim custPropManager As CustomPropertyManager
mDoc = swVirtComp.GetModelDoc2
' adding and overwrting Custom properties
custPropManager = mDoc.Extension.CustomPropertyManager("Default")
custPropManager.Add3("Description", swCustomInfoType_e.swCustomInfoText, txt_NewPartDescr.Text, swCustomPropertyAddOption_e.swCustomPropertyReplaceValue)
custPropManager.Add3("Vendor", swCustomInfoType_e.swCustomInfoText, txt_Vendor.Text, swCustomPropertyAddOption_e.swCustomPropertyReplaceValue)
custPropManager.Add3("VendorNo", swCustomInfoType_e.swCustomInfoText, txt_VendorPN.Text, swCustomPropertyAddOption_e.swCustomPropertyReplaceValue)
' to be able to pattern the part we need to select it and select the axis
boolstatus = swModel.Extension.SelectByID2(swVirtComp.Name2 & "@" & swModel.GetTitle, "COMPONENT", 0, 0, 0, False, 1, Nothing, 0)
boolstatus = swModel.Extension.SelectByID2("X-Axis", "AXIS", 0, 0, 0, True, 2, Nothing, 0)
' creating the pattern
Dim FeatManager As FeatureManager
FeatManager = swModel.FeatureManager
FeatManager.FeatureLinearPattern(vp_qty, 1, 0, 0, False, False, "Qty", "")
' this portion of the code Getting the lase Pattern Feature and Renaming it to Match last Added Virtual part name.
Dim CurrentFeature As Feature
Dim PreviousFeature As Feature
CurrentFeature = swModel.FirstFeature
' cycling through the features and getting the last one
While Not CurrentFeature Is Nothing
PreviousFeature = CurrentFeature
CurrentFeature = CurrentFeature.GetNextFeature
End While
' renaming the pattern feature
PreviousFeature.Name = sVirtPart + "-Pattern"
mDoc.Save()
Catch ex As Exception
swApp.SendMsgToUser("An exception occurred:" & vbCrLf & ex.Message)
End Try
End If
-
-
-
-
-