I have this code that automatically colors all assembly components with random color. I asked a different question with this code before but this time, I want to ask if anyone could help
To make this code colors only the selected assembly component?
I hope someone can help me with this, I am still learning in API. Please see code below.
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Public Sub ColorMacro1()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swElement As Object
Dim vElementArr As Variant
Dim vElement As Variant
Dim vMatProp As Variant
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
vMatProp = swModel.MaterialPropertyValues
'Get all elements
vElementArr = swModel.GetComponents(False)
For Each vElement In vElementArr
Set swElement = vElement
Randomize
vMatProp(0) = Rnd 'Red
vMatProp(1) = Rnd 'Green
vMatProp(2) = Rnd 'Blue
vMatProp(3) = Rnd / 2 + 0.5 'Ambient
vMatProp(4) = Rnd / 2 + 0.5 'Diffuse
vMatProp(5) = Rnd 'Specular
vMatProp(6) = Rnd * 0.9 + 0.1 'Shininess
swElement.MaterialPropertyValues = vMatProp
Next
'Redraw to see new color
swModel.GraphicsRedraw2
End Sub
You can get the selected components with GetSelectedObjectsComponent4 like so:
Option Explicit
Public Sub ColorMacro1()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim vMatProp As Variant
Dim swSelMgr As SldWorks.SelectionMgr
Dim swComp As SldWorks.Component2
Dim Count As Integer
Dim i As Integer
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swSelMgr = swModel.SelectionManager
Count = swSelMgr.GetSelectedObjectCount2(0)
If Count = 0 Then MsgBox "No Components selected": Exit Sub
vMatProp = swModel.MaterialPropertyValues
For i = 1 To Count
Set swComp = swSelMgr.GetSelectedObjectsComponent4(i, 0)
Randomize
vMatProp(0) = Rnd 'Red
vMatProp(1) = Rnd 'Green
vMatProp(2) = Rnd 'Blue
vMatProp(3) = Rnd / 2 + 0.5 'Ambient
vMatProp(4) = Rnd / 2 + 0.5 'Diffuse
vMatProp(5) = Rnd 'Specular
vMatProp(6) = Rnd * 0.9 + 0.1 'Shininess
swComp.MaterialPropertyValues = vMatProp
Next
swModel.GraphicsRedraw2
End Sub
Where you set the object, try this:
Set swElement = Selection
Related
Dear SolidWorks users,
I am using SW2012 and via VBA I like to create two(2) edge flanges. I have the following code, this creates one edge flange after you select one edge of the sheet metal.
I like to know how can I add(put) 2 selections edge in an array? Like that (maybe), can be created two(2) edge flanges.
In the function of .InsertSheetMetalEdgeFlange2 it is mention that this function can accept array selection and array sketch.
Thank you.
Sub Bends_2()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swEdge As SldWorks.Edge
Dim swFeature As SldWorks.Feature
Dim swEntity As SldWorks.Entity
Dim swSketch As SldWorks.Sketch
Dim swSketchLine As SldWorks.SketchLine
Dim swStartPoint As SldWorks.SketchPoint
Dim swEndPoint As SldWorks.SketchPoint
Dim aFlangeEdges(0) As SldWorks.Edge
Dim aSketchFeats(0) As SldWorks.Sketch
Dim vFlangeEdges As Variant
Dim vSketchFeats As Variant
Dim bValue As Boolean
Dim dAngle As Double
Dim dLength As Double
Dim vSketchSegments As Variant
' Connect to SOLIDWORKS
Set swApp = Application.SldWorks
' Get active document
Set swModel = swApp.ActiveDoc
' Set the angle +length
dAngle = (90# / 180#) * 3.1415926535897
dLength = 25 / 1000
swModel.ShowNamedView2 "*Trimetric", -1
swModel.ViewZoomtofit2
' Get edge
Set swEdge = swModel.SelectionManager.GetSelectedObject6(1, -1)
' Insert a sketch for an Edge Flange
Set swFeature = swModel.InsertSketchForEdgeFlange(swEdge, dAngle, False)
' Select
bValue = swFeature.Select2(False, 0)
' Start sketch editing
swModel.EditSketch
' Get the active sketch
Set swSketch = swModel.GetActiveSketch2
' Add the edge to the sketch
Set swEntity = swEdge
' Select edge
bValue = swEntity.Select4(False, Nothing)
' Use the edge in the sketch
bValue = swModel.SketchManager.SketchUseEdge(False)
' Get the created sketch line
vSketchSegments = swSketch.GetSketchSegments
Set swSketchLine = vSketchSegments(0)
' Get start and end point
Set swStartPoint = swSketchLine.GetStartPoint2
Set swEndPoint = swSketchLine.GetEndPoint2
' Create additional lines to define sketch
swModel.SetAddToDB True
swModel.SetDisplayWhenAdded False
swModel.CreateLine2 swStartPoint.X, swStartPoint.Y, 0#, swStartPoint.X, swStartPoint.Y + dLength, 0#
swModel.CreateLine2 swStartPoint.X, swStartPoint.Y + dLength, 0#, swEndPoint.X, swStartPoint.Y + dLength, 0#
swModel.CreateLine2 swEndPoint.X, swEndPoint.Y, 0#, swEndPoint.X, swEndPoint.Y + dLength, 0#
'reset
swModel.SetDisplayWhenAdded True
swModel.SetAddToDB False
' Commit changes made to the sketch
swModel.InsertSketch2 True
Set aFlangeEdges(0) = swEdge
Set aSketchFeats(0) = swSketch
vFlangeEdges = aFlangeEdges
vSketchFeats = aSketchFeats
'create edge flange
Set swFeature = swModel.FeatureManager.InsertSheetMetalEdgeFlange2((vFlangeEdges), (vSketchFeats), 128, dAngle, 0.7 / 1000, swFlangePositionTypes_e.swFlangePositionTypeMaterialInside, dLength, swSheetMetalReliefTypes_e.swSheetMetalReliefNone, 0#, 0#, 0#, swFlangeDimTypes_e.swFlangeDimTypeInnerVirtualSharp, Nothing)
End Sub
I have created a cylinder programmatically via vb on NX, the cylinder is successful, but unfortunately it doesn't change its color. Below is my code, could someone please tell me what's wrong with my code? Or is there any other method which I can change the color of my cylinder?
Thank you very much
Imports System
Imports NXOpen
Module Points_01
Sub Main()
Dim theSession As Session = Session.GetSession()
Dim workPart As Part = theSession.Parts.Work
Dim lw As ListingWindow = theSession.ListingWindow
lw.Open()
'create Point3d using the constructor
Dim myPt1 As New Point3d(0, 0, 0)
'create center point
Dim ptObj As Point
ptObj = workPart.Points.CreatePoint(myPt1)
ptObj.SetVisibility(SmartObject.VisibilityOption.Visible)
Dim myVector As Vector3d
'enter values for vector
myVector.X = (1)
myVector.Y = (2)
myVector.Z = (3)
'create offset
Dim myOffset As Offset
myOffset = workPart.Offsets.CreateOffset(ptObj.Coordinates, myVector, SmartObject.UpdateOption.WithinModeling)
'create new point offset from first point
Dim offsetPoint As Point
offsetPoint = workPart.Points.CreatePoint(myOffset, ptObj, SmartObject.UpdateOption.WithinModeling)
offsetPoint.RemoveParameters()
offsetPoint.SetVisibility(SmartObject.VisibilityOption.Visible)
lw.Close()
' Create circle
Dim curves As NXOpen.CurveCollection = workPart.Curves
Dim center As NXOpen.Point3d
center = New Point3d(0,0,0)
Dim pi as Double =System.Math.PI
Dim twopi As Double = 2*pi
Dim length As Double = 8
Dim axisX = New Vector3d(1,0,0)
Dim axisY = New Vector3d(0,1,0)
Dim circle = workPart.curves.CreateArc(center, axisX, axisY, length, 0, twopi)
Dim ctol = 0.0095 ' Chaining tolerance
Dim dtol = 0.01 ' Distance tolerance
Dim atol = 0.5 ' Angle tolerance
'Create a circular section
Dim circ As NXOpen.Section = workPart.Sections.CreateSection(ctol, dtol, atol)
Dim helpPoint As New NXOpen.Point3d(0,0,0)
Dim nullObj As NXOpen.NXObject = Nothing
Dim noChain As Boolean = False
Dim createMode As NXOpen.Section.Mode = Section.Mode.Create
' Create rules to add the circle to the section
Dim circl As NXOpen.CurveDumbRule = workPart.ScRuleFactory.CreateRuleBaseCurveDumb({circle})
circ.AddToSection({circl}, circle, nullObj, nullObj, helpPoint, createMode, noChain)
Dim builder = workPart.Features.CreateExtrudeBuilder(Nothing)
builder.Section = circ
'Define the direction of the Extrude
Dim origin As New NXOpen.Point3d(0,0,0)
Dim axisZ As New NXOpen.Vector3d(0,0,1)
Dim updateOption = SmartObject.UpdateOption.DontUpdate
builder.Direction = workPart.Directions.CreateDirection(origin, axisZ, updateOption)
builder.Limits.StartExtend.Value.RightHandSide = "0"
builder.Limits.EndExtend.Value.RightHandSide = "500"
Dim extrudeFeature As NXOpen.Features.Extrude = builder.CommitFeature
builder.Destroy
'Get the displayable object of the Extrude feature
Dim bodies As NXOpen.Body() = extrudeFeature.GetBodies
' Change its color
bodies(0).Color = 186 ' Usually red, by default
End Sub
End Module```
I am trying to implement a minimum boundary box subroutine inside my macro. Subroutine ends before going into if statement. Can you help me find the solution?
Option Explicit
Sub bounding()
Dim partDocument1 As PartDocument
Set partDocument1 = CATIA.ActiveDocument
Dim part1 As Part
Set part1 = partDocument1.Part
Dim hybridShapeFactory1 As HybridShapeFactory
Set hybridShapeFactory1 = part1.HybridShapeFactory
Dim hybridBodies1 As HybridBodies
Set hybridBodies1 = part1.HybridBodies
Dim hybridBody1 As hybridbody
Set hybridBody1 = hybridBodies1.Item(cevap)
Dim hybridShapes1 As HybridShapes
Set hybridShapes1 = hybridBody1.HybridShapes
Dim axisSystems1 As AxisSystems
Set axisSystems1 = part1.AxisSystems
Dim axisSystem1 As AxisSystem
Set axisSystem1 = part1.FindObjectByName("axissys")
Dim direction As Long
If extindex Mod 2 = 1 Then
direction = 1
Else
direction = 0
End If
Dim reference1 As Reference
MsgBox CStr(extindex)
Select Case extindex
Case 1, 2
Set reference1 = axisSystem1.XAxisDirection
MsgBox CStr(extindex) + "1ve2"
Case 3, 4
Set reference1 = axisSystem1.YAxisDirection
MsgBox CStr(extindex) + "3ve4"
Case Else
Set reference1 = axisSystem1.YAxisDirection
MsgBox CStr(extindex) + "5ve6"
End Select
Debug.Print ("exit if check")
Dim hybridShapeDirection1 As HybridShapeDirection
Set hybridShapeDirection1 = hybridShapeFactory1.AddNewDirection(reference1)
Dim bodies1 As Bodies
Set bodies1 = part1.Bodies
Dim body1 As Body
Set body1 = bodies1.Item("PartBody")
Dim reference2 As Reference
Set reference2 = part1.CreateReferenceFromObject(body1)
Dim hybridShapeExtremum1 As HybridShapeExtremum
Set hybridShapeExtremum1 = hybridShapeFactory1.AddNewExtremum(reference2,
hybridShapeDirection1, 0)
part1.Update
hybridBody1.AppendHybridShape hybridShapeExtremum1
part1.InWorkObject = hybridShapeExtremum1
hybridShapeExtremum1.Name = "ext1" + CStr(extindex)
part1.Update
End Sub
All variables on the program are checked and they work. I don't understand what is happening an why it doesnt work. I even checked all variables. Program should go inside if statement but it doesnt
The AxisSystem properties XAxisDirection, YAxisDirection, and ZAxisDirection refer to the references from which the axis system was defined.
You can use these properties to edit the AxisSystem object itself but they are not "output" Reference objects which should be used to construct downstream geometry.
You can pull the vectors components using the GetXAxis, GetYAxis, and GetZAxis methods (which will always contain values) and then use HybridShapeFactory.AddDirectionFromCoord() method to create the direction for the extremum.
...
MsgBox CStr(extindex)
Dim vect(2)
Dim vAxis As Variant
Set vAxis = axisSystem1
Select Case extindex
Case 1, 2
vAxis.GetXAxis vect
Case 3, 4
vAxis.GetYAxis vect
Case Else
vAxis.GetYAxis vect
End Select
Dim hybridShapeDirection1 As HybridShapeDirection
Set hybridShapeDirection1 = hybridShapeFactory1.AddNewDirectionByCoord(vect(0), vect(1), vect(2))
...
I had previously asked about how to evenly distribute the items in n lists into a single list and was referred to this question: Good algorithm for combining items from N lists into one with balanced distribution?.
I made a practical example of my solution for this in VBA for Excel, since my application for this was resorting my Spotify lists which can be easily pasted into Excel for manipulation. Assumptions are that you have a headerless worksheet (wsSource) of songs with columns A, B, C representing Artist, Song, SpotifyURI respectively, a "Totals" worksheet (wsTotals) containing the sum of songs for each Artist from wsSource sorted in descending order, and a "Destination" worksheet where the new list will be created. Could I get some suggestions to improve this? I was going to get rid of the totals worksheet and have this portion done in code, but I have to go and I wanted to go ahead and put this out there. Thanks!
Sub WeaveSort()
Dim wb As Workbook
Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim wsTotals As Worksheet
Dim i As Integer
Dim iLast As Integer
Dim iDest As Integer
Dim iSource As Integer
Dim iOldRow As Integer
Dim iNewRow As Integer
Dim dDiff As Double
Dim dDiffSum As Double
Set wb = ThisWorkbook
Set wsTotals = wb.Worksheets("Totals")
Set wsSource = wb.Worksheets("Source")
Set wsDest = wb.Worksheets("Dest")
iLast = wsTotals.Range("A1").End(xlDown).Row - 1
For i = 2 To iLast
iSource = wsTotals.Range("B" & i).Value
iDest = wsDest.Range("A99999").End(xlUp).Row
If i = 2 Then
wsDest.Range("A1:C" & iSource).Value2 = wsSource.Range("A1:C" & iSource).Value2
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
GoTo NextI
End If
dDiff = iDest / iSource
dDiffSum = 0
iNewRow = 0
For iOldRow = 1 To iSource
dDiff = iDest / iSource
dDiffSum = dDiffSum + dDiff
iNewRow = Round(dDiffSum, 0)
wsSource.Rows(iOldRow).Copy
wsDest.Rows(iNewRow).Insert xlShiftDown
iDest = iDest + 1
Next iOldRow
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
NextI:
Next i
End Sub
Great question! I would take an object oritentated approach. Also I didn;t think it was clear what the logic was so here is my answer. Two classes and one normal module. Save these separately with the filenames ListManager.cls, List.cls, tstListManager.bas
So the ListManager.cls is this
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ListManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mdic As Object
Public Sub Initialise(ByVal vLists As Variant)
Set mdic = VBA.CreateObject("Scripting.Dictionary")
Dim vListLoop As Variant
For Each vListLoop In vLists
Dim oList As List
Set oList = New List
oList.Initialise vListLoop, ""
mdic.Add mdic.Count, oList
Next
End Sub
Public Function WeaveSort() As Variant
Dim dicReturn As Object
Set dicReturn = VBA.CreateObject("Scripting.Dictionary")
Dim oNextList As List
Set oNextList = Me.WhichListHasLeastProgress
While oNextList.PercentageDone <= 1
Dim vListItem As Variant
vListItem = oNextList.GetListItem
dicReturn.Add dicReturn.Count, vListItem
oNextList.MoveNext
Set oNextList = Me.WhichListHasLeastProgress
Wend
Dim vItems As Variant
vItems = dicReturn.Items
'I don't like this bit
ReDim vRet(1 To dicReturn.Count, 1 To 1)
Dim lLoop As Long
For lLoop = 0 To dicReturn.Count - 1
vRet(lLoop + 1, 1) = vItems(lLoop)
Next lLoop
WeaveSort = vRet
End Function
Public Function WhichListHasLeastProgress() As List
Dim vKeyLoop As Variant
Dim oListLoop As List
Dim oLeastProgress As List
For Each vKeyLoop In mdic.keys
Set oListLoop = mdic.Item(vKeyLoop)
If oLeastProgress Is Nothing Then
'nothing to compare yet
Set oLeastProgress = oListLoop
Else
If oListLoop.PercentageDone < oLeastProgress.PercentageDone Then
'definitely take this new candidate
Set oLeastProgress = oListLoop
ElseIf oListLoop.PercentageDone = oLeastProgress.PercentageDone And oListLoop.Size > oListLoop.Size Then
'close thing, both showing equal progress but we should give it to the one with the bigger "queue"
Set oLeastProgress = oListLoop
Else
'no swap
End If
End If
Next
'return the answer
Set WhichListHasLeastProgress = oLeastProgress
End Function
and the List.cls file is
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "List"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mvList As Variant
Private mlCount As Long
Private mlCursor As Long
Private mvName As Variant
Public Function Initialise(ByRef vList As Variant, ByVal vName As Variant)
Debug.Assert TypeName(vList(1, 1)) <> "" ' this will break unless you specify a 2d array
Debug.Assert LBound(vList, 1) = 1 ' this ensure you got it from a sheet
mvList = vList
mlCount = UBound(mvList)
mlCursor = 1
mvName = vName
End Function
Public Function GetListItem()
GetListItem = mvList(mlCursor, 1)
End Function
Public Function Name() As Variant
Name = mvName
End Function
Public Function MoveNext() As Boolean
mlCursor = mlCursor + 1
MoveNext = (mlCursor < mlCount)
End Function
Public Function Size() As Long
Size = mlCount
End Function
Public Function PercentageDone() As Double
PercentageDone = mlCursor / mlCount
End Function
The last file is this tstListManager.bas
Attribute VB_Name = "tstListManager"
Option Explicit
Sub test()
Dim oListMan As ListManager
Set oListMan = New ListManager
Dim vLists As Variant
vLists = VBA.Array(ThisWorkbook.Sheets("Source").Range("A1:A3").Value2, _
ThisWorkbook.Sheets("Source").Range("B1:B2").Value2, _
ThisWorkbook.Sheets("Source").Range("C1:C5").Value2)
oListMan.Initialise vLists
Dim vSorted As Variant
vSorted = oListMan.WeaveSort
Dim lTotal As Long
ThisWorkbook.Sheets("Dest").Range("A1").Resize(UBound(vSorted, 1)).Value2 = vSorted
End Sub
Finally, the test data was in A1:A3 B1:B2 C1:C5
You should note I have abstracted away any Excel reading/writing logic and the pure weavesort logic is not cluttered.
Feel free to reject outright. Object orientation can be quite controversial and we think differently. :)
I've been trying to resurrect an existing drawing check macro, and want to find the co-ordinates of any note blocks on each sheet. I've been modifying code found here using the GetAttachPos method from this page, but for some reason any co-ordinates returned come back around (8.80942311664557E-03,2.24429295226372E-03).
I'm thinking that the problem is that I've missed a reference somewhere, but I'm not sure where. Although it's definitely finding the notes since it passes back their text. Anyway, here's the method I'm testing at the moment:
Sub Main()
Dim swApp As SldWorks.SldWorks
Set swApp = CreateObject("SldWorks.Application")
Dim NoteNumbersText As String
Dim NoteText As String
Dim NumberofSheets As Integer ' The number of sheets in this drawing
Dim NamesOfSheets As Variant ' Names of all of the sheets
Dim sheet As SldWorks.sheet ' The Sheet that we are working on
Dim LocalView As SldWorks.View ' Current View that we are looking at
Dim LocalNote As SldWorks.Note ' Current Note that we are looking at
Dim TextFormat As SldWorks.TextFormat ' Current text format object of a note
Dim Xpos As Double ' X, Y Z position on the drawing in Metres
Dim Ypos As Double
Dim SizeOfSheet As Double
Dim x As Integer ' general Loop Variables
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim vPosition As Variant
Dim vNote As Variant ' Single note
Dim swNote As SldWorks.Note ' Single Solidworks Note Object
Dim ThisAnnotation As SldWorks.Annotation
Dim swBlockInst As SldWorks.SketchBlockInstance
Dim swBlockDef As SldWorks.SketchBlockDefinition
Dim NumofNotes As Integer
Dim ArrayOfNotes() As NoteInfo
Dim LocalDrawingDoc As SldWorks.DrawingDoc ' Declared as an Object so that non Drawings can be detected!
Dim LocalPart As SldWorks.ModelDoc2 ' Declared as an Object so that non Drawings can be detected!
Dim strShtProp As Variant
Set LocalDrawingDoc = swApp.ActiveDoc
Set LocalPart = swApp.ActiveDoc
ReDim ArrayOfNotes(0)
' Get the sheet names and the number of them
NamesOfSheets = LocalDrawingDoc.GetSheetNames()
NumberofSheets = LocalDrawingDoc.GetSheetCount
' store this sheet name
Set sheet = LocalDrawingDoc.GetCurrentSheet()
strShtProp = sheet.GetProperties() ' get the sheet properties use much later for converting position into ref
SizeOfSheet = strShtProp(5)
Dim SwSketchMgr As SldWorks.SketchManager
Set SwSketchMgr = LocalDrawingDoc.SketchManager
Dim i As Integer
Dim vBlockDef As Variant
Dim vBlockInst As Variant
Dim strReturn As String
' Dim bret As Boolean
vBlockDef = SwSketchMgr.GetSketchBlockDefinitions
For x = NumberofSheets - 1 To 0 Step -1
If LocalDrawingDoc.GetCurrentSheet.GetName <> NamesOfSheets(x) Then LocalDrawingDoc.ActivateSheet NamesOfSheets(x)
Set LocalView = LocalDrawingDoc.GetFirstView
While Not LocalView Is Nothing
If Not IsEmpty(vBlockDef) Then
For i = 0 To UBound(vBlockDef)
Set swBlockDef = vBlockDef(i)
vBlockInst = swBlockDef.GetInstances
vNote = swBlockDef.GetNotes
If Not IsEmpty(vNote) Then
For j = 0 To UBound(vNote)
Set swNote = vNote(j)
NoteNumbersText = Trim(swNote.GetText)
If Left(NoteNumbersText, 1) = "n" And Len(NoteNumbersText) > 1 And Len(NoteNumbersText) < 4 Then
Set ThisAnnotation = swNote.GetAnnotation
'vPosition = swNote.GetAttachPos
vPosition = ThisAnnotation.GetPosition
Xpos = vPosition(0)
Ypos = vPosition(1)
Debug.Print ("Note " & NoteNumbersText & ": " & Xpos & "," & Ypos)
End If
Next j
End If
Next i
End If
Set LocalView = LocalView.GetNextView
Wend
Next x
End Sub
Turns out that SolidWorks is set up to return positions of blocks relative to the drawing view on which they're placed. Calling GetXForm for the view which they are placed on then provides a way of calculating the absolute position of each note.