TheSwamp
Code Red => VB(A) => Topic started by: Troy Williams on September 27, 2005, 01:16:18 PM
-
Does anyone have a code sample that offsets a polyline similar to the offset command in AutoCAD?
-
I kinda did that a few years ago using vba to take a polyline profile of one side of an extrusion to calculate some breakmetal bends. It is quite a lot of code. If you want to parse thru it to get what you want, I'll be glad to post.
-
I kinda did that a few years ago using vba to take a polyline profile of one side of an extrusion to calculate some breakmetal bends. It is quite a lot of code. If you want to parse thru it to get what you want, I'll be glad to post.
Thanks for the offer, I appreciate it.
I have a good idea on what needs to be done but I can't seem to figure out the starting point. The way I see it is that a polyline can consist of hundreds of segments (I am only interested in straight segments, no fancy stuff like bulges) and can be opened or closed. The first step is to determine which side the offset is on (left, right, top, bottom, inside or outside). Each segment needs to be offset by a certain amount along a line that is perpendicular to the line segment. The perpendicular is the one that points in the correct offset direction (either positive or negative). Once I have the correct perpendicular line then I can easily create an offset of the line segment. Since all polylines are either clockwise or counter-clockwise I can pretty much use the first perpendicular as a reference to tell me wheather each of the segments use a positive or negative perpendicular offset. From there it is simply a matter of finding all the intersection points of the adjacent segments and constructing the offset entity.
I hope that made sense. I am having problems figuring out if the perpendicular offset should be negative or positive. I'd love to post a diagram, but I won't have access to a proper system till next week.
-
Hi Troy,
I think you are looking too deep into this. Wouldn't be easier to just offset the pline instead of the individual segments? Plines are offset with a positive value being to the right, and negative to the left, in relation to the direction they were drawn. So that leaves just finding the side that is selected when the offset is a given distance, and finding the perpendicular distance at the specified point for a "Through" distance.
Does that make it any simpler?
-
Hi Troy,
I think you are looking too deep into this. Wouldn't be easier to just offset the pline instead of the individual segments? Plines are offset with a positive value being to the right, and negative to the left, in relation to the direction they were drawn. So that leaves just finding the side that is selected when the offset is a given distance, and finding the perpendicular distance at the specified point for a "Through" distance.
Does that make it any simpler?
Jeff, that does make it simpler! I'll see if I can work out the math today. Thanks!
-
Well, if you can do that then this may be overkill but here it is anyway. There will be way more here than you are interested in and I'm sorry for bad coding techniques but this is a few years old. Of course you will not be interested in the buldges but I needed them to show the sheetmetal bends.
here is the form code:
'frmMain
Option Explicit
' form scope variables
' the offset (thickness of the shape)
Private dOffset As Double
' Insertion Point
Private Ipt(0 To 2) As Double
' Viewport scale
Private ViewScale As Double
' how many breaks
Private Breaks As Integer
' the blank length
Private brkLength As Double
' break calculation modifier
Private dblModifier As Double
Private Sub Go()
Dim varCoords As Variant
Dim NewCoords() As Double
' the three points necessary to build an angular dimension
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double
Dim pt3(0 To 2) As Double
Dim varRet As Variant
Dim varStPt As Variant
Dim ObjEntity As AcadLWPolyline
Dim objNewEntity As AcadLWPolyline
Dim angle1 As Double
Dim angle2 As Double
Dim angle3 As Double
Dim Dir1 As Double
Dim Dir2 As Double
Dim DistTemp As Double
Dim Dist1 As Double
Dim Dist2 As Double
Dim Plus As Boolean
Dim aPlus As Boolean
Dim I As Integer
Dim J As Integer
Dim count As Integer
Dim NewCount As Integer
Dim currentY As Integer
Dim currentOppY As Integer
Dim ProjectExist As Boolean
Dim CurrSegCount As Integer
Dim CurrOppSegCount As Integer
Dim BulgeArray() As Integer
Dim AngleArray() As Double
Const x = 0
Const y = 1
' get the ployline
Set ObjEntity = Get_Poly
' if it's a closed polyline then it's going to look funky
If ObjEntity.Closed Then
MsgBox "This is a closed polyline, Hmmm..." & vbCr & _
"I REALLY Don't think you want to do that.. I quit"
End
End If
varCoords = ObjEntity.Coordinates
' if there are less than 5 points then you can't
' get an angle
If UBound(varCoords) < 5 Then ' inform and insult the user
MsgBox "This polyline has less than 2 sides you dork"
Exit Sub
End If
' set the new coordinates boundaries
count = UBound(varCoords)
ReDim NewCoords(count * 3)
NewCount = UBound(NewCoords)
' get the first vector of the polyline and the direction from point1 to point2
pt1(x) = varCoords(0): pt1(y) = varCoords(1)
pt2(x) = varCoords(2): pt2(y) = varCoords(3)
Dir1 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
' get the middle point so we can get a direction
Dist1 = Distance(pt1, pt2)
varStPt = ThisDrawing.Utility.PolarPoint(pt1, Dir1, 0.5 * Dist1)
angle1 = ThisDrawing.Utility.GetAngle(varStPt, "Pick Side To Offset: ")
' do we add 90 along the path or subtract 90 for the offset direction
Plus = isPlus(Dir1, angle1)
' and the array of the buldges
ReDim BulgeArray(CInt((count - 3) / 2) - 1)
ReDim AngleArray(UBound(BulgeArray))
' set the breaks to this number plus one
Breaks = UBound(BulgeArray) + 1
Dim TmpCount As Integer
' calculate the total segment count
TmpCount = CInt((count - 1) / 2)
TmpCount = (TmpCount * 2) + TmpCount
'initialize the j counter and the segment counters
J = 0
CurrSegCount = 0
CurrOppSegCount = TmpCount
' loop thru the points and process the polyline
For I = 5 To count Step 2
' points 1 thru 3
pt1(x) = varCoords(I - 5): pt1(y) = varCoords(I - 4)
pt2(x) = varCoords(I - 3): pt2(y) = varCoords(I - 2)
pt3(x) = varCoords(I - 1): pt3(y) = varCoords(I)
' get the distances
Dist1 = Distance(pt1, pt2)
Dist2 = Distance(pt2, pt3)
' get the directions
Dir1 = ThisDrawing.Utility.AngleFromXAxis(pt2, pt1)
Dir2 = ThisDrawing.Utility.AngleFromXAxis(pt2, pt3)
' set the small angle
angle1 = SmallAngle(Dir1, Dir2)
' reverse the direction of the first vector to follow the polyline path
Dir1 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
' set the angle perpendicular to the current vector
If Plus Then
angle2 = Dir1 + dtr(90)
Else
angle2 = Dir1 - dtr(90)
End If
' is the current angle in the plus direction or not
aPlus = isPlus(Dir1, Dir2)
' first we sould test to see whether this is the first angle
' if it is then do the square corner stuff
If I = 5 Then ' first segment
' set the first and last points of the new polyline
' First Point
NewCoords(x) = varCoords(x): NewCoords(y) = varCoords(y)
' last point
NewCoords(NewCount - 1) = varCoords(x): NewCoords(NewCount) = varCoords(y)
' second to last point - move over the offset distance
varRet = ThisDrawing.Utility.PolarPoint(pt1, angle2, dOffset)
' set the coordinates
NewCoords(NewCount - 3) = varRet(x): NewCoords(NewCount - 2) = varRet(y)
' set the current y place and the opposite y place
currentY = 1
currentOppY = NewCount - 2
' segment index for the buldge calculation
CurrSegCount = 1
CurrOppSegCount = CurrOppSegCount - 2
End If
' do we project the bulge points on the existing line or the projected line
If Plus Then
If aPlus Then
ProjectExist = True
Else
ProjectExist = False
End If
Else
If aPlus Then
ProjectExist = False
Else
ProjectExist = True
End If
End If
' now calculate offset distance
If angle1 = 0 Then angle1 = dtr(360)
DistTemp = (dOffset / (Tan(0.5 * angle1)))
If angle1 = dtr(360) Then angle1 = 0
If ProjectExist Then ' project the buldge on the existing line
' go back dir1
varRet = ThisDrawing.Utility.PolarPoint(pt2, Dir1 - dtr(180), DistTemp)
NewCoords(currentY + 1) = varRet(x): NewCoords(currentY + 2) = varRet(y)
' now set the opposite corner
varRet = ThisDrawing.Utility.PolarPoint(varRet, angle2, dOffset)
NewCoords(currentOppY - 3) = varRet(x): NewCoords(currentOppY - 2) = varRet(y)
' now go up dir2
varRet = ThisDrawing.Utility.PolarPoint(pt2, Dir2, DistTemp)
NewCoords(currentY + 3) = varRet(x): NewCoords(currentY + 4) = varRet(y)
' reset currenty and opposite y
currentY = currentY + 4
currentOppY = currentOppY - 2
' set the buldge and move the counters
BulgeArray(J) = CurrSegCount
AngleArray(J) = Tan((dtr(180) - angle1) / 4)
CurrSegCount = CurrSegCount + 2
CurrOppSegCount = CurrOppSegCount - 1
Else ' project the buldge on the new line
' set angle3 to the perpendicular of the second line
If Plus Then
angle3 = Dir2 + dtr(90)
Else
angle3 = Dir2 - dtr(90)
End If
' set the existing
NewCoords(currentY + 1) = pt2(x): NewCoords(currentY + 2) = pt2(y)
' do the opposite
varRet = ThisDrawing.Utility.PolarPoint(pt2, angle2, dOffset)
NewCoords(currentOppY - 3) = varRet(x): NewCoords(currentOppY - 2) = varRet(y)
varRet = ThisDrawing.Utility.PolarPoint(pt2, angle3, dOffset)
NewCoords(currentOppY - 5) = varRet(x): NewCoords(currentOppY - 4) = varRet(y)
' reset the running counts of y placeholders
currentY = currentY + 2
currentOppY = currentOppY - 4
' set the buldge and move the counters
BulgeArray(J) = CurrOppSegCount
AngleArray(J) = Tan((dtr(180) - angle1) / 4)
CurrOppSegCount = CurrOppSegCount - 2
CurrSegCount = CurrSegCount + 1
End If
' If it's the last one then do the last stuff
If I = count Then ' the last one
' reset the offset angle to match
If Plus Then
angle2 = Dir2 + dtr(90)
Else
angle2 = Dir2 - dtr(90)
End If
NewCoords(currentY + 1) = varCoords(count - 1): NewCoords(currentY + 2) = varCoords(count)
' get the point we need
varRet = ThisDrawing.Utility.PolarPoint(pt3, angle2, dOffset)
' set the coordinates
NewCoords(currentY + 3) = varRet(x): NewCoords(currentY + 4) = varRet(y)
End If
' increment the buldge counter
J = J + 1
Next I
' make the polyline
Set objNewEntity = ThisDrawing.ModelSpace.AddLightWeightPolyline(NewCoords)
' do the bulges
Dim tmpDir As Double
For J = 0 To UBound(BulgeArray)
' which direction
If Plus Then
tmpDir = AngleArray(J)
Else
tmpDir = -AngleArray(J)
End If
objNewEntity.SetBulge BulgeArray(J), tmpDir
Next J
objNewEntity.Closed = True
' update the pline
objNewEntity.Update
' find the size of the object drawn so we can calculate the viewport
' and determine the scale factor
Dim varMin As Variant
Dim varMax As Variant
Dim Width As Double
Dim Height As Double
objNewEntity.GetBoundingBox varMin, varMax
' set the center point to be used by the viewport code
Ipt(0) = ((varMax(0) - varMin(0)) / 2) + varMin(0)
Ipt(1) = ((varMax(1) - varMin(1)) / 2) + varMin(1)
' get the height and width
Width = varMax(0) - varMin(0) + dOffset
Height = varMax(1) - varMin(1) + dOffset
If Width > 9.3 Or Height > 6.5 Then
ThisDrawing.SetVariable "Dimscale", 2
ViewScale = 0.5
Else
ThisDrawing.SetVariable "Dimscale", 1
ViewScale = 1
End If
' dimension the original one
Call DoDims(varCoords, ObjEntity)
End Sub
' takes a vector and a direction from the vector and returns
' whether or not the offset side perpendicular would be an addition
' of ninety degrees or a subtraction of ninety degrees from the
' original vector direction
Private Function isPlus(Vector As Double, Side As Double) As Boolean
Dim angle1 As Double
Dim angle2 As Double
angle1 = Vector
angle2 = Vector + dtr(180)
If angle2 > dtr(360) Then angle2 = angle2 - dtr(360)
If angle2 > angle1 Then ' angle 2 is the large one
If Side > angle1 And Side < angle2 Then
isPlus = True
Else
isPlus = False
End If
Else ' angle 1 is the large one
If Side > angle2 And Side < angle1 Then
isPlus = False
Else
isPlus = True
End If
End If
End Function
' get's the smallest angle of two vectors
Private Function SmallAngle(Vector1 As Double, Vector2 As Double) As Double
' subtract the smaller angle from the smaller one
If Vector1 > Vector2 Then
SmallAngle = Vector1 - Vector2
Else
SmallAngle = Vector2 - Vector1
End If
If SmallAngle > dtr(180) Then SmallAngle = dtr(360) - SmallAngle
End Function
Private Sub cmdGo_Click()
' get the aluminum thickness and select the
' modifier and the thickness
Select Case listType.ListIndex
Case 0
dblModifier = 0.076
dOffset = 0.05
Case 1
dblModifier = 0.095
dOffset = 0.0625
Case 2
dblModifier = 0.1425
dOffset = 0.09
Case 3
dblModifier = 0.19
dOffset = 0.125
Case 4
dblModifier = 0.285
dOffset = 0.1875
Case Else
' this should never happen so inform the user and exit
MsgBox "Something is wrong, see the programmer: "
Exit Sub
End Select
Me.Hide
Call Go
Call MakeLayout
End Sub
Private Sub DoDims(varCoords As Variant, ObjEntity As AcadEntity)
Dim txtHeight As Double
Dim DimOffset As Double
' the three points necessary to build an angular dimension
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double
Dim pt3(0 To 2) As Double
' running blank and total length
Dim dblLength As Double
Dim dblTotalLength As Double
' included angle for calculations
Dim dblAngle As Double
' distance between the 2 end points for calculating
' the dimension text location
Dim dblDist As Double
' use x for x and y for y, z for z if needed
Const x = 0: Const y = 1: Const z = 2
' integer counter
Dim I As Integer
' left and right points for the dimensions
Dim lpt As Variant
Dim rpt As Variant
' get the drawing scale and set the text height and dimension var's
DwgScale = ThisDrawing.GetVariable("dimscale")
txtHeight = DwgScale * 0.125
DimOffset = DwgScale * 1
' point for the angular text location (temporary)
Dim varPT As Variant
' dimension object (temporary)
Dim objDim As AcadDimAngular
' set the initial length to zero
dblLength = 0
dblTotalLength = 0
' loop thru the polyline, extract the vertexes
' and calculate the angles, length and break distances
For I = 5 To UBound(varCoords) Step 2
' points 1 thru 3
pt1(x) = varCoords(I - 5)
pt1(y) = varCoords(I - 4)
pt2(x) = varCoords(I - 3)
pt2(y) = varCoords(I - 2)
pt3(x) = varCoords(I - 1)
pt3(y) = varCoords(I)
' add linear dimensions
lpt = pt1
rpt = pt2
' get the angle of the first line so we can draw the dimension
dblAngle = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
' draw the dimension
Call DrawDim(lpt, rpt, DimOffset, dblAngle, "STD1")
' test for the last line segment and if it is then draw the dimension
If I = UBound(varCoords) Then
lpt = pt2
rpt = pt3
dblAngle = ThisDrawing.Utility.AngleFromXAxis(pt2, pt3)
Call DrawDim(lpt, rpt, DimOffset, dblAngle, "STD1")
End If
' add the length of point 1 and 2
dblLength = dblLength + Distance(pt1, pt2)
dblTotalLength = dblTotalLength + Distance(pt1, pt2)
' get the distance of the 2 outer end points
dblDist = Distance(pt1, pt3)
' get the angle so we can get the halfway point
dblAngle = ThisDrawing.Utility.AngleFromXAxis(pt1, pt3)
' get the halfway point , we will use this to give us
' a text location for the temporary dimension
varPT = ThisDrawing.Utility.PolarPoint _
(pt1, dblAngle, 0.5 * dblDist)
' draw the dimension
Set objDim = ThisDrawing.ModelSpace.AddDimAngular _
(pt2, pt1, pt3, varPT)
' get the angle between the two segments
dblAngle = rtd(objDim.Measurement)
' if more than ninety then use the excluded angle
If dblAngle > 90 Then
dblAngle = 180 - dblAngle
End If
' subtract the break length calculated
dblLength = dblLength - ((dblAngle / 90) * dblModifier)
' if this is the last one then add the last chord
If I = UBound(varCoords) Then
dblLength = dblLength + Distance(pt2, pt3)
dblTotalLength = dblTotalLength + Distance(pt2, pt3)
End If
Next I
' show the user what the length is
' now it's time to get the text location
' get the bounding box coordinates
Dim varMin As Variant
Dim varMax As Variant
ObjEntity.GetBoundingBox varMin, varMax
' set the center point to be used by the viewport code
Ipt(0) = ((varMax(0) - varMin(0)) / 2) + varMin(0)
Ipt(1) = ((varMax(1) - varMin(1)) / 2) + varMin(1)
' set the break length variable to be used in the title block
brkLength = dblLength
' delete the original polyline because we don't need it anymore
ObjEntity.Delete
' now, let's zoom extents so you can see it all, baby
ThisDrawing.Application.ZoomCenter Ipt, 1
End Sub
-
I had to break it up because it was too long
second part of the frmMain code
Private Sub MakeLayout()
Dim strTitleBlock As String
Dim strFile
Dim I As Long
Dim objLayout As AcadLayout
Dim objViewPort As AcadPViewport
Dim objObject As AcadObject
Dim BlkRef As AcadBlockReference
Dim Ipt1(0 To 2) As Double
On Error GoTo err_Handler
strTitleBlock = "TitleBlock"
' NOTE: The drawing 'BKML.dwg' must be in the support path
strFile = "BKMTL.dwg"
' first, let's add the layout
Set objLayout = ThisDrawing.Layouts.Add(strTitleBlock)
' zoom the drawint
Application.ZoomCenter Ipt, ViewScale
' make the layout and go to paper space
ThisDrawing.ActiveLayout = ThisDrawing.Layouts(strTitleBlock)
ThisDrawing.ActiveSpace = acPaperSpace
' set the insertion point to 0,0
Ipt1(0) = 0: Ipt1(1) = 0
' insert the title block
Set BlkRef = ThisDrawing.PaperSpace.InsertBlock(Ipt1, strFile, 1, 1, 1, 0)
ThisDrawing.Application.ZoomCenter Ipt, ViewScale
' set the middle of the viewport
Ipt1(0) = 4.9375: Ipt1(1) = 5#
Set objViewPort = ThisDrawing.PaperSpace.AddPViewport(Ipt1, 9.375, 6.625)
ThisDrawing.ActiveSpace = acModelSpace
' zoom the viewport
ThisDrawing.Application.ZoomCenter Ipt, ViewScale
' go back to paper space
ThisDrawing.ActiveSpace = acPaperSpace
objViewPort.Visible = True
objViewPort.Display True
objViewPort.StandardScale = acVpCustomScale
objViewPort.CustomScale = ViewScale
objViewPort.DisplayLocked = True
ThisDrawing.Regen acAllViewports
ThisDrawing.Application.ZoomExtents
' now, delete all of the layouts
Set objLayout = Nothing
For Each objLayout In ThisDrawing.Layouts
If objLayout.Name = "Layout1" Then
objLayout.Delete
ElseIf objLayout.Name = "Layout2" Then
objLayout.Delete
End If
Next objLayout
' now let's insert the Title Info and fill in the data
Dim varAttrib As Variant
Dim attribObj As AcadAttributeReference
' the block name
strFile = "BrkInfo"
' set the insertion point
Ipt1(0) = 0.25: Ipt1(1) = 1.1875
' round the blank length to 3 spaces
brkLength = RoundExt(brkLength, 3)
Set BlkRef = ThisDrawing.PaperSpace.InsertBlock(Ipt1, strFile, 1, 1, 1, 0)
varAttrib = BlkRef.GetAttributes
' fix the attributes text strings
For I = LBound(varAttrib) To UBound(varAttrib)
Set attribObj = varAttrib(I)
Select Case attribObj.TagString
Case "QUANTITY"
attribObj.TextString = "1"
Case "MARK"
attribObj.TextString = "A"
Case "DESC"
attribObj.TextString = "Description"
Case "LENGTH"
attribObj.TextString = "1"
Case "BLANK"
attribObj.TextString = CStr(brkLength)
Case "BREAKS"
attribObj.TextString = CStr(Breaks)
Case "BAYMARK"
attribObj.TextString = "Bay"
Case "REMARKS"
attribObj.TextString = "Remarks"
Case Else
End Select
Next I
' update the blkreference
BlkRef.Update
' Finished - Yeah
Exit Sub
err_Handler:
Select Case Err.Number
Case -2145386475 ' Title block layout already exists
Err.Clear
MsgBox "You already have a Title Block Layout " & vbCr & _
"Make sure You aren't duplicating Title BLocks"
Resume Next
Case Else
MsgBox Err.Number & " " & Err.Description
End Select
End Sub
Private Sub UserForm_Initialize()
' fill the aluminum thickenss text box
listType.AddItem "0.05"
listType.AddItem "0.0625"
listType.AddItem "0.09"
listType.AddItem "0.125"
listType.AddItem "0.1875"
' set the initial index to the first one
listType.ListIndex = 0
End Sub
-
here is the code from the main module with some helper functions which I cannot take credit for a couple of them:
'' breakmetal.dvb
'' 5/2/01
'' runs inside autocad to extract vertexes and lengths from
'' lightweightpolylines drawn by the user to calculate the
'' break length of sheetmetal
''
'' calculations are dependant upon the included angle of the
'' vertex and the thickness of the aluminum used
''
'' if the included angle is greater than 90 then the opposite
'' angle is used - for some reason for more than 90 degrees the
'' amount adjusted is equal to the opposite side angle
''
'' Vba only lets me get the array of points in x and y values
'' since I had to get lengths and angles I used to following techniques:
'' For lengths I created a function call "Distance" using trig
'' For the angles I created an angular dimension using the endpoints and
'' the vertex along with a text location I calculated from a point halfway
'' of an imaginary line between the two end points - pt1, and pt3
'' I then extracted the measurement in radians and converted to degrees
'' for the calculation and then delete the dimension
' public variables
' the drawing scale factor
Public DwgScale As Double
' main sub
Public Sub Main()
frmMain.Show
End Sub
' get lwpolyline sub
Public Function Get_Poly() As AcadLWPolyline
Dim ObjEntity As AcadLWPolyline
Dim varPoint As Variant
On Error GoTo PickError:
ThisDrawing.Utility.GetEntity _
ObjEntity, varPoint, "Please Pick a PolyLine: "
Set Get_Poly = ObjEntity
Exit Function
PickError:
Dim Answer As Integer
' display a message in case the user picked something
' other than a lightweightpolyline or did not pick
' anything at all
Answer = MsgBox("You did not pick a polyline!" _
& vbLf & "Try Again?", 52, "Break Metal")
' if the answer is not "OK" then end the program
If Answer <> 6 Then
End
End If
' if the answer is "OK" then try again
Resume
End Function
' obtain distance function from 2 points
Function Distance(sp As Variant, ep As Variant)
Dim x As Double
Dim y As Double
Dim z As Double
x = sp(0) - ep(0)
y = sp(1) - ep(1)
z = sp(2) - ep(2)
Distance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function
' radians to degress function
Function rtd(rad As Double) As Double
rtd = (rad / PI) * 180
End Function
' degrees to rad
Public Function dtr(a As Double) As Double
dtr = (a / 180) * PI()
End Function
' the pi forumula for the dtr and rdt functions
Public Function PI() As Double
PI = Atn(1) * 4
End Function
' draws a rotated dimension
Sub DrawDim(lpt As Variant, rpt As Variant, Offset As Double, _
DimDir As Double, Dimtype As String)
Dim NewDimStyle As AcadDimStyle
Dim DimObj As AcadDimRotated
Dim LdimPt(0 To 2) As Double
Dim RdimPt(0 To 2) As Double
Dim DimLoc(0 To 2) As Double
Dim TempVar As Variant
Dim DimDir90 As Double
On Error GoTo BlkError
' set the current dimension style to the Dimtype parameter
' passed to the program
Set NewDimStyle = ThisDrawing.DimStyles.Item(Dimtype)
ThisDrawing.ActiveDimStyle = NewDimStyle
ThisDrawing.SetVariable "Dimscale", DwgScale
ThisDrawing.ActiveDimStyle.CopyFrom ThisDrawing
' left and right dimension points
LdimPt(0) = lpt(0): LdimPt(1) = lpt(1)
RdimPt(0) = rpt(0): RdimPt(1) = rpt(1)
TempVar = lpt
' 90degrees from dimension direction
DimDir90 = dtr(90) + DimDir
' get the dimension location
TempVar = ThisDrawing.Utility.PolarPoint(TempVar, DimDir90, Offset)
DimLoc(0) = TempVar(0): DimLoc(1) = TempVar(1)
' create the dimension object
Set DimObj = ThisDrawing.ModelSpace.AddDimRotated(LdimPt, RdimPt, DimLoc, DimDir)
Exit Sub
BlkError:
Select Case Err.Number
Case -2145386476 ' dimstyle does not exist
Resume Next
Case Else
Exit Sub
End Select
End Sub
' checks to see if a number is even or NOT
Public Function isEven(iNum As Integer) As Boolean
Dim Answer As Boolean
If iNum Mod 2 = 0 Then
Answer = True
Else
Answer = False
End If
isEven = Answer
End Function
hope this helps...
-
Draftek, thank you for posting the code! I will take a look at it and see how it works.
Thanks again!
-
hmmmmmm .. wonder what hatch is doing these days ?
-
Thank you Draftek!
I do need this, but it returns error message.
Could you repair it available and upload it.
Helping me,much much ...... appreciated.
-
I deal with closed polyines, so you may have to adjust the code and make it deal with one more vertex.
This code offsets a polyline. The returned area if bigger or smaller tells you the direction of the verticies too.
Public Function DirPolSante(polyEnt As AcadEntity) As String
Dim OffsetObj As Variant
Dim AreaObj As Double
Dim AreaOffset As Double
AreaObj = polyEnt.Area
OffsetObj = polyEnt.Offset(0.01)
AreaOffset = OffsetObj(0).Area
OffsetObj(0).Delete
If AreaOffset < AreaObj Then
VertDir = "Clockwise"
Else
VertDir = "CounterClockwise"
End If
End Function
this finds the area if needed:
Public Function polyArea(arrPts() As Double) As Double
Dim intloop As Integer
Dim intLow As Integer
Dim intHigh As Integer
Dim dblArea As Double
intLow = LBound(arrPts)
intHigh = UBound(arrPts)
For intloop = intLow To intHigh - 3 Step 3
dblArea = dblArea + (arrPts(intloop) * arrPts(intloop + 4)) - (arrPts(intloop + 0) * arrPts(intloop + 1))
Next intloop
dblArea = dblArea + (arrPts(intHigh - 1 * arrPts(1))) - (arrPts(intHigh - 1) * arrPts(0))
polyArea = dblArea / 2
polyArea2 = polyArea
End Function
This reverses a open LWpolyline:
Private Sub revPline(polyEnt As AcadLWPolyline)
Dim idx As Integer
Dim numPts As Integer
Dim numBulge As Integer
Dim bulge As Double
'set an array to store the coordinates of the pline
Dim newcoord() As Double
numPts = UBound(polyEnt.Coordinates) - 1
ReDim newcoord(numPts + 1)
'set an array to store the bludge factor for each segment
Dim newbulge() As Double
numBulge = ((numPts - 3) / 2)
If ((UBound(polyEnt.Coordinates) + 1) / 2) Mod 2 = 0 Then
GoTo myout
Else
numBulge = numBulge + 1
End If
myout:
ReDim newbulge(numBulge)
'loop through the vertices of the pline and save x,y in reverse order
For idx = 0 To numPts Step 2
newcoord(numPts - idx) = polyEnt.Coordinates(idx)
newcoord(numPts - idx + 1) = polyEnt.Coordinates(idx + 1)
Next idx
'loop through the bulge factors and save in reverse order
For idx = 0 To numBulge
newbulge(numBulge - idx) = polyEnt.GetBulge(idx) * -1
Next idx
'reverse the original pline
polyEnt.Coordinates = newcoord
For idx = 0 To numBulge
polyEnt.SetBulge idx, newbulge(idx)
Next idx
polyEnt.Update
End Sub
This reverses a closed LWpolyline:
Private Sub reverse_pline(polyEnt As AcadLWPolyline)
Dim idx As Integer
Dim numPts As Integer
Dim numBulge As Integer
Dim bulge As Double
'set an array to store the coordinates of the pline
Dim newcoord() As Double
numPts = UBound(polyEnt.Coordinates) - 1 'was -1
ReDim newcoord(numPts + 1) 'was 1
'set an array to store the bludge factor for each segment
Dim newbulge() As Double
numBulge = (((numPts)) / 2) 'was -3)/2
ReDim newbulge(numBulge)
'loop through the vertices of the pline and save x,y in reverse order
For idx = 0 To numPts Step 2
newcoord(numPts - idx) = polyEnt.Coordinates(idx)
newcoord(numPts - idx + 1) = polyEnt.Coordinates(idx + 1) 'was +1 in 2 places
Next idx
'loop through the bulge factors and save in reverse order
For idx = 0 To numBulge
If idx <> numBulge Then
newbulge(numBulge - idx) = polyEnt.GetBulge(idx) * -1
Else
newbulge(0) = polyEnt.GetBulge(idx) * -1
End If
Next idx
'reverse the original pline
polyEnt.Coordinates = newcoord
For idx = 0 To numBulge
If idx = 0 Then
polyEnt.SetBulge (numBulge), newbulge(idx)
Else
polyEnt.SetBulge (idx - 1), newbulge(idx)
End If
Next idx
polyEnt.Update
End Sub
This converts a LWpolyline toa 2D polyline. Great for older CNC programs when you have to have 2D poly a tthe end of your code. ACAD does a much better with Pedit on LW polylines (sendcommand):
Public Function polyentconvert(polyEnt As Object) As AcadPolyline
Dim entity As AcadDocument
Set entity = AutoCAD_Application.ActiveDocument
Dim I As Integer, j As Integer, K As Integer
If polyEnt.EntityName = "AcDbPolyline" Then
Dim Coords As Variant
Coords = polyEnt.Coordinates
I = Fix((UBound(Coords) + 1) * 1.5) - 1
ReDim Coords2(I) As Double
j = 0
Dim X As Double, y As Double, z As Double
For I = LBound(Coords) To UBound(Coords) Step 2
X = Coords(I): y = Coords(I + 1): z = 0#
Coords2(j) = X:
Coords2(j + 1) = y:
Coords2(j + 2) = z:
j = j + 3
Next I
Dim Coords2V As Variant
Coords2V = Coords2
Dim EN2 As AcadPolyline
Set EN2 = entity.ModelSpace.AddPolyline(Coords2V)
EN2.Closed = polyEnt.Closed
EN2.Color = polyEnt.Color
EN2.Linetype = polyEnt.Linetype
EN2.Thickness = polyEnt.Thickness
EN2.Layer = polyEnt.Layer
Dim b As Double, w As Double, W2 As Double
For I = 0 To UBound(Coords) Step 2
j = I / 2
b = polyEnt.GetBulge(j)
polyEnt.GetWidth j, w, W2
EN2.SetBulge j, b
EN2.SetWidth j, w, W2
Next I
Dim polyentx As AcadPolyline
Set polyentx = EN2
polyEnt.Delete
End If
End Function
Most of this code can be contributed to Malcom Fernadaz. His code delt with open polylines. I modified it to deal with closed ones
-
Thank you so much,Davew!