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

zzyong00

1.     AppActivate objCad.Caption
   
2.     Dim objPl1 As AcadLWPolyline, objPl2 As AcadLWPolyline, pt1 As Variant, blnESC As Boolean
   
3.     SelectSinglePLine objPl1, pt1, blnESC
   
4.     If blnESC Then Exit Sub
   
5.     SelectSinglePLine objPl2, pt1, blnESC
   
6.     If blnESC Then Exit Sub
   
7.     Dim dbl1 As Double, myPt1, myPt2, myPt3(2) As Double, i As Long
   
8.     dbl1 = ThisDrawing.Utility.GetReal("请输入示坡线间距：")
   
9.     Dim objCurve1 As New Curve, objCurve2 As New Curve
   
10.     Dim objL As AcadLine
    
11.     Set objCurve1.Entity = objPl1
    
12.     Set objCurve2.Entity = objPl2
    
13.     Do While i * dbl1 < objCurve1.length And i * dbl1 < objCurve2.length
    
14.         myPt1 = objCurve1.GetPointAtDistance(i * dbl1)
    
15.         myPt2 = objCurve2.GetPointAtDistance(i * dbl1)
    
16.         If i Mod 2 = 1 Then
    
17.             myPt3(0) = (myPt1(0) + myPt2(0)) / 2
    
18.             myPt3(1) = (myPt1(1) + myPt2(1)) / 2
    
19.             Set objL = ThisDrawing.ModelSpace.AddLine(myPt1, myPt3)
    
20.         Else
    
21.             Set objL = ThisDrawing.ModelSpace.AddLine(myPt1, myPt2)
    
22.         End If
    
23.         i = i + 1
    
24.     Loop
    
25.     ThisDrawing.Regen acActiveViewport
    

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

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

yuebu

好厉害呀，谢谢大佬

枪花不凋谢

好东西 拿下了

枪花不凋谢

好东西 拿下了

zzyong00

再来一个!

1. Private Sub Command23_Click()
   
2.     AppActivate objCad.Caption
   
3.     Dim objPl1 As AcadLWPolyline, objPl2 As AcadLWPolyline, pt1 As Variant, blnESC As Boolean
   
4.     SelectSinglePLine objPl1, pt1, blnESC
   
5.     If blnESC Then Exit Sub
   
6.     On Error GoTo err1
   
7.     Dim dbl1 As Double, myPt1, myPt2, myPt3, dblA As Double, i As Long
   
8.     dbl1 = 3
   
9.     dbl1 = ThisDrawing.Utility.GetReal("请输入示坡线间距<3>：")
   
10.     Dim objCurve1 As New Curve
    
11.     Dim objL As AcadLine
    
12.     Set objCurve1.Entity = objPl1
    
13.     Dim DrtPt(2) As Double, ScdPt(2) As Double, FstPt(2) As Double, tmppt As Variant, lngDrt As Long
    
14.     tmppt = ThisDrawing.Utility.GetPoint(objCurve1.StartPoint, "请指定示坡方向：")
    
15.     DrtPt(0) = tmppt(0)
    
16.     DrtPt(1) = tmppt(1)
    
17.     DrtPt(2) = tmppt(2)
    
18.     tmppt = objCurve1.GetClosestPointTo(DrtPt)
    
19.     If Abs(tmppt(0) - DrtPt(0)) < EPS And Abs(tmppt(1) - DrtPt(1)) < EPS And Abs(tmppt(1) - DrtPt(1)) < EPS Then
    
20.         MsgBox "请不要用曲线上的点指定方向！", vbInformation + vbOKOnly, App.Title
    
21.         Exit Sub
    
22.     End If
    
23.     ScdPt(0) = objPl1.Coordinate(1)(0)
    
24.     ScdPt(1) = objPl1.Coordinate(1)(1)
    
25.     ScdPt(2) = 0
    
26.     FstPt(0) = objPl1.Coordinate(0)(0)
    
27.     FstPt(1) = objPl1.Coordinate(0)(1)
    
28.     FstPt(2) = 0
    
29.     lngDrt = Cmp_PolarAngel_arrP(DrtPt, ScdPt, FstPt) '取旋转方向
    
30. 
    
31.     Do While i * dbl1 < objCurve1.length
    
32.         myPt1 = objCurve1.GetPointAtDistance(i * dbl1)
    
33.         myPt2 = objCurve1.GetFirstDerivative(objCurve1.GetParameterAtDistance(i * dbl1))
    
34.         myPt2(0) = myPt1(0) + myPt2(0)
    
35.         myPt2(1) = myPt1(1) + myPt2(1)
    
36.         dblA = ThisDrawing.Utility.AngleFromXAxis(myPt1, myPt2) + lngDrt * PI / 2
    
37.         If i Mod 2 = 1 Then
    
38.             myPt3 = ThisDrawing.Utility.PolarPoint(myPt1, dblA, dbl1 / 2)
    
39. 
    
40.             Set objL = ThisDrawing.ModelSpace.AddLine(myPt1, myPt3)
    
41.         Else
    
42.             myPt3 = ThisDrawing.Utility.PolarPoint(myPt1, dblA, dbl1)
    
43.             Set objL = ThisDrawing.ModelSpace.AddLine(myPt1, myPt3)
    
44.         End If
    
45.         i = i + 1
    
46.     Loop
    
47.     ThisDrawing.Regen acActiveViewport
    
48.     Exit Sub
    
49. err1:
    
50.     Debug.Print Err.Number
    
51.     If Err.Number = -2145320928 Then
    
52.         Err.Clear
    
53.         Resume Next
    
54.     End If
    
55. End Sub
    

Private Sub Command23_Click()<br />     AppActivate objCad.Caption<br />     Dim objPl1 As AcadLWPolyline, objPl2 As AcadLWPolyline, pt1 As Variant, blnESC As Boolean<br />     SelectSinglePLine objPl1, pt1, blnESC<br />     If blnESC Then Exit Sub<br />     On Error GoTo err1<br />     Dim dbl1 As Double, myPt1, myPt2, myPt3, dblA As Double, i As Long<br />     dbl1 = 3<br />     dbl1 = ThisDrawing.Utility.GetReal("请输入示坡线间距<3>：")<br />     Dim objCurve1 As New Curve<br />     Dim objL As AcadLine<br />     Set objCurve1.Entity = objPl1<br />     Dim DrtPt(2) As Double, ScdPt(2) As Double, FstPt(2) As Double, tmppt As Variant, lngDrt As Long<br />     tmppt = ThisDrawing.Utility.GetPoint(objCurve1.StartPoint, "请指定示坡方向：")<br />     DrtPt(0) = tmppt(0)<br />     DrtPt(1) = tmppt(1)<br />     DrtPt(2) = tmppt(2)<br />     tmppt = objCurve1.GetClosestPointTo(DrtPt)<br />     If Abs(tmppt(0) - DrtPt(0)) < EPS And Abs(tmppt(1) - DrtPt(1)) < EPS And Abs(tmppt(1) - DrtPt(1)) < EPS Then<br />         MsgBox "请不要用曲线上的点指定方向！", vbInformation + vbOKOnly, App.Title<br />         Exit Sub<br />     End If<br />     ScdPt(0) = objPl1.Coordinate(1)(0)<br />     ScdPt(1) = objPl1.Coordinate(1)(1)<br />     ScdPt(2) = 0<br />     FstPt(0) = objPl1.Coordinate(0)(0)<br />     FstPt(1) = objPl1.Coordinate(0)(1)<br />     FstPt(2) = 0<br />     lngDrt = Cmp_PolarAngel_arrP(DrtPt, ScdPt, FstPt) '取旋转方向<br /> <br />     Do While i * dbl1 < objCurve1.length<br />         myPt1 = objCurve1.GetPointAtDistance(i * dbl1)<br />         myPt2 = objCurve1.GetFirstDerivative(objCurve1.GetParameterAtDistance(i * dbl1))<br />         myPt2(0) = myPt1(0) + myPt2(0)<br />         myPt2(1) = myPt1(1) + myPt2(1)<br />         dblA = ThisDrawing.Utility.AngleFromXAxis(myPt1, myPt2) + lngDrt * PI / 2<br />         If i Mod 2 = 1 Then<br />             myPt3 = ThisDrawing.Utility.PolarPoint(myPt1, dblA, dbl1 / 2)<br /> <br />             Set objL = ThisDrawing.ModelSpace.AddLine(myPt1, myPt3)<br />         Else<br />             myPt3 = ThisDrawing.Utility.PolarPoint(myPt1, dblA, dbl1)<br />             Set objL = ThisDrawing.ModelSpace.AddLine(myPt1, myPt3)<br />         End If<br />         i = i + 1<br />     Loop<br />     ThisDrawing.Regen acActiveViewport<br />     Exit Sub<br /> err1:<br />     Debug.Print Err.Number<br />     If Err.Number = -2145320928 Then<br />         Err.Clear<br />         Resume Next<br />     End If<br /> End Sub<br />

gungun

ayslh

无尘235

枪花不凋谢

好东西 拿下了

枪花不凋谢

好东西 拿下了

枪花不凋谢

好东西 拿下了

枪花不凋谢

好东西 拿下了