社区 › VBA/VB/ActiveX/API 编程技术 › 纯算法实现由中心直线生成两侧框线

longxh28 发表于 2025-7-12 20:04:29

纯算法实现由中心直线生成两侧框线

写了一段代码，用纯算法实现，发现还是有一些地方可能用的上。
效果如下：
   

没有使用特别的变量，虽然是用浩辰CAD的VBA写的，但在AutoCAD的VBA中也应该能用。
测试时用的中心直线在图层<Axis_1>上，生成的框线在图层<WINDOW>
执行后需按CAD命令栏提示输入数据，输入图层后缀<1>，输入墙厚<100>




'轴线生墙
Private Sub BtnZXSC_Click()
    Me.Hide
    ThisDrawing.Activate
    Call LnCAD_CreateWallByAxis
End Sub




Option Explicit

Type Point_t
    X As Double
    Y As Double
End Type

Type AxisPt_t '轴点
    X As Double
    Y As Double
    LineCount As Integer '属于轴线的数目
    LineNs(6) As Integer '属于轴线的自然序号
    LineEPt(6) As String'属于轴线的端号 S起点E终点
    RayAng(6) As Double '记录射线角度（逆时针）
End Type

Type AxisLine_t '轴线
    StartPtN As Integer
    EndPtN As Integer
    LLineStartPt As Point_t
    LLineEndPt As Point_t
    RLineStartPt As Point_t
    RLineEndPt As Point_t
End Type

