设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › VBA/VB/ActiveX/API 编程技术 › 用VB6进行Autocad的二次开发(原创)
12345678910... 21下一页
返回列表 发新帖
查看: 68126|回复: 253

用VB6进行Autocad的二次开发(原创)

    [复制链接]
zzyong00
发表于 2014-10-18 19:03:19 | 显示全部楼层 |阅读模式
本帖最后由 zzyong00 于 2014-10-21 21:47 编辑

     版本较高一些AutoCAD，都支持COM开发，而vb6基于COM开发是其拿手好戏。因此，用VB6进行Autocad的二次开发是完全可以的！
      当然，AutoDesk官方并没有明确说明关于用vb6开发的相关信息，而且，vb6的autocad二次开发的程序也有一定的局限性，因此，用VB6进行Autocad的二次开发应用并不广泛！
      AutoDesk官方提供VBA开发的方式，VBA与VB语法几乎完全相同，开发方便、灵活，但由于vba是解释执行，运行速度较慢，而且，源代码几乎没有保密性可言，因此，几乎没人有用VBA进行autocad的商业开发。
     本人介绍一些用VB6进行Autocad的二次开发的方法，以抛砖引玉。
一、基本情况介绍
     1、vb6与autocad的连接
    vb6调用任何COM对象（即ActiveX对象，包括ActiveX Dll 、ActiveX EXE等 ），基本都有两种方法，即前期绑定和后期绑定，
前期绑定需要在Vb6IDE环境下引用COM对象，而后期绑定则不需要引用，只需要用代码实现即可。关于前期绑定和后期绑定，是VB6的一些基础知识，这里不做介绍。
      哪么在用VB6进行Autocad的二次开发，是采用前期绑定和后期绑定呢?应该说是都可以了，但是，在编码调试过程中，最好引用COM对象，编码的自动完成功能就值得你这么做！
接下来，我们开始进行VB6+Autocad二次开发的第一步了
（1）打开vb6 IDE,新建一个“标准 exe"工程，在”工程“菜单下，”引用“ Autocad 200* Type Library(你电脑里正确安装的某个版本的Autocad)
(2)新建模块，命名为ModCommon,输入以下代码：
  1. Public objCad As Object  ''定义为全局Autocad对象
  2.    Public Sub ConnectAutoCAD()
  3.     On Error Resume Next
  4.     #Const cadVer = "R16"''条件编译开关,根据你电脑安装的Autocad版本修改，如果实在不知道，把本行代码注释掉也行

  6.     #If cadVer = "R16" Then
  7.         '----------------------------------
  8.         '' R16(autocad2004~2006)
  9.         Set objCad = GetObject(, "Autocad.Application.16")

  11.         If Err Then
  12.             Err.Clear
  13.             Set objCad = CreateObject("Autocad.Application.16")
  14.             objCad.Visible = True

  16.             If Err Then

  18.                 MsgBox "计算机可能没有正确安装相应版本的Autocad", vbOKOnly + vbCritical
  19.                 End
  20.             End If

  22.         End If
  23.         '----------------------------------------------------
  24.     #ElseIf cadVer = "R17" Then
  25.         '     '----------------------------------
  26.         '    'R17(autocad2007~2009)
  27.         Set objCad = GetObject(, "Autocad.Application.17")

  29.         If Err Then
  30.             Err.Clear
  31.             Set objCad = CreateObject("Autocad.Application.17")
  32.             objCad.Visible = True

  34.             If Err Then

  36.                 MsgBox "计算机可能没有正确安装相应版本的Autocad", vbOKOnly + vbCritical
  37.                 End
  38.             End If

  40.         End If
  41.     #ElseIf cadVer = "R18" Then

  43.         '    '----------------------------------------------------
  44.         '----------------------------------
  45.         '''''    R18(autocad2010~2012)
  46.         Set objCad = GetObject(, "Autocad.Application.18")

  48.         If Err Then
  49.             Err.Clear
  50.             Set objCad = CreateObject("Autocad.Application.18")
  51.             objCad.Visible = True

  53.             If Err Then

  55.                 MsgBox "计算机可能没有正确安装相应版本的Autocad", vbOKOnly + vbCritical
  56.                 End
  57.             End If

  59.         End If
  60.         '''    '----------------------------------------------------
  61.         '----------------------------------------------------
  62.     #ElseIf cadVer = "R19" Then

  64.         'R19(autocad2013~2014)
  65.         Set objCad = GetObject(, "Autocad.Application.19")

  67.         If Err Then
  68.             Err.Clear
  69.             Set objCad = CreateObject("Autocad.Application.19")
  70.             objCad.Visible = True

  72.             If Err Then

  74.                 MsgBox "计算机可能没有正确安装相应版本的Autocad", vbOKOnly + vbCritical
  75.                 End
  76.             End If

  78.         End If
  79.         '''''''''''''''''''''''''''''''''''''''''''
  80.     #ElseIf cadVer = "R20" Then

  82.         '    'R20(autocad2015~2015)
  83.         Set objCad = GetObject(, "Autocad.Application.20")

  85.         If Err Then
  86.             Err.Clear
  87.             Set objCad = CreateObject("Autocad.Application.20")
  88.             objCad.Visible = True

  90.             If Err Then

  92.                 MsgBox "计算机可能没有正确安装相应版本的Autocad", vbOKOnly + vbCritical
  93.                 End
  94.             End If

  96.         End If
  97.         ''
  98.         '----------------------------------------------------
  99.     #Else
  100.         '    '----------------------------------
  101.         '通用代码
  102.         Set objCad = GetObject(, "Autocad.Application")

  104.         If Err Then
  105.             Err.Clear
  106.             Set objCad = CreateObject("Autocad.Application")
  107.             objCad.Visible = True

  109.             If Err Then

  111.                 MsgBox "计算机可能没有正确安装相应版本的Autocad", vbOKOnly + vbCritical
  112.                 End
  113.             End If

  115.         End If
  116.         '----------------------------------------------------

  118.     #End If
  119.         
  120.     AppActivate objCad.Caption
  121.   
  122. End Sub


