zzyong00 发表于 2015-5-17 00:49:05

看见有人发示坡线程序，随手写一个



    AppActivate objCad.Caption
    Dim objPl1 As AcadLWPolyline, objPl2 As AcadLWPolyline, pt1 As Variant, blnESC As Boolean
    SelectSinglePLine objPl1, pt1, blnESC
    If blnESC Then Exit Sub
    SelectSinglePLine objPl2, pt1, blnESC
    If blnESC Then Exit Sub
    Dim dbl1 As Double, myPt1, myPt2, myPt3(2) As Double, i As Long
    dbl1 = ThisDrawing.Utility.GetReal("请输入示坡线间距：")
    Dim objCurve1 As New Curve, objCurve2 As New Curve
    Dim objL As AcadLine
    Set objCurve1.Entity = objPl1
    Set objCurve2.Entity = objPl2
    Do While i * dbl1 < objCurve1.length And i * dbl1 < objCurve2.length
      myPt1 = objCurve1.GetPointAtDistance(i * dbl1)
      myPt2 = objCurve2.GetPointAtDistance(i * dbl1)
      If i Mod 2 = 1 Then
            myPt3(0) = (myPt1(0) + myPt2(0)) / 2
            myPt3(1) = (myPt1(1) + myPt2(1)) / 2
            Set objL = ThisDrawing.ModelSpace.AddLine(myPt1, myPt3)
      Else
            Set objL = ThisDrawing.ModelSpace.AddLine(myPt1, myPt2)
      End If
      i = i + 1
    Loop
    ThisDrawing.Regen acActiveViewport


用到的主要模块，见http://bbs.mjtd.com/thread-113517-1-1.html

yuebu 发表于 2019-4-18 19:05:24

好厉害呀，谢谢大佬

枪花不凋谢 发表于 2020-2-18 18:43:07

好东西 拿下了

枪花不凋谢 发表于 2020-2-18 18:42:51

好东西 拿下了

zzyong00 发表于 2015-5-17 23:04:36

本帖最后由 zzyong00 于 2015-5-17 23:06 编辑

再来一个!


Private Sub Command23_Click()
    AppActivate objCad.Caption
    Dim objPl1 As AcadLWPolyline, objPl2 As AcadLWPolyline, pt1 As Variant, blnESC As Boolean
    SelectSinglePLine objPl1, pt1, blnESC
    If blnESC Then Exit Sub
    On Error GoTo err1
    Dim dbl1 As Double, myPt1, myPt2, myPt3, dblA As Double, i As Long
    dbl1 = 3
    dbl1 = ThisDrawing.Utility.GetReal("请输入示坡线间距<3>：")
    Dim objCurve1 As New Curve
    Dim objL As AcadLine
    Set objCurve1.Entity = objPl1
    Dim DrtPt(2) As Double, ScdPt(2) As Double, FstPt(2) As Double, tmppt As Variant, lngDrt As Long
    tmppt = ThisDrawing.Utility.GetPoint(objCurve1.StartPoint, "请指定示坡方向：")
    DrtPt(0) = tmppt(0)
    DrtPt(1) = tmppt(1)
    DrtPt(2) = tmppt(2)
    tmppt = objCurve1.GetClosestPointTo(DrtPt)
    If Abs(tmppt(0) - DrtPt(0)) < EPS And Abs(tmppt(1) - DrtPt(1)) < EPS And Abs(tmppt(1) - DrtPt(1)) < EPS Then
      MsgBox "请不要用曲线上的点指定方向！", vbInformation + vbOKOnly, App.Title
      Exit Sub
    End If
    ScdPt(0) = objPl1.Coordinate(1)(0)
    ScdPt(1) = objPl1.Coordinate(1)(1)
    ScdPt(2) = 0
    FstPt(0) = objPl1.Coordinate(0)(0)
    FstPt(1) = objPl1.Coordinate(0)(1)
    FstPt(2) = 0
    lngDrt = Cmp_PolarAngel_arrP(DrtPt, ScdPt, FstPt) '取旋转方向

    Do While i * dbl1 < objCurve1.length
      myPt1 = objCurve1.GetPointAtDistance(i * dbl1)
      myPt2 = objCurve1.GetFirstDerivative(objCurve1.GetParameterAtDistance(i * dbl1))
      myPt2(0) = myPt1(0) + myPt2(0)
      myPt2(1) = myPt1(1) + myPt2(1)
      dblA = ThisDrawing.Utility.AngleFromXAxis(myPt1, myPt2) + lngDrt * PI / 2
      If i Mod 2 = 1 Then
            myPt3 = ThisDrawing.Utility.PolarPoint(myPt1, dblA, dbl1 / 2)

            Set objL = ThisDrawing.ModelSpace.AddLine(myPt1, myPt3)
      Else
            myPt3 = ThisDrawing.Utility.PolarPoint(myPt1, dblA, dbl1)
            Set objL = ThisDrawing.ModelSpace.AddLine(myPt1, myPt3)
      End If
      i = i + 1
    Loop
    ThisDrawing.Regen acActiveViewport
    Exit Sub
err1:
    Debug.Print Err.Number
    If Err.Number = -2145320928 Then
      Err.Clear
      Resume Next
    End If
End Sub


gungun 发表于 2015-5-25 15:16:37

ayslh 发表于 2018-1-13 10:01:28

无尘235 发表于 2019-4-23 12:44:33

枪花不凋谢 发表于 2020-2-18 18:41:41

好东西 拿下了

枪花不凋谢 发表于 2020-2-18 18:41:53

好东西 拿下了

枪花不凋谢 发表于 2020-2-18 18:42:04

好东西 拿下了

枪花不凋谢 发表于 2020-2-18 18:42:15

好东西 拿下了
页: [1] 2
查看完整版本: 看见有人发示坡线程序，随手写一个