好吧,我采取了808的良好开端,并使其变得更好。现在的属性是正确的旋转角度和正确的位置。我花了一段时间才弄清楚,因为插入点属性不用于没有为其对齐属性留下、适合或对齐的属性。
希望这有助于其他人。最终需要做unmirY。哦,我从来没有更新过纸空间部分。但是谁在纸空间中绘制和镜像?
- 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, ]:")
- 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) = ""
-
- 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 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 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
|