[art_rrc]

Доброго времени суток! Задача состоит в следующем... Необходимо перечеркнуть отрезком все внешние ссылки (кроме них на чертеже ничего нет). Задача элементарная, но я столкнулся с проблемой - часть внешних ссылок имеет "Недопустимые границы" (Ругается на строчку "BlockRef.GetBoundingBox minPoint, maxPoint"). Сталкивался кто-нибудь с такой проблемой? Подскажите как быть?
Заранее спасибо!

Код:

[Выделить все]

Sub art_Xref()
Dim SelSet1 As AcadSelectionSet
Dim Entry As AcadEntity
Dim minPoint As Variant
Dim maxPoint As Variant
Dim BlockRef As AcadBlockReference
Dim lineObj As AcadLine
'Call ClearSelectionSets
Set SelSet1 = ThisDrawing.SelectionSets.Add("artXref")
SelSet1.SelectOnScreen
If SelSet1.Count = 0 Then GoTo DavayDoSvidaniya
For Each Entry In SelSet1
    Select Case Entry.ObjectName
        Case "AcDbBlockReference"
            Set BlockRef = Entry
            'On Error Resume Next
            BlockRef.GetBoundingBox minPoint, maxPoint
            'If Err <> 0 Then
            '     BlockRef.Highlight True
            '    Exit Sub
            'End If
            Set lineObj = ThisDrawing.ModelSpace.AddLine(minPoint, maxPoint)
    End Select
Next
DavayDoSvidaniya:
SelSet1.Delete
End Sub

ps К сожалению в данный момент нет возможности прикрепить пример файла. Если будет необходимость, прикреплю чуть позже.

[trir]

http://www.theswamp.org/index.php?topic=10794.0

Код:

[Выделить все]

Option Explicit
Public Enum XRefStatus
  xrloaded = 1
  xrdetached = 2
  xrNotFound = 3
End Enum

Public Sub test()
  Dim colBlocks As AcadObject
  Dim objBlock As AcadBlock
  Dim objXRefDbase1 As AcadDatabase
  Dim objXRefDbase2 As AcadDatabase
  Dim objXref As AcadExternalReference
  Dim varXref() As Variant
  Dim intCount As Integer
   
  Set colBlocks = Me.Blocks
    For Each objBlock In colBlocks
      If objBlock.IsXRef Then
        Select Case GetXRefStatus(objBlock)
          Case 1 'xrloaded
            MsgBox "Xref " & objBlock.Name & " is Loaded"
          Case 2 'xrdetached
            MsgBox "Xref " & objBlock.Name & " is Detached"
          Case 3 'xrnotfound
            MsgBox "Xref " & objBlock.Name & " was not found"
          Case Else
            MsgBox "Xref " & objBlock.Name & " has me confused"
        End Select
      End If
    Next objBlock 

End Sub

Public Function GetXRefStatus(pXRef As AcadBlock) As XRefStatus
  Dim xStatus As XRefStatus
  Dim objTestObj As Object
  
  On Error GoTo XRefStatus_Error
    
  If pXRef.Count > 1 Then
    GetXRefStatus = xrloaded
    Exit Function
  End If
  
  If pXRef.Count = 1 Then
    If pXRef(0).ObjectName = "AcDbText" Then
      If pXRef(0).TextString Like "*" & pXRef.Name & "*" Then
        GetXRefStatus = xrNotFound
        Exit Function
      Else ' it only has one item, and that item is text
        GetXRefStatus = xrloaded
        Exit Function
      End If
    Else ' it only has one object in it, but that item isnt text
      GetXRefStatus = xrloaded
      Exit Function
    End If
  End If
  
  If pXRef.Count = 0 Then 'either unloaded or empty xref
    'unloaded xrefs have no database so this will raise an error
    Set objTestObj = pXRef.XRefDatabase
    GetXRefStatus = xrloaded ' if it gets to here, then the xref is attached but
    Exit Function            ' contains no objects
  End If
  
XRefStatus_Error:
  Select Case Err.Number
    Case -2145386390 ' no database error
      GetXRefStatus = xrdetached
      Err.Clear
      Exit Function
    Case Else
      MsgBox Err.Number
      Debug.Print "Error " & Err.Number
      Err.Clear
      Exit Function
  End Select

End Function

[art_rrc]

Хм... За код конечно спасибо. Но как он может мне помочь с решением моей проблемы? Он с успехом сообщает мне, что все мои ссылки успешно загружены, о чем я в принципе и так знаю.. Может я что-то упускаю?
Offtop: Заменил "Me" на "ThisDrawing". Иначе не хотел работать.

[trir]

тогда надо смотреть файлы

[Boxa]

https://msdn.microsoft.com/en-us/lib...=vs.85%29.aspx
0x8020001C / -2145386468 / BG_E_TOO_MANY_FILES / You cannot add more than one file to an upload job. (No more files can be added to this job.)

А сколько xref-ов Вы обрабатываете?

ЗЫ.
http://bbs.mjtd.com/thread-99702-1-1.html

[Александр Ривилис]

Сообщение от art_rrc Сталкивался кто-нибудь с такой проблемой?

Да. Пустые тексты, пустые блоки, пустые атрибуты могут приводить к такому.

[art_rrc]

Всем большое спасибо за отклики!
Boxa, в тестовом файле было 6 внешних ссылок. Когда перед getboundingbox ставил "On Error Resume Next", то 2 обрабатывалить как надо, а 4 остальных не перечеркивались.

Александр Ривилис, Вы правы, в файле обнаружились пустые тексты. Хотя пустые - это с какой стороны посмотреть. Открывая файл в Acad_2015, при запуске выскакивает диалог выбора шрифта, а после выбора, текста корректно отображаются (при неправильном шрифте отображаются не иероглифы, а знаки вопроса, но в данный момент это не имеет никакого значения, важно само отображение графики, чтоб GetBoundingBox мог его поймать). А при запуске в Acad_2016 этот диалог отсутствует и содержиное текстов не отображается, выделить эти объекты можно только "быстрым выбором", "ctrl+a" и т.д. И тут есть одна проблема - мне кажется, что диалог раньше был и возможно более модернизированный с возможностью поставить галочку "Всегда следовать данному выбору" и возможно я давно эту галочку случайно поставил. Перерыл все настройки автокада, пытаясь найти где это можно включить. Просмотрел 60 страниц системных переменных, надеялся что-то выловить в _.sysvarmonitor, пытался найти какие именно НОВЫЕ системные переменные появились в 2016 версии - все безрезультатно. Теперь в замешательстве. Помогите советом, как еще можно заставить отображать эти примитивы?

ps Настройки к дополнительным шрифтам абсолютно идентичны.

[kacugu]

art_rrc, http://forum.dwg.ru/showthread.php?t=74624