用VB6进行Autocad的二次开发(原创)
本帖最后由 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,输入以下代码：
Public objCad As Object''定义为全局Autocad对象
Public Sub ConnectAutoCAD()
On Error Resume Next
#Const cadVer = "R16"''条件编译开关,根据你电脑安装的Autocad版本修改，如果实在不知道，把本行代码注释掉也行
#If cadVer = "R16" Then
'----------------------------------
'' R16(autocad2004~2006)
Set objCad = GetObject(, "Autocad.Application.16")
If Err Then
Err.Clear
Set objCad = CreateObject("Autocad.Application.16")
objCad.Visible = True
If Err Then
MsgBox "计算机可能没有正确安装相应版本的Autocad", vbOKOnly + vbCritical
End
End If
End If
'----------------------------------------------------
#ElseIf cadVer = "R17" Then
' '----------------------------------
' 'R17(autocad2007~2009)
Set objCad = GetObject(, "Autocad.Application.17")
If Err Then
Err.Clear
Set objCad = CreateObject("Autocad.Application.17")
objCad.Visible = True
If Err Then
MsgBox "计算机可能没有正确安装相应版本的Autocad", vbOKOnly + vbCritical
End
End If
End If
#ElseIf cadVer = "R18" Then
' '----------------------------------------------------
'----------------------------------
''''' R18(autocad2010~2012)
Set objCad = GetObject(, "Autocad.Application.18")
If Err Then
Err.Clear
Set objCad = CreateObject("Autocad.Application.18")
objCad.Visible = True
If Err Then
MsgBox "计算机可能没有正确安装相应版本的Autocad", vbOKOnly + vbCritical
End
End If
End If
''' '----------------------------------------------------
'----------------------------------------------------
#ElseIf cadVer = "R19" Then
'R19(autocad2013~2014)
Set objCad = GetObject(, "Autocad.Application.19")
If Err Then
Err.Clear
Set objCad = CreateObject("Autocad.Application.19")
objCad.Visible = True
If Err Then
MsgBox "计算机可能没有正确安装相应版本的Autocad", vbOKOnly + vbCritical
End
End If
End If
'''''''''''''''''''''''''''''''''''''''''''
#ElseIf cadVer = "R20" Then
' 'R20(autocad2015~2015)
Set objCad = GetObject(, "Autocad.Application.20")
If Err Then
Err.Clear
Set objCad = CreateObject("Autocad.Application.20")
objCad.Visible = True
If Err Then
MsgBox "计算机可能没有正确安装相应版本的Autocad", vbOKOnly + vbCritical
End
End If
End If
''
'----------------------------------------------------
#Else
' '----------------------------------
'通用代码
Set objCad = GetObject(, "Autocad.Application")
If Err Then
Err.Clear
Set objCad = CreateObject("Autocad.Application")
objCad.Visible = True
If Err Then
MsgBox "计算机可能没有正确安装相应版本的Autocad", vbOKOnly + vbCritical
End
End If
End If
'----------------------------------------------------
#End If
AppActivate objCad.Caption
End Sub
(3)在 form1中输入以下代码：
Private Sub Form_Load()
ConnectAutoCAD
End Sub
按F5运行程序，一阵等待后，你会发现Autocad展现在你面前
本帖最后由 zzyong00 于 2014-10-25 22:58 编辑
2、坐标标注
坐标标注本身很简单，类似的工具满天飞，我这里也贴一个
Public Sub SeriesCoordinate() '连续标坐标
Dim blnExitSeriesCoord As Boolean
' InitCommonVar
'全局变量
Coordinate_TextHeight = 3
ratio = 1
TextRowSpace = 0.6
Do
Coordinate blnExitSeriesCoord '本子过程源码需要回复才能看到
Loop Until blnExitSeriesCoord
End Sub
**** Hidden Message *****
对于vb或vba来说，在没创建AcadText对象之前，很难精确算出AcadText对象的长度，本例子中，先大致估算，然后生成AcadText对象，但暂时隐藏它，通过GetBoundingBox 取得AcadText对象真实大小后，再调整AcadText对象位置和直线长度！
另外说一点Autocad的小知识，知道的同志请忽略，对于不支持先选择后执行命令的命令，也可以先选择后执行，方法是：（1），选择你要选择的对象
（2），执行命令，选择对象之前按p键，回车就可以了 好东西，其它语言也可以参考。可惜微软逐渐放弃VB6了 经典的vb6，，不支持64位:'(
永远的痛。。。 顶！
楼主的免费教程，无私分享令人敬佩！
支持！！ zjyingxf 发表于 2015-9-21 14:17 static/image/common/back.gif
楼主大神，VB6引用64位CAD，编译不通过怎么解决的呢。
为什么我一编译就出错呢 增加一个判断点在pl曲线内侧还是外侧
'在模块中添加以下代码
Public Enum InOut
Inside = -1
Outside = 1
End Enum
Private Function InOutside(pl As AcadLWPolyline, P1 As Variant) As long
'PL是要标注的PL线，P1是要监测是否在曲线内的点，三维DOUBLE数组
'判断标注位置是否在PL范围内，可以设定坐标标在范围内还是外面
'intInOut=-1是内侧，intInOut＝1是外侧,intInOut=0是不确定是内还是外
Dim Ppl As Variant
Dim tmpPL As AcadLWPolyline
Dim i As Integer
Set tmpPL = pl.Copy
tmpPL.Closed = True
tmpPL.Elevation = 0
Ppl = tmpPL.Coordinates
Dim dblYmax As Double 'Y坐标最大值
dblYmax = Ppl(1)
For i = 3 To UBound(Ppl) Step 2
If dblYmax < Ppl(i) Then dblYmax = Ppl(i)
Next i
Dim tmpP(2) As Double '临时点
tmpP(0) = P1(0)
tmpP(1) = dblYmax + 100
tmpP(2) = 0
Dim objL As AcadLine
Set objL = ThisDrawing.ModelSpace.AddLine(P1, tmpP)
'ZoomAll
Dim dblPoints As Variant
dblPoints = objL.IntersectWith(tmpPL, acExtendNone)
tmpPL.Delete
objL.Delete '清理战场
'Debug.Print VarType(dblPoints) '即使没有交点，也是一个空的三维数组
If UBound(dblPoints) = -1 Then
InOutside = Outside
Exit Function
End If
If ((UBound(dblPoints) - LBound(dblPoints) + 1) / 3) Mod 2 Then '交点个数为奇数，就在内侧；为偶数，就在外侧
InOutside = Inside
Else
InOutside = Outside
End If
'Debug.Print InOutside
End Function
2、Autocad对象模型
Autocad对象模型是树型结构，具体内容详见Autocad开发人员帮助或明经论坛翻译的中文版AcadAuto.chm。
Autocad对象模型中最重要的对象是AcadDocument对象，在VBA中，当前图的AcadDocument对象的对象名是ThisDrawing,这个名起的非常好，顾名而思意，在AcadAuto.chm中，所有涉及到AcadDocument对象的代码都用的是ThisDrawing.
如以下代码：
Sub Example_TextString()
' This example creates a text object in model space.
' It then returns the text string for that object.
Dim textObj As AcadText
Dim text As String
Dim insertionPoint(0 To 2) As Double
Dim height As Double
' Define the text object
text = "Hello, World."
insertionPoint(0) = 2: insertionPoint(1) = 2: insertionPoint(2) = 0
height = 0.5
' Create the text object in model space
Set textObj = ThisDrawing.ModelSpace.AddText(text, insertionPoint, height)
ZoomAll
' Return the current text string for the object
text = textObj.textString
MsgBox "The TextString property equals: " & text, vbInformation, "TextString 示例"
End Sub
而在VB6中，即使你引用Autocad对象，也没有ThisDrawing这个对象，如果用vb6测试VBA代码时，就会很麻烦。因此，需要你在ModCommon.bas中增加函数。
Public Function ThisDrawing() As AcadDocument
If Not (objCad Is Nothing) Then Set ThisDrawing = objCad.ActiveDocument
End Function
有了上面代码，你就可以轻松测试大部分VBA代码了。
*请你想想，为什么不把ThisDrawing定义成一个AcadDocument类型的变量，而是要定义成返回AcadDocument类型的函数呢？ 本帖最后由 zzyong00 于 2014-10-19 23:02 编辑
用VB6进行Autocad的二次开发的基本环境已经搭建完成，接下来牛刀小试了！
首先我们征对单行文字进行各种操作。
1、增量复制
功能，请看gif演示
分析：实现该功能分解步骤：
（1）选择单行文字
（2）输入序号的增量，即每复制一次增加几？
(3)复制基点与目标点和原文字与目标文字插入点的计算
（4）生成一个新单行文字
对于（1）选择单行文字文字来说，有多选和单选的区别，多选一般用AcadSelectionSet对象的Select****方法，而单选一般用
AcadDocumnet的Utility类的GetEntity 方法。
对于单选，本人给出一个子程序SelectSingleText。
在工程中新建一个模块，取名为ModTextTreatment.bas
添加以下代码：
Private Sub SelectSingleText(returnObj As AcadText, blnESC As Boolean)
Dim basePnt As Variant
On Error Resume Next
RETRY:
ThisDrawing.Utility.GetEntity returnObj, basePnt, "请选择单行文字："
' Debug.Print Err.Number, Err.Description
If Err.Number = -2147352567 Then
blnESC = True
Exit Sub
End If
If Err <> 0 Then
Err.Clear
GoTo RETRY
Else
returnObj.Highlight True
End If
子程序SelectSingleText的简要说明：
参数：returnObj 返回选择的单行文字；
blnESC是一个标记，标记用户是否选择了文字，有可能用户按ESC键取消了操作
如果用户按ESC键取消了操作，返回的错误号Err.Number = -2147352567，你猜猜我是如何知道的？
（2）输入序号的增量，即每复制一次增加几？
Autocad的键盘输入，大部分都可以用Utility类中的方法。这里我们用GetReal
Dim IncreaseNum As Double
IncreaseNum = ThisDrawing.Utility.GetReal("请输入增加量（可以为负,默认为1）：")
本来这样就可以了，但是，“默认为1”，就是用户懒得输入，或，最常用到的情况，直接按回车或空格键就代替用户输入，这样是会出错的，因为getReal不支持输入空内容。因此，又用到错误处理（关于vb的内容，这里不讲）
On Error GoTo Err2
Dim IncreaseNum As Double
IncreaseNum = ThisDrawing.Utility.GetReal("请输入增加量（可以为负,默认为1）：")
If IncreaseNum = 0 Then IncreaseNum = 1
Err2:
Err.Clear
Resume Next
本帖最后由 zzyong00 于 2014-10-19 23:15 编辑
(3)复制基点与目标点和原文字与目标文字插入点的计算
这个就不详细说了，一些简单的计算
（4）生成一个新单行文字
这里用的AcadText对象的copy +move方法
以下为增量复制的完整代码
Public Sub CopyTextIncrement() '增量复制
Dim objText As AcadText, blnESC As Boolean
SelectSingleText objText, blnESC
If blnESC Then Exit Sub
On Error GoTo Err2
Dim IncreaseNum As Double
IncreaseNum = ThisDrawing.Utility.GetReal("请输入增加量（可以为负,默认为1）：")
If IncreaseNum = 0 Then IncreaseNum = 1
On Error GoTo err1
Dim copyObj As AcadText, pt1, pt2
Dim dx As Double, dy As Double, InsPt(2) As Double
pt1 = ThisDrawing.Utility.GetPoint(, "请指定复制基点：")
dx = pt1(0) - objText.InsertionPoint(0)
dy = pt1(1) - objText.InsertionPoint(1)
Do
InsPt(0) = objText.InsertionPoint(0) + dx
InsPt(1) = objText.InsertionPoint(1) + dy
pt2 = ThisDrawing.Utility.GetPoint(InsPt, "请指定复制到点：")
Set copyObj = objText.Copy()
Dim strText As String, iPos As Integer, iDotPos As Integer, strFormat As String
strText = RTrim(objText.TextString)
iPos = Len(strText)
Do While IsNumeric(Mid(strText, iPos))
iPos = iPos - 1
If iPos = 0 Then Exit Do
Loop
If iPos = Len(strText) Then
strText = strText & CStr(IncreaseNum)
Else
iDotPos = InStr(iPos + 1, strText, ".", vbTextCompare) '取小数点位置
If iDotPos <> 0 Then
strFormat = "#." & String(Len(strText) - iDotPos, "0")
strText = Mid(strText, 1, iPos) & Format(Val((Mid(strText, iPos + 1)) + _
IncreaseNum), strFormat)
Else
strText = Mid(strText, 1, iPos) & CStr(Val((Mid(strText, iPos + 1)) + _
IncreaseNum))
End If
End If
copyObj.TextString = strText
copyObj.Move InsPt, pt2
objText.Highlight False
Set objText = copyObj
objText.Highlight True
Loop
Exit Sub
err1:
Err.Clear
objText.Highlight False
Debug.Print Err.Description
Exit Sub
Err2:
Err.Clear
Resume Next
End Sub 你的排图框的源码呢， 2、多选增量复制
在实际应用中，有可能同时选择多个文字对象，进行增量复制
先发个多选的子程序
Private Sub SelectLots(ByVal Ssetname As String, _
ByVal objName As String, _
Optional strPrompt As String = "请选择单行文本，可以框选" & vbCrLf)
'Ssetname 新建选择集的名
'objName 要选择对象的名，可以文字对象，也可以是直线或其它任何acad实体
'strPrompt 选择时提示的文字
Dim sSetObj As AcadSelectionSet, flag As Boolean
For Each sSetObj In ThisDrawing.SelectionSets
If sSetObj.name = Ssetname Then
flag = True
Exit For
End If
Next
If flag Then sSetObj.Delete '创建集合，如集存在，则删除，新建
Set sSetObj = ThisDrawing.SelectionSets.Add(Ssetname)
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0
dataValue(0) = objName
Dim groupCode As Variant, dataCode As Variant
groupCode = gpCode
dataCode = dataValue
ThisDrawing.Utility.Prompt strPrompt
sSetObj.SelectOnScreen groupCode, dataCode
End Sub
没有太多变化，直接发代码：
Public Sub CopyTextIncrement2() '增量复制,多选模式
Dim strSsetname As String, objTextArr() As AcadText, i As Long
strSsetname = "MEA~CopyTextIncrement2"
SelectLots strSsetname, "TEXT"
If ThisDrawing.SelectionSets(strSsetname).Count = 0 Then Exit Sub
On Error GoTo Err2
ReDim objTextArr(ThisDrawing.SelectionSets(strSsetname).Count - 1)
For i = 0 To ThisDrawing.SelectionSets(strSsetname).Count - 1
Set objTextArr(i) = ThisDrawing.SelectionSets(strSsetname).Item(i)
Next i
Dim IncreaseNum As Double
IncreaseNum = ThisDrawing.Utility.GetReal("请输入增加量（可以为负,默认为1）：")
If IncreaseNum = 0 Then IncreaseNum = 1
On Error GoTo err1
Dim copyObj As AcadText, pt1, pt2
Dim dx As Double, dy As Double, InsPt(2) As Double
pt1 = ThisDrawing.Utility.GetPoint(, "请指定复制基点：")
Do
pt2 = ThisDrawing.Utility.GetPoint(pt1, "请指定复制到点：")
For i = 0 To UBound(objTextArr)
dx = pt2(0) - pt1(0)
dy = pt2(1) - pt1(1)
Set copyObj = objTextArr(i).Copy()
Dim strText As String, iPos As Integer, iDotPos As Integer, strFormat As String
strText = RTrim(copyObj.TextString)
iPos = Len(strText)
Do While IsNumeric(Mid(strText, iPos))
iPos = iPos - 1
If iPos = 0 Then Exit Do
Loop
If iPos = Len(strText) Then '末尾没有数字
strText = strText & CStr(IncreaseNum)
Else
iDotPos = InStr(iPos + 1, strText, ".", vbTextCompare) '取小数点位置
If iDotPos <> 0 Then '有小数点
strFormat = "#." & String(Len(strText) - iDotPos, "0")
strText = Mid(strText, 1, iPos) & Format(Val((Mid(strText, iPos + 1)) + _
IncreaseNum), strFormat)
Else '无小数点
strText = Mid(strText, 1, iPos) & CStr(Val((Mid(strText, iPos + 1)) + _
IncreaseNum))
End If
End If
InsPt(0) = copyObj.InsertionPoint(0) + dx
InsPt(1) = copyObj.InsertionPoint(1) + dy
copyObj.TextString = strText
copyObj.Move copyObj.InsertionPoint, InsPt
copyObj.Highlight False
Set objTextArr(i) = copyObj
copyObj.Highlight True
Next i
pt1 = pt2
Loop
Exit Sub
err1:
If Not (copyObj Is Nothing) Then copyObj.Highlight False
Debug.Print Err.Description
Err.Clear
Exit Sub
Err2:
Err.Clear
Resume Next
End Sub
3、先选择对象再执行命令
在vb中可不可以先选择对象再执行命令呢？当然是可以的，AcadDocument对象有一个PickfirstSelectionSet属性，可以实现这个目的。看代码：
Private Function getPickFirstSel(Optional strObjName As String = "AcDbText") As _
AcadSelectionSet '选当前选择的text
On Error GoTo err1
Dim objSset As AcadSelectionSet
Dim obj1 As AcadObject, objRemove(0) As AcadObject, i As Integer
Dim iNum As Integer
iNum = 0
Set objSset = ThisDrawing.PickfirstSelectionSet
If objSset.Count > 0 Then
For i = objSset.Count - 1 To 0 Step -1
Set obj1 = objSset.Item(i)
If StrComp(obj1.ObjectName, strObjName, vbTextCompare) = 0 Then
iNum = iNum + 1
Else
Set objRemove(0) = obj1 '如果不是文字，就从选集中删除
objSset.RemoveItems objRemove '这里必须是数组(变体)
End If
Next i
End If
If iNum > 0 Then
Set getPickFirstSel = objSset
Else
Set getPickFirstSel = Nothing
End If
Exit Function
err1:
Set getPickFirstSel = Nothing
‘Debug.Print Err.Number, Err.Description
Err.Clear
End Function 很好很强大 学习学习