I am developing a VBA macro to use in AutoCAD. At the moment it converts a circle into a 3D polyline and in itself it is working perfectly. It is just the start and I will be able to put some flesh on the final routine.
This is the VBA macro:
Sub CircleToPolyline()
Dim objSel As AcadEntity
Dim myCircle As AcadCircle
Dim pickedPoint As Variant
' Get the user to select a circle
' Eventually we will use a Selection Set with Filtering to pick them all in the drawing
Call ThisDrawing.Utility.GetEntity(objSel, pickedPoint, "Select Circle:")
If objSel.ObjectName <> "AcDbCircle" Then GoTo SKIP
Set myCircle = objSel
Dim dAngle As Double, dAngleStep As Double, dMaxAngle As Double
dAngle = 0# ' We always start at 0 degrees / radians
dAngleStep = 0.17453293 ' This is 10 degrees in radians
dMaxAngle = 6.28318531 ' This is 360 degrees in radians
' So our polyline will always have 36 vertices
Dim ptCoord() As Double
Dim ptProject As Variant
Dim i As Integer
i = 0
While dAngle < dMaxAngle
ReDim Preserve ptCoord(0 To i + 2) ' Increase size of array to hold next vertex
' Calculate the next coordinate on the edge of the circle
ptProject = ThisDrawing.Utility.PolarPoint(myCircle.center, dAngle, myCircle.Radius)
' Add to the coordinate list
ptCoord(i) = ptProject(0)
ptCoord(i + 1) = ptProject(1)
ptCoord(i + 2) = ptProject(2)
' Increment for next coordinate/angle on the circle edge
dAngle = dAngle + dAngleStep
i = i + 3
Wend
' Create the 3D polyline
Dim oPolyline As Acad3DPolyline
Set oPolyline = ThisDrawing.ModelSpace.Add3DPoly(ptCoord)
oPolyline.Closed = True
oPolyline.Update
SKIP:
End Sub
I am just wondering if there are any alternative methods for managing my dynamic array (ptCoord)? For example, is there any way that I can just add the ptProject into a dynamic list and then just use this list in the Add3dPoly routine?
The thing is, PolarPoint returns a variant. And ptCoord is a array of doubles (which is what Add3dPoly expects). This is why I have done it like this. I have not used variants (except for handling return values).
My code is quite simple and sufficient, but if it can be further simplified I would be interested in knowing (given the context of VBA and AutoCAD environment).
I hope my question is clear. Thank you.
It is feasible to allocate a chunk of memory and write the sequential results of each of your PolarPoint calls to it. You could then copy that memory to your ptCoord array in one call. However, the APIs are very awkward, there'd be a lot of fiddling with pointers (never straightforward in VBA) and most memory coding errors result in a complete Excel crash. For 108 data points it doesn't seem worth the effort.
I'd say your notion of iterating each of the result arrays and writing them individually to ptCoord is as good a way as any.
Your comments
'We always start at 0 degrees / radians, and 'So our polyline will always have 36 vertices
suggest your ptCoord array will have a fixed dimension (ie 36 * 3). If that's the case couldn't you just dimension the array once? Even if you want to vary the number of degrees to draw through, you could still dimension your array at (n * 3) without having to ReDim Preserve on every iteration.
A snippet of your code could therefore become:
Dim alpha As Double
Dim index As Integer
Dim i As Integer
Dim ptCoord(0 To 107) As Double
Dim ptProject() As Double
Dim pt As Variant
...
For i = 0 To 35
ptProject = ThisDrawing.Utility.PolarPoint(myCircle.center, dAngle, myCircle.Radius)
For Each pt In ptProject
ptCoord(index) = pt
index = index + 1
Next
alpha = alpha + 0.174532925199433
Next
Your code appears good to me, I was going to suggest a two dimensional array: -
Dim ptCoord(2,0)
...
ptCoord(0,0) = ptProject(0)
ptCoord(1,0) = ptProject(1)
ptCoord(2,0) = ptProject(2)
ReDim Preserve ptCoord(2,1)
ptCoord(0,1) = ptProject(0)
ptCoord(1,1) = ptProject(1)
ptCoord(2,1) = ptProject(2)
The second dimension in a two dimensional array can be dynamically re-dimensioned. But I'm not sure this will save you anything and it may not work with Add3DPoly.
You could use UBound to save on the i variable.
ReDim Preserve ptCoord(UBound(ptCoord,1)+3)
In the above I haven't declared the lower/base (0 To) as 0 is the default base, I have then used UBound (Upper bound) to get the size of the array and added 3 to that to make it 3 larger.
UBound([Array],[Dimension])
Array being the array you want to check
Dimension being the dimension you want to check the size on, it has a base of 1 not 0 (so the first dimension is 1 not 0, the second is 2 not 1, and so on...)
You can omit Dimension and the first will be assumed.
To access it without i you could use: -
ptCoord(UBound(ptCoord,1)-2) = ptProject(0)
ptCoord(UBound(ptCoord,1)-1) = ptProject(1)
ptCoord(UBound(ptCoord,1)) = ptProject(2)
you can skip arrays dimming altogether by use of AppendVertex() method
Option Explicit
Sub CircleToPolyline()
Dim myCircle As AcadCircle
Dim circleCenter As Variant, circleRadius As Double
Dim dAngle As Double, dAngleStep As Double, dMaxAngle As Double
Dim oPolyline As Acad3DPolyline
'Get the user to select a circle
Set myCircle = GetCircle(circleCenter, circleRadius)
If myCircle Is Nothing Then Exit Sub
dAngle = 0# ' We always start at 0 degrees / radians
dAngleStep = 0.17453293 ' This is 10 degrees in radians
dMaxAngle = 6.28318531 ' This is 360 degrees in radians
Set oPolyline = GetStarting3dPoly(circleCenter, circleRadius, dAngle, dAngleStep) ' Create the 3D polyline with first two points
Do While dAngle + dAngleStep <= dMaxAngle
dAngle = dAngle + dAngleStep ' Increment for next coordinate/angle on the circle edge
oPolyline.AppendVertex ThisDrawing.Utility.PolarPoint(circleCenter, dAngle, circleRadius) 'append a new vertex
Loop
'finish the polyline
oPolyline.Closed = True
oPolyline.Update
End Sub
Function GetStarting3dPoly(circleCenter As Variant, circleRadius As Double, dAngle As Double, dAngleStep As Double) As Acad3DPolyline
Dim ptCoord(0 To 5) As Double
Dim ptCoords As Variant
ptCoords = ThisDrawing.Utility.PolarPoint(circleCenter, dAngle, circleRadius)
ptCoord(0) = ptCoords(0)
ptCoord(1) = ptCoords(1)
ptCoord(2) = ptCoords(2)
dAngle = dAngle + dAngleStep
ptCoords = ThisDrawing.Utility.PolarPoint(circleCenter, dAngle, circleRadius)
ptCoord(3) = ptCoords(0)
ptCoord(4) = ptCoords(1)
ptCoord(5) = ptCoords(2)
Set GetStarting3dPoly = ThisDrawing.ModelSpace.Add3DPoly(ptCoord)
End Function
Function GetCircle(circleCenter As Variant, circleRadius As Double) As AcadCircle
Dim objSel As AcadEntity
Dim pickedPoint As Variant
' Get the user to select a circle
' Eventually we will use a Selection Set with Filtering to pick them all in the drawing
ThisDrawing.Utility.GetEntity objSel, pickedPoint, "Select Circle:"
If objSel.ObjectName = "AcDbCircle" Then
Set GetCircle = objSel
circleCenter = objSel.Center
circleRadius = objSel.Radius
End If
End Function
as you see I also extracted some actions from the main code and confined them into functions, so to improve further enhancing of your code and its functionalities
Related
Is there a way to change orientation (direction) of Hole Table axes with SolidWorks API?
I can do it manually by dragging the handles but recorded VBA macro does not contain actual changes.
This is what I would like to achieve:
Before
After
I don't have Visual Studio Tools on this PC so I cannot record a C# or VB macro and see if it contains more code. If somebody could check that on their PC I would be grateful.
I have figured it out. This time digging through SolidWorks API Help was useful.
By using HoleTable.DatumOrigin.SetAxisPoints() method it is possible to change points that define the Hole Table axes.
Important to notice is that SetAxisPoints() changes only the end points of the axis arrows (tips of the arrowheads). Start points get updated automatically.
You can get current point values with HoleTable.DatumOrigin.GetAxisPoints2() method.
Another thing to notice is that values in the hole table do not get updated automatically. They did update after I manually dragged a an axis point.
To get them update by the code set HoleTable.EnableUpdate property to False before and back to True after the call to SetAxisPoints().
Here is the code excerpt that does what I needed:
Dim ht As SldWorks.HoleTable
Dim htdo As SldWorks.DatumOrigin
Dim htdaxpts() As Double
Dim htdaxptsnew(0 To 3) As Double
Dim ystarty As Double
Dim yendx As Double
Dim yendy As Double
Dim xstartx As Double
Dim xendx As Double
Dim xendy As Double
'...
'here comes code to prepare for Hole Table insertion
'...
'insert the Hole Table
Set htann = theView.InsertHoleTable2(False, anchorx, anchory, swBOMConfigurationAnchor_BottomLeft, "A", holetemplatepath)
If Not htann Is Nothing Then
Set ht = htann.HoleTable
Set htdo = ht.DatumOrigin
'disable hole table update to get it refresh when done
ht.EnableUpdate = False
'get coordinates of the axis arrows (4 pairs of (x,y) doubles: X start(0,1), X end(2,3), Y start(4,5), Y end(6,7))
htdaxpts = htdo.GetAxisPoints2()
'take the values we use
xstartx = htdaxpts(0)
xendx = htdaxpts(2)
xendy = htdaxpts(3)
ystarty = htdaxpts(5)
yendx = htdaxpts(6)
yendy = htdaxpts(7)
'change direction only if Y arrow points up
If ystarty < yendy Then
yendy = ystarty - (yendy - ystarty)
End If
'change direction only if X arrow points left
If xstartx > xendx Then
xendx = xstartx - (xendx - xstartx)
End If
'change position only if X arrow is below Y arrow
If xendy < ystarty Then
'we can change end point only so change X end y only
xendy = xendy + (ystarty - xendy) * 2
End If
'prepare new axis points (2 pairs of (x,y) doubles: X end(0,1), Y end(2,3))
htdaxptsnew(0) = xendx
htdaxptsnew(1) = xendy
htdaxptsnew(2) = yendx
htdaxptsnew(3) = yendy
'set new axis end points
htdo.SetAxisPoints htdaxptsnew
'enable hole table update to refresh the values
ht.EnableUpdate = True
End If
I'm trying to figure out how to code a straight line to the straight part of a curve, the curve should look something like the exponential, click the link to open the image:
Straight line to Curve and determining the x-intercept
Here is the code, I'm only using the exponential as an example
`
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim s As String
Dim xl As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
wb = xl.Workbooks.Add 'create new workbook
ws = wb.Worksheets(1) 'select sheet 1
ws.Activate()
Dim Currents() As Double
Dim PhotodiodeValues() As Double
Dim AppliedCurrent As Double
'AppliedCurrent = SerialPort1.ReadLine
AppliedCurrent = 0
If AppliedCurrent >= 0 And AppliedCurrent < 0.1 Then
Dim j As Integer = 1
For i As Double = 0 To 5 Step 0.5
ReDim Preserve Currents(j)
ReDim Preserve PhotodiodeValues(j)
MsgBox(i)
MsgBox("LDI " & CType(i, String))
s = ("LDI " & CType(i, String))
AppliedCurrent = i
If AppliedCurrent >= i And AppliedCurrent < (i + 0.1) Then
Currents(j) = CType(i, Double)
Label1.Text = Currents(j)
PhotodiodeValues(j) = CType(Math.E ^ (i), Double)
ws.Cells(j, 1) = Currents(j)
ws.Cells(j, 2) = PhotodiodeValues(j)
Else
System.Threading.Thread.Sleep(1000)
End If
j = j + 1
Next
Else
System.Threading.Thread.Sleep(1000)
End If
sfd1.ShowDialog() 'get file name
wb.SaveAs(sfd1.FileName) 'save data to file
wb.Close()
xl = Nothing 'dispose of excel
ScatterGraph1.PlotXY(Currents, PhotodiodeValues)
'SerialPort1.Close()
End Sub
End Class`
First off, I'll explain my thought process. If I have misunderstood, please let me know and I will update my answer. The slope dy/dx of the curve y = e^x is dy/dx = e^x, a monotonically increasing function of x for all real x. There is never a point at which the function becomes linear and, while it has a horizontal asymptote (y = 0) it has no vertical asymptote.
I take it that what you want is the equation of a tangent line taken at a point where the slope first becomes greater than some cutoff value m*. After that point, the graph of y = e^x "might as well" be a straight line for your intents and purposes.
So, we must first solve the equation m* = dy/dx = e^x for the x at which m* occurs. The range of e^x is all positive real numbers and e^x is monotonically increasing, so any positive real number m* will have a unique solution x*. indeed, x* = ln(m*). Our tangent line will pass through the point (x*, e^x*) and have slope m*. Recall that m* = e^x*, so the point is (ln(m*), m*) and the slope is m*.
With a point and the slope, we can figure out the equation of a line. We have that the slope from the given point to any other point must be m*; so, (y - y*)/(x - x*) = m*. Rearranging, (y - y*) = m*(x - x*), y = mx - mx* + y*, and finally y = mx + (y - mx) = mx + (m - mln(m)). The Y-intercept is therefore (m* - mln(m)). We can get the X-intercept by setting y = 0 and solving for x: 0 = mx + (m - mln(m)), mx = mln(m*) - m*, x = ln(m*) - 1.
In summary:
the equation of the line tangent to y = e^x with slope m* is y = mx + (m - mln(m)).
the Y-intercept of this line is (m* - mln(m)).
the X-intercept of this line is ln(m*) - 1
If the curve is known at compile time, I recommend hard-coding a closed form analytical solution for the derivative and any asymptotes. If the function is not known until runtime, the derivative at a given point can be approximated numerically using a variety of methods. Intuitively, the definition of the derivative as the limit of (f(x+d) - f(x)) / d as d approaches zero can be used to find approximations of the derivative where the derivative (likely) exists. For well-behaved analytic functions, you will typically be safe except in special cases.
If the function's derivative is monotonically non-decreasing, as in this example, you can find the point (if any) at which the function's slope meets or exceeds a certain cutoff using approximation (as above) in conjunction with something akin to binary search. Start at a value such as x = 0, and increase or decrease x by some multiplicatively increasing factor until you have passed your target. Now, with bounds on the values of x between which your target can be found, check the middle of the range, and then either the left or right half recursively until a suitably good x* is found.
Recently, in an interview I encountered a question in VBA. The question is:
Write a program to sort the shapes in a worksheet, like for example : I have various shapes like circle, triangle, rectangle, pentagon... This needs to be sorted and placed one below the other.
I tried with Shapes object and msoshapeRectangle method. But it didnt work.
Could you please tell me is this possible to be done?
Thanks
It was an interesting challenge, so I did it. Might as well post the result (commented for clarity):
Sub tgr()
'There are 184 total AutoShapeTypes
'See here for full list
'https://msdn.microsoft.com/VBA/Office-Shared-VBA/articles/msoautoshapetype-enumeration-office
Dim aShapeTypes(1 To 184) As String
Dim ws As Worksheet
Dim Shp As Shape
Dim i As Long, j As Long
Dim vShpName As Variant
Dim dLeftAlign As Double
Dim dTopAlign As Double
Dim dVerticalInterval As Double
Dim dHorizontalInterval As Double
Dim dPadding As Double
Set ws = ActiveWorkbook.ActiveSheet
'Sort order will be by the AutoShapeType numerical ID
'Using this, shapes will be sorted in this order (incomplete list for brevity):
' Rectangle, Parallelogram, Trapezoid, Diamond, Rounded rectangle, Octagon, Isosceles triangle, Right triangle, Oval, Hexagon
'Note that you can use a Select Case to order shapes to a more customized list
'I use this method to put the -2 (indicates a combination of the other states) at the bottom of the sort order
For Each Shp In ws.Shapes
Select Case Shp.AutoShapeType
Case -2: aShapeTypes(UBound(aShapeTypes)) = aShapeTypes(UBound(aShapeTypes)) & "||" & Shp.Name
Case Else: aShapeTypes(Shp.AutoShapeType) = aShapeTypes(Shp.AutoShapeType) & "||" & Shp.Name
End Select
Next Shp
'Now that all shapes have been collected and put into their sort order, perform the actual sort operation
'Adjust the alignment and vertical veriables as desired
'The Padding variable is so that the shapes don't start at the very edge of the sheet (can bet set to 0 if that's fine)
'I have it currently set to sort the shapes vertically, but they can be sorted horizontally by uncommenting those lines and commenting out the vertical sort lines
dPadding = 10
dLeftAlign = 5
dTopAlign = 5
dVerticalInterval = 40
dHorizontalInterval = 40
j = 0
For i = LBound(aShapeTypes) To UBound(aShapeTypes)
If Len(aShapeTypes(i)) > 0 Then
For Each vShpName In Split(Mid(aShapeTypes(i), 3), "||")
With ws.Shapes(vShpName)
'Vertical Sort
.Left = dLeftAlign
.Top = j * dVerticalInterval + dPadding
'Horizont Sort
'.Top = dTopAlign
'.Left = j * dHorizontalInterval + dPadding
End With
j = j + 1
Next vShpName
End If
Next i
End Sub
I want to use the coefficient from LinEst but LinEst returns an array. What is the best way to access the parts of the array output? What data types will the parts of the array be?
This solution may help someone, although I appreciate it is an old question.
I found that the WorksheetFunction.Linest function returns the error message Unable to get the LinEst property of the WorksheetFunction class, for all manner of errors. So by trial and error(lots) I finally got to this solution:
Sub CalcTrend()
'--------------
' To Determine a simple linear trend of the form y = mx + b
'First declare arrays for x and y data series
Dim x() As Double, y() As Double
' Next declare a variant array for the Linest return values
Dim RtnArray() As Variant
' Also declare simple variable for the individual parameters
Dim m As Double, b As Double, r2 As Double
' Finally declare and index variable for For-Next loop
Dim i As Long
' Both x() and y() arrays MUST be same size
' and assuming the data is in a worksheet in columns x any y then,
' to populate the arrays, for example
' With Worksheet
' RowsInDataSet = .Range(.Cells(firstrow, xCol), .Cells(lastRow, xCol)).Rows.Count
' End With
ReDim x(0 To RowsInDataSet)
ReDim y(0 To RowsInDataSet)
For i = 0 To UBound(x)
x(i) = X_Range.Cells(i + 1, 1) 'Replace X_Range with worksheet range for x series
y(i) = Y_Range.Cells(i + 1, 1) 'Replace y_Range with worksheet range for y series
Next i
' Now run the Linest function ...
DataArray = WorksheetFunction.LinEst(y, x, , True)
' ... and the results can be found as follows
' Slope
m = DataArray(1, 1)
' Y-intercept
b = DataArray(1, 2)
' Coefficient of determination (how well the data correlates to the line)
r2 = DataArray(3, 1)
End Sub
See the Microsoft docs for a full map of all the Return Array values.
This solution is shown as a Sub to demonstrate obtaining the WorksheetFunction return values. For practical purpose using a Function with ByRef arguments for return array could be more useful.
Let me start by first thanking everyone for the help/intention to help. This community is phenomenal. Second: I'm pretty new at this- before this week I'd learned basic in highschool a decade ago but no other programming experience outside of theory.
Without further ado, here's my issue:
Working on code to find unique variables (I know there's a lot of opensource stuff out there, need to customize this though). When I go to populate the array with the very first string I run into an 'out of range' error at array(1), which I had explicity set (1 TO UB), with UB being the upper bound. I've also double checked the value of UB with msgbox and it's at 15 with my dummy data, so that shouldn't be an issue. I've set the values in the array to empty (have also done so with 0, to no avail).
The error occurs at "ResultArray(1) = CurrentArray(1)"
I'm at a loss; any assistance would be much appreciated.
Option Explicit
Sub unque_values()
'''''''''Variable declaration
'
' CurrentArray() is the array taken from the worksheet
' Comp is the method of comparing inputs (either case sensitive or case insensitive)
' resultarray() is the array that unique values are placed
' UB is the upper bound of Result Array
' resultindex is the variable that keeps track of which cells are unique and which are not
' n is a helped variable that assists with resizing the array
Dim currentarray() As Variant
Dim comp As VbCompareMethod
Dim resultarray() As Variant
Dim UB As Long
Dim resultindex As Long
Dim n As Long
Dim v As Variant
Dim inresults As Boolean
Dim m As Long
' set variables to default values
Let comp = vbTextCompare
Let n = 0
' count the number of cells included in currentarray and populate with values
Let n = ActiveWorkbook.Worksheets("Data").Range("A:A").Count
Let UB = ActiveWorkbook.Worksheets("Data").Range("A" & n).End(xlUp).Row
' dimension arrays
ReDim resultarray(1 To UB)
ReDim currentarray(1 To UB)
' don't forget to change to named ranges
Let currentarray() = Range("f2", "f" & UB)
' populate resultarray with empty values
For n = LBound(resultarray) To UBound(resultarray)
resultarray(n) = Empty
Next n
MsgBox (n)
'check for invalid values in array
For Each v In currentarray
If IsNull(n) = True Then
resultarray = CVErr(xlErrNull)
Exit Sub
End If
Next v
' assumes the first value is unique
resultindex = 1
'''''''''''''''''''''''''''''''''''''''''error is this line''''''''''''''
resultarray(1) = currentarray(1)
' Search for duplicates by cycling through loops
' n = index of value being checked
' m = index of value being checked against
For n = 2 To UB
Let inresults = False
For m = 1 To n
If StrComp(CStr(resultarray(m)), CStr(currentarray(n)), comp) = 0 Then
inresults = True
Exit For
End If
Next m
If inresults = False Then
resultindex = resultindex + 1
resultarray(resultindex) = currentarray(n)
End If
Next n
ReDim Preserve resultarray(1 To resultindex)
End Sub
You've assigned to currentArray a range array. These are always two-dimensional arrays.
You should be able to resolve it with:
resultarray(1) = currentarray(1, 1)
You would need to modify a few more lines in your code to refer to both dimensions of the array.
Alternatively, with the least manipulation to your existing code, transpose the array which turns it to a one-dimensional array. This should require no other changes to your code.
Let currentArray() = Application.Transpose(Range("f2", "f" & UB))
Try with ActiveWorkbook.Worksheets("Data").UsedRange.Columns(1).cells.Count