使用镜像属性
我写了一些VBA代码来镜像一个对象（因为我必须通过编程而不是手动完成），我遇到了一个问题VBA镜像功能似乎不像普通镜像命令那样自动镜像块的属性
我会附上一个测试dwg文件，并张贴代码，如果有人可以向我解释如何修复代码，使属性也镜像
Option Explicit
Sub AutoMirror()
Dim x1 As AcadBlockReference
Dim x2 As AcadBlockReference
Dim inspt As Variant
ThisDrawing.Utility.GetEntity x1, inspt, "Select item to mirror:"
Set x2 = MirrorFix(x1)
End Sub
Public Function MirrorFix(entMirror As AcadBlockReference) As AcadBlockReference
Dim pt1(2) As Double
Dim pt2(2) As Double
Dim inspt As Variant
Dim bb1 As Variant
Dim bb2 As Variant
Dim AttList As Variant
Dim i As Integer
Dim nHeight As Integer
Dim attr(3) As String
Dim entNew As AcadBlockReference
If entMirror.XScaleFactor <> Abs(entMirror.XScaleFactor) Then
'save attribute info to variables and then delete from block
' or the bounding box will be wrong
AttList = entMirror.GetAttributes
attr(0) = AttList(0).TextString
attr(1) = AttList(1).TextString
attr(2) = AttList(2).TextString
attr(3) = AttList(3).TextString
AttList(0).TextString = ""
AttList(1).TextString = ""
AttList(2).TextString = ""
AttList(3).TextString = ""
' mirror the block
' doesnt mirror the attributes for some reason
entMirror.GetBoundingBox bb1, bb2
pt1(0) = bb1(0) + ((bb2(0) - bb1(0)) / 2)
pt1(1) = bb1(1) + ((bb2(1) - bb1(1)) / 2)
pt2(0) = pt1(0) + (10 * Cos(entMirror.Rotation)) ' new X
pt2(1) = pt1(1) + (10 * Sin(entMirror.Rotation)) ' new Y
Set entNew = entMirror.Mirror(pt1, pt2)
entMirror.Delete
' add attribute info back to block
AttList = entNew.GetAttributes
AttList(0).TextString = attr(0)
AttList(1).TextString = attr(1)
AttList(2).TextString = attr(2)
AttList(3).TextString = attr(3)
Else
Set entNew = entMirror
End If
Set MirrorFix = entNew
End Function
镜子测试。图纸
页:
[1]