用VB6进行Autocad的二次开发(原创) 乐筑天下

zzyong00 发表于 2014-10-18 19:03:00

用VB6进行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:57:00

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

On Error GoTo err1
' Dim Coordinate_TextHeight As Double '文字高
' Dim Ratio As Double '全局比例
' Dim TextRowSpace As Double '文字行间距
' Coordinate_TextHeight = 3
' Ratio = 1
' TextRowSpace = 0.6
Dim p1, p2                                                                '标注点坐标，标注文字位置
p1 = ThisDrawing.Utility.GetPoint(, "请点击要标注的点（按回车键退出）:")
p2 = ThisDrawing.Utility.GetPoint(p1, "请点击标注位置（按回车键退出）:")
Dim T1 As AcadText, T2 As AcadText
Dim strT As String, intStrL1 As Integer, intStrL2 As Integer             'Y和X坐标文字的长度
strT = "X " & Format$(p1(1), "0.000")
intStrL1 = Len(strT)
Dim pt1(2) As Double, pt2(2) As Double                                  '文字坐标
If p2(0) > p1(0) Then                                                    '确定标注点与标注文字位置的左右关系，以确定文字插入点
   pt1(0) = p2(0)
   pt1(1) = p2(1) + TextRowSpace / 2 * Coordinate_TextHeight * ratio
Else
   pt1(0) = p2(0) - intStrL1 * Coordinate_TextHeight * ratio * _
   ThisDrawing.ActiveTextStyle.Width ^ 2                               '宽度比例(总是宽度比例的平方，因为当前文字样式设了宽度，而AcadText本身又有个ScaleFactor,而且等于width）
   pt1(1) = p2(1) + TextRowSpace / 2 * Coordinate_TextHeight * ratio
End If
Set T1 = ThisDrawing.ModelSpace.AddText(strT, pt1, Coordinate_TextHeight * ratio)
T1.Visible = False
strT = "Y " & Format$(p1(0), "0.000")
intStrL2 = Len(strT)
pt2(0) = pt1(0)
pt2(1) = pt1(1) - T1.Height * (1 + TextRowSpace)                         'TextRowSpace代表文字间距是TextRowSpace倍的字高
Set T2 = ThisDrawing.ModelSpace.AddText(strT, pt2, Coordinate_TextHeight * ratio)
T2.Visible = False
Dim Pend(2) As Double                                                    '标注结束点
Pend(0) = p2(0)
Dim TminP, TmaxP
If intStrL1 > intStrL2 Then                                              '取最长文字长度
   T1.GetBoundingBox TminP, TmaxP
Else
   T2.GetBoundingBox TminP, TmaxP
End If
If p2(0) > p1(0) Then                                                    '确定标注点与标注文字位置的左右关系，以确定标注结束点位置
   Pend(0) = p2(0) + (TmaxP(0) - TminP(0))
   Pend(1) = p2(1)
Else
   Pend(0) = p2(0) - (TmaxP(0) - TminP(0))
   Pend(1) = p2(1)
   pt1(0) = Pend(0)
   pt2(0) = Pend(0)
   T1.InsertionPoint = pt1
   T2.InsertionPoint = pt2
End If
T1.Visible = True
T2.Visible = True
Dim L1 As AcadLine, L2 As AcadLine
Set L1 = ThisDrawing.ModelSpace.AddLine(p1, p2)
Set L2 = ThisDrawing.ModelSpace.AddLine(p2, Pend)
Exit Sub
err1:
Err.Clear
blnExitSeriesCoord = True
End Sub

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

vbcad 发表于 2014-10-24 18:47:00

顶！
楼主的免费教程，无私分享令人敬佩！
支持！！

zjyingxf 发表于 2015-10-8 16:47:00

为什么我一编译就出错呢

zzyong00 发表于 2014-11-22 23:09:00

增加一个判断点在pl曲线内侧还是外侧

zzyong00 发表于 2014-10-18 19:21:00

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 22:54:00

用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 Err0 Then
   Err.Clear
   GoTo RETRY
Else
   returnObj.Highlight True
End If

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

zzyong00 发表于 2014-10-19 23:08:00

（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:13:00

(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 iDotPos0 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

chenshulu 发表于 2014-10-20 18:44:00

你的排图框的源码呢，

页: [1] 2

乐筑天下's Archiver

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