乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 14|回复: 0

用Vlax、Curve类离散地形等高线为文字为什么有时会自动退出ACAD

[复制链接]

3

主题

3

帖子

1

银币

初来乍到

Rank: 1

铜币
15
发表于 2007-4-21 14:09:00 | 显示全部楼层 |阅读模式
运用Vlax、Curve类 写了一个离散等高线为文字的函数,但性能不稳定,有时多选几条等高线后会出现参数过多的提示或自动退出ACAD,请大侠帮忙看看问题何在?拜托!
Sub dgx_text()
    '定义选择集
    Dim SsetObj As AcadSelectionSet
    Dim FilterType(0 To 1) As Integer
    Dim FilterData(0 To 1) As Variant
   
    '定义循环变量
    Dim N As Long
    Dim I As Long, J As Long, K As Long, II As Long, JJ As Long
   
    '定义文字变量
    Dim High As Double
    Dim XText As AcadText
    Dim insPt(0 To 2) As Double
   
     '定义引用曲线类模块
     Dim ObjCurve As Curve
     Set ObjCurve = New Curve
     '获取曲线变量
     Dim sPt As Variant
     Dim ePt As Variant
     Dim Pt As Variant
     Dim ENT As AcadEntity
   
    '配置参数
    Dim Dist As Double
    Dim Htext As Double
    Dim Color1 As Integer
    Dim Color2 As Integer
    Dim Color3 As Integer
   
    'Op.Show
    'Dist = Val(Op.TextBox1.Text)
    'Htext = Val(Op.TextBox2.Text)
    'Color1 = Val(Op.TextBox3.Text)
    'Color2 = Val(Op.TextBox4.Text)
    Dist = 5
    Htext = 1
    Color1 = 3
    Color2 = 1
   
   
   
    '选择曲线
    On Error Resume Next
    Set SsetObj = ThisDrawing.SelectionSets.Add("b")
    If Err Then
        Err.Clear
        Set SsetObj = ThisDrawing.SelectionSets.Item("b")
    End If
    SsetObj.Clear
    SsetObj.SelectOnScreen
    N = SsetObj.Count
   
   
    Dim Length As Double
    Dim mLength As Double
    '循环选择对象
    For I = 0 To N - 1
        If SsetObj.Item(I).ObjectName = "AcDbLine" Or _
           SsetObj.Item(I).ObjectName = "AcDbCircle" Or _
           SsetObj.Item(I).ObjectName = "AcDbArc" Or _
           SsetObj.Item(I).ObjectName = "AcDbSpline" Or _
           SsetObj.Item(I).ObjectName = "AcDb3dPolyline" Or _
           SsetObj.Item(I).ObjectName = "AcDbPolyline" Or _
           SsetObj.Item(I).ObjectName = "AcDb2dPolyline" Or _
           SsetObj.Item(I).ObjectName = "AcDbEllipse" Or _
           SsetObj.Item(I).ObjectName = "AcDbLeader" Then
           
            If SsetObj.Item(I).ObjectName = "AcDbLine" Then
                High = SsetObj.Item(I).StartPoint()(2)
            ElseIf SsetObj.Item(I).ObjectName = "AcDbCircle" Then
                High = SsetObj.Item(I).CenterPoint()(2)
            ElseIf SsetObj.Item(I).ObjectName = "AcDbArc" Then
                High = SsetObj.Item(I).CenterPoint()(2)
            ElseIf SsetObj.Item(I).ObjectName = "AcDbSpline" Then
                High = SsetObj.Item(I).ControlPoints(0)(2)
            ElseIf SsetObj.Item(I).ObjectName = "AcDb3dPolyline" Then
                High = SsetObj.Item(I).Coordinates()(2)
            ElseIf SsetObj.Item(I).ObjectName = "AcDbPolyline" Then
                High = SsetObj.Item(I).Elevation
            ElseIf SsetObj.Item(I).ObjectName = "AcDb2dPolyline" Then
                High = SsetObj.Item(I).Elevation
            End If
            Set ENT = SsetObj.Item(I)
            '亮显要处理的曲线以方便输入曲线代表高程
            Color3 = SsetObj.Item(I).color
            SsetObj.Item(I).color = Color1
            SsetObj.Item(I).Update
            ENT.Highlight True
            If High  0 Then
                Set ObjCurve.Entity = ENT
                sPt = ObjCurve.StartPoint
                ePt = ObjCurve.EndPoint
                Length = ObjCurve.Length
                ThisDrawing.ModelSpace.AddText Trim(Str(High)), sPt, Htext
                ThisDrawing.ModelSpace.AddText Trim(Str(High)), ePt, Htext
                If Length > Dist Then
                    mLength = 0
                    Do
                      mLength = mLength + Dist
                      If mLength
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-7-7 17:26 , Processed in 0.903291 second(s), 54 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表