社区 › VB › 偏移多段线

Draftek 发表于 2005-9-27 13:16:18

偏移多段线

是否有类似于AutoCAD中的“偏移”命令的偏移多段线的代码示例？

Jeff_M 发表于 2005-9-27 16:31:15

几年前，我使用vba获取拉伸一侧的多段线轮廓来计算一些断裂金属折弯。这是相当多的代码。如果你想通过解析得到你想要的，我&#039；我很乐意发帖。

Draftek 发表于 2005-9-27 18:46:31

谢谢你的提议，我很感激
我知道需要做什么，但我可以&#039；我似乎没有找到出发点。在我看来，一条多段线可以由数百段组成（我只对直线段感兴趣，没有像凸起这样的奇特东西），并且可以打开或关闭。第一步是确定偏移位于哪一侧（左侧、右侧、顶部、底部、内部或外部）。每个线段需要沿垂直于线段的直线偏移一定量。垂线是指指向正确偏移方向（正或负）的垂线。一旦我有了正确的垂直线，然后我可以很容易地创建线段的偏移。由于所有多段线都是顺时针或逆时针方向，我几乎可以使用第一条垂线作为参考，告诉我每个线段使用的是正垂线偏移还是负垂线偏移。从那里，只需找到相邻线段的所有交点并构造偏移实体
我希望这有意义。我在计算垂直偏移应该是负值还是正值时遇到了问题。本人&#039；我很想贴一张图表，但我赢了；我要到下周才能使用合适的系统

Draftek 发表于 2005-9-27 19:01:32

嗨，特洛伊，我觉得你对这件事看得太深了。不会&#039；偏移pline而不是单个线段是否更容易？相对于绘制方向，样条线向右偏移正值，向左偏移负值。因此，只需找到当偏移量为给定距离时选择的边，并找到指定点处的垂直距离；通过“；距离
这会让事情变得更简单吗&nbsp；

Draftek 发表于 2005-9-28 07:42:55

杰夫，这确实让事情变得更简单了！本人&#039；我看看我今天能不能算出这道数学题。谢谢

Kerry 发表于 2005-9-28 08:07:35

好吧，如果你能做到这一点，那么这可能是过度杀伤力，但无论如何，它在这里。这里会有比你和我更感兴趣的东西；我为糟糕的编码技术感到抱歉，但这已经有几年了。当然你不会对Budges感兴趣，但我需要它们来展示钣金折弯
这是表格代码：
'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)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 Sideangle2 And SideVector2 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

Draftek 发表于 2005-9-28 08:08:32

我不得不把它拆开，因为frmMain代码的第二部分太长了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

Draftek 发表于 2005-9-28 08:10:18

这是来自主模块的代码，其中有一些辅助函数，我不能将它们归功于其中的两个：
'' 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 Answer6 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
希望这有帮助。。。

Jeff_M 发表于 2005-10-3 08:36:43

Draftek，谢谢你发布代码！我会看看它，看看它是如何工作的
再次感谢！

Jeff_M 发表于 2005-10-3 10:34:08

嗯……想知道哈奇这几天在做什么

查看完整版本: 偏移多段线