'轴线生墙
Function LnCAD_CreateWallByAxis()
    Dim i As Integer
    Dim j As Integer
    '新建图层
    Dim lay0 As GcadLayer
    Dim Layer1 As GcadLayer
    Dim LayerExist As Boolean
      LayerExist = False
    For Each lay0 In ThisDrawing.Layers
       If UCase(lay0.Name) = "WALL" Then
         LayerExist = True
         Set Layer1 = lay0
         Exit For
       End If
    Next
    If LayerExist = False Then
      Set Layer1 = ThisDrawing.Layers.Add("WALL")
    End If
      LayerExist = False
    For Each lay0 In ThisDrawing.Layers
       If UCase(lay0.Name) = "WINDOW" Then
         LayerExist = True
         Set Layer1 = lay0
         Exit For
       End If
    Next
    If LayerExist = False Then
      Set Layer1 = ThisDrawing.Layers.Add("WINDOW")
    End If
   
    '输入参数
    On Error Resume Next
   
    '图层
    Dim layerEx As Double
      layerEx = ThisDrawing.Utility.GetReal("图层尾号<?/1>：")
    Dim selectLayer As String
    If Err.Number < 0 Then
      selectLayer = "AXIS"
    ElseIf Abs(layerEx - 1) < 0.01 Then
      selectLayer = "AXIS_1"
    Else
      Exit Function
    End If
   
   
    '墙厚
    Dim wallThick As Double
      wallThick = ThisDrawing.Utility.GetReal("墙厚(mm)：")
    Dim lw As Double
    If Err.Number < 0 Then
      Select Case selectLayer
            Case "AXIS"
                lw = 100
            Case "AXIS_1"
                lw = 40
      End Select
    Else
      lw = wallThick / 2
    End If

    If lw < 1 Then
      MsgBox "墙厚过小"
      Exit Function
    End If
   
    '选择集
    Dim filterset As Variant
    Call LnCAD_GetSelectionSet("ZXSC_1", ThisDrawing, filterset)
    Dim filtertype(1) As Integer
    Dim filterdata(1) As Variant '设置过滤器类型
      filtertype(0) = 0 '设置过滤数据
      filterdata(0) = "Line"
      filtertype(1) = 8 '设置过滤数据
      filterdata(1) = selectLayer '"Axis"
    filterset.SelectOnScreen filtertype, filterdata
    If filterset.Count = 0 Then
      Exit Function
    End If
   
   
    '线模型
    Dim axisLineN As Integer
      axisLineN = filterset.Count - 1
    Dim axisLines() As AxisLine_t
    ReDim axisLines(axisLineN)
    Dim axisPts() As AxisPt_t
    ReDim axisPts(2 * (axisLineN + 1) - 1)
    Dim iPt As Integer
    iPt = 0
    Dim iLine As Integer
    iLine = 0
    Dim IsCoincide As Boolean '重合
    Dim coincideN As Integer '重合号
    Dim filterent As Variant
    Dim fsPt As Variant
    Dim fePt As Variant
    For Each filterent In filterset
      fsPt = filterent.StartPoint
      fePt = filterent.EndPoint
      If iPt = 0 Then
            axisLines(0).StartPtN = 0
            axisLines(0).EndPtN = 1
            axisPts(0).X = fsPt(0)
            axisPts(0).Y = fsPt(1)
            axisPts(0).LineCount = 1
            axisPts(0).LineNs(0) = 0
            axisPts(0).LineEPt(0) = "S"
            axisPts(1).X = fePt(0)
            axisPts(1).Y = fePt(1)
            axisPts(1).LineCount = 1
            axisPts(1).LineNs(0) = 0
            axisPts(1).LineEPt(0) = "E"
            iPt = iPt + 1
      Else
            '起点与已录入点是否重合
            IsCoincide = False
            For i = 0 To iPt
                If Abs(fsPt(0) - axisPts(i).X) < 0.001 And Abs(fsPt(1) - axisPts(i).Y) < 0.001 Then
                  IsCoincide = True
                  coincideN = i
                  Exit For
                End If
            Next
            If IsCoincide = False Then
                iPt = iPt + 1
                axisLines(iLine).StartPtN = iPt
                axisPts(iPt).X = fsPt(0)
                axisPts(iPt).Y = fsPt(1)
                axisPts(iPt).LineNs(axisPts(iPt).LineCount) = iLine
                axisPts(iPt).LineEPt(axisPts(iPt).LineCount) = "S"
                axisPts(iPt).LineCount = axisPts(iPt).LineCount + 1
            Else
                axisLines(iLine).StartPtN = coincideN
                axisPts(coincideN).LineNs(axisPts(coincideN).LineCount) = iLine
                axisPts(coincideN).LineEPt(axisPts(coincideN).LineCount) = "S"
                axisPts(coincideN).LineCount = axisPts(coincideN).LineCount + 1
            End If
            '终点与已录入点是否重合
            IsCoincide = False
            For i = 0 To iPt
                If Abs(fePt(0) - axisPts(i).X) < 0.001 And Abs(fePt(1) - axisPts(i).Y) < 0.001 Then
                  IsCoincide = True
                  coincideN = i
                  Exit For
                End If
            Next
            If IsCoincide = False Then
                iPt = iPt + 1
                axisLines(iLine).EndPtN = iPt
                axisPts(iPt).X = fePt(0)
                axisPts(iPt).Y = fePt(1)
                axisPts(iPt).LineNs(axisPts(iPt).LineCount) = iLine
                axisPts(iPt).LineEPt(axisPts(iPt).LineCount) = "E"
                axisPts(iPt).LineCount = axisPts(iPt).LineCount + 1
            Else
                axisLines(iLine).EndPtN = coincideN
                axisPts(coincideN).LineNs(axisPts(coincideN).LineCount) = iLine
                axisPts(coincideN).LineEPt(axisPts(coincideN).LineCount) = "E"
                axisPts(coincideN).LineCount = axisPts(coincideN).LineCount + 1
            End If
      End If
      iLine = iLine + 1
    Next
   
    ReDim Preserve axisLines(iLine - 1)
    ReDim Preserve axisPts(iPt)
   
    '逐点计算偏移线
    Dim rayX As Double '射线端点坐标
    Dim rayY As Double
    Dim rayLineN As Integer '射线所在的轴线号
    Dim vertorX As Double '射线向量
    Dim vertorY As Double
    Dim rayOrder() As Integer '记录射线顺序（逆时针）
    Dim pl_x As Double, pl_y As Double, pr_x As Double, pr_y As Double
    Dim p1_x As Double, p1_y As Double, p2_x As Double, p2_y As Double, po_x As Double, po_y As Double, dist

