Well, I took 808's good start and made it better. The attributes now are the correct rotation angle and the correct location. Took me a while to figure it out because the insertion point property is not used for attributes that are not left, fit, or aligned for their alignment property.
Hope this helps others. Eventually need to do the unmirY. Oh and I never updated the paperspace part. But who draws and mirrors in paperspace?
Option Explicit
Public Sub UnMirror()
On Error GoTo ErrorControl
Dim strSet As String
Dim intGroup() As Integer
Dim varGroup() As Variant
Dim varAtts As Variant
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Dim strBlkName As String
Dim PI As Double
Dim strSetName As String
Dim objBlkRef As AcadBlockReference
Dim objEnt As AcadEntity
Dim intCnt As Integer
PI = (Atn(1) * 4)
Set objSelSets = ThisDrawing.SelectionSets
strSetName = 1
ReDim intGroup(0)
ReDim varGroup(0)
intGroup(0) = 0
varGroup(0) = "insert"
BlockName:
strBlkName = ThisDrawing.Utility.GetString(True, "Block to unmirror [All, Select, <default block name goes here>]:")
If strBlkName = "" Or Left(strBlkName, 1) = " " Then
ReDim Preserve intGroup(0 To 1)
ReDim Preserve varGroup(0 To 1)
intGroup(1) = 2
varGroup(1) = "defaultblockname"
ElseIf StrComp(strBlkName, "a", vbTextCompare) = 0 Or StrComp(strBlkName, "all", vbTextCompare) = 0 Then
ReDim Preserve intGroup(0 To 1)
ReDim Preserve varGroup(0 To 1)
intGroup(1) = 2
varGroup(1) = "*"
ElseIf StrComp(strBlkName, "s", vbTextCompare) = 0 Or StrComp(strBlkName, "sel", vbTextCompare) = 0 Or StrComp(strBlkName, "select", vbTextCompare) = 0 Then
KillSet strSetName
Set objSelSet = objSelSets.Add(strSetName)
objSelSet.SelectOnScreen intGroup, varGroup
ReDim intGroup(0 To (objSelSet.Count) + 1)
ReDim varGroup(0 To (objSelSet.Count) + 1)
intGroup(0) = -4
varGroup(0) = "<or"
intGroup((objSelSet.Count) + 1) = -4
varGroup((objSelSet.Count) + 1) = "or>"
For intCnt = 1 To objSelSet.Count
If TypeOf objSelSet.Item(intCnt - 1) Is AcadBlockReference Then
Set objBlkRef = objSelSet.Item(intCnt - 1)
intGroup(intCnt) = 2
varGroup(intCnt) = objBlkRef.Name
End If
Next intCnt
Else
ReDim Preserve intGroup(0 To 1)
ReDim Preserve varGroup(0 To 1)
intGroup(1) = 2
varGroup(1) = strBlkName
End If
KillSet strSetName
Set objSelSet = objSelSets.Add(strSetName)
objSelSet.Select acSelectionSetAll, , , intGroup, varGroup
If objSelSet.Count > 0 Then
GoTo FollowTheRabbit
Else
ThisDrawing.Utility.Prompt vbCrLf & "**No Blocks Selected**" & vbCrLf
GoTo ExitHere
End If
FollowTheRabbit:
Dim dblMSpc As Double
Dim dblPSpc As Double
Dim dblRotRad As Double
Dim dblrotrad180 As Double
Dim dblRotDeg As Double
Dim dblScale(0 To 2) As Double
Dim dblInsPt(0 To 2) As Double
Dim objNewRef As AcadBlockReference
Dim varOldAtt As Variant
Dim varNewAtt As Variant
dblMSpc = ThisDrawing.ModelSpace.ObjectID
dblPSpc = ThisDrawing.PaperSpace.ObjectID
For Each objEnt In objSelSet
If TypeOf objEnt Is AcadBlockReference Then
Set objBlkRef = objEnt
If objBlkRef.XScaleFactor < 0 Then
dblInsPt(0) = objBlkRef.InsertionPoint(0)
dblInsPt(1) = objBlkRef.InsertionPoint(1)
dblInsPt(2) = objBlkRef.InsertionPoint(2)
dblScale(0) = objBlkRef.XScaleFactor * -1
dblScale(1) = objBlkRef.YScaleFactor
dblScale(2) = objBlkRef.ZScaleFactor
dblRotRad = objBlkRef.Rotation
'*******************************
dblRotDeg = (dblRotRad * 180) / PI
'If dblRotDeg > 90 Then MsgBox "dblrotdeg above 90 radians = " & dblRotRad
Debug.Print "dblRotRad " & dblRotRad
'Select Case dblRotRad
'Case 0 To (PI * 120) / 180
' Debug.Print "dblRotRad between 0 and 90 =" & dblRotRad
dblrotrad180 = (PI * 180) / 180
dblRotRad = dblRotRad + dblrotrad180
'Case (PI * 120) / 180 To (PI * 360) / 180
' Debug.Print "dblRotRad between 120 and 330 =" & dblRotRad
' dblrotrad180 = (PI * 180) / 180
' dblRotRad = dblRotRad + dblrotrad180
'Case Else
' Debug.Print "dblRotRad NOT BETWEEN 0 AND 90 =" & dblRotRad
'End Select
'*******************************
' dblRotDeg = (dblRotRad * 180) / PI
' Debug.Print "dblRotDeg " & dblRotDeg
' If dblRotDeg > 120 And dblRotDeg < 330 Then
' dblRotDeg = dblRotDeg + 180
' If dblRotDeg > 360 Then
' dblRotDeg = dblRotDeg - 360
' End If
' dblRotRad = (PI * dblRotDeg) / 180
' End If
If objBlkRef.OwnerID = dblMSpc Then
Set objNewRef = ThisDrawing.ModelSpace.InsertBlock(dblInsPt, objBlkRef.Name, dblScale(0), dblScale(1), dblScale(2), dblRotRad)
If objNewRef.HasAttributes Then
varOldAtt = objBlkRef.GetAttributes
varNewAtt = objNewRef.GetAttributes
For intCnt = 0 To UBound(varOldAtt)
varNewAtt(intCnt).TextString = varOldAtt(intCnt).TextString
objNewRef.Update
varNewAtt(intCnt).InsertionPoint = varOldAtt(intCnt).InsertionPoint
If varNewAtt(intCnt).Alignment <> acAlignmentLeft And varNewAtt(intCnt).Alignment <> acAlignmentFit And varNewAtt(intCnt).Alignment <> acAlignmentAligned Then
varNewAtt(intCnt).TextAlignmentPoint = varOldAtt(intCnt).TextAlignmentPoint
End If
' Debug.Print "NEWATT INSX= " & CStr(varNewAtt(intCnt).InsertionPoint(0))
' Debug.Print "NEWATT INSY= " & varNewAtt(intCnt).InsertionPoint(1)
' Debug.Print "OLDATT INSX= " & varOldAtt(intCnt).InsertionPoint(0)
' Debug.Print "OLDATT INSY= " & varOldAtt(intCnt).InsertionPoint(1)
' Debug.Print "***********************************"
varNewAtt(intCnt).Rotation = varOldAtt(intCnt).Rotation
Next intCnt
End If
objNewRef.Layer = objBlkRef.Layer
objNewRef.Linetype = objBlkRef.Linetype
objNewRef.LinetypeScale = objBlkRef.LinetypeScale
objNewRef.Lineweight = objBlkRef.Lineweight
If Left(ThisDrawing.GetVariable("acadver"), 2) = "16" Then
objNewRef.TrueColor = objBlkRef.TrueColor
Else
objNewRef.color = objBlkRef.color
End If
objNewRef.Visible = objBlkRef.Visible
' objNewRef.Update
' If objNewRef.HasAttributes Then
' varOldAtt = objBlkRef.GetAttributes
' varNewAtt = objNewRef.GetAttributes
' For intCnt = 0 To UBound(varOldAtt)
' 'varNewAtt(intCnt).TextString = varOldAtt(intCnt).TextString
'
' varNewAtt(intCnt).InsertionPoint = varOldAtt(intCnt).InsertionPoint
'' Debug.Print "NEWATT INSX= " & CStr(varNewAtt(intCnt).InsertionPoint(0))
'' Debug.Print "NEWATT INSY= " & varNewAtt(intCnt).InsertionPoint(1)
'' Debug.Print "OLDATT INSX= " & varOldAtt(intCnt).InsertionPoint(0)
'' Debug.Print "OLDATT INSY= " & varOldAtt(intCnt).InsertionPoint(1)
'' Debug.Print "***********************************"
'
' 'varNewAtt(intCnt).Rotation = varOldAtt(intCnt).Rotation
' Next intCnt
' End If
objBlkRef.Delete
objNewRef.Update
Else
Set objNewRef = ThisDrawing.PaperSpace.InsertBlock(dblInsPt, objBlkRef.Name, dblScale(0), dblScale(1), dblScale(2), dblRotRad)
If objNewRef.HasAttributes Then
varOldAtt = objBlkRef.GetAttributes
varNewAtt = objNewRef.GetAttributes
For intCnt = 0 To UBound(varOldAtt)
varNewAtt(intCnt).TextString = varOldAtt(intCnt).TextString
Next intCnt
End If
objNewRef.Layer = objBlkRef.Layer
objNewRef.Linetype = objBlkRef.Linetype
objNewRef.LinetypeScale = objBlkRef.LinetypeScale
objNewRef.Lineweight = objBlkRef.Lineweight
If Left(ThisDrawing.GetVariable("acadver"), 2) = "16" Then
objNewRef.TrueColor = objBlkRef.TrueColor
Else
objNewRef.color = objBlkRef.color
End If
objNewRef.Visible = objBlkRef.Visible
objBlkRef.Delete
objNewRef.Update
End If
End If
End If
Next objEnt
ExitHere:
Exit Sub
ErrorControl:
Select Case Err.Number
Case Else
MsgBox "''" & Err.Description & "'' error has occured in UnMirror" & vbCr & _
"All Blocks May NOT have updated correctly" & vbCrLf & _
"Please report the error to Cad Manager", vbCritical, "Error in UnMirror"
GoTo ExitHere
End Select
End Sub
Function KillSet(strSet As String)
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Set objSelSets = ThisDrawing.SelectionSets
For Each objSelSet In objSelSets
If objSelSet.Name = strSet Then
ThisDrawing.SelectionSets.Item(strSet).Delete
Exit For
End If
Next
End Function
