设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 120|回复: 2

[分享] 坐标标注

[复制链接]

已领礼包: 7个

财富等级: 恭喜发财

发表于 2019-1-2 15:32:55 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

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

x
坐标标注   X Y坐标都可用   

[pcode=vb,true]

' 在模型空间中创建坐标标注。
Public Sub pc_zb()
    On Error Resume Next

    Dim dimObj As AcadDimOrdinate
    Dim pT0 As Variant
    Dim pT As Variant
    Dim pTyd(0 To 2) As Double
    Dim pTs(0 To 2) As Double
    Dim pTe(0 To 2) As Double
    Dim fx As Boolean

    fx = True
    pTyd(0) = 0: pTyd(1) = 0: pTyd(2) = 0
    pT0 = ThisDrawing.Utility.GetPoint(, "坐标起点: ")

    Dim j_xxs As Double, j_yxs As Double, j_wzxs As Boolean
    j_wzxs = True
    '获取标注的全局比例
    Dim RetVal As Variant
    RetVal = ThisDrawing.GetVariable("dimscale")
    j_xxs = 0: j_yxs = RetVal * 10

    ' 在模型空间中创建起点坐标标注
    pTs(0) = 0: pTs(1) = 0: pTs(2) = 0
    pTe(0) = j_xxs: pTe(1) = j_yxs: pTe(2) = 0
    Set dimObj = ThisDrawing.ModelSpace.AddDimOrdinate(pTs, pTe, fx)
    dimObj.Layer = "标注"
    dimObj.Move pTyd, pT0

     '设置关键字
    ThisDrawing.Utility.InitializeUserInput 1, "X Y T"
    Do
        pT = ThisDrawing.Utility.GetPoint(pT0, "[X]标注X坐标,[Y]标注Y坐标,[T]变换文字位置,选取下一点: ")
        If Err Then
            If InStr(1, Err.Description, "关键字", vbTextCompare) > 0 Or _
                InStr(1, Err.Description, "keyword", vbTextCompare) > 0 Then '输入了一个关键字
                Dim inputString As String
                Err.Clear
                inputString = ThisDrawing.Utility.GetInput
                Select Case inputString
                    Case "X"
                        fx = True
                        If j_wzxs Then
                            j_xxs = 0: j_yxs = RetVal * 10
                        Else
                            j_xxs = 0: j_yxs = 0 - RetVal * 10
                        End If
                    Case "Y"
                        fx = False
                        If j_wzxs Then
                            j_xxs = RetVal * 10: j_yxs = 0
                        Else
                            j_xxs = 0 - RetVal * 10: j_yxs = 0
                        End If
                    Case "T"
                        j_wzxs = Not j_wzxs
                        j_xxs = 0 - j_xxs: j_yxs = 0 - j_yxs
                End Select
            Else
                Err.Clear
                Exit Sub  '错误退出
            End If
        Else
            pTs(0) = pT(0) - pT0(0): pTs(1) = pT(1) - pT0(1): pTs(2) = 0
            pTe(0) = pTs(0) + j_xxs: pTe(1) = pTs(1) + j_yxs: pTe(2) = 0
            Set dimObj = ThisDrawing.ModelSpace.AddDimOrdinate(pTs, pTe, fx)
                dimObj.Layer = "标注"
                dimObj.Move pTyd, pT0
        End If
    Loop
End Sub

[/pcode]

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 7个

财富等级: 恭喜发财

 楼主| 发表于 2019-1-2 15:34:48 | 显示全部楼层
为什么不是高亮显示


  1. ' 在模型空间中创建坐标标注。
  2. Public Sub pc_zb()
  3.     On Error Resume Next
  4.    
  5.     Dim dimObj As AcadDimOrdinate
  6.     Dim pT0 As Variant
  7.     Dim pT As Variant
  8.     Dim pTyd(0 To 2) As Double
  9.     Dim pTs(0 To 2) As Double
  10.     Dim pTe(0 To 2) As Double
  11.     Dim fx As Boolean
  12.    
  13.     fx = True
  14.     pTyd(0) = 0: pTyd(1) = 0: pTyd(2) = 0
  15.     pT0 = ThisDrawing.Utility.GetPoint(, "坐标起点: ")
  16.    
  17.     Dim j_xxs As Double, j_yxs As Double, j_wzxs As Boolean
  18.     j_wzxs = True
  19.     '获取标注的全局比例
  20.     Dim RetVal As Variant
  21.     RetVal = ThisDrawing.GetVariable("dimscale")
  22.     j_xxs = 0: j_yxs = RetVal * 10
  23.    
  24.     ' 在模型空间中创建起点坐标标注
  25.     pTs(0) = 0: pTs(1) = 0: pTs(2) = 0
  26.     pTe(0) = j_xxs: pTe(1) = j_yxs: pTe(2) = 0
  27.     Set dimObj = ThisDrawing.ModelSpace.AddDimOrdinate(pTs, pTe, fx)
  28.     dimObj.Layer = "标注"
  29.     dimObj.Move pTyd, pT0
  30.    
  31.      '设置关键字
  32.     ThisDrawing.Utility.InitializeUserInput 1, "X Y T"
  33.     Do
  34.         pT = ThisDrawing.Utility.GetPoint(pT0, "[X]标注X坐标,[Y]标注Y坐标,[T]变换文字位置,选取下一点: ")
  35.         If Err Then
  36.             If InStr(1, Err.Description, "关键字", vbTextCompare) > 0 Or _
  37.                 InStr(1, Err.Description, "keyword", vbTextCompare) > 0 Then '输入了一个关键字
  38.                 Dim inputString As String
  39.                 Err.Clear
  40.                 inputString = ThisDrawing.Utility.GetInput
  41.                 Select Case inputString
  42.                     Case "X"
  43.                         fx = True
  44.                         If j_wzxs Then
  45.                             j_xxs = 0: j_yxs = RetVal * 10
  46.                         Else
  47.                             j_xxs = 0: j_yxs = 0 - RetVal * 10
  48.                         End If
  49.                     Case "Y"
  50.                         fx = False
  51.                         If j_wzxs Then
  52.                             j_xxs = RetVal * 10: j_yxs = 0
  53.                         Else
  54.                             j_xxs = 0 - RetVal * 10: j_yxs = 0
  55.                         End If
  56.                     Case "T"
  57.                         j_wzxs = Not j_wzxs
  58.                         j_xxs = 0 - j_xxs: j_yxs = 0 - j_yxs
  59.                 End Select
  60.             Else
  61.                 Err.Clear
  62.                 Exit Sub  '错误退出
  63.             End If
  64.         Else
  65.             pTs(0) = pT(0) - pT0(0): pTs(1) = pT(1) - pT0(1): pTs(2) = 0
  66.             pTe(0) = pTs(0) + j_xxs: pTe(1) = pTs(1) + j_yxs: pTe(2) = 0
  67.             Set dimObj = ThisDrawing.ModelSpace.AddDimOrdinate(pTs, pTe, fx)
  68.                 dimObj.Layer = "标注"
  69.                 dimObj.Move pTyd, pT0
  70.         End If
  71.     Loop
  72. End Sub
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 71个

财富等级: 招财进宝

发表于 2019-1-3 07:50:48 | 显示全部楼层
谢谢!学习学习!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

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

本版积分规则

QQ|申请友链|小黑屋|手机版|Archiver|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )  

GMT+8, 2019-7-17 04:35 , Processed in 0.068898 second(s), 25 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

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