As Double, p_x As Double, p_y As Double, pcw_x As Double, pcw_y As Double
    Dim startAng As Double '出发角
    Dim endAng As Double '终到角
    Dim ccwAng As Double '逆时针夹角
    For iPt = 0 To UBound(axisPts)
      '单独点
      If axisPts(iPt).LineCount = 1 Then
            rayLineN = axisPts(iPt).LineNs(0) '轴线
            If axisPts(iPt).LineEPt(0) = "S" Then
                p1_x = axisPts(axisLines(rayLineN).EndPtN).X
                p1_y = axisPts(axisLines(rayLineN).EndPtN).Y
            Else
                p1_x = axisPts(axisLines(rayLineN).StartPtN).X
                p1_y = axisPts(axisLines(rayLineN).StartPtN).Y
            End If
            Call M_GetBiasPoint3(axisPts(iPt).X, axisPts(iPt).Y, p1_x, p1_y, 1, lw, pl_x, pl_y, pr_x, pr_y)
            '将结果写入轴线数据
            rayLineN = axisPts(iPt).LineNs(0) '轴线
            If axisPts(iPt).LineEPt(0) = "S" Then
                axisLines(rayLineN).LLineStartPt.X = pl_x
                axisLines(rayLineN).LLineStartPt.Y = pl_y
                axisLines(rayLineN).RLineStartPt.X = pr_x
                axisLines(rayLineN).RLineStartPt.Y = pr_y
            Else
                axisLines(rayLineN).RLineEndPt.X = pl_x
                axisLines(rayLineN).RLineEndPt.Y = pl_y
                axisLines(rayLineN).LLineEndPt.X = pr_x
                axisLines(rayLineN).LLineEndPt.Y = pr_y
            End If
      End If
      '多点交汇
      If axisPts(iPt).LineCount > 1 Then
            '求射线角度
            For i = 0 To axisPts(iPt).LineCount - 1
                rayLineN = axisPts(iPt).LineNs(i)
                If axisPts(iPt).LineEPt(i) = "S" Then
                  rayX = axisPts(axisLines(rayLineN).EndPtN).X
                  rayY = axisPts(axisLines(rayLineN).EndPtN).Y
                Else
                  rayX = axisPts(axisLines(rayLineN).StartPtN).X
                  rayY = axisPts(axisLines(rayLineN).StartPtN).Y
                End If
                vertorX = rayX - axisPts(iPt).X
                vertorY = rayY - axisPts(iPt).Y
                Call M_AngleFromXAxis(vertorX, vertorY, axisPts(iPt).RayAng(i))
            Next
            '射线角度排序(从小到大)
            ReDim rayOrder(axisPts(iPt).LineCount - 1)
            For i = 0 To axisPts(iPt).LineCount - 1
                rayOrder(i) = i
            Next
            For i = UBound(rayOrder) - 1 To 0 Step -1
                For j = 0 To i
                  If axisPts(iPt).RayAng(rayOrder(j)) > axisPts(iPt).RayAng(rayOrder(j + 1)) Then
                        rayOrder(j) = rayOrder(j) + rayOrder(j + 1)
                        rayOrder(j + 1) = rayOrder(j) - rayOrder(j + 1)
                        rayOrder(j) = rayOrder(j) - rayOrder(j + 1)
                  End If
                Next j
            Next i
            '相邻两线计算偏向交点
            For i = 0 To axisPts(iPt).LineCount - 2 '先算到除最后一条线
                rayLineN = axisPts(iPt).LineNs(rayOrder(i)) '第1条轴线
                If axisPts(iPt).LineEPt(rayOrder(i)) = "S" Then
                  p1_x = axisPts(axisLines(rayLineN).EndPtN).X
                  p1_y = axisPts(axisLines(rayLineN).EndPtN).Y
                Else
                  p1_x = axisPts(axisLines(rayLineN).StartPtN).X
                  p1_y = axisPts(axisLines(rayLineN).StartPtN).Y
                End If
                rayLineN = axisPts(iPt).LineNs(rayOrder(i + 1)) '第2条轴线
                If axisPts(iPt).LineEPt(rayOrder(i + 1)) = "S" Then
                  p2_x = axisPts(axisLines(rayLineN).EndPtN).X
                  p2_y = axisPts(axisLines(rayLineN).EndPtN).Y
                Else
                  p2_x = axisPts(axisLines(rayLineN).StartPtN).X
                  p2_y = axisPts(axisLines(rayLineN).StartPtN).Y
                End If
                Call M_GetBiasPoint4(p1_x, p1_y, p2_x, p2_y, axisPts(iPt).X, axisPts(iPt).Y, lw, p_x, p_y,

pcw_x, pcw_y)
                '将结果写入轴线数据
                rayLineN = axisPts(iPt).LineNs(rayOrder(i)) '第1条轴线
                If axisPts(iPt).LineEPt(rayOrder(i)) = "S" Then
                  axisLines(rayLineN).LLineStartPt.X = p_x
                  axisLines(rayLineN).LLineStartPt.Y = p_y
                Else
                  axisLines(rayLineN).RLineEndPt.X = p_x
                  axisLines(rayLineN).RLineEndPt.Y = p_y
                End If
                rayLineN = axisPts(iPt).LineNs(rayOrder(i + 1)) '第2条轴线
                If axisPts(iPt).LineEPt(rayOrder(i + 1)) = "S" Then
                  axisLines(rayLineN).RLineStartPt.X = p_x
                  axisLines(rayLineN).RLineStartPt.Y = p_y
                Else
                  axisLines(rayLineN).LLineEndPt.X = p_x
                  axisLines(rayLineN).LLineEndPt.Y = p_y
                End If
            Next
            '算最后一条线与第1条线
            rayLineN = axisPts(iPt).LineNs(rayOrder(axisPts(iPt).LineCount - 1)) '第1条轴线
            If axisPts(iPt).LineEPt(rayOrder(axisPts(iPt).LineCount - 1)) = "S" Then
                p1_x = axisPts(axisLines(rayLineN).EndPtN).X
                p1_y = axisPts(axisLines(rayLineN).EndPtN).Y
            Else
                p1_x = axisPts(axisLines(rayLineN).StartPtN).X
                p1_y = axisPts(axisLines(rayLineN).StartPtN).Y
            End If
            rayLineN = axisPts(iPt).LineNs(rayOrder(0)) '第2条轴线
            If axisPts(iPt).LineEPt(rayOrder(0)) = "S" Then
                p2_x = axisPts(axisLines(rayLineN).EndPtN).X
                p2_y = axisPts(axisLines(rayLineN).EndPtN).Y
            Else
                p2_x = axisPts(axisLines(rayLineN).StartPtN).X
                p2_y = axisPts(axisLines(rayLineN).StartPtN).Y
            End If
            Call M_GetBiasPoint4(p1_x, p1_y, p2_x, p2_y, axisPts(iPt).X, axisPts(iPt).Y, lw, p_x, p_y,

pcw_x, pcw_y)
            '将结果写入轴线数据
            rayLineN = axisPts(iPt).LineNs(rayOrder(axisPts(iPt).LineCount - 1)) '第1条轴线
            If axisPts(iPt).LineEPt(rayOrder(axisPts(iPt).LineCount - 1)) = "S" Then
                axisLines(rayLineN).LLineStartPt.X = p_x
                axisLines(rayLineN).LLineStartPt.Y = p_y
            Else
                axisLines(rayLineN).RLineEndPt.X = p_x
                axisLines(rayLineN).RLineEndPt.Y = p_y
            End If
            rayLineN = axisPts(iPt).LineNs(rayOrder(0)) '第2条轴线
            If axisPts(iPt).LineEPt(rayOrder(0)) = "S" Then
                axisLines(rayLineN).RLineStartPt.X = p_x
                axisLines(rayLineN).RLineStartPt.Y = p_y
            Else
                axisLines(rayLineN).LLineEndPt.X = p_x
                axisLines(rayLineN).LLineEndPt.Y = p_y
            End If
      End If
    Next
   
   
    '判断绘图空间
    Dim wkSpace As Variant ' *Space 工作空间
    If ThisDrawing.ActiveSpace = acModelSpace Then
      Set wkSpace = ThisDrawing.ModelSpace
    Else
      Set wkSpace = ThisDrawing.PaperSpace
    End If
    '指定图层
    Select Case selectLayer
      Case "AXIS"
            ThisDrawing.ActiveLayer = ThisDrawing.Layers("WALL")
      Case "AXIS_1"
            ThisDrawing.ActiveLayer = ThisDrawing.Layers("WINDOW")
    End Select
   
   
    '绘制
    Dim aLine As Variant
    Dim pa(0 To 2) As Double
    Dim pb(0 To 2) As Double
    '绘轴线的平行线
    For iLine = 0 To UBound(axisLines)
      pa(0) = axisLines(iLine).LLineStartPt.X
      pa(1) = axisLines(iLine).LLineStartPt.Y
      pb(0) = axisLines(iLine).LLineEndPt.X
      pb(1) = axisLines(iLine).LLineEndPt.Y
      Set aLine = wkSpace.AddLine(pa, pb)
      pa(0) = axisLines(iLine).RLineStartPt.X
      pa(1) = axisLines(iLine).RLineStartPt.Y
      pb(0) = axisLines(iLine).RLineEndPt.X
      pb(1) = axisLines(iLine).RLineEndPt.Y
      Set aLine = wkSpace.AddLine(pa, pb)
    Next
    '如果是末端轴点，则封口
    For iPt = 0 To UBound(axisPts)
      If axisPts(iPt).LineCount = 1 Then
            rayLineN = axisPts(iPt).LineNs(0)
            If axisPts(iPt).LineEPt(0) = "S" Then
                pa(0) = axisLines(rayLineN).LLineStartPt.X
                pa(1) = axisLines(rayLineN).LLineStartPt.Y
                pb(0) = axisLines(rayLineN).RLineStartPt.X
                pb(1) = axisLines(rayLineN).RLineStartPt.Y
            Else
                pa(0) = axisLines(rayLineN).LLineEndPt.X
                pa(1) = axisLines(rayLineN).LLineEndPt.Y
                pb(0) = axisLines(rayLineN).RLineEndPt.X
                pb(1) = axisLines(rayLineN).RLineEndPt.Y
            End If
            Set aLine = wkSpace.AddLine(pa, pb)
      End If
    Next
