阻止不镜像

jjs · 发表于 2006-12-21 18:08:59

于是我通过808 \/\/4 # R
http://www . theswamp . org/index . PHP找到了这个帖子？topic = 6791 . msg 83800 # msg 83800
我在一张图纸上尝试了它，我在这张图纸上测试了不同的例程。大多数积木都可以用，但有些不行。奇怪。我还需要添加一个旋转属性旋转到0代码部分。我遇到困难时会寻求帮助。
当然，除非808在最初发布后进行了整理。
808井？

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

Arizona · 发表于 2006-12-21 19:13:04

嗨，杰瑞米，
鲍勃已经有一段时间没有了

jjs · 发表于 2006-12-21 19:26:47

我发完帖子后，回去重读了他的帖子，注意到他的名字下面写着客人。如果一个人连自己都看不到，那么让他难堪就没什么意思了。
我会尝试通过其他方式联系他，看看能不能把他拖回来。
谢谢提醒。

Arizona · 发表于 2006-12-21 19:33:15

很高兴见到你，圣诞快乐！

jjs · 发表于 2006-12-21 22:04:46

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

copy

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
              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