| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 1137 人关注过本帖
标题:画线
只看楼主 加入收藏
lzx1556
Rank: 1
等 级:新手上路
帖 子:41
专家分:8
注 册:2012-9-5
结帖率:85.71%
收藏
 问题点数:0 回复次数:7 
画线
下面这段代码要实现在三角网空间画任意直线求与三角形的交点坐标,以每一直线段为基本单元进行操作,autocad-vba编写
存在的问题:
   1、 直线与三角形交点数目正确,但画图时每段直线与三角形边交点会漏掉一二个点没画出来。
   2、 代码中已过滤了重复坐标值,但画图时每段直线与三角形边交点会有一二处重复点出现,本来想上传图片可以比较直观看出来的,不熟悉这里的操作,传不上~~

希望得到指点,如何处理上述问题
代码如下:
Private Sub CommandButton6_Click()
   '直线放样
   SJWandDGXForm.Hide
   Dim Cu_x() As Variant, Cu_y() As Variant
   Dim Poly3dline As Variant
   Dim TriangleNet As AcadSelectionSet
   Dim ptt As AcadEntity
   Dim ptt1 As AcadEntity
  
   Dim g, gg, jj, j As Integer
   Dim Point1(0 To 2) As Double, Point2(0 To 2) As Double, Point3(0 To 2) As Double
   Dim Point4(0 To 2) As Double, Point5(0 To 2) As Double, Point6(0 To 2) As Double
   Dim Point03(0 To 2) As Double, Point02(0 To 2) As Double
   Dim point04(0 To 2) As Double, point05(0 To 2) As Double, point06(0 To 2) As Double
   
   
    Dim newLayer As AcadLayer
    Dim Tulayer As String
    Tulayer = "样线"
    Set newLayer = JTCLayer(Tulayer, 5)
    ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
    ThisDrawing.Layers("样线").Lock = False
    ThisDrawing.Layers("样线").Freeze = False
    ThisDrawing.Layers("样线").LayerOn = True
    ThisDrawing.ActiveLayer = newLayer
   
    Call CreatePolyline(Cu_x(), Cu_y())
   
  With ThisDrawing
  
  If .SelectionSets.Count > 0 Then .SelectionSets("CurrentSelection").Delete
       Set TriangleNet = .SelectionSets.add("CurrentSelection")
       Dim mode As Integer
       ReDim gpCode(0) As Integer
       ReDim dataValue(0) As Variant
       Dim groupCode As Variant, dataCode As Variant
  If UBound(Cu_x()) = 2 Then
    Dim corner1(0 To 2) As Double
    Dim corner2(0 To 2) As Double
    mode = acSelectionSetCrossing
    corner1(0) = Cu_x(0): corner1(1) = Cu_y(0): corner1(2) = 0
    corner2(0) = Cu_x(1): corner2(1) = Cu_y(1): corner2(2) = 0
    gpCode(0) = 8
    dataValue(0) = "三角形,细化三角形,填充三角形,三角网"
    groupCode = gpCode
    dataCode = dataValue
    TriangleNet.Select mode, corner1, corner2, groupCode, dataCode
 Else
   Dim ca_points() As Double
    mode = acSelectionSetCrossingPolygon
    For j = 0 To UBound(Cu_x()) - 1
      ReDim Preserve ca_points(3 * j + 2)
        ca_points(3 * j) = Cu_x(j)
        ca_points(3 * j + 1) = Cu_y(j)
        ca_points(3 * j + 2) = 0
     Next
      gpCode(0) = 8
      dataValue(0) = "三角形,细化三角形,填充三角形,三角网"
      groupCode = gpCode
      dataCode = dataValue
      TriangleNet.SelectByPolygon mode, ca_points, groupCode, dataCode
      'TriangleNet.Highlight True
      'TriangleNet.Update
    End If
     
 '判断样线顶点并求出坐标
        
         Dim Cass_Text As AcadText
         Dim pointobj1 As AcadPoint
         Dim BL1, BL2, BL3, Bl4, Bl5 As Boolean
         Dim AA, Ba, Ca, Da, Ha As Double
         Dim Xf, Yf, Zf As Variant
         Dim point4Value As Variant
         Dim templ As Single
         Dim polyint_x() As Variant
         Dim polyint_y() As Variant
         Dim collect As New Collection
         Dim Cass_x0() As Double
         Dim Cass_y0() As Double
         Dim Cass_H0() As Double
         Dim cvv As Integer
   
    cvv = 0
