Solidworks VBA Edge Selection Wont Work - vba

I have attached what my macro currently looks like below. So far the macro will make a rectangle with 2 holes in it. It then needs to chamfer the four edge corners. But for some reason when I try to select those corners it wont work. I actually will get different results on different tries.
The code portion in question is the last 7 or so lines. If I run those lines completely separate from the macro I get the results that I am after. Could it just be some syntax thing?
I am new to VBA with respect to Solidworks. I have worked with it in excel. So if you spot any bad habbits other feedback is appreciated.
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swSketchMgr As SldWorks.SketchManager
Dim swFeature As SldWorks.Feature
Dim swFeatureMgr As SldWorks.FeatureManager
Dim vSkLines As Variant
Dim boolstatus As Boolean
Dim longstatus As Long
Dim circ As SldWorks.SketchSegment
Dim cx1 As Double
Dim cx2 As Double
Dim cy1 As Double
Dim cy2 As Double
Dim d1 As Double
Dim d2 As Double
Dim b1 As Double
Dim w1 As Double
Dim t1 As Double
Dim in2mmconv As Double
Dim m2mmconv As Double
Sub main()
in2mmconv = 0.0254
m2mmconv = 1 / 1000
b1 = 5.5 * in2mmconv
w1 = 3.5 * in2mmconv
t1 = 0.75 * in2mmconv
cy1 = b1 - 1.75 * in2mmconv
cx1 = w1 / 2
d1 = 66.779 * m2mmconv + 0.0002 * in2mmconv
cx2 = cx1
cy2 = cy1 - 79.3 * m2mmconv
d2 = 0.5007 * in2mmconv
Set swApp = Application.SldWorks
' Reset the counts for untitled documents for this macro
Set swModel = swApp.ActiveDoc
' Select the Front plane
Set swModelDocExt = swModel.Extension
boolstatus = swModelDocExt.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
' Open a sketch and sketch a rectangle
Set swSketchMgr = swModel.SketchManager
swSketchMgr.InsertSketch True
swModel.ClearSelection2 True
vSkLines = swSketchMgr.CreateCornerRectangle(0, b1, 0, w1, 0, 0)
' Change view orientation and clear all selections
swModel.ShowNamedView2 "*Trimetric", 8
swModel.ClearSelection2 True
' Select the sketch entities to extrude
Set swModelDocExt = swModel.Extension
boolstatus = swModelDocExt.SelectByID2("Line2", "SKETCHSEGMENT", 0, 0, 0, False, 0, Nothing, 0)
boolstatus = swModelDocExt.SelectByID2("Line1", "SKETCHSEGMENT", 0, 0, 0, True, 0, Nothing, 0)
boolstatus = swModelDocExt.SelectByID2("Line4", "SKETCHSEGMENT", 0, 0, 0, True, 0, Nothing, 0)
boolstatus = swModelDocExt.SelectByID2("Line3", "SKETCHSEGMENT", 0, 0, 0, True, 0, Nothing, 0)
' Create the extrude feature
Set swFeatureMgr = swModel.FeatureManager
Set swFeature = swFeatureMgr.FeatureExtrusion2(True, False, True, 0, 0, t1, 0.381, False, False, False, False, 0.01745329251994, 0.01745329251994, False, False, False, False, True, True, True, 0, 0, False)
' Fit the model in the graphics area
swModel.ViewZoomtofit2
' Select the face on the extrude feature
' and sketch the entities to pattern
swModel.ShowNamedView2 "*Front", 1
boolstatus = swModelDocExt.SelectByID2("", "FACE", -w1, 0, -t1, False, 0, Nothing, 0)
Set circ = swSketchMgr.CreateCircle(cx1, cy1, 0, cx1 - d1 / 2, cy1, 0)
Set circ = swSketchMgr.CreateCircle(cx2, cy2, 0, cx2 - d2 / 2, cy2, 0)
boolstatus = swModelDocExt.SelectByID2("Arc1", "SKETCHSEGMENT", 0, 0, 0, False, 0, Nothing, 0)
boolstatus = swModelDocExt.SelectByID2("Arc2", "SKETCHSEGMENT", 0, 0, 0, False, 0, Nothing, 0)
swModel.ClearSelection2 True
Set swFeature = swFeatureMgr.FeatureCut3(True, False, False, swEndCondThroughAll, swEndCondBlind, 0.01, 0.01, False, False, False, False, 0.01745329251994, 0.01745329251994, False, False, False, False, False, True, True, False, False, False, swStartSketchPlane, 0, False)
swModel.ClearSelection2 True
boolstatus = swModelDocExt.SelectByID2("", "EDGE", 0, 0, -t1 / 2, True, 0, Nothing, 0)
boolstatus = swModelDocExt.SelectByID2("", "EDGE", 0, b1, 0, True, 0, Nothing, 0)
boolstatus = swModelDocExt.SelectByID2("", "EDGE", w1, b1, -t1 / 2, True, 0, Nothing, 0)
boolstatus = swModelDocExt.SelectByID2("", "EDGE", w1, 0, -t1 / 2, True, 0, Nothing, 0)
Set swFeature = swFeatureMgr.InsertFeatureChamfer(4, 1, 0.00254, 0.78539816339745, 0, 0, 0, 0)
End Sub