(3)在 form1中输入以下代码：
  1. Private Sub Form_Load()
  2. ConnectAutoCAD
  3. End Sub


按F5运行程序，一阵等待后，你会发现Autocad展现在你面前


而且, autocad, 源代码, 局限性, 开发, autocad

点评

chenshulu
把你那个排行列等距图框的程序放上来，可设置明经币，给大家测测看，  发表于 2014-10-30 11:25

评分

参与人数 5明经币 +6 金钱 +16 收起 理由
3xxx + 1 + 10
zctao1966 + 1 很给力!
VBALISPER + 1 很给力!
xiaxiang + 2 很给力!
不死猫 + 1 + 6

查看全部评分

本帖被以下淘专辑推荐:

相关帖子
回复

使用道具 举报

zzyong00
 楼主| 发表于 2014-10-25 22:57:03 | 显示全部楼层
本帖最后由 zzyong00 于 2014-10-25 22:58 编辑

2、坐标标注
坐标标注本身很简单，类似的工具满天飞，我这里也贴一个


  1. Public Sub SeriesCoordinate()                                                   '连续标坐标
  2.     Dim blnExitSeriesCoord As Boolean
  3.     ' InitCommonVar
  4.     '全局变量
  5.     Coordinate_TextHeight = 3
  6.     ratio = 1
  7.     TextRowSpace = 0.6

  9.     Do
  10.         Coordinate blnExitSeriesCoord '本子过程源码需要回复才能看到
  11.     Loop Until blnExitSeriesCoord
  12. End Sub

  1.     On Error GoTo err1
  2.     '    Dim Coordinate_TextHeight As Double '文字高
  3.     '    Dim Ratio As Double '全局比例
  4.     '    Dim TextRowSpace As Double '文字行间距
  5.     '    Coordinate_TextHeight = 3
  6.     '    Ratio = 1
  7.     '    TextRowSpace = 0.6
  8.     Dim p1, p2                                                                  '标注点坐标，标注文字位置
  9.     p1 = ThisDrawing.Utility.GetPoint(, "请点击要标注的点（按回车键退出）:")
  10.     p2 = ThisDrawing.Utility.GetPoint(p1, "请点击标注位置（按回车键退出）:")
  11.     Dim T1   As AcadText, T2 As AcadText
  12.     Dim strT As String, intStrL1 As Integer, intStrL2 As Integer                'Y和X坐标文字的长度
  13.     strT = "X " & Format$(p1(1), "0.000")
  14.     intStrL1 = Len(strT)
  15.     Dim pt1(2) As Double, pt2(2) As Double                                      '文字坐标
  16.     If p2(0) > p1(0) Then                                                       '确定标注点与标注文字位置的左右关系，以确定文字插入点
  17.         pt1(0) = p2(0)
  18.         pt1(1) = p2(1) + TextRowSpace / 2 * Coordinate_TextHeight * ratio
  19.     Else
  20.         pt1(0) = p2(0) - intStrL1 * Coordinate_TextHeight * ratio * _
  21.         ThisDrawing.ActiveTextStyle.Width ^ 2                                   '宽度比例(总是宽度比例的平方，因为当前文字样式设了宽度，而AcadText本身又有个ScaleFactor,而且等于width）
  22.         pt1(1) = p2(1) + TextRowSpace / 2 * Coordinate_TextHeight * ratio
  23.     End If
  24.     Set T1 = ThisDrawing.ModelSpace.AddText(strT, pt1, Coordinate_TextHeight * ratio)
  25.     T1.Visible = False
  26.     strT = "Y " & Format$(p1(0), "0.000")
  27.     intStrL2 = Len(strT)
  28.     pt2(0) = pt1(0)
  29.     pt2(1) = pt1(1) - T1.Height * (1 + TextRowSpace)                            'TextRowSpace代表文字间距是TextRowSpace倍的字高
  30.     Set T2 = ThisDrawing.ModelSpace.AddText(strT, pt2, Coordinate_TextHeight * ratio)
  31.     T2.Visible = False
  32.     Dim Pend(2) As Double                                                       '标注结束点
  33.     Pend(0) = p2(0)
  34.     Dim TminP, TmaxP
  35.     If intStrL1 > intStrL2 Then                                                 '取最长文字长度
  36.         T1.GetBoundingBox TminP, TmaxP
  37.     Else
  38.         T2.GetBoundingBox TminP, TmaxP
  39.     End If
  40.     If p2(0) > p1(0) Then                                                       '确定标注点与标注文字位置的左右关系，以确定标注结束点位置
  41.         Pend(0) = p2(0) + (TmaxP(0) - TminP(0))
  42.         Pend(1) = p2(1)
  43.     Else
  44.         Pend(0) = p2(0) - (TmaxP(0) - TminP(0))
  45.         Pend(1) = p2(1)
  46.         pt1(0) = Pend(0)
  47.         pt2(0) = Pend(0)
  48.         T1.InsertionPoint = pt1
  49.         T2.InsertionPoint = pt2
  50.     End If
  51.     T1.Visible = True
  52.     T2.Visible = True

  54.     Dim L1 As AcadLine, L2 As AcadLine
  55.     Set L1 = ThisDrawing.ModelSpace.AddLine(p1, p2)
  56.     Set L2 = ThisDrawing.ModelSpace.AddLine(p2, Pend)
  57.     Exit Sub
  58. err1:
  59.     Err.Clear
  60.     blnExitSeriesCoord = True
  61. End Sub


