社区 › VB › 偏移折线

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

偏移折线

有人有类似于AutoCAD中offset命令的偏移多段线的代码示例吗？
**** Hidden Message *****

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

几年前，我用vba做了一件事，用拉伸一边的折线轮廓来计算一些断裂金属弯曲。这是相当多的代码。如果你想解析它得到你想要的，我会很乐意张贴。

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

谢谢你的提议，我很感激。
我对需要做什么有一个很好的想法，但我似乎无法弄清楚起点。我看到的方式是，折线可以由数百个段组成（我只对直线段感兴趣，没有像凸起这样的花哨的东西），并且可以打开或关闭。第一步是确定偏移位于哪一侧（左、右、上、下、内或外）。每个线段需要沿垂直于线段的线偏移一定量。垂直线是指向正确偏移方向（正或负）的垂直方向。一旦我有了正确的垂直线，我就可以很容易地创建线段的偏移量。由于所有折线都是顺时针或逆时针的，我几乎可以使用第一个垂直线作为参考，告诉我每个段都使用正或负垂直偏移。从那里开始，只需找到相邻线段的所有交点并构造偏移图元即可。
我希望这是有道理的。我在确定垂直偏移应为负数还是正数时遇到问题。我很想发布一个图表，但我要到下周才能访问适当的系统。

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

嗨，Troy，
我觉得你对这件事看得太深了。偏移直线而不是单个线段不是更容易吗？相对于绘制方向，折线向右偏移一个正值，向左偏移一个负值。因此，当偏移为给定距离时，只需找到所选的边，并找到指定点处的垂直距离作为“通过”距离。
这是否使事情变得更简单了？

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

杰夫，这确实让事情更简单了！我看看今天能不能算出这道数学题。谢谢

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

好吧，如果你能做到这一点，那么这可能是过度杀戮，但无论如何都是这样。这里会有比你感兴趣的更多的东西，我很抱歉糟糕的编码技术，但这是几年前的事了。当然，您不会对凸起感兴趣，但我需要它们来显示钣金弯曲。
这是表单代码：
'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

gilseorin 发表于 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

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

这是来自主模块的代码，其中包含一些帮助函数，我不能将其中的几个归功于它们：
希望这能有所帮助...

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

Draftek，谢谢你发布代码！我会看看它，看看它是如何工作的 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
这会将LWPolyline转换为2D多边形。非常适合旧的CNC程序，当您必须在代码的末尾使用2D poly a时。ACAD在LW多段线（sendCommand）上使用Pedit做得更好：
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
大部分代码都可以贡献给Malcom Fernadaz。他的代码delt带有开放多段线。我修改了它以处理封闭的

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

非常感谢你，戴维！

查看完整版本: 偏移折线