社区 › VB › 块取消错误

Maverick® 发表于 2006-12-21 18:08:59

块取消错误

所以我在808找到了这篇文章http://www.theswamp.org/index.php?topic=6791.msg83800#msg83800我在一个我一直在测试不同例程的图形上尝试了它。大多数块都有效，但有些没有。古怪的我还需要将旋转属性旋转添加到0代码部分。当我陷入困境时，我会寻求帮助
当然，除非808从最初发布后就把它整理好了
808井

左手╰→ 发表于 2006-12-21 19:13:04

嗨，杰里米，鲍勃有一段时间没来了

赵阳 发表于 2006-12-21 19:26:47

在我发帖后，我回去重读了他的帖子，注意到帖子上写着以他的名字命名的客人。如果一个人甚至看不见，给他一段艰难的时光是没有意思的
我会试着用其他方式联系他，看看能不能把他拖回来
谢谢你的提醒。

英皇联盟 发表于 2006-12-21 19:33:15

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

Andy 发表于 2006-12-21 22:04:46

嗯，我拿了808#039；这是一个好的开始，让它变得更好。属性现在是正确的旋转角度和正确的位置。我花了一段时间才弄明白，因为插入点属性不用于未按其对齐属性保留、拟合或对齐的属性
希望这能帮助别人。最终需要做联利特派团。哦，我从来没有更新过纸质部分。但是谁在纸上画画和镜像呢
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

教皇厅 发表于 2006-12-21 23:43:32

嘿Jeremie&nbsp；很高兴见到你&nbsp；希望你的新事业进展顺利，圣诞快乐！

牵手春天 发表于 2007-3-2 01:20:56

嘿，小牛，我过了一个美好的圣诞节。快到复活节了。

水贴一族 发表于 2007-3-2 09:13:34

嗨，jjs，很高兴见到你&nbsp；不要成为陌生人

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

我有一些ABS编程要做，所以我会经常在身边。

最高粽院 发表于 2007-3-2 18:49:26

嗨，杰里米，这么长时间你去哪儿了
很高兴你回来。前几天我偶然看到你的照片，你想要吗？

查看完整版本: 块取消错误