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

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

版本较高一些，都支持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,输入以下代码：

copy

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中输入以下代码：

copy

Private Sub Form_Load()
ConnectAutoCAD
End Sub

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

zzyong00 · 发表于 2014-10-25 22:57:00

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

q0ymr3xiobh.gif

copy

Public Sub SeriesCoordinate()                                                   '连续标坐标
    Dim blnExitSeriesCoord As Boolean
    ' InitCommonVar
    '全局变量
    Coordinate_TextHeight = 3
    ratio = 1
    TextRowSpace = 0.6
    Do
        Coordinate blnExitSeriesCoord '本子过程源码需要回复才能看到
    Loop Until blnExitSeriesCoord
End Sub

copy

    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.
如以下代码：

copy

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中增加函数。

copy

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演示

zbuibe1s54o.gif

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

copy

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，你猜猜我是如何知道的？

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

（2）输入序号的增量，即每复制一次增加几？
Autocad的键盘输入，大部分都可以用Utility类中的方法。这里我们用GetReal

copy

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

本来这样就可以了，但是，“默认为1”，就是用户懒得输入，或，最常用到的情况，直接按回车或空格键就代替用户输入，这样是会出错的，因为getReal不支持输入空内容。因此，又用到错误处理（关于vb的内容，这里不讲）

copy

   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方法
以下为增量复制的完整代码

copy

    
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

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

你的排图框的源码呢，

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

发表回复

精选推荐