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

2017forverd

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

    '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 pathname = Nothing
    Set activedoc = Nothing
    acadapp.Visible = True
    MsgBox "本次共编辑图号" & i & "张"
End Sub

这是我编写的一段代码，但是运行在第一个else的时候出现
第一次遇到这个错误，请问怎么解决？谢谢

mikewolf2k

请给个完整的代码，包括各个变量是如何定义的。

2017forverd

mikewolf2k 发表于 2018-1-9 09:20
请给个完整的代码，包括各个变量是如何定义的。

已贴出完整代码

mikewolf2k

监视下出问题时候，activedoc有没有对象

2017forverd

mikewolf2k 发表于 2018-1-10 10:10
监视下出问题时候，activedoc有没有对象

测试文件已上传，帮忙测试下   ，谢谢

mikewolf2k

你的是vb，我把帖子里的代码放在vba中并做相应修改，可以运行。关键点是如果activedoc有定义，代码是好的。
Sub Maintest()
     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
     '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
    Dim h As Double
    Dim mydir As String
    Dim wb
    Dim activedoc
     Dim myname As String
     Dim ownid
     Dim obj As AcadBlockReference
     Dim layout_name As String
     Dim a As Double
     Dim pathname As String
     
     i = 0
     h = 4.5
     mydir = Dir("d:\*.dwg", vbNormal)
        Set activedoc = acadapp.ActiveDocument
        myname = "test"
        On Error Resume Next
        Set objsel = ThisDrawing.SelectionSets.Add("myselection") '选择所有的插入图形为选择集
        Set objsel = ThisDrawing.SelectionSets("myselection")
        On Error GoTo 0
        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)
                 Set obj = objref
                 '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
     
     Set wb = Nothing
     'Set pathname = Nothing
     Set activedoc = Nothing
     acadapp.Visible = True
     MsgBox "本次共编辑图号" & i & "张"
End Sub

2017forverd

mikewolf2k 发表于 2018-1-10 16:20
你的是vb，我把帖子里的代码放在vba中并做相应修改，可以运行。关键点是如果activedoc有定义，代码是好的。 ...

activedoc有定义呀
Set activedoc = acadapp.ActiveDocument 这样不可以吗？

mikewolf2k

自己去一个个监视了检查。
以下是其它软件vba做的，效果跟vb应该一样，没问题。
Sub Main()
     Dim acadapp As Object
     Dim activedoc, objtext
     On Error Resume Next
     Dim ptmin(2) As Double
     Set acadapp = GetObject(, "AutoCAD.Application")
     If Err Then
         Err.Clear
         Set acadapp = CreateObject("AutoCAD.Application")
     End If
     On Error GoTo 0
     Set activedoc = acadapp.ActiveDocument
     Set objtext = activedoc.ModelSpace.AddText("test", ptmin, 10)
End Sub

2017forverd

谁还有解决的办法吗？问题一直没有解决，我一行一行的调试还是没有找到问题

2017forverd

mikewolf2k 发表于 2018-1-10 16:20
你的是vb，我把帖子里的代码放在vba中并做相应修改，可以运行。关键点是如果activedoc有定义，代码是好的。 ...

'activedoc.ActiveLayout = activedoc.Layouts.Item(layout_name) '激活图框的布局
问题在这行，这行之前的activedoc.paperspace还没有问题，过了这一行activedoc.paperspace就出现了没有对象，不知道咱们修改这个