对于vb或vba来说，在没创建AcadText对象之前，很难精确算出AcadText对象的长度，本例子中，先大致估算，然后生成AcadText对象，但暂时隐藏它，通过GetBoundingBox 取得AcadText对象真实大小后，再调整AcadText对象位置和直线长度！

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x
回复 支持 2 反对 0

使用道具 举报

zzyong00
 楼主| 发表于 2014-10-20 21:58:42 | 显示全部楼层
另外说一点Autocad的小知识，知道的同志请忽略，对于不支持先选择后执行命令的命令，也可以先选择后执行，方法是：（1），选择你要选择的对象
                   （2），执行命令，选择对象之前按p键，回车就可以了
回复 支持 0 反对 1

使用道具 举报

Source_Liu
发表于 2022-9-24 22:05:47 来自手机 | 显示全部楼层
好东西，其它语言也可以参考。可惜微软逐渐放弃VB6了
回复 支持 1 反对 0

使用道具 举报

landsat99
发表于 2022-4-20 13:23:58 | 显示全部楼层
经典的vb6，，不支持64位  

永远的痛。。。

点评

hhc
是啊，同感........  发表于 2023-2-26 20:50
回复 支持 1 反对 0

使用道具 举报

vbcad
发表于 2014-10-24 18:47:50 | 显示全部楼层
顶！
楼主的免费教程，无私分享令人敬佩！
支持！！
回复 支持 1 反对 0