End Function


'获得选择集
'根据结定名称获得选择集
Function LnCAD_GetSelectionSet(sSetName As String, aDrawing As Object, ByRef aSelectionSet As Variant)
    Dim ExistSSet As Boolean
      ExistSSet = False
    For Each aSelectionSet In aDrawing.SelectionSets
      If aSelectionSet.Name = sSetName Then
            ExistSSet = True
            Exit For
      End If
    Next
    If ExistSSet = True Then
      aDrawing.SelectionSets(sSetName).Delete
      Set aSelectionSet = aDrawing.SelectionSets.Add(sSetName)
    Else
      Set aSelectionSet = aDrawing.SelectionSets.Add(sSetName)
    End If
End Function


'角度自X轴
'Function : M_AngleFromXAxis
'Descrip :solve angle from x axis
'Input :    v_x,v_y : represents vertor(v_x,v_y)
'Output :   ax_rad : angle from x axis(radian)
'Return :   1 : success , -1 : error
'History :2024-4-10 create
Public Function M_AngleFromXAxis(v_x As Double, v_y As Double, ByRef ax_rad As Double) As Long
    M_AngleFromXAxis = 1
    If v_x < 0 Then
      ax_rad = 4 * Atn(1) + Atn(v_y / v_x)
    Else
      If v_x > 0 Then
            If v_y >= 0 Then
                ax_rad = Atn(v_y / v_x)
            Else
                ax_rad = 8 * Atn(1) + Atn(v_y / v_x)
            End If
      ElseIf v_x = 0 Then
            If v_y > 0 Then
                ax_rad = 2 * Atn(1)
            ElseIf v_y < 0 Then
                ax_rad = 6 * Atn(1)
            ElseIf v_y = 0 Then
                M_AngleFromXAxis = -1
                MsgBox "ERROR : cannot solve angle from v_x axis at vertor(0,0)"
            End If
      End If
    End If
