[编程交流] 使用镜像属性

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