Set acadApp = GetObject("autocad.application")
If Err Then
Err.Clear
Set acadApp = CreateObject("autocad.application")
If Err Then
MsgBox ("不能运行CAD,请检查是否安装")
Exit Sub
End If
End If
acadApp.Visible = False
cadApp.Documents.Open filename, True '打开一个图
Dim Lt As AcadLayer
Dim uCircle As AcadCircle
Dim cen(0 To 2) As Double
Dim obj As AcadObject
Dim CC As Variant
Dim i As Integer, t As Integer
Dim Repeat As Boolean '检测是否重复
On Error GoTo err_0
Me.MousePointer = 11
i = 1
txtcir.Clear
Listcir.Clear
Listprog.Clear
'For Each Lt In acadApp.ActiveDocument.Layers
For Each obj In acadApp.ActiveDocument.ModelSpace
' Debug.Print obj.ObjectName & " Layer:" & Lt.Name
If LCase(obj.ObjectName) = "acdbcircle" Then
Set uCircle = obj
' ' MsgBox obj.ObjectName
If uCircle.Layer = Trim(Layer) Then
CC = uCircle.Center
Repeat = False
'取x,y最大值
If CC(0) > x_max Then x_max = CC(0)
If CC(1) > y_max Then y_max = CC(1)
If uCircle.Diameter > d_max Then d_max = uCircle.Diameter
自己补全吧