阻止不镜像乐筑天下 - Powered by Discuz! Archiver

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井？
**** Hidden Message *****

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。哦，我从来没有更新过纸空间部分。但是谁在纸空间中绘制和镜像？
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 :")
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.XScaleFactor90 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 dblRotDeg360 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).AlignmentacAlignmentLeft And varNewAtt(intCnt).AlignmentacAlignmentFit And varNewAtt(intCnt).AlignmentacAlignmentAligned 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

Maverick® 发表于 2006-12-21 23:43:32

嘿杰米！很高兴见到你。希望新的冒险进行顺利，你有一个伟大的圣诞节！

jjs 发表于 2007-3-2 01:20:56

嘿jjs，很高兴见到你。不要成为陌生人

jjs 发表于 2007-3-2 09:13:34

我有一些ABS编程要做，所以我会更频繁地出现。

Arizona 发表于 2007-3-2 11:16:25

我，你确定它不是麦基弗吗？

页: [1]

乐筑天下's Archiver

阻止不镜像