End Function


'获得偏向点3
'Function : M_GetBiasPoint3
'Descrip : 给定两点，指定其中1点为基点，给定距离，获得基点垂线偏出指定距离的2个点
'Input :    p1_x,p1_y : point1    p2_x,p2_y : point2    dist : distance
'         p_n :1表示p1为基点2表示p2为基点
'Output :   pl_x,pl_y : 以p1指向p2 left 方向 point
'         pr_x,pr_y : 以p1指向p2 right 方向 point
'History :2025-3-8 create
Function M_GetBiasPoint3(ByVal p1_x As Double, ByVal p1_y As Double, ByVal p2_x As Double, ByVal p2_y As

Double, ByVal p_n As Integer, ByVal dist As Double, ByRef pl_x As Double, ByRef pl_y As Double, ByRef pr_x

As Double, ByRef pr_y As Double)
    Dim l_dist As Double 'p1-p2 length
      l_dist = Sqr((p1_x - p2_x) ^ 2 + (p1_y - p2_y) ^ 2)
    Dim uv_x As Double, uv_y As Double '单位向量
      uv_x = (p2_x - p1_x) / l_dist
      uv_y = (p2_y - p1_y) / l_dist
    Dim ccwvuv_x As Double, ccwvuv_y As Double '逆时针方向垂直单位向量
      ccwvuv_x = -uv_y
      ccwvuv_y = uv_x
    If p_n = 1 Then
      pl_x = p1_x + dist * ccwvuv_x
      pl_y = p1_y + dist * ccwvuv_y
      pr_x = p1_x - dist * ccwvuv_x
      pr_y = p1_y - dist * ccwvuv_y
    End If
    If p_n = 2 Then
      pl_x = p2_x + dist * ccwvuv_x
      pl_y = p2_y + dist * ccwvuv_y
      pr_x = p2_x - dist * ccwvuv_x
      pr_y = p2_y - dist * ccwvuv_y
    End If
