|
|
发表于 2006-7-8 18:00:00
|
显示全部楼层
感谢你的解答，我修改后的程序如下，插入点问题解决了，就是调试运行中执行blkrefobj.Explode '运行此句总是出错，提示“输入无效”，请问是何原因？
Sub adjust_scale()
Dim ss As AcadSelectionSet
Dim pt(0 To 2) As Double
Dim i As Integer
ThisDrawing.PurgeAll
If ThisDrawing.SelectionSets.Count 0 Then
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Delete
Next
End If
Set ss = ThisDrawing.SelectionSets.Add("ssss")
ss.SelectOnScreen
ReDim retval(0 To ss.Count - 1) As AcadEntity
For i = 0 To ss.Count - 1
Set retval(i) = ss.Item(i)
Next
Dim entobj As AcadEntity
Dim minext As Variant, maxext As Variant
Dim a(2), b(2) As Double
Set entobj = ss.Item(0)
entobj.GetBoundingBox minext, maxext
a(0) = maxext(0)
a(1) = maxext(1)
a(2) = maxext(2)
b(0) = minext(0)
b(1) = minext(1)
b(2) = minext(2)
For i = 1 To ss.Count - 1
Set entobj = ss.Item(i)
entobj.GetBoundingBox minext, maxext
If a(0) minext(0) Then
b(0) = minext(0)
End If
If b(1) > minext(1) Then
b(1) = minext(1)
End If
Next
pt(0) = b(0)
pt(1) = b(1)
pt(2) = b(2)
Dim bk As AcadBlock
Set bk = ThisDrawing.Blocks.Add(pt, "tempblock")
ThisDrawing.CopyObjects retval, bk
Erase retval
ss.Erase
Dim c1 As Variant
Dim c2 As Variant
c1 = ThisDrawing.Utility.GetPoint(, "选择边界点1:")
c2 = ThisDrawing.Utility.GetPoint(, "选择边界点2:")
Dim d(1) As Double
d(0) = VBA.Abs(c1(0) - c2(0))
d(1) = VBA.Abs(c1(1) - c2(1))
Dim e(1) As Double
e(0) = VBA.Abs(b(0) - a(0))
e(1) = VBA.Abs(b(1) - a(1))
Dim inspt(2) As Double
Dim blkrefobj As AcadBlockReference
inspt(0) = b(0): inspt(1) = b(1): inspt(2) = b(2)
Dim s As Double
Dim smin As Double
smin = d(1) / e(1)
If smin > d(0) / e(0) Then
smin = d(0) / e(0)
End If
s = smin
Set blkrefobj = ThisDrawing.ModelSpace.InsertBlock(inspt, "tempblock", s, s, 1, 0)
blkrefobj.Update
blkrefobj.Explode '运行此句总是出错，提示“输入无效”
blkrefobj.Delete
Application.Update
ThisDrawing.PurgeAll
'Application.ZoomExtents
End Sub
|
|
置顶卡