I faced the same problem recently. After some google search, I found that the selectbyID2 method may behave in certain circumstances. One of them is that there is an edge that is over your required edge. And there are so many of them. So, what did I do in my code? I planned to rotate the model so that the required object to be selected is in normal view. In my case, this procedure solved my issues completely. Try it.
To rotate the model, use the showNamedView2 method before using selectbyID2.

Related

Changes the color of a part using vba macro in solidworks api

I'm trying to change the appearance of a part using the VBA code.
I found a code already on the forum that changes the color for each face individually, but that's a complicated code to use for a simple part.
I tried to record a macro while changing the color but nothing was captured in the macro for some reason.
I tried also to look into the help documentation and all I found was this one: https://help.solidworks.com/2017/english/api/sldworksapi/solidworks.interop.sldworks~solidworks.interop.sldworks.iappearancesetting~color.html
And that's my code along with color commands.
Dim swModel As ModelDoc2
Dim boolstatus As Boolean
Dim swApp As SldWorks
Private x, X1, Y1, X2, Y2 As Integer
swModel = swApp.NewPart()
swModel = swApp.ActiveDoc
'Drawing 2D Sketch
boolstatus = swModel.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
Dim swSketch As SketchManager
swSketch = swModel.SketchManager
swSketch.InsertSketch(True)
X1 = 2
Y1 = 2
X2 = 2
Y2 = 2
Dim skSegment As Object
skSegment = swModel.SketchManager.CreateLine(0, 0, 0#, 2, 0, 0#)
skSegment = swModel.SketchManager.CreateLine(2, 0, 0#, 2, 2, 0#)
skSegment = swModel.SketchManager.CreateLine(2, 2, 0#, 0, 2, 0#)
skSegment = swModel.SketchManager.CreateLine(0, 2, 0#, 0, 0, 0#)
swModel.SketchManager.InsertSketch(True)
swModel.ClearSelection2(True)
swModel.ViewZoomtofit()
' Extrude
Dim CreateExtrude As Feature
boolstatus = swModel.Extension.SelectByID2("Sketch1", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
CreateExtrude = swModel.FeatureManager.FeatureExtrusion2(True, False, False, 0, 0, 3, 0.01, False, False, False, False, 0, 0, False, False, False, False, True, True, True, 0, 0, False)
'''''''''''' COLOR Changing based on the link above '''''''''''''''
Dim Part_color As IAppearanceSetting
Dim value As Integer = 0
value = Math.Max(Math.Min(120, 255), 0) + Math.Max(Math.Min(120, 255), 0) * 16 * 16 + Math.Max(Math.Min(120, 255), 0) * 16 * 16 * 16 * 16
Part_color.Color = value
''''''''''''''
The part was created successfully but the color changing didn't work.
Any thoughts?
I got the answer from the SolidWorks forum (Thanks to Mr. Willie Roelofs)
I just kept the post in case someone is a super beginner in API like me and looking for the same thing.
If it's not useful, just delete it :)
Option Explicit
Sub main()
Dim boolStatus As Boolean
Dim swApp As SldWorks.SldWorks
Set swApp = Application.SldWorks
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
Call Draw2DSketch(swModel)
Call ExtrudeSketch(swModel)
Call ColorPart(swModel)
End Sub
Function Draw2DSketch(swModel As SldWorks.ModelDoc2)
'Drawing 2D Sketch
Dim boolStatus As Boolean
boolStatus = swModel.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
Dim swSketch As SketchManager
Set swSketch = swModel.SketchManager
swSketch.InsertSketch True
swModel.ClearSelection2 True
Dim skSegment As Object
Set skSegment = swModel.SketchManager.CreateLine(0, 0, 0#, 2, 0, 0#)
Set skSegment = swModel.SketchManager.CreateLine(2, 0, 0#, 2, 2, 0#)
Set skSegment = swModel.SketchManager.CreateLine(2, 2, 0#, 0, 2, 0#)
Set skSegment = swModel.SketchManager.CreateLine(0, 2, 0#, 0, 0, 0#)
swModel.SketchManager.InsertSketch (True)
swModel.ClearSelection2 (True)
swModel.ViewZoomtofit
End Function
Function ExtrudeSketch(swModel As SldWorks.ModelDoc2)
Dim boolStatus As Boolean
boolStatus = swModel.Extension.SelectByID2("Sketch1", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
Dim CreateExtrude As Feature
On Error Resume Next
CreateExtrude = swModel.FeatureManager.FeatureExtrusion2(True, False, False, 0, 0, 3, 0.01, False, False, False, False, 0, 0, False, False, False, False, True, True, True, 0, 0, False)
On Error GoTo 0
End Function
Function ColorPart(swModel As SldWorks.ModelDoc2)
Dim vMatProps
vMatProps = swModel.MaterialPropertyValues
'Define the RGB values (1 = RGB value 255)
vMatProps(0) = 154 / 255 'R
vMatProps(1) = 155 / 255 'G
vMatProps(2) = 156 / 255 'B
swModel.MaterialPropertyValues = vMatProps
swModel.GraphicsRedraw2
End Function

How to create a "flip offset" reference plane with Solidworks VBA/API

I am trying to create two parallel reference planes equidistant from the origin. I am able to create the positive plane with:
Dim swDoc As SldWorks.ModelDoc2
Dim distance As Double
Dim BoolStatus As Boolean
Dim swLeftFace As SldWorks.RefPlane
Dim swRightFace As SldWorks.RefPlane
BoolStatus = swDoc.Extension.SelectByID2("Right Plane", "PLANE", 0, 0, 0, False, 0, Nothing, swSelectOption_e.swSelectOptionDefault)
Set swRightFace = swDoc.FeatureManager.InsertRefPlane(swRefPlaneReferenceConstraints_e.swRefPlaneReferenceConstraint_Distance, distance, 0, 0, 0, 0)
However, I cannot create the negative plane. When "distance" is negative, it is evaluated as 0. This creates a plane coincident with the origin.
I have tried a few variations with "swRefPlaneReferenceConstraint_OptionFlip" constraint, but the documentation is very poor and it either:
Fails to create a plane
BoolStatus = swDoc.Extension.SelectByID2("Right Plane", "PLANE", 0, 0, 0, False, 0, Nothing, swSelectOption_e.swSelectOptionDefault)
Set swLeftFace = swDoc.FeatureManager.InsertRefPlane(swRefPlaneReferenceConstraints_e.swRefPlaneReferenceConstraint_OptionFlip, distance, 0, 0, 0, 0)
or creates a plane with a positive offset, coincident with the first reference plane. This occurs for X=-1, X=0, and X=1.
BoolStatus = swDoc.Extension.SelectByID2("Right Plane", "PLANE", 0, 0, 0, False, 0, Nothing, swSelectOption_e.swSelectOptionDefault)
Set swRightFace = swDoc.FeatureManager.InsertRefPlane(swRefPlaneReferenceConstraints_e.swRefPlaneReferenceConstraint_Distance, distance, 0, 0, 0, 0)
BoolStatus = swDoc.Extension.SelectByID2("Right Plane", "PLANE", 0, 0, 0, False, 0, Nothing, swSelectOption_e.swSelectOptionDefault)
Set swLeftFace = swDoc.FeatureManager.InsertRefPlane(swRefPlaneReferenceConstraints_e.swRefPlaneReferenceConstraint_Distance, distance, swRefPlaneReferenceConstraints_e.swRefPlaneReferenceConstraint_OptionFlip, X, 0, 0)
The options need to be added like this:
Set swRightFace = swDoc.FeatureManager.InsertRefPlane(swRefPlaneReferenceConstraints_e.swRefPlaneReferenceConstraint_Distance + swRefPlaneReferenceConstraints_e.swRefPlaneReferenceConstraint_OptionFlip, distance, 0, 0, 0, 0)

How to get CATPart number and name into text editor in drawing using macro?

I'm trying to create a macro in CATIA. The macro should use a UserForm with the button. After clicking on the button, it will automatically fill in the text field with data (Part Name + Part Number).
I am a total novice in VBA.
Private Sub CommandButton1_Click()
Dim DrwDocument As DrawingDocument
Set DrwDocument = CATIA.ActiveDocument
Set DrwSheets = DrwDocument.Sheets
Set Selection = DrwDocument.Selection
Set DrwSheet = DrwSheets.ActiveSheet
Set DrwView = DrwSheet.Views.ActiveView
Set DrwTexts = CATIA.ActiveDocument.Sheets.ActiveSheet.Views.ActiveView.Texts
Dim parameters4 As Parameters
Set parameters4 = DrwDocument.Parameters
Dim realParam4 As Parameter
Set realParam4 = parameters4.Item("Sheet.1\ViewMakeUp.3\Scale")
DrwView.Activate
Set Projekt = DrwTexts.Add(tbProjekt.Text, (288), (45.5))
Projekt.AnchorPosition = catMiddleLeft
Projekt.SetFontName 0, 0, "Monospac821 BT"
Projekt.SetFontSize 0, 0, 3
Set PocetKs = DrwTexts.Add(tbPocetKs.Text + "x", (36), (78))
PocetKs.AnchorPosition = catMiddleLeft
PocetKs.SetFontName 0, 0, "Monospac821 BT"
PocetKs.SetFontSize 0, 0, 3
If OptionZrk = True Then
Set PocetKsZrk = DrwTexts.Add(tbPocetKs.Text + "x", (36),(70))
PocetKsZrk.AnchorPosition = catMiddleLeft
PocetKsZrk.SetFontName 0, 0, "Monospac821 BT"
PocetKsZrk.SetFontSize 0, 0, 3
Set ZrkText = DrwTexts.Add("Zrkadlový", (102), (80))
ZrkText.AnchorPosition = catMiddleLeft
ZrkText.SetFontName 0, 0, "Monospac821 BT"
ZrkText.SetFontSize 0, 0, 3
End If
Set Material = DrwTexts.Add(cbMaterial.Text, (288), (37.5))
Material.AnchorPosition = catMiddleLeft
Material.SetFontName 0, 0, "Monospac821 BT"
Material.SetFontSize 0, 0, 3
Set Mierka = DrwTexts.Add(realParam4.ValueAsString, (238), (40))
Mierka.AnchorPosition = catMiddleLeft
Mierka.SetFontName 0, 0, "Monospac821 BT"
Mierka.SetFontSize 0, 0, 3
Set DatumUpravy = DrwTexts.Add(tbDatum.Text, (355), (38))
DatumUpravy.AnchorPosition = catMiddleLeft
DatumUpravy.SetFontName 0, 0, "Monospac821 BT"
DatumUpravy.SetFontSize 0, 0, 3
End Sub
Via the GenerativeBehavior of a view you get the shown product.
dim oProduct as Product
Set oProduct = DrwView.GenerativeBehavior.Document
MsgBox CStr(oProduct.PartNumber)
MsgBox CStr(oProduct.Nomenclature)
Make shure that the view has a link to a geometry/product

Drawing letters in excel

Is there a plugin that helps generate letters (A-Z) in excel as seen below? Or can we write some sort of VBA script to do this?
Stackoverflow is not a code-for-me service. Anyhow, the task looked interesting, and I have decided to code something about it:
Option Explicit
Public Sub WriteLetterA()
Dim varLetterA(8) As Variant
Dim lngColCounter As Long
Dim lngRowCounter As Long
Dim blnReverse As Boolean
Dim rngCell As Range
blnReverse = True
varLetterA(0) = Array(1, 1, 1, 0, 0, 1, 1, 1)
varLetterA(1) = Array(1, 0, 0, 0, 0, 0, 0, 1)
varLetterA(2) = Array(1, 0, 0, 1, 1, 0, 0, 1)
varLetterA(3) = Array(1, 0, 0, 1, 1, 0, 0, 1)
varLetterA(4) = Array(0, 0, 0, 1, 1, 0, 0, 0)
varLetterA(5) = Array(0, 0, 0, 0, 0, 0, 0, 0)
varLetterA(6) = Array(0, 0, 0, 0, 0, 0, 0, 0)
varLetterA(7) = Array(0, 0, 1, 1, 1, 1, 0, 0)
varLetterA(8) = Array(0, 0, 1, 1, 1, 1, 0, 0)
Cells(1, 1).Select
For lngRowCounter = 0 To UBound(varLetterA)
For lngColCounter = 0 To UBound(varLetterA(lngRowCounter))
Set rngCell = Cells(lngRowCounter + 1, lngColCounter + 1)
If varLetterA(lngRowCounter)(lngColCounter) Then
rngCell.Interior.Color = IIf(blnReverse, vbBlack, vbWhite)
Else
rngCell.Interior.Color = IIf(blnReverse, vbWhite, vbBlack)
End If
Next lngColCounter
Next lngRowCounter
End Sub
' Points for improvement - varLetterA in a separate class
' Refer to the sheet, do not assume it
' Pass the first cell as a reference
This is what you get:
blnReverse = False
blnReverse = True
Take a look at the points for improvement - they can be useful, if you decide to build the rest of the alphabet. Good luck.

Extract from multidimensional array

I have an array dat that shows Type = Variant/Variant(0 to 500, 0 to 0, 0 to 1)
There is a "column" of dates:
dat(0, 0, 0) = #1/1/2013#
dat(1, 0, 0) = #1/2/2013#
I want to extract this set of dates. I tried:
Dim dat As Variant
Dim dt As Variant
'stuff gets dat in the format described above
dt = Application.Index(dat, 0, 1, 1)
Unfortunately this gives me an Error 13 Type Mismatch. What am I doing wrong?
Use a Loop
Sub dural()
Dim dat(0 To 500, 0 To 1, 0 To 1) As Variant
dat(0, 0, 0) = #1/1/2013#
dat(1, 0, 0) = #1/2/2013#
Dim dt(0 To 500) As Variant
For i = 0 To 500
dt(i) = dat(i, 0, 0)
Next i
End Sub