End Function

'获得偏向点4
'Function : M_GetBiasPoint4
'Descrip : 给定三点，po为基点，求由p1逆时针旋至p2的角平分线上，距两条线垂直距离为给定距离的点
'Input :    p1_x,p1_y : point1    p2_x,p2_y : point2    dist : distance
'         po_x,po_y : 基点
'Output :   p_x,p_y : 逆时针方向 point
'         pcw_x,pcw_y : 顺时针方向 point
'History :2025-3-8 create
Function M_GetBiasPoint4(ByVal p1_x As Double, ByVal p1_y As Double, ByVal p2_x As Double, ByVal p2_y As

Double, ByVal po_x As Double, ByVal po_y As Double, ByVal dist As Double, ByRef p_x As Double, ByRef p_y As

Double, ByRef pcw_x As Double, ByRef pcw_y As Double)
    '判断3点是否共线（叉乘cross product为0）
    Dim v1_x As Double '向量1
    Dim v1_y As Double
    Dim v2_x As Double '向量2
    Dim v2_y As Double
      v1_x = p1_x - po_x
      v1_y = p1_y - po_y
      v2_x = p2_x - po_x
      v2_y = p2_y - po_y
    Dim cp As Double
      cp = v1_x * v2_y - v2_x * v1_y
   
    Dim l_dist As Double 'length
      l_dist = Sqr((p1_x - po_x) ^ 2 + (p1_y - po_y) ^ 2)
    Dim uv1_x As Double '单位向量1
    Dim uv1_y As Double
      uv1_x = (p1_x - po_x) / l_dist
      uv1_y = (p1_y - po_y) / l_dist
   
    Dim ccwvuv_x As Double, ccwvuv_y As Double '逆时针方向垂直单位向量
    If Abs(cp) < 0.000001 Then '三点共线的处理
      ccwvuv_x = -uv1_y
      ccwvuv_y = uv1_x
      p_x = po_x + dist * ccwvuv_x
      p_y = po_y + dist * ccwvuv_y
      pcw_x = po_x - dist * ccwvuv_x
      pcw_y = po_y - dist * ccwvuv_y
      Exit Function
    End If

    '三点不共线的处理
    l_dist = Sqr((p2_x - po_x) ^ 2 + (p2_y - po_y) ^ 2) '线2的长度
    Dim uv2_x As Double '单位向量2
    Dim uv2_y As Double
      uv2_x = (p2_x - po_x) / l_dist
      uv2_y = (p2_y - po_y) / l_dist
    Dim v_x As Double '向量
    Dim v_y As Double
    '角平分线向量(考虑方向，如果v1叉乘v2大于零,意味着v2在v1逆时针180°以内的方向)
    If uv1_x * uv2_y - uv2_x * uv1_y > 0 Then
      v_x = uv1_x + uv2_x '角平分线向量
      v_y = uv1_y + uv2_y
    Else
      v_x = -uv1_x - uv2_x '角平分线向量
      v_y = -uv1_y - uv2_y
    End If
    l_dist = Sqr((v_x) ^ 2 + (v_y) ^ 2) '角平分线向量的模
    Dim uv_x As Double '单位向量
    Dim uv_y As Double
      uv_x = (v_x) / l_dist '角平分线单位向量
      uv_y = (v_y) / l_dist
    '3点求面积（S=(x1y2-x1y3+x2y3-x2y1+x3y1-x2y2)）
    Dim s_area As Double
      s_area = uv1_x * uv2_y - uv2_x * uv1_y'单位向量形成的菱形面积
    Dim us_dist As Double '单位向量菱形的高
      us_dist = s_area
    l_dist = Sqr((uv2_x - uv1_x) ^ 2 + (uv2_y - uv1_y) ^ 2) '单位向量终点连线的长度
    Dim ul_dist As Double '单位向量角平分线向量的模
      ul_dist = s_area * 2 / l_dist '菱形四边为1，对角线的积为2倍面积
    Dim ls_time As Double '角平分线长度是三角形高的倍数
      ls_time = ul_dist / us_dist
    p_x = po_x + ls_time * dist * uv_x
    p_y = po_y + ls_time * dist * uv_y
    pcw_x = po_x - ls_time * dist * uv_x
    pcw_y = po_y - ls_time * dist * uv_y
   
End Function

yangyangyixia 发表于 2025-7-13 08:44:56

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=169314&highlight=%CF%DF%2B%C7%BD

JGHLYM 发表于 2025-7-16 17:05:17

变成双线后转域面再布尔运算后提取域面边界可能会更简单,且可支持弧线和PL线

tiancao100 发表于 2025-7-12 20:25:39

支持VBA的

你有种再说一遍 发表于 2025-7-12 21:09:25

扫描线算法,秒了

张向华 发表于 2025-7-14 16:18:32

编程不易，多谢分享

wwwswallow 发表于 2025-7-15 16:54:38

感谢分享源码，很值得学习。

翔云95 发表于 2025-10-13 10:00:15

赞一个。vba实现得简便

查看完整版本: 纯算法实现由中心直线生成两侧框线