不支持自动化？麻烦帮忙解决下
本帖最后由 2017forverd 于 2018-1-10 14:33 编辑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 发表于 2018-1-9 09:20
请给个完整的代码，包括各个变量是如何定义的。
已贴出完整代码 监视下出问题时候，activedoc有没有对象 mikewolf2k 发表于 2018-1-10 10:10
监视下出问题时候，activedoc有没有对象
测试文件已上传，帮忙测试下 ，谢谢 你的是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
mikewolf2k 发表于 2018-1-10 16:20
你的是vb，我把帖子里的代码放在vba中并做相应修改，可以运行。关键点是如果activedoc有定义，代码是好的。 ...
activedoc有定义呀
Set activedoc = acadapp.ActiveDocument 这样不可以吗？ 自己去一个个监视了检查。
以下是其它软件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 谁还有解决的办法吗？问题一直没有解决，我一行一行的调试还是没有找到问题 mikewolf2k 发表于 2018-1-10 16:20
你的是vb，我把帖子里的代码放在vba中并做相应修改，可以运行。关键点是如果activedoc有定义，代码是好的。 ...
'activedoc.ActiveLayout = activedoc.Layouts.Item(layout_name) '激活图框的布局
问题在这行，这行之前的activedoc.paperspace还没有问题，过了这一行activedoc.paperspace就出现了没有对象，不知道咱们修改这个
页:
[1]
2