使用道具 举报

zjyingxf
发表于 2015-10-8 16:47:49 | 显示全部楼层
zjyingxf 发表于 2015-9-21 14:17
楼主大神，VB6引用64位CAD，编译不通过怎么解决的呢。

为什么我一编译就出错呢
回复 支持 1 反对 0

使用道具 举报

zzyong00
 楼主| 发表于 2014-11-22 23:09:11 | 显示全部楼层
增加一个判断点在pl曲线内侧还是外侧
  1. '在模块中添加以下代码
  2. Public Enum InOut
  3.     Inside = -1
  4.     Outside = 1
  5. End Enum

  7. Private Function InOutside(pl As AcadLWPolyline, P1 As Variant) As long
  8.     'PL是要标注的PL线，P1是要监测是否在曲线内的点，三维DOUBLE数组
  9.     '判断标注位置是否在PL范围内，可以设定坐标标在范围内还是外面
  10.     'intInOut=-1是内侧，intInOut＝1是外侧,intInOut=0是不确定是内还是外
  11.     Dim Ppl   As Variant
  12.     Dim tmpPL As AcadLWPolyline
  13.     Dim i     As Integer
  14.     Set tmpPL = pl.Copy

  16.     tmpPL.Closed = True
  17.     tmpPL.Elevation = 0
  18.     Ppl = tmpPL.Coordinates
  19.     Dim dblYmax As Double                                                       'Y坐标最大值
  20.     dblYmax = Ppl(1)
  21.     For i = 3 To UBound(Ppl) Step 2                                            
  22.         If dblYmax < Ppl(i) Then dblYmax = Ppl(i)
  23.     Next i
  24.     Dim tmpP(2) As Double                                                       '临时点
  25.     tmpP(0) = P1(0)
  26.     tmpP(1) = dblYmax + 100
  27.     tmpP(2) = 0
  28.     Dim objL As AcadLine
  29.     Set objL = ThisDrawing.ModelSpace.AddLine(P1, tmpP)

  31.     'ZoomAll
  32.     Dim dblPoints As Variant
  33.     dblPoints = objL.IntersectWith(tmpPL, acExtendNone)
  34.     tmpPL.Delete
  35.     objL.Delete                                                                 '清理战场
  36.     'Debug.Print VarType(dblPoints) '即使没有交点，也是一个空的三维数组
  37.     If UBound(dblPoints) = -1 Then                                          
  38.         InOutside = Outside                                                   
  39.         Exit Function
  40.     End If
  41.     If ((UBound(dblPoints) - LBound(dblPoints) + 1) / 3) Mod 2 Then             '交点个数为奇数，就在内侧；为偶数，就在外侧
  42.         InOutside = Inside
  43.     Else
  44.         InOutside = Outside
  45.     End If
  46.     'Debug.Print InOutside
  47. End Function


回复 支持 1 反对 0

使用道具 举报

zzyong00
 楼主| 发表于 2014-10-18 19:21:45 | 显示全部楼层
2、Autocad对象模型
Autocad对象模型是树型结构，具体内容详见Autocad开发人员帮助或明经论坛翻译的中文版AcadAuto.chm。
Autocad对象模型中最重要的对象是AcadDocument对象，在VBA中，当前图的AcadDocument对象的对象名是ThisDrawing,这个名起的非常好，顾名而思意，在AcadAuto.chm中，所有涉及到AcadDocument对象的代码都用的是ThisDrawing.
如以下代码：
  1. Sub Example_TextString()
  2.     ' This example creates a text object in model space.
  3.     ' It then returns the text string for that object.
  4.    
  5.     Dim textObj As AcadText
  6.     Dim text As String
  7.     Dim insertionPoint(0 To 2) As Double
  8.     Dim height As Double
  9.    
  10.     ' Define the text object
  11.     text = "Hello, World."
  12.     insertionPoint(0) = 2: insertionPoint(1) = 2: insertionPoint(2) = 0
  13.     height = 0.5
  14.    
  15.     ' Create the text object in model space
  16.     Set textObj = ThisDrawing.ModelSpace.AddText(text, insertionPoint, height)
  17.     ZoomAll
  18.    
  19.     ' Return the current text string for the object
  20.     text = textObj.textString
  21.     MsgBox "The TextString property equals: " & text, vbInformation, "TextString 示例"
  22.       
  23. End Sub

而在VB6中，即使你引用Autocad对象，也没有ThisDrawing这个对象，如果用vb6测试VBA代码时，就会很麻烦。因此，需要你在ModCommon.bas中增加函数。
  1. Public Function ThisDrawing() As AcadDocument
  2.     If Not (objCad Is Nothing) Then Set ThisDrawing = objCad.ActiveDocument
  3. End Function

有了上面代码，你就可以轻松测试大部分VBA代码了。
*请你想想，为什么不把ThisDrawing定义成一个AcadDocument类型的变量，而是要定义成返回AcadDocument类型的函数呢？
回复 支持 反对

使用道具 举报

zzyong00
 楼主| 发表于 2014-10-19 22:54:29 | 显示全部楼层
本帖最后由 zzyong00 于 2014-10-19 23:02 编辑

用VB6进行Autocad的二次开发的基本环境已经搭建完成，接下来牛刀小试了！
首先我们征对单行文字进行各种操作。
1、增量复制
功能，请看gif演示

分析：实现该功能分解步骤：
（1）选择单行文字
（2）输入序号的增量，即每复制一次增加几？
(3)复制基点与目标点和原文字与目标文字插入点的计算
（4）生成一个新单行文字
对于（1）选择单行文字文字来说，有多选和单选的区别，多选一般用AcadSelectionSet对象的Select****方法，而单选一般用
AcadDocumnet的Utility类的GetEntity 方法。
对于单选，本人给出一个子程序SelectSingleText。
在工程中新建一个模块，取名为ModTextTreatment.bas
添加以下代码：
  1. Private Sub SelectSingleText(returnObj As AcadText, blnESC As Boolean)

  3.     Dim basePnt As Variant

  5.     On Error Resume Next

  7. RETRY:
  8.     ThisDrawing.Utility.GetEntity returnObj, basePnt, "请选择单行文字："
  9.    ' Debug.Print Err.Number, Err.Description

  11.     If Err.Number = -2147352567 Then
  12.         blnESC = True
  13.         Exit Sub
  14.     End If

  16.     If Err <> 0 Then
  17.         Err.Clear
  18.         GoTo RETRY
  19.     Else
  20.         returnObj.Highlight True
  21.      End If


子程序SelectSingleText的简要说明：
参数：returnObj 返回选择的单行文字；
blnESC是一个标记，标记用户是否选择了文字，有可能用户按ESC键取消了操作
如果用户按ESC键取消了操作，返回的错误号Err.Number = -2147352567，你猜猜我是如何知道的？

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x
回复 支持 反对

使用道具 举报

zzyong00
 楼主| 发表于 2014-10-19 23:08:43 | 显示全部楼层
（2）输入序号的增量，即每复制一次增加几？
Autocad的键盘输入，大部分都可以用Utility类中的方法。这里我们用GetReal
  1.     Dim IncreaseNum As Double
  2.     IncreaseNum = ThisDrawing.Utility.GetReal("请输入增加量（可以为负,默认为1）：")

本来这样就可以了，但是，“默认为1”，就是用户懒得输入，或，最常用到的情况，直接按回车或空格键就代替用户输入，这样是会出错的，因为getReal不支持输入空内容。因此，又用到错误处理（关于vb的内容，这里不讲）
  
  1.    On Error GoTo Err2
  2.      Dim IncreaseNum As Double
  3.      IncreaseNum = ThisDrawing.Utility.GetReal("请输入增加量（可以为负,默认为1）：")
  4.     If IncreaseNum = 0 Then IncreaseNum = 1
  5.     Err2:
  6.     Err.Clear
  7.     Resume Next
  8.    
回复 支持 反对

使用道具 举报

zzyong00
 楼主| 发表于 2014-10-19 23:13:39 | 显示全部楼层
本帖最后由 zzyong00 于 2014-10-19 23:15 编辑

(3)复制基点与目标点和原文字与目标文字插入点的计算
这个就不详细说了，一些简单的计算
（4）生成一个新单行文字
这里用的AcadText对象的copy +move方法
以下为增量复制的完整代码
  1.    
  2. Public Sub CopyTextIncrement()                                                  '增量复制
  3.     Dim objText As AcadText, blnESC As Boolean
  4.    
  5.     SelectSingleText objText, blnESC
  6.    
  7.     If blnESC Then Exit Sub
  8.    
  9.     On Error GoTo Err2
  10.    
  11.     Dim IncreaseNum As Double
  12.    
  13.     IncreaseNum = ThisDrawing.Utility.GetReal("请输入增加量（可以为负,默认为1）：")
  14.    
  15.     If IncreaseNum = 0 Then IncreaseNum = 1
  16.    
  17.     On Error GoTo err1
  18.    
  19.     Dim copyObj As AcadText, pt1, pt2
  20.    
  21.     Dim dx As Double, dy As Double, InsPt(2) As Double
  22.    
  23.     pt1 = ThisDrawing.Utility.GetPoint(, "请指定复制基点：")
  24.     dx = pt1(0) - objText.InsertionPoint(0)
  25.     dy = pt1(1) - objText.InsertionPoint(1)
  26.    
  27.     Do
  28.         InsPt(0) = objText.InsertionPoint(0) + dx
  29.         InsPt(1) = objText.InsertionPoint(1) + dy
  30.         pt2 = ThisDrawing.Utility.GetPoint(InsPt, "请指定复制到点：")
  31.         Set copyObj = objText.Copy()
  32.         
  33.         Dim strText As String, iPos As Integer, iDotPos As Integer, strFormat As String
  34.         
  35.         strText = RTrim(objText.TextString)
  36.         iPos = Len(strText)
  37.         
  38.         Do While IsNumeric(Mid(strText, iPos))
  39.             iPos = iPos - 1
  40.             
  41.             If iPos = 0 Then Exit Do
  42.         Loop
  43.         
  44.         If iPos = Len(strText) Then
  45.             strText = strText & CStr(IncreaseNum)
  46.         Else
  47.             iDotPos = InStr(iPos + 1, strText, ".", vbTextCompare)              '取小数点位置
  48.             
  49.             If iDotPos <> 0 Then
  50.                 strFormat = "#." & String(Len(strText) - iDotPos, "0")
  51.                 strText = Mid(strText, 1, iPos) & Format(Val((Mid(strText, iPos + 1)) + _
  52.                 IncreaseNum), strFormat)
  53.             Else
  54.                 strText = Mid(strText, 1, iPos) & CStr(Val((Mid(strText, iPos + 1)) + _
  55.                 IncreaseNum))
  56.             End If
  57.         End If
  58.         
  59.         copyObj.TextString = strText
  60.         copyObj.Move InsPt, pt2
  61.         objText.Highlight False
  62.         Set objText = copyObj
  63.         objText.Highlight True
  64.     Loop
  65.    
  66.     Exit Sub
  67.    
  68. err1:
  69.     Err.Clear
  70.     objText.Highlight False
  71.     Debug.Print Err.Description
  72.    
  73.     Exit Sub
  74.    
  75. Err2:
  76.     Err.Clear
  77.    
  78.     Resume Next
  79.    
  80. End Sub
回复 支持 反对

使用道具 举报

chenshulu
发表于 2014-10-20 18:44:06 | 显示全部楼层
你的排图框的源码呢，

点评

zzyong00
我这个东西才刚开始，一定会介绍到那儿的，实际上，我已发过二维排序的源码，只是没人重视而已  发表于 2014-10-20 21:32
回复 支持 反对

使用道具 举报

zzyong00
 楼主| 发表于 2014-10-20 21:44:30 | 显示全部楼层
2、多选增量复制
在实际应用中，有可能同时选择多个文字对象，进行增量复制


先发个多选的子程序
  1. Private Sub SelectLots(ByVal Ssetname As String, _
  2.     ByVal objName As String, _
  3.     Optional strPrompt As String = "请选择单行文本，可以框选" & vbCrLf)
  4.     'Ssetname 新建选择集的名
  5.    'objName 要选择对象的名，可以文字对象，也可以是直线或其它任何acad实体
  6.    'strPrompt 选择时提示的文字
  7.     Dim sSetObj As AcadSelectionSet, flag As Boolean

  9.     For Each sSetObj In ThisDrawing.SelectionSets

  11.         If sSetObj.name = Ssetname Then
  12.             flag = True
  13.             Exit For
  14.         End If

  16.     Next

  18.     If flag Then sSetObj.Delete                                                 '创建集合，如集存在，则删除，新建
  19.     Set sSetObj = ThisDrawing.SelectionSets.Add(Ssetname)

  21.     Dim gpCode(0)    As Integer

  23.     Dim dataValue(0) As Variant

  25.     gpCode(0) = 0
  26.     dataValue(0) = objName

  28.     Dim groupCode As Variant, dataCode As Variant

  30.     groupCode = gpCode
  31.     dataCode = dataValue
  32.     ThisDrawing.Utility.Prompt strPrompt
  33.     sSetObj.SelectOnScreen groupCode, dataCode
  34. End Sub

没有太多变化，直接发代码：
  1. Public Sub CopyTextIncrement2()                                                  '增量复制,多选模式

  3.     Dim strSsetname As String, objTextArr() As AcadText, i As Long

  5.     strSsetname = "MEA~CopyTextIncrement2"
  6.     SelectLots strSsetname, "TEXT"

  8.     If ThisDrawing.SelectionSets(strSsetname).Count = 0 Then Exit Sub

  10.     On Error GoTo Err2

  12.     ReDim objTextArr(ThisDrawing.SelectionSets(strSsetname).Count - 1)
  13.     For i = 0 To ThisDrawing.SelectionSets(strSsetname).Count - 1
  14.         Set objTextArr(i) = ThisDrawing.SelectionSets(strSsetname).Item(i)
  15.     Next i


  18.     Dim IncreaseNum As Double

  20.     IncreaseNum = ThisDrawing.Utility.GetReal("请输入增加量（可以为负,默认为1）：")

  22.     If IncreaseNum = 0 Then IncreaseNum = 1

  24.     On Error GoTo err1

  26.     Dim copyObj As AcadText, pt1, pt2

  28.     Dim dx As Double, dy As Double, InsPt(2) As Double

  30.     pt1 = ThisDrawing.Utility.GetPoint(, "请指定复制基点：")

  32.     Do
  33.         pt2 = ThisDrawing.Utility.GetPoint(pt1, "请指定复制到点：")
  34.         For i = 0 To UBound(objTextArr)
  35.             dx = pt2(0) - pt1(0)
  36.             dy = pt2(1) - pt1(1)
  37.             Set copyObj = objTextArr(i).Copy()

  39.             Dim strText As String, iPos As Integer, iDotPos As Integer, strFormat As String

  41.             strText = RTrim(copyObj.TextString)
  42.             iPos = Len(strText)

  44.             Do While IsNumeric(Mid(strText, iPos))
  45.                 iPos = iPos - 1

  47.                 If iPos = 0 Then Exit Do
  48.             Loop

  50.             If iPos = Len(strText) Then '末尾没有数字
  51.                 strText = strText & CStr(IncreaseNum)
  52.             Else
  53.                 iDotPos = InStr(iPos + 1, strText, ".", vbTextCompare)              '取小数点位置

  55.                 If iDotPos <> 0 Then '有小数点
  56.                     strFormat = "#." & String(Len(strText) - iDotPos, "0")
  57.                     strText = Mid(strText, 1, iPos) & Format(Val((Mid(strText, iPos + 1)) + _
  58.                     IncreaseNum), strFormat)
  59.                 Else '无小数点
  60.                     strText = Mid(strText, 1, iPos) & CStr(Val((Mid(strText, iPos + 1)) + _
  61.                     IncreaseNum))
  62.                 End If
  63.             End If
  64.             InsPt(0) = copyObj.InsertionPoint(0) + dx
  65.             InsPt(1) = copyObj.InsertionPoint(1) + dy

  67.             copyObj.TextString = strText
  68.             copyObj.Move copyObj.InsertionPoint, InsPt
  69.             copyObj.Highlight False
  70.             Set objTextArr(i) = copyObj
  71.             copyObj.Highlight True

  73.         Next i
  74.         pt1 = pt2

  76.     Loop

  78.     Exit Sub

  80. err1:

  82.     If Not (copyObj Is Nothing) Then copyObj.Highlight False
  83.     Debug.Print Err.Description
  84.     Err.Clear
  85.     Exit Sub

  87. Err2:
  88.     Err.Clear

  90.     Resume Next

  92. End Sub



本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x
回复 支持 反对

使用道具 举报

zzyong00
 楼主| 发表于 2014-10-20 21:54:26 | 显示全部楼层
3、先选择对象再执行命令
在vb中可不可以先选择对象再执行命令呢？当然是可以的，AcadDocument对象有一个PickfirstSelectionSet属性，可以实现这个目的。看代码：
  1. Private Function getPickFirstSel(Optional strObjName As String = "AcDbText") As _

  3.     AcadSelectionSet                                                            '选当前选择的text
  4.    
  5.     On Error GoTo err1
  6.    
  7.     Dim objSset As AcadSelectionSet
  8.    
  9.     Dim obj1    As AcadObject, objRemove(0) As AcadObject, i As Integer
  10.    
  11.     Dim iNum    As Integer
  12.    
  13.     iNum = 0
  14.     Set objSset = ThisDrawing.PickfirstSelectionSet
  15.    
  16.     If objSset.Count > 0 Then
  17.         
  18.         For i = objSset.Count - 1 To 0 Step -1
  19.             Set obj1 = objSset.Item(i)
  20.             
  21.             If StrComp(obj1.ObjectName, strObjName, vbTextCompare) = 0 Then
  22.                 iNum = iNum + 1
  23.             Else
  24.                 Set objRemove(0) = obj1                                         '如果不是文字，就从选集中删除
  25.                 objSset.RemoveItems objRemove                                   '这里必须是数组(变体)
  26.             End If
  27.             
  28.         Next i
  29.         
  30.     End If
  31.    
  32.     If iNum > 0 Then
  33.         Set getPickFirstSel = objSset
  34.     Else
  35.         Set getPickFirstSel = Nothing
  36.     End If
  37.    
  38.     Exit Function
  39.    
  40. err1:
  41.     Set getPickFirstSel = Nothing
  42.     ‘Debug.Print Err.Number, Err.Description
  43.     Err.Clear
  44. End Function
回复 支持 反对

使用道具 举报

浪迹天涯追月
发表于 2014-10-21 15:38:49 | 显示全部楼层
很好很强大 学习学习
回复 支持 反对

使用道具 举报

12345678910... 21下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-22 20:53 , Processed in 0.352569 second(s), 31 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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