VBA 2015
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Why won't this work in 2015 compared to 2014?
Option Explicit
Dim DblDiameter As Double
Dim varPnt1 As Variant
Dim varPnt2 As Variant
Dim dblHeight As Double
Dim varPnt1UCS As Variant
Public Sub Bolts()
DblDiameter = ThisDrawing.Utility.GetInteger("Input bolt diameter: ")
varPnt1 = ThisDrawing.Utility.GetPoint(, "Pick bolt head side")
varPnt1UCS = ThisDrawing.Utility.TranslateCoordinates(varPnt1, acWorld, acUCS, False)
varPnt2 = ThisDrawing.Utility.GetPoint(varPnt1UCS, "Pick nut side")
dblHeight = Distance(varPnt1, varPnt2)
SolidBolt
SolidNut
End Sub
Function Add_UCS_improved(origin() As Double, xAxisPnt() _
As Double, yAxisPnt() As Double, ucsName As String) As AcadUCS
' origin, xAxisPnt, and yAxisPnt must all be dimmed (0 to 2)
Dim ucsObj As AcadUCS
Dim xAxisVec(0 To 2) As Double
Dim yAxisVec(0 To 2) As Double
Dim perpYaxisPnt(0 To 2) As Double
Dim xCy As Variant, perpYaxisVec As Variant
Debug.Print "xAxisPnt: " & xAxisPnt(0) & ", " & xAxisPnt(1) & ", " & xAxisPnt(2)
Debug.Print "yAxisPnt: " & yAxisPnt(0) & ", " & yAxisPnt(1) & ", " & yAxisPnt(2)
Debug.Print "origin: " & origin(0) & ", " & origin(1) & ", " & origin(2)
xAxisVec(0) = xAxisPnt(0) - origin(0)
xAxisVec(1) = xAxisPnt(1) - origin(1)
xAxisVec(2) = xAxisPnt(2) - origin(2)
yAxisVec(0) = yAxisPnt(0) - origin(0)
yAxisVec(1) = yAxisPnt(1) - origin(1)
yAxisVec(2) = yAxisPnt(2) - origin(2)
Debug.Print "xAxis: " & xAxisVec(0) & ", " & xAxisVec(1) & ", " & xAxisVec(2)
Debug.Print "yAxis: " & yAxisVec(0) & ", " & yAxisVec(1) & ", " & yAxisVec(2)
xCy = Cross3D(xAxisVec, yAxisVec)
Debug.Print "xCy: " & xCy(0) & ", " & xCy(1) & ", " & xCy(2)
perpYaxisVec = Cross3D(xCy, xAxisVec)
Debug.Print "perpYaxisVec: " & perpYaxisVec(0) & ", " & perpYaxisVec(1) & ", " & perpYaxisVec(2)
perpYaxisPnt(0) = perpYaxisVec(0) + origin(0)
perpYaxisPnt(1) = perpYaxisVec(1) + origin(1)
perpYaxisPnt(2) = perpYaxisVec(2) + origin(2)
Debug.Print "perpYaxisPnt: " & perpYaxisPnt(0) & ", " & perpYaxisPnt(1) & ", " & perpYaxisPnt(2)
Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, perpYaxisPnt, ucsName)
Set Add_UCS_improved = ucsObj
End Function
Function Cross3D(A As Variant, B As Variant) As Variant
' A and B must be dimensioned Double(0 to 2)
Dim C(0 To 2) As Double
C(0) = A(1) * B(2) - A(2) * B(1)
C(1) = -(A(0) * B(2) - A(2) * B(0))
C(2) = A(0) * B(1) - A(1) * B(0)
Cross3D = C
End Function
Function Distance(p1, p2) As Variant
Dim xDist As Variant
Dim yDist As Variant
Dim zDist As Variant
xDist = p1(0) - p2(0)
yDist = p1(1) - p2(1)
zDist = p1(2) - p2(2)
Distance = Sqr(xDist ^ 2 + yDist ^ 2 + zDist ^ 2)
End Function
Public Function RoundToValue(ByVal nValue, _
nCeiling As Double, Optional RoundUp As Boolean = True) _
As Double
Dim tmp As Integer
Dim tmpVal
If Not IsNumeric(nValue) Then Exit Function
nValue = CDbl(nValue)
'Round up to a whole integer -
'Any decimal value will force a round to the next integer.
'i.e. 0.01 = 1 or 0.8 = 1
tmpVal = ((nValue / nCeiling) + (-0.5 + (RoundUp And 1)))
tmp = Fix(tmpVal)
tmpVal = CInt((tmpVal - tmp) * 10 ^ 0)
nValue = tmp + tmpVal / 10 ^ 0
'Multiply by ceiling value to set RoundtoValue
RoundToValue = nValue * nCeiling
End Function
Function SolCylinder(diameter As Double, Height As Double)
'This function creates a 3D cylinder based on supplied data. Centre is the point at the start
'of the cylinder. Diameter is self explanatory. Height is the length of the cylinder
'A negative value acts the same as the extrude command.
Dim dblRadius As Double
Dim dblCenter(2) As Double
dblRadius = diameter / 2
'' calculate center point from input
dblCenter(0) = 0
dblCenter(1) = 0
dblCenter(2) = (Height / 2)
If Height < 0 Then
Height = -Height
End If
Set SolCylinder = ThisDrawing.ModelSpace.AddCylinder(dblCenter, dblRadius, Height)
End Function
Function RotateAngle(Point1 As Variant, Point2 As Variant)
Dim yAxisPnt(2) As Double
Dim xAxisPnt(2) As Double
Dim origin(2) As Double
Dim testUCS As AcadUCS
Dim dblAngle As Double
Dim dbla As Double
Dim dblb As Double
Dim dblc As Double
yAxisPnt(0) = Point1(0)
yAxisPnt(1) = Point1(1)
yAxisPnt(2) = Point1(2) + Distance(Point1, Point2)
origin(0) = Point1(0)
origin(1) = Point1(1)
origin(2) = Point1(2)
xAxisPnt(0) = Point2(0)
xAxisPnt(1) = Point2(1)
xAxisPnt(2) = Point2(2)
If Point1(0) = Point2(0) And Point1(1) = Point2(1) Then
RotateAngle = 0
Else
Set testUCS = Add_UCS_improved(origin, xAxisPnt, yAxisPnt, "test")
ThisDrawing.ActiveUCS = testUCS
dbla = Distance(origin, xAxisPnt)
dblb = dbla
dblc = Distance(yAxisPnt, xAxisPnt)
dblAngle = ((dbla ^ 2 + dblb ^ 2 - dblc ^ 2) / (2 * dbla * dblb))
dblAngle = Atn(-dblAngle / Sqr(-dblAngle * dblAngle + 1)) + 2 * Atn(1)
RotateAngle = -dblAngle
End If
End Function
Private Sub SolidBolt()
' Define the UCS pointsCyl
Dim xAxisPnt(0 To 2) As Double
xAxisPnt(0) = 1: xAxisPnt(1) = 0: xAxisPnt(2) = 0
Dim yAxisPnt(0 To 2) As Double
yAxisPnt(0) = 0: yAxisPnt(1) = 1: yAxisPnt(2) = 0
Dim zAxisPnt(0 To 2) As Double
zAxisPnt(0) = 0: zAxisPnt(1) = 0: zAxisPnt(2) = 1
Dim origin(2) As Double
origin(0) = 0#: origin(1) = 0#: origin(2) = 0#
' Add the UCS to the
' UserCoordinatesSystems collection
Dim ucsObj As AcadUCS
Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, zAxisPnt, "New_UCS")
' Make the new UCS the active UCS
ThisDrawing.ActiveUCS = ucsObj
Dim pointsCyl(0 To 9) As Double
Dim diameter As Double
Dim pi
pi = 4 * Atn(1)
diameter = DblDiameter
' Define the 2D polyline pointsCyl
pointsCyl(0) = 0: pointsCyl(1) = 0
pointsCyl(2) = ((0.8 * diameter) / Cos(30 * (pi / 180))): pointsCyl(3) = 0
pointsCyl(4) = ((0.8 * diameter) / Cos(30 * (pi / 180))): pointsCyl(5) = -((0.7 * diameter) - ((diameter / Cos(30 * (pi / 180))) - diameter))
pointsCyl(6) = 0.8 * diameter: pointsCyl(7) = -(0.7 * diameter)
pointsCyl(8) = 0: pointsCyl(9) = -(0.7 * diameter)
With ThisDrawing.ModelSpace
Dim PlineCyl As AcadLWPolyline
' Create a lightweight Polyline object in model space
Set PlineCyl = .AddLightWeightPolyline(pointsCyl)
PlineCyl.Closed = True
Dim RegionCyl(0) As Object
Set RegionCyl(0) = PlineCyl
Dim RegionC As Variant
RegionC = .AddRegion(RegionCyl)
Dim Axis(2) As Double
Axis(0) = 0#: Axis(1) = 0#: Axis(2) = 1#
Dim SolidCyl As Acad3DSolid
Set SolidCyl = .AddRevolvedSolid(RegionC(0), origin, Axis, 360)
End With
PlineCyl.Delete
RegionC(0).Delete
Dim dblLength As Double
dblLength = Distance(varPnt1, varPnt2)
dblLength = RoundToValue((dblLength + (0.2 * DblDiameter) + DblDiameter + 5), 5, True)
Dim pointsCha(0 To 5) As Double
pointsCha(0) = ((diameter / 2) - (0.075 * diameter)): pointsCha(1) = dblLength
pointsCha(2) = (diameter / 2): pointsCha(3) = dblLength
pointsCha(4) = (diameter / 2): pointsCha(5) = (dblLength - (0.075 * diameter))
With ThisDrawing.ModelSpace
Dim PlineCha As AcadLWPolyline
' Create a lightweight Polyline object in model space
Set PlineCha = .AddLightWeightPolyline(pointsCha)
PlineCha.Closed = True
Dim RegionCha(0) As Object
Set RegionCha(0) = PlineCha
Dim RegionCh As Variant
RegionCh = .AddRegion(RegionCha)
Dim SolidCha As Acad3DSolid
Set SolidCha = .AddRevolvedSolid(RegionCh(0), origin, Axis, 360)
End With
PlineCha.Delete
RegionCh(0).Delete
Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "New_UCS")
' Make the new UCS the active UCS
ThisDrawing.ActiveUCS = ucsObj
Dim pointsHex(0 To 11) As Double
pointsHex(0) = ((0.8 * diameter) / Cos(30 * (pi / 180))): pointsHex(1) = 0
pointsHex(2) = ((0.8 * diameter) * Tan(30 * (pi / 180))): pointsHex(3) = (0.8 * diameter)
pointsHex(4) = -((0.8 * diameter) * Tan(30 * (pi / 180))): pointsHex(5) = (0.8 * diameter)
pointsHex(6) = -((0.8 * diameter) / Cos(30 * (pi / 180))): pointsHex(7) = 0
pointsHex(8) = -((0.8 * diameter) * Tan(30 * (pi / 180))): pointsHex(9) = -(0.8 * diameter)
pointsHex(10) = ((0.8 * diameter) * Tan(30 * (pi / 180))): pointsHex(11) = -(0.8 * diameter)
With ThisDrawing.ModelSpace
Dim PlineHex As AcadLWPolyline
' Create a lightweight Polyline object in model space
Set PlineHex = .AddLightWeightPolyline(pointsHex)
PlineHex.Closed = True
Dim RegionHex(0) As Object
Set RegionHex(0) = PlineHex
Dim RegionH As Variant
RegionH = .AddRegion(RegionHex)
Dim SolidHex As Acad3DSolid
Set SolidHex = .AddExtrudedSolid(RegionH(0), -(0.7 * diameter), 0)
SolidCyl.Boolean acIntersection, SolidHex
Dim SolidShaft As Acad3DSolid
Set SolidShaft = SolCylinder(DblDiameter, dblLength)
SolidCyl.Boolean acUnion, SolidShaft
SolidCyl.Boolean acSubtraction, SolidCha
SolidCyl.Move origin, varPnt1
SolidCyl.Rotate varPnt1, RotateAngle(varPnt1, varPnt2)
SolidCyl.Update
Dim SolidWash1 As Acad3DSolid
Dim SolidWash2 As Acad3DSolid
Set SolidWash1 = SolCylinder((2 * DblDiameter), (0.2 * DblDiameter))
Set SolidWash2 = SolCylinder(DblDiameter, (0.2 * DblDiameter))
SolidWash1.Boolean acSubtraction, SolidWash2
SolidWash1.Move origin, varPnt1
SolidWash1.Rotate varPnt1, RotateAngle(varPnt1, varPnt2)
SolidWash1.Move varPnt1, varPnt2
SolidWash1.Update
PlineHex.Delete
RegionH(0).Delete
End With
End Sub
Private Sub SolidNut()
' Define the UCS pointsCyl
Dim xAxisPnt(0 To 2) As Double
xAxisPnt(0) = 1: xAxisPnt(1) = 0: xAxisPnt(2) = 0
Dim yAxisPnt(0 To 2) As Double
yAxisPnt(0) = 0: yAxisPnt(1) = 1: yAxisPnt(2) = 0
Dim zAxisPnt(0 To 2) As Double
zAxisPnt(0) = 0: zAxisPnt(1) = 0: zAxisPnt(2) = 1
Dim origin(2) As Double
origin(0) = 0#: origin(1) = 0#: origin(2) = 0#
' Add the UCS to the
' UserCoordinatesSystems collection
Dim ucsObj As AcadUCS
Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, zAxisPnt, "New_UCS")
' Make the new UCS the active UCS
ThisDrawing.ActiveUCS = ucsObj
Dim pointsCyl(0 To 11) As Double
Dim diameter As Double
Dim pi
pi = 4 * Atn(1)
diameter = DblDiameter
' Define the 2D polyline pointsCyl
pointsCyl(0) = diameter / 2: pointsCyl(1) = 0
pointsCyl(2) = 0.8 * diameter: pointsCyl(3) = 0
pointsCyl(4) = ((0.8 * diameter) / Cos(30 * (pi / 180))): pointsCyl(5) = -((diameter / Cos(30 * (pi / 180))) - diameter)
pointsCyl(6) = ((0.8 * diameter) / Cos(30 * (pi / 180))): pointsCyl(7) = -((0.8 * diameter) - ((diameter / Cos(30 * (pi / 180))) - diameter))
pointsCyl(8) = 0.8 * diameter: pointsCyl(9) = -(0.8 * diameter)
pointsCyl(10) = diameter / 2: pointsCyl(11) = -(0.8 * diameter)
With ThisDrawing.ModelSpace
Dim PlineCyl As AcadLWPolyline
' Create a lightweight Polyline object in model space
Set PlineCyl = .AddLightWeightPolyline(pointsCyl)
PlineCyl.Closed = True
Dim RegionCyl(0) As Object
Set RegionCyl(0) = PlineCyl
Dim RegionC As Variant
RegionC = .AddRegion(RegionCyl)
Dim Axis(2) As Double
Axis(0) = 0#: Axis(1) = 0#: Axis(2) = 1#
Dim SolidCyl As Acad3DSolid
Set SolidCyl = .AddRevolvedSolid(RegionC(0), origin, Axis, 360)
End With
PlineCyl.Delete
RegionC(0).Delete
Dim dblLength As Double
dblLength = Distance(varPnt1, varPnt2)
dblLength = RoundToValue((dblLength + DblDiameter), 5, True)
Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "New_UCS")
' Make the new UCS the active UCS
ThisDrawing.ActiveUCS = ucsObj
Dim pointsHex(0 To 11) As Double
pointsHex(0) = ((0.8 * diameter) / Cos(30 * (pi / 180))): pointsHex(1) = 0
pointsHex(2) = ((0.8 * diameter) * Tan(30 * (pi / 180))): pointsHex(3) = (0.8 * diameter)
pointsHex(4) = -((0.8 * diameter) * Tan(30 * (pi / 180))): pointsHex(5) = (0.8 * diameter)
pointsHex(6) = -((0.8 * diameter) / Cos(30 * (pi / 180))): pointsHex(7) = 0
pointsHex(8) = -((0.8 * diameter) * Tan(30 * (pi / 180))): pointsHex(9) = -(0.8 * diameter)
pointsHex(10) = ((0.8 * diameter) * Tan(30 * (pi / 180))): pointsHex(11) = -(0.8 * diameter)
With ThisDrawing.ModelSpace
Dim PlineHex As AcadLWPolyline
' Create a lightweight Polyline object in model space
Set PlineHex = .AddLightWeightPolyline(pointsHex)
PlineHex.Closed = True
Dim RegionHex(0) As Object
Set RegionHex(0) = PlineHex
Dim RegionH As Variant
RegionH = .AddRegion(RegionHex)
Dim SolidHex As Acad3DSolid
Set SolidHex = .AddExtrudedSolid(RegionH(0), -(0.8 * diameter), 0)
SolidCyl.Boolean acIntersection, SolidHex
Dim nutLen(0 To 2) As Double
nutLen(0) = 0: nutLen(1) = 0: nutLen(2) = (Distance(varPnt1, varPnt2) + diameter)
SolidCyl.Move origin, nutLen
SolidCyl.Move origin, varPnt1
SolidCyl.Rotate varPnt1, RotateAngle(varPnt1, varPnt2)
SolidCyl.Update
PlineHex.Delete
RegionH(0).Delete
End With
End Sub
