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

2017forverd · 发表于 2018-1-8 17:50:00

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(, ".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的时候出现

szzxuc0vzzn.jpg

第一次遇到这个错误，请问怎么解决？谢谢

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

mikewolf2k · 发表于 2018-1-9 09:20:00

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

2017forverd · 发表于 2018-1-10 09:25:00

已贴出完整代码

mikewolf2k · 发表于 2018-1-10 10:10:00

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

2017forverd · 发表于 2018-1-10 14:34:00

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

mikewolf2k · 发表于 2018-1-10 16:20:00

你的是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 · 发表于 2018-1-10 21:32:00

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

mikewolf2k · 发表于 2018-1-11 09:22:00

自己去一个个监视了检查。
以下是其它软件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 · 发表于 2018-1-15 17:11:00

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

2017forverd · 发表于 2018-1-15 18:25:00

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

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

发表回复

精选推荐