For jj = 1 To UBound(Cu_x()) - 1
   
    If collect.Count > 0 Then Set collect = Nothing
     gg = 0
     For Each ptt In TriangleNet
         Poly3dline = ptt.Coordinates
     If GetVertexCount(ptt) = 3 Then
         Point4(0) = Round(Poly3dline(0), 3): Point4(1) = Round(Poly3dline(1), 3): Point4(2) = Round(Poly3dline(2), 3)
         Point5(0) = Round(Poly3dline(3), 3): Point5(1) = Round(Poly3dline(4), 3): Point5(2) = Round(Poly3dline(5), 3)
         Point6(0) = Round(Poly3dline(6), 3): Point6(1) = Round(Poly3dline(7), 3): Point6(2) = Round(Poly3dline(8), 3)
         
         BL1 = Line2ToPoint(Point4(0), Point4(1), Point5(0), Point5(1), Round(Cu_x(jj - 1), 3), Round(Cu_y(jj - 1), 3), Round(Cu_x(jj), 3), Round(Cu_y(jj), 3), Xf, Yf)
         BL2 = Line2ToPoint(Point5(0), Point5(1), Point6(0), Point6(1), Round(Cu_x(jj - 1), 3), Round(Cu_y(jj - 1), 3), Round(Cu_x(jj), 3), Round(Cu_y(jj), 3), Xf, Yf)
         BL3 = Line2ToPoint(Point6(0), Point6(1), Point4(0), Point4(1), Round(Cu_x(jj - 1), 3), Round(Cu_y(jj - 1), 3), Round(Cu_x(jj), 3), Round(Cu_y(jj), 3), Xf, Yf)
         
      If BL1 = True Or BL2 = True Or BL3 = True Then
      gg = gg + 1
      collect.add Item:=ptt, key:=CStr(gg)
   End If
   End If
   Next
               gg = collect.Count
               ReDim Preserve Cass_x0(5 * gg + 4) '分配内存
               ReDim Preserve Cass_y0(5 * gg + 4)
               ReDim Preserve Cass_H0(5 * gg + 4)
               cvv = cvv + gg
     
  For Each ptt1 In collect
          Poly3dline = ptt1.Coordinates
     If GetVertexCount(ptt1) = 3 Then
         Point1(0) = Round(Poly3dline(0), 3): Point1(1) = Round(Poly3dline(1), 3): Point1(2) = Round(Poly3dline(2), 3)
         Point2(0) = Round(Poly3dline(3), 3): Point2(1) = Round(Poly3dline(4), 3): Point2(2) = Round(Poly3dline(5), 3)
         Point3(0) = Round(Poly3dline(6), 3): Point3(1) = Round(Poly3dline(7), 3): Point3(2) = Round(Poly3dline(8), 3)
         ReDim Preserve polyint_x(2)  '分配内存
         ReDim Preserve polyint_y(2)
         polyint_x(0) = Point1(0): polyint_y(0) = Point1(1)
         polyint_x(1) = Point2(0): polyint_y(1) = Point2(1)
         polyint_x(2) = Point3(0): polyint_y(2) = Point3(1)
         
         Bl4 = Point_in_Area(polyint_x(), polyint_y(), Round(Cu_x(jj - 1), 3), Round(Cu_y(jj - 1), 3))
         Bl5 = Point_in_Area(polyint_x(), polyint_y(), Round(Cu_x(jj), 3), Round(Cu_y(jj), 3))
     If Bl4 = True Then
            AA = Point1(1) * (Point2(2) - Point3(2)) + Point2(1) * (Point3(2) - Point1(2)) + Point3(1) * (Point1(2) - Point2(2))
            Ba = Point1(2) * (Point2(0) - Point3(0)) + Point2(2) * (Point3(0) - Point1(0)) + Point3(2) * (Point1(0) - Point2(0))
            Ca = Point1(0) * (Point2(1) - Point3(1)) + Point2(0) * (Point3(1) - Point1(1)) + Point3(0) * (Point1(1) - Point2(1))
            Da = -(AA * Point1(0) + Ba * Point1(1) + Ca * Point1(2))
            Ha = -(AA * Round(Cu_x(jj - 1), 3) + Ba * Round(Cu_y(jj - 1), 3) + Da) / Ca
            Point03(0) = Round(Cu_x(jj - 1), 3): Point03(1) = Round(Cu_y(jj - 1), 3): Point03(2) = Ha

               Cass_x0(5 * gg + 0) = Point03(0)
               Cass_y0(5 * gg + 0) = Point03(1)
               Cass_H0(5 * gg + 0) = Point03(2)
           
     End If
     If Bl5 = True Then
            AA = Point1(1) * (Point2(2) - Point3(2)) + Point2(1) * (Point3(2) - Point1(2)) + Point3(1) * (Point1(2) - Point2(2))
            Ba = Point1(2) * (Point2(0) - Point3(0)) + Point2(2) * (Point3(0) - Point1(0)) + Point3(2) * (Point1(0) - Point2(0))
            Ca = Point1(0) * (Point2(1) - Point3(1)) + Point2(0) * (Point3(1) - Point1(1)) + Point3(0) * (Point1(1) - Point2(1))
            Da = -(AA * Point1(0) + Ba * Point1(1) + Ca * Point1(2))
            Ha = -(AA * Round(Cu_x(jj), 3) + Ba * Round(Cu_y(jj), 3) + Da) / Ca
            Point02(0) = Round(Cu_x(jj), 3): Point02(1) = Round(Cu_y(jj), 3): Point02(2) = Ha

               Cass_x0(5 * gg + 4) = Point02(0)
               Cass_y0(5 * gg + 4) = Point02(1)
               Cass_H0(5 * gg + 4) = Point02(2)
           
     End If
     End If
 Next
  
  '与样线相交的△求出边交点
   
         gg = 1
     For Each ptt In collect
         
         Poly3dline = ptt.Coordinates
     If GetVertexCount(ptt) = 3 Then
         Point4(0) = Round(Poly3dline(0), 3): Point4(1) = Round(Poly3dline(1), 3): Point4(2) = Round(Poly3dline(2), 3)
         Point5(0) = Round(Poly3dline(3), 3): Point5(1) = Round(Poly3dline(4), 3): Point5(2) = Round(Poly3dline(5), 3)
         Point6(0) = Round(Poly3dline(6), 3): Point6(1) = Round(Poly3dline(7), 3): Point6(2) = Round(Poly3dline(8), 3)
         
         BL1 = Line2ToPoint(Point4(0), Point4(1), Point5(0), Point5(1), Round(Cu_x(jj - 1), 3), Round(Cu_y(jj - 1), 3), Round(Cu_x(jj), 3), Round(Cu_y(jj), 3), Xf, Yf)
         BL2 = Line2ToPoint(Point5(0), Point5(1), Point6(0), Point6(1), Round(Cu_x(jj - 1), 3), Round(Cu_y(jj - 1), 3), Round(Cu_x(jj), 3), Round(Cu_y(jj), 3), Xf, Yf)
         BL3 = Line2ToPoint(Point6(0), Point6(1), Point4(0), Point4(1), Round(Cu_x(jj - 1), 3), Round(Cu_y(jj - 1), 3), Round(Cu_x(jj), 3), Round(Cu_y(jj), 3), Xf, Yf)
         
If BL1 = True Or BL2 = True Or BL3 = True Then
 
     If BL1 = True Then
   
            AA = Point4(1) * (Point5(2) - Point6(2)) + Point5(1) * (Point6(2) - Point4(2)) + Point6(1) * (Point4(2) - Point5(2))
            Ba = Point4(2) * (Point5(0) - Point6(0)) + Point5(2) * (Point6(0) - Point4(0)) + Point6(2) * (Point4(0) - Point5(0))
            Ca = Point4(0) * (Point5(1) - Point6(1)) + Point5(0) * (Point6(1) - Point4(1)) + Point6(0) * (Point4(1) - Point5(1))
            Da = -(AA * Point4(0) + Ba * Point4(1) + Ca * Point4(2))
            Ha = -(AA * Xf + Ba * Yf + Da) / Ca
            Zf = Ha
            point04(0) = Xf: point04(1) = Yf: point04(2) = Zf
            
        Dim fat As Boolean
        fat = False
        g = 0
     For g = 0 To UBound(Cass_x0())
     If point04(0) = Cass_x0(g) And point04(1) = Cass_y0(g) And point04(2) = Cass_H0(g) Then
        fat = True
        g = g + 1
          End If
     Next g
         If fat = False Then
            Cass_x0(5 * gg + 1) = point04(0)
            Cass_y0(5 * gg + 1) = point04(1)
            Cass_H0(5 * gg + 1) = point04(2)
      
        End If
        End If
        
     If BL2 = True Then
   
            AA = Point4(1) * (Point5(2) - Point6(2)) + Point5(1) * (Point6(2) - Point4(2)) + Point6(1) * (Point4(2) - Point5(2))
            Ba = Point4(2) * (Point5(0) - Point6(0)) + Point5(2) * (Point6(0) - Point4(0)) + Point6(2) * (Point4(0) - Point5(0))
            Ca = Point4(0) * (Point5(1) - Point6(1)) + Point5(0) * (Point6(1) - Point4(1)) + Point6(0) * (Point4(1) - Point5(1))
            Da = -(AA * Point4(0) + Ba * Point4(1) + Ca * Point4(2))
            Ha = -(AA * Xf + Ba * Yf + Da) / Ca
            Zf = Ha
            point05(0) = Xf: point05(1) = Yf: point05(2) = Zf
            
            Dim fat1 As Boolean
        fat1 = False
        g = 0
     For g = 0 To UBound(Cass_x0())
     If point05(0) = Cass_x0(g) And point05(1) = Cass_y0(g) And point05(2) = Cass_H0(g) Then
        fat1 = True
        g = g + 1
          End If
     Next g
         If fat1 = False Then
            Cass_x0(5 * gg + 2) = point05(0)
            Cass_y0(5 * gg + 2) = point05(1)
            Cass_H0(5 * gg + 2) = point05(2)
      
        End If
        End If

     If BL3 = True Then
   
            AA = Point4(1) * (Point5(2) - Point6(2)) + Point5(1) * (Point6(2) - Point4(2)) + Point6(1) * (Point4(2) - Point5(2))
            Ba = Point4(2) * (Point5(0) - Point6(0)) + Point5(2) * (Point6(0) - Point4(0)) + Point6(2) * (Point4(0) - Point5(0))
            Ca = Point4(0) * (Point5(1) - Point6(1)) + Point5(0) * (Point6(1) - Point4(1)) + Point6(0) * (Point4(1) - Point5(1))
            Da = -(AA * Point4(0) + Ba * Point4(1) + Ca * Point4(2))
            Ha = -(AA * Xf + Ba * Yf + Da) / Ca
            Zf = Ha
            point06(0) = Xf: point06(1) = Yf: point06(2) = Zf
            
            Dim fat2 As Boolean
        fat2 = False
        g = 0
     For g = 0 To UBound(Cass_x0())
     If point06(0) = Cass_x0(g) And point06(1) = Cass_y0(g) And point06(2) = Cass_H0(g) Then
        fat2 = True
        g = g + 1
          End If
     Next g
         If fat2 = False Then
            Cass_x0(5 * gg + 3) = point06(0)
            Cass_y0(5 * gg + 3) = point06(1)
            Cass_H0(5 * gg + 3) = point06(2)
         End If
         End If
         
    End If
    End If
 gg = gg + 1
 
Next
          Dim pnt() As Variant
          Dim jn As Integer
          jn = 0
     For j = 0 To UBound(Cass_x0())
         If Abs(Cass_x0(j)) > 0 And Abs(Cass_y0(j)) > 0 And Abs(Cass_H0(j)) > 0 Then
                ReDim Preserve pnt(jn)
                pnt(jn) = Point3d(Cass_x0(j), Cass_y0(j), Cass_H0(j))
                jn = jn + 1
          End If
     Next j
     MsgBox UBound(pnt)
     
  '排序
   PtList pnt, True, True, 0
   
    Dim newtxt As String
    newtxt = "坐标排序的顺序:"
    Dim Cass_L() As Double
    Dim pointobj As AcadPoint
     For j = 0 To UBound(pnt)
      
      If Abs(pnt(j)(0)) > 0 And Abs(pnt(j)(1)) > 0 And Abs(pnt(j)(2)) > 0 Then
           ReDim Preserve Cass_L(3 * j + 2)
           Cass_L(3 * j + 0) = pnt(j)(0)
           Cass_L(3 * j + 1) = pnt(j)(1)
           Cass_L(3 * j + 2) = pnt(j)(2)
           
           newtxt = newtxt & vbCr & "第" & j + 1 & "点坐标为:" & pnt(j)(0) & "   " & pnt(j)(1) & "   " & pnt(j)(2)
           If Cu_x(0) <= Cu_x(UBound(Cu_x())) Then
                    Set Cass_Text = ThisDrawing.ModelSpace.AddText(j + 1, pnt(j), 0.3)
           Else
                    Set Cass_Text = ThisDrawing.ModelSpace.AddText(UBound(pnt) - j + 1, pnt(j), 0.3)
           End If
                        Cass_Text.Color = acYellow
             Set pointobj = .ModelSpace.AddPoint(pnt(j))     '点
                .SetVariable "PDMODE", 35
                .SetVariable "PDSIZE", 0.15
                 pointobj.Color = acGreen
          End If
         
       Next j
  
       MsgBox newtxt
      
    Dim Plineobj1 As Acad3DPolyline
      
        Set Plineobj1 = ThisDrawing.ModelSpace.Add3DPoly(Cass_L) '画样线
            Plineobj1.Lineweight = acLnWt020
            ThisDrawing.Application.Update
               
   Erase Cass_x0()
   Erase Cass_y0()
   Erase Cass_H0()
   Erase pnt

   Next jj
 
 End With

   TriangleNet.Clear
   Set TriangleNet = Nothing
   Unload Me
   
End Sub
搜索更多相关主题的帖子: 画图 三角形 如何 
2012-12-09 15:52
lzx1556
Rank: 1
等 级:新手上路
帖 子:41
专家分:8
注 册:2012-9-5
收藏
得分:0 
没有高手???
2012-12-21 21:54
bczgvip
Rank: 14Rank: 14Rank: 14Rank: 14
等 级:贵宾
威 望:66
帖 子:1310
专家分:5312
注 册:2009-2-26
收藏
得分:0 
不是每个人都安装CAD的,楼主代码用到了CAD的控件,或是动态库?呃,忘了。
2012-12-22 00:44
lzx1556
Rank: 1
等 级:新手上路
帖 子:41
专家分:8
注 册:2012-9-5
收藏
得分:0 
我想最有可能的是那个动态数组,请高手看看那个动态数组的形式是不是满足这种写法?如果有更好的动态数组形式,请明示,谢了!

或者是与三角形的法线方向有关吗?
2012-12-27 09:18
yz1025
Rank: 8Rank: 8
等 级:蝙蝠侠
威 望:6
帖 子:491
专家分:919
注 册:2012-10-26
收藏
得分:0 
autocad有VBA
几年前拿过autocad结训证书时
老师没跟我们说autocad有VBA耶
基础工都是在纸上画3视图
最后才上机熟悉autocad界面
没记错的话是R14版的

不要投我
2012-12-27 16:50
lzx1556
Rank: 1
等 级:新手上路
帖 子:41
专家分:8
注 册:2012-9-5
收藏
得分:0 
,aaaa......
2012-12-27 17:41
lzx1556
Rank: 1
等 级:新手上路
帖 子:41
专家分:8
注 册:2012-9-5
收藏
得分:0 
2012-12-29 13:41
lzx1556
Rank: 1
等 级:新手上路
帖 子:41
专家分:8
注 册:2012-9-5
收藏
得分:0 
经过仔细分析,问题以自己解决,谢谢诸位!
2013-01-04 14:48
快速回复:画线
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.023416 second(s), 8 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved