不支持自动化？麻烦帮忙解决下

forverd

Sub Main()
    Dim acadapp As Object
    Dim objsel As AcadSelectionSet
    Dim xref As AcadExternalReference
    Dim ptmin(2) As Double
    Dim ptmax(2) As Double
    Dim objtext As AcadText
    Dim objref As AcadExternalReference
    Dim h As Double
    Dim mydir As String
    Dim wb
    Dim myname As String
    Dim ownid
    Dim layout_name As String
    Dim a As Double
    Dim pathname As String

    'On Error Resume Next
    Set acadapp = GetObject(, "AutoCAD.Application")
    If Err Then
        Err.Clear
        Set acadapp = CreateObject("AutoCAD.Application")
    End If

    '遍历该程序所在文件夹内的所有dwg文件
    Dim i As Integer
    i = 0
    h = 4.5
    mydir = Dir(App.Path & "\*.dwg", vbNormal)
    Do While mydir <> ""
        Set wb = GetObject(App.Path & "\" & mydir)
        If mydir = "标准图框.dwg" Then
            GoTo nextdo
        End If
        Set activedoc = acadapp.ActiveDocument
        myname = Left(mydir, InStr(mydir, Chr(32)) - 1) '获取文件名中的图号

        Set objsel = activedoc.SelectionSets.Add("myselection") '选择所有的插入图形为选择集
        Dim ft(0) As Integer
        Dim fd(0)
        ft(0) = 0: fd(0) = "insert"
        objsel.Select acSelectionSetAll, , , ft, fd

        For Each objref In objsel
            If objref.Name = "标准图框" Then
                ownid = objref.OwnerID
                Set obj = activedoc.ObjectIdToObject(ownid)
                layout_name = obj.Layout.Name
                activedoc.ActiveLayout = activedoc.Layouts.Item(layout_name) '激活图框的布局
                a = objref.XScaleFactor '获取图框的缩放因子
                ptmin(0) = objref.InsertionPoint(0) + a * 388.3 '获取图框的插入点
                ptmin(1) = objref.InsertionPoint(1) + a * 12.86

                If objref.Hyperlinks.Application.ActiveDocument.ActiveSpace = acModelSpace Then
                    Set objtext = activedoc.ModelSpace.AddText(myname, ptmin, h * a)
                Else
                    Set objtext = activedoc.PaperSpace.AddText(myname, ptmin, h * a)
                End If
                'objtext.StyleName = "zdmhz1"
                'objtext.ScaleFactor = 0.7
                'objtext.Update
            End If
        Next
        wb.Save
        activedoc.Close
        i = i + 1
nextdo:
        mydir = Dir
    Loop
    Set wb = Nothing
    Set activedoc = Nothing
    acadapp.Visible = True
    MsgBox "本次共编辑图号" & i & "张"
End Sub
在我画红的地方之前的activedoc.paperspace还没有问题，过了这一行activedoc.paperspace就出现了没有对象，不知道怎么修改这个

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:编制图号.rar 
下载次数:0  文件大小:281.93 KB 
下载权限: 不限 以上  [免费赚D豆]