明经CAD社区

 找回密码
 注册

扫一扫,访问微社区

QQ登录

只需一步,快速开始

查看: 634|回复: 3

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

[复制链接]
发表于 2015-5-17 00:49 | 显示全部楼层 |阅读模式


  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


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

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x

评分

参与人数 1明经币 +1 收起 理由
bshkl + 1 赞一个!

查看全部评分

 楼主| 发表于 2015-5-17 23:04 | 显示全部楼层
本帖最后由 zzyong00 于 2015-5-17 23:06 编辑

再来一个!

  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.     Do While i * dbl1 < objCurve1.length
  31.         myPt1 = objCurve1.GetPointAtDistance(i * dbl1)
  32.         myPt2 = objCurve1.GetFirstDerivative(objCurve1.GetParameterAtDistance(i * dbl1))
  33.         myPt2(0) = myPt1(0) + myPt2(0)
  34.         myPt2(1) = myPt1(1) + myPt2(1)
  35.         dblA = ThisDrawing.Utility.AngleFromXAxis(myPt1, myPt2) + lngDrt * PI / 2
  36.         If i Mod 2 = 1 Then
  37.             myPt3 = ThisDrawing.Utility.PolarPoint(myPt1, dblA, dbl1 / 2)

  38.             Set objL = ThisDrawing.ModelSpace.AddLine(myPt1, myPt3)
  39.         Else
  40.             myPt3 = ThisDrawing.Utility.PolarPoint(myPt1, dblA, dbl1)
  41.             Set objL = ThisDrawing.ModelSpace.AddLine(myPt1, myPt3)
  42.         End If
  43.         i = i + 1
  44.     Loop
  45.     ThisDrawing.Regen acActiveViewport
  46.     Exit Sub
  47. err1:
  48.     Debug.Print Err.Number
  49.     If Err.Number = -2145320928 Then
  50.         Err.Clear
  51.         Resume Next
  52.     End If
  53. End Sub


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2015-5-25 15:16 | 显示全部楼层
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号  
©2000-2017 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2018-1-18 15:46 , Processed in 0.238187 second(s), 36 queries , Gzip On.

Powered by Discuz! X3.3

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表