Логотип сайта поддержки пользователей САПРО сайте поддержки пользователей САПР Translate to:

Примитивы чертежей AutoCAD (часть 3)

Текст

Функции для операций над аттрибутами и текстом

Создание объекта DText (Динамический текст)

Процедура DTextImposter работает анологично команде DText. Особой пользы от нее никакой, просто посмотрите как можно усложнить простые вещи.

Option Explicit

Public Sub DTextImposter()
  Dim objUtil As AcadUtility
  Dim objText As AcadText
  Dim objSpace As AcadBlock
  Dim dblOffset As Double
  Dim dblAngle As Double
  Dim dblHght As Double
  Dim dblRot As Double
  Dim varPnt As Variant
  Dim strPrmt As String
  Dim strRet As String
  Dim strTemp As String
  Dim strText As String
  Dim blnDefault As Boolean
  Dim dblDIMSCALE As Double
  On Error GoTo Err_Control

  If ThisDrawing.ActiveSpace = acModelSpace Then
    Set objSpace = ThisDrawing.ModelSpace
  Else
    Set objSpace = ThisDrawing.PaperSpace
  End If
  Set objUtil = ThisDrawing.Utility
  dblDIMSCALE = CDbl(ThisDrawing.GetVariable("DIMSCALE"))
  If dblDIMSCALE = 0 Then dblDIMSCALE = 1
  dblHght = dblDIMSCALE * 7
  strPrmt = vbLf & "Start point: "
  varPnt = objUtil.GetPoint(Prompt:=strPrmt)
  strPrmt = vbLf & "Angle <0>: "
  objUtil.InitializeUserInput 32
  dblRot = objUtil.GetAngle(varPnt, strPrmt)
  If blnDefault Then
    dblRot = 0
  End If
  dblAngle = dblRot + 4.71238898038469
  dblOffset = dblHght + dblHght * 0.66
  strPrmt = vbLf & "Text: "
  Do
    strTemp = objUtil.GetString(True, strPrmt)
    If Len(strTemp) > 0 Then
      strText = strTemp
      Set objText = objSpace.AddText(strText, _
      varPnt, dblHght)
      objText.Rotate varPnt, dblRot
      varPnt = objUtil.PolarPoint(varPnt, _
      dblAngle, dblOffset)
      objText.Update
    Else
      Exit Do
    End If
  Loop
  Set objText = Nothing
  Set objUtil = Nothing
  Set objSpace = Nothing
Exit_Here:
  Exit Sub
Err_Control:
  Select Case Err.Number
  Case -2145320928
    strRet = ThisDrawing.Utility.GetInput
    If strRet = "" Then
      blnDefault = True
      Resume Next
    End If
  Case -2147352567
    Resume Exit_Here
  Case Else
    MsgBox Err.Description
    Resume Exit_Here
  End Select
End Sub
 

Создание текстового объекта с заданным выравниванием

Есть тут одна хитрость. Если вновь созданному объекту просто задать стиль выравнивания (свойство HorizontalAlignment), то этого будет недостаточно. Нужно еще задать свойство TextAlignmentPoint, задающее, относительно какой точки выравнивать текст. Обычно эту точку делают совпадающей с точкой вставки текста. Причем обязатель нужно вначале задать стиль выравнивания, а уже потом точку, относительно которой выравнивать текст. В общем вот пример:

Option Explicit

Public Sub TestAddText()
  Dim varStart As Variant
  Dim dblHeight As Double
  Dim strText As String
  Dim objEnt As AcadText
  'New variable for the alignment
  Dim dblAlignPnt(0 To 2) As Double
  
  On Error Resume Next
  '' get input from user
  With ThisDrawing.Utility
    varStart = .GetPoint(, vbCr & _
    "Pick the start point: ")
    dblHeight = .GetDistance(varStart, vbCr & _
    "Indicate the height: ")
    strText = .GetString(True, vbCr & _
    "Enter the text: ")
  End With
  
  dblAlignPnt(0) = varStart(0)
  dblAlignPnt(1) = varStart(1)
  dblAlignPnt(2) = varStart(2)
  
  '' create the text
  Set objEnt = ThisDrawing.ModelSpace.AddText(strText, _
  varStart, dblHeight)
  With objEnt
    .StyleName = "3"
    .Layer = "DRAWTXT"
    'This must be first
    .HorizontalAlignment = acHorizontalAlignmentCenter
    'Then set your point!
    .TextAlignmentPoint = dblAlignPnt
    'Задаем угол наклона равным 15 градусов
    .ObliqueAngle = 15*3.14159265359 / 180
    .Update
  End With
End Sub
 

Поиск и замена текста

Option Explicit

Public Function ReplaceText(strSrchIn As String, _
                            strFor As String, _
                            strWith As String) As String
  Dim intLoc As Integer
  Dim intCnt As Integer
  Dim intLenFor As Integer
  Dim intLenIn As Integer
  Dim strLeft As String
  Dim strRight As String
  Dim intHitPnt As Integer
  
  ReplaceText = strSrchIn
  intCnt = 1
  intLenFor = Len(strFor)
  intLenIn = Len(strSrchIn)
  Do
    intLoc = InStr(intCnt, strSrchIn, strFor)
    If intLoc = 0 Then Exit Do
    intCnt = intCnt + intLoc
    intHitPnt = intLenFor + intLoc - 1
    strLeft = Left(strSrchIn, intLoc - 1)
    strRight = Right(strSrchIn, intLenIn - intHitPnt)
    strSrchIn = strLeft & strWith & strRight
    ReplaceText = strLeft & strWith & strRight
  Loop Until intLoc = 0
End Function

Public Sub TEST_ReplaceText()
  Dim strText As String
  Dim strFind As String
  Dim strRep As String
  Dim intDXF(3) As Integer
  Dim varVal(3) As Variant
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objEnt As AcadText
  
  On Error Resume Next
  With ThisDrawing.Utility
    strFind = .GetString(True, vbCr & "Какой текст заменить?: ")
    strRep = .GetString(True, vbCr & "На что заменить?: ")
  End With
  
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = "Textonly" Then
        objSelSet.Delete
        Exit For
      End If
    Next
  Set objSelSet = ThisDrawing.SelectionSets.Add("Textonly")
  ' Обеспечиваем фильтр выбора объектов
  intDXF(0) = -4
  varVal(0) = "<OR"
  intDXF(1) = 0
  varVal(1) = "MTEXT"
  intDXF(2) = 0
  varVal(2) = "TEXT"
  intDXF(3) = -4
  varVal(3) = "OR>"
  objSelSet.SelectOnScreen intDXF, varVal
  For Each objEnt In objSelSet
  ' Просматриваем все выбранные объекты
    objEnt.TextString = ReplaceText(objEnt.TextString, strFind, strRep)
    objEnt.Update
  Next
End Sub
 

Изменение угла наклона всех текстовых объектов чертежа

Option Explicit

Public Sub SetObliqueAngle(dblAngle As Double)
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objText As AcadText
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Set objSelCol = ThisDrawing.SelectionSets
  For Each objSelSet In objSelCol
    If objSelSet.Name = "txtoa" Then
      objSelCol.Item("txtoa").Delete
      Exit For
    End If
  Next objSelSet
  Set objSelSet = objSelCol.Add("txtoa")
  intType(0) = 0
  varData(0) = "TEXT"
  objSelSet.Select 5, filtertype:=intType, _
  filterdata:=varData
  For Each objText In objSelSet
    objText.ObliqueAngle = dblAngle
  Next objText
  objSelCol.Item("txtoa").Delete
End Sub

Public Sub TEST_SetObliqueAngle()
  Dim dblAng As Double
  
  dblAng = ThisDrawing.Utility.GetAngle(, _
           vbCr & "Задайте угол наклона для всех текстовых объектов: ")
  If dblAng >=0 And dblAng < 85 * 3.14159265359 / 180 Then
    SetObliqueAngle dblAng
  Else
    Beep
    ThisDrawing.Utility.Prompt vbCr & "Не верный угол наклона!"
  End If
End Sub
 

Объединение нескольких многострочных текстовых объектов в один

Option Explicit

Public Sub MergeMT()
  Dim objGen As Object
  Dim varPnt As Variant
  Dim strAll As String
  Dim varInsPnt As Variant
  Dim varCorner As Variant
  Dim dblWidth As Double
  Dim strPrompt As String
  Dim intActiveSpace As Integer
  Dim objMtxt As AcadMText
  intActiveSpace = ThisDrawing.ActiveSpace
  strPrompt = "Use the Screen to select width _
  of Mtext or enter at command line: "
  ThisDrawing.Utility.InitializeUserInput 1
  varInsPnt = ThisDrawing.Utility.GetPoint(, _
  "Pick the Upper Left insertion point for the Mtext: ")
  varCorner = ThisDrawing.Utility.GetCorner(varInsPnt, strPrompt)
  dblWidth = Abs(varInsPnt(0) - varCorner(0))
  Do Until Err
    On Error Resume Next
    strPrompt = "Select MText to merge: "
    ThisDrawing.Utility.GetEntity objGen, varPnt, strPrompt
    If TypeOf objGen Is AcadMText Then
      strAll = strAll & objGen.TextString
      'Want to keep the old MText? Comment out the next line
      'Если не хотите, чтобы исходные текстовые объекты
      'удалались "закомментируйте" следующую строку
      objGen.Delete
    End If
  Loop
  Err.Clear
  On Error GoTo Err_Control
  If ThisDrawing.ActiveSpace = acModelSpace Then
    ThisDrawing.ModelSpace.AddMText varInsPnt, dblWidth, strAll
  Else
    ThisDrawing.PaperSpace.AddMText varInsPnt, dblWidth, strAll
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
End Sub
 

Перевод всех символов выбранного текста в верхний регистр

Option Explicit

Public Sub CAPIT(objEnt As AcadEntity)
  Dim strTxt As String
  If TypeOf objEnt Is AcadText Or _
  TypeOf objEnt Is AcadMText Then
    strTxt = StrConv(objEnt.TextString, vbUpperCase)
    objEnt.TextString = strTxt
    objEnt.Update
  End If
End Sub

Public Sub TEST_CAPIT()
  Dim objText As AcadEntity
  Dim varPnt As Variant
  
  On Error GoTo Err_Handler
  ThisDrawing.Utility.GetEntity objText, varPnt, _
  vbCr & "Выберите текстовый объект: "
  CAPIT objText
  Exit Sub
Err_Handler:
  ThisDrawing.Utility.Prompt _
  vbCr & "Выбранный объект не является текстовым объектом!"
End Sub
 

Поиск и замена текста во вставленных блоках

Создайте новый чертеж и создайте в нем несколько текстовых объектов. Двум текстовым объектам присвойте значения "555 - 1212". Теперь создайте из всех этих текстовых объектов блок с именем "blkTEST", вставьте этот блок несколько раз в чертеж и запустите макрос ReplaceTextValue, помещенный предварительно в стандартный модуль VBA. После запуска процедура ReplaceTextVlue просматривает все вставленные в чертеж блоки с именем "blkTEST" и, если в этих блоках есть текстовые объекты со значениями "555 - 1212", то процедура заменит их на "555 - 1234". При этом блок переопределяется и если попытаться вставить его после запуска процедуры, то он будет вставлен уже с обновленным текстовым значением.

Option Explicit

Public Sub ReplaceTextValue()
  Dim objBlk As AcadBlock
  Dim objEnt As AcadEntity
  Dim varPnt As Variant
  Dim strOld As String
  Dim strNew As String
  Dim intCnt As Integer
  
  On Error GoTo Err_Control
  'Pete change this to the number
  'you want to replace
  strOld = "555 - 1212"
  'Change this to the new number
  strNew = "555 - 1234"
  'Change the name "blkTEST" to the name
  'of your title block
  'Замените имя блока "blkTEST" на то,
  'которое Вы использовали в чертеже
  Set objBlk = ThisDrawing.Blocks("blkTEST")
  For intCnt = 0 To objBlk.Count-1
    Set objEnt = objBlk.Item(intCnt)
    If TypeOf objEnt Is AcadText Then
      If objEnt.TextString = strOld Then
        objEnt.TextString = strNew
        'so the change is visible
        ThisDrawing.Regen acAllViewports
        'Если за ранее известно, что заданный
        'текст может встретится в блоке
        'только один раз, то удалите
        'символ комментария из следующей строки
        'Exit For
      End If
    End If
  Next intCnt
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 

Добавление текстового объекта в блок

Создайте в чертеже блок с именем "TESTADD", вставьте его в чертеж несколько раз и запустите процедуру IntoBlkRef. Блок с именем "TESTADD" будет переопределен. В блок будет добавлен текстовый объект со значением "Sample Text", при этом координаты точки вставки этого объекта будут совпадать координатами точки вставки блока.

Option Explicit

Public Sub IntoBlkRef()
  Dim objBlk As AcadBlock
  Dim objText As AcadText
  Dim dblHt As Double
  
  On Error GoTo Err_Control
  dblHt = CDbl(ThisDrawing.GetVariable("TEXTSIZE"))
  'Change to match your blocks name
  Set objBlk = ThisDrawing.Blocks("TESTADD")
  Set objText = objBlk.AddText("Sample Text", _
  objBlk.Origin, dblHt)
  objText.Alignment = acAlignmentCenter
  ThisDrawing.Regen acAllViewports
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 

Создание связи между двумя текстовыми объектами

Создайте новый чертеж и добавьте в него два текстовых объекта. Откройте редактор VBA и добавьте в проект модуль класса, который назовите TextBlock. Добавьте в этот модуль класса следующий код:

Option Explicit

Private WithEvents oText As AcadText
Private oChild As AcadText

Private Sub oText_Modified(ByVal pObject As AutoCAD.IAcadObject)
  oChild.TextString = oText.TextString
End Sub

Public Property Set ParentEntity(objEnt As AcadText)
  Set oText = objEnt
End Property

Public Property Set ChildEntity(objEnt As AcadText)
  Set oChild = objEnt
End Property
 

Теперь перейдите в модуль "ThisDrawing" и добавьте в него следующий код:

Option Explicit

Dim objTxtBlk As TextBlock

Public Sub DefineRelation()
  Dim objEnt As AcadEntity
  Dim varPnt As Variant
  Dim strPrmpt As String
  
  'strPrmpt = vbCrLf & "Select parent text object: "
  strPrmpt = vbCrLf & "Выберите главный текстовый объект: "
  Set objTxtBlk = New TextBlock
  ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmpt
  If TypeOf objEnt Is AcadText Then
    Set objTxtBlk.ParentEntity = objEnt
  End If
  'strPrmpt = vbCrLf & "Select child text object: "
  strPrmpt = vbCrLf & "Выберите подчиненный текстовый объект: "
  ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmpt
  If TypeOf objEnt Is AcadText Then
    Set objTxtBlk.ChildEntity = objEnt
  End If
End Sub
 

Теперь запустите процедуру DefineRelation и выберите по очереди два текстовых объекта, сделав один главным, а другой подчиненным. Теперь, если поменять содержимое главного объекта, то содержимое подчиненного объекта автоматически сделается такам же как у главного.

Штриховка

Добавление штриховки в блок

Создайте в чертеже блок, в котором была бы хоть одна окружность, задайте ему имя test, и поместите в стандартный модуль следующую ниже процедуру. Если запустить ее, то все окружности в блоке будут заштрихованы штриховкой типа ANSI31.
Option Explicit

Public Sub ReDefineWithHatch()
  Dim objhatch As AcadHatch
  Dim objBlk As AcadBlock
  Dim objLoop(0) As AcadEntity
  Dim objent As AcadEntity
  
  Set objBlk = ThisDrawing.Blocks("test")
  For Each objent In objBlk
    If TypeOf objent Is AcadCircle Then
      Set objLoop(0) = objent
      Set objhatch = objBlk.AddHatch(1, "ANSI31", True)
      objhatch.AppendOuterLoop objLoop
      objhatch.Evaluate
      'Exit For
    End If
  Next
  ThisDrawing.Regen acAllViewports
End Sub
 

Создание штриховки по образцу

Создайте в чертеже штриховку и какой-нибудь замкнутый объект (Окружность, Прямоугольник или Полилинию). Поместите в стандартный модуль следующий код и запустите процедуру ReHatch. Выберите вначале существующую штриховку, а затем не заштрихованный замкнутый объект. Результатом этих действий будет создание штриховки в замкнутом объекте, свойства которой совпадает с выбранной.

Option Explicit

Public Sub ReHatch()
  'This code takes the "Error's Happen"
  'Approach...
  Dim objHatch As AcadHatch
  Dim objEnt As AcadEntity
  Dim objUtil As AcadUtility
  Dim objLoop(0) As AcadEntity
  Dim varPnt As Variant
  Dim strPrmt As String

  On Error GoTo Err_Control
  Set objUtil = ThisDrawing.Utility
  strPrmt = "Выберите штриховку - образец: "
  objUtil.GetEntity objEnt, varPnt, strPrmt
  Set objHatch = objEnt
  objHatch.Visible = False
  strPrmt = "Выберите замкнутый объект дла штриховки: "
  objUtil.GetEntity objEnt, varPnt, strPrmt
  Set objLoop(0) = objEnt
  objHatch.AppendInnerLoop objLoop
  objHatch.Evaluate
  objHatch.Update
Exit_Here:
  If Not objHatch Is Nothing Then
    If objHatch.Visible = False Then
      objHatch.Visible = True
      Set objHatch = Nothing
    End If
  End If
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 

Внешние ссылки

Функции, находящиеся в других разделах Защита от изменений всех слоев вставленных в чертеж внешних ссылок

Поиск всех внешних ссылок и конвертирование их в блоки

Следующая, простенькая на первый взгляд процедура, выполняет довольно полезную в некоторых случаях операцию. Она находит все внешние ссылки, вставленный в чертеж и конвертирует их в блоки.

Option Explicit

Public Sub BindXrefs()
  Dim objBlk As AcadBlock
  Dim objAllBlks As AcadBlocks

  Set objAllBlks = ThisDrawing.Blocks
  For Each objBlk In objAllBlks
    If objBlk.IsXRef Then
      objBlk.Bind False
    End If
  Next objBlk
End Sub
 

Создание класса для доступа к свойствам внешних ссылок

Создайте VBA проект, добавьте в проект модуль класса и задайте ему имя AcadExternalReferences. Поместите в модуль класса следующий код:

Option Explicit

Private AcadXrefs As New Collection

Private Sub Class_Initialize()
  'When the class is created
  Call LoadXrefs
End Sub

Private Sub LoadXrefs()
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Dim objXref As AcadExternalReference
  Dim objEnt As AcadEntity
  Dim objBlk As AcadBlock
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  
  On Error GoTo Err_Control
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = "LogXrefs" Then
        objSelSet.Delete
        Exit For
      End If
    Next
  Set objSelSet = ThisDrawing.SelectionSets.Add("LogXrefs")
  intType(0) = 0
  varData(0) = "INSERT"
  objSelSet.Select acSelectionSetAll, filtertype:=intType, _
  filterdata:=varData
  For Each objEnt In objSelSet
    Set objBlk = ThisDrawing.Blocks(objEnt.Name)
    If objBlk.IsXRef Then
      Set objXref = objEnt
      AcadXrefs.Add objXref
      'Get any nested xrefs
      GetNested objBlk
    End If
  Next objEnt
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
Private Function GetNested(objBlk As AcadBlock) As Integer
  Dim objXref As AcadExternalReference
  Dim objBlkRef As AcadBlockReference
  Dim objEnt As AcadEntity
  Dim objNext As AcadBlock
    For Each objEnt In objBlk
      If TypeOf objEnt Is AcadBlockReference Then
        Set objBlkRef = objEnt
        Set objNext = ThisDrawing.Blocks(objBlkRef.Name)
        If objNext.IsXRef Then
          Set objXref = objEnt
          AcadXrefs.Add objXref
          GetNested objNext
        End If
      End If
    Next
  GetNested = AcadXrefs.Count
End Function
 
'Returns the stored Xref at Index
Public Property Get Item(Index As Integer) As AcadExternalReference
  Set Item = AcadXrefs(Index)
End Property
 
'How many in the drawing (includes nested)
Public Property Get Count() As Integer
  Count = AcadXrefs.Count
End Property
 

Теперь добавьте стандартный модуль и добавьте в него этот код:

Option Explicit

Public objXrefCol As AcadExternalReferences

Public Sub TestIt()
  Dim intCnt As Integer
  
  Set objXrefCol = New AcadExternalReferences
  MsgBox "В чертеж вставлено " & CStr(objXrefCol.Count) _
  & " ссылок.", vbInformation + vbOKOnly
  For intCnt = 1 To objXrefCol.Count
    MsgBox objXrefCol.Item(intCnt).Path
  Next intCnt
End Sub

Вставьте в чертеж несколько внешних ссылок и запустите TestIt.

Открытие файла внешней ссылки

Добавьте в стандартный модуль следующий код и запустите процедуру, не забыв до этого вставить в чертеж пару-тройку внешних ссылок. На полученный запрос выберите любую из вставленных ссылок. Что произойдет дальше зависит от значения системной переменной XLOADCTL. Если она равна 0 (Открытие файлов внешних ссылок открытого чертежа запрещено) или если она равна 1 (открытие файлов внешних ссылок разрешено) то текущий чертеж будет закрыт и вместо него будет открыт файл выбранной внешней ссылки. Если же системная переменная XLOADCTL равна 2 (открытие файлов внешних ссылок разрешено, но, без возможности редактирования), то текущий чертеж не будет закрыт, а файл внешней ссылки будет открыт в режиме "Только чтение".

Option Explicit

'Begin code
'From Randall Rath's ACAD newsletter, 09/20/2000
'noted modifications by MKW 09/20/2000
Public Sub Open_Xref()
  Dim objEnt As AcadEntity
  Dim varPnt As Variant
  Dim strPrmt As String
  Dim strPath As String
  
  On Error GoTo Err_Control
  strPrmt = vbCrLf & "Select External Reference to open: "
  ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmt
  If TypeOf objEnt Is AcadExternalReference Then
    strPath = objEnt.Path
    '############################################
    If ThisDrawing.GetVariable("XLOADCTL") <> 2 Then
        ThisDrawing.Close
    '############################################
    End If
    Application.Documents.Open strPath
  Else
    strPrmt = vbCrLf & "Selected entity was not a reference"
    MsgBox strPrmt
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 

Изменение пути внешний ссылки

Пример процедур, с помощью которых можно изменить пути к файлам внешних ссылок и перезагрузить их.

Option Explicit

Private Sub ChangeXrefPath(strRefPath As String)
  Dim objSelSet As AcadSelectionSet
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Dim objBlkRef As Object
  Dim objXref As AcadExternalReference

  intType(0) = 0
  varData(0) = "INSERT"
  Set objSelSet = vbdPowerSet("repathxrefs")
  objSelSet.Select acSelectionSetAll, _
  filtertype:=intType, filterdata:=varData
  For Each objBlkRef In objSelSet
    If TypeOf objBlkRef Is AcadExternalReference Then
      Set objXref = objBlkRef
      objXref.Path = strRefPath & objXref.Name & ".dwg"
    End If
  Next
  ReloadXRefs
  objSelSet.Delete
End Sub

Private Sub ReloadXRefs()
  Dim objBlk As AcadBlock
  Dim objBlks As AcadBlocks
  Set objBlks = ThisDrawing.Blocks
  For Each objBlk In objBlks
    If objBlk.IsXRef Then
      objBlk.Reload
    End If
  Next objBlk
  ThisDrawing.Regen acAllViewports
End Sub

Public Function vbdPowerSet(strName As String) As AcadSelectionSet
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = strName Then
        objSelSet.Delete
        Exit For
      End If
    '//If you get the error "Automation Error"
    'At the "Next" line, it's because one the blocks
    'You just and changed, contained another Xref, and thats
    'The block you are now trying to change! The solution for
    'This problem can be found in the Project X code for our
    'Object Model extension AcadExternalReferences
    Next
  Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
  Set vbdPowerSet = objSelSet
End Function
 

Диалоговое окно для вставки в чертеж внешних ссылок

Следующий пример не является панацеей, оно не лишено недостатков, но, думаю Вы сможете, если захотите, на основании этого примера зделать нечто более лучшее. Итак, начнем. Добавьте в проект модуль формы и разместите на ней элементы, показанные на картинке:

Затем поместите в модуль этой формы весь следующий код:

Option Explicit

'//The Win32 API Functions///
Private Declare Function GetSaveFileName Lib _
"comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As Long

Private Declare Function GetOpenFileName Lib _
"comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long

'//The Structure
Private Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

'//A few of the available Flags///
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_EXPLORER = &H80000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_LONGNAMES = &H200000
Private Const OFN_NODEREFERENCELINKS = &H100000
 
Private Const OFS_FILE_OPEN_FLAGS = _
OFN_EXPLORER Or OFN_LONGNAMES Or _
OFN_CREATEPROMPT Or OFN_NODEREFERENCELINKS _
Or OFN_ALLOWMULTISELECT
 
Private lngHwnd As Long
Private strFilter As String
Private strTitle As String
Private strDir As String
 
Private Sub UserForm_Initialize()
  On Error GoTo Err_Control
  Me.Caption = "Multiple External Reference"
  Frame1.Caption = "File names"
  Frame2.Caption = "Reference Type"
  Frame3.Caption = "Insertion Point"
  Frame4.Caption = "Scale"
  Frame5.Caption = "Rotation"
  Label1.Caption = "X:"
  Label2.Caption = "Y:"
  Label3.Caption = "Z:"
  TextBox1.Text = "0,00"
  TextBox2.Text = "0,00"
  TextBox3.Text = "0,00"
  Label4.Caption = "X:"
  Label5.Caption = "Y:"
  Label6.Caption = "Z:"
  TextBox4.Text = "1,00"
  TextBox5.Text = "1,00"
  TextBox6.Text = "1,00"
  Label7.Caption = "Angle"
  TextBox7.Text = "0"
  CheckBox1.Caption = "Specify on screen"
  CheckBox2.Caption = "Specify on screen"
  CheckBox3.Caption = "Specify on screen"
  OptionButton1.Caption = "Attachment"
  OptionButton1.Value = True
  OptionButton2.Caption = "Overlay"
  CommandButton1.Caption = "Browse"
  CommandButton2.Caption = "Remove"
  CommandButton3.Caption = "OK"
  CommandButton4.Caption = "Cancel"
  CommandButton5.Caption = "Help"
  strDir = CurDir
  strTitle = "Llamas Rule"
  Filter = "AutoCAD Drawings (*.dwg)|*.dwg"
  OwnerHwnd = ThisDrawing.HWND
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
Private Sub CommandButton1_Click()
  Dim strTemp As String
  Dim strFile As String
  Dim intCnt As Integer
  Dim strFiles As String
  Dim strFileName As String
  Dim strPath As String
  
  On Error GoTo Err_Control
  strTemp = ShowOpen
  If Len(strTemp) > 0 Then
    If InStr(strTemp, Chr$(0)) > 0 Then
      strPath = Mid(strTemp, 1, _
      InStr(strTemp, Chr$(0)) - 1)
      strTemp = Mid(strTemp, _
      InStr(strTemp, Chr$(0)) + 1)
      If Len(strTemp) > 0 Then
        If Right(strPath, 1) <> "\" Then
          strPath = strPath & "\"
        End If
        Do Until Len(strTemp) = 0
          strFile = ParseOut(strTemp, Chr(0))
          ListBox1.AddItem strPath & strFile
        Loop
      Else
        ListBox1.AddItem strPath
      End If
    Else
      ListBox1.AddItem strTemp
    End If
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
Private Sub CommandButton2_Click()
  Dim intCnt As Integer
  For intCnt = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(intCnt) Then
      ListBox1.RemoveItem intCnt
      Exit For
    End If
  Next intCnt
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
Private Sub CommandButton3_Click()
  Dim objSpace As AcadBlock
  Dim varPnt As Variant
  Dim strPrmt As String
  Dim dblX As Double
  Dim dblY As Double
  Dim dblZ As Double
  Dim dblAngle As Double
  Dim objUtil As Object
  Dim intCnt As Integer
  Dim strName As String
  Dim strPath As String
  Dim blnOvly As Boolean

  On Error GoTo Err_Control
  Me.Hide
  Set objUtil = ThisDrawing.Utility
  blnOvly = OptionButton2.Value
  If CheckBox1.Value = True Then
    strPrmt = vbCr & "Insertion point: "
    varPnt = objUtil.GetPoint(Prompt:=strPrmt)
  Else
    objUtil.CreateTypedArray varPnt, _
    vbDouble, TextBox1, TextBox2, TextBox3
  End If
  If CheckBox2.Value = True Then
    strPrmt = vbCr & "X Scale: "
    dblX = objUtil.GetReal(strPrmt)
    strPrmt = vbCr & "Y Scale: "
    dblY = objUtil.GetReal(strPrmt)
    strPrmt = vbCr & "Z Scale: "
    dblZ = objUtil.GetReal(strPrmt)
  Else
    dblX = CDbl(TextBox4)
    dblY = CDbl(TextBox5)
    dblZ = CDbl(TextBox6)
  End If
  If CheckBox3.Value = True Then
    strPrmt = vbCr & "Angle: "
    dblAngle = objUtil.GetAngle(Prompt:=strPrmt)
  Else
    dblAngle = CDbl(TextBox1 / 180 * (Atn(1) * 4))
  End If
  If ThisDrawing.ActiveSpace = acModelSpace Then
    Set objSpace = ThisDrawing.ModelSpace
  Else
    Set objSpace = ThisDrawing.PaperSpace
  End If
  'For intCnt = 0 To ListBox1.ListCount - 1
    strPath = ListBox1.Text
  '  strPath = ListBox1.List(intCnt)
    strName = StripPath(strPath)
    objSpace.AttachExternalReference strPath, _
    strName, varPnt, dblX, dblY, dblZ, _
    dblAngle, blnOvly
  'Next intCnt
  Me.Show
  Application.Update
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
Private Sub CheckBox1_Click()
  Dim objCtl As Control
  If CheckBox1.Value = True Then
    For Each objCtl In Frame3.Controls
      If Not TypeOf objCtl Is CheckBox Then
        objCtl.Enabled = False
      End If
    Next objCtl
  Else
    For Each objCtl In Frame3.Controls
      If Not TypeOf objCtl Is CheckBox Then
        objCtl.Enabled = True
      End If
    Next objCtl
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
Private Sub CheckBox2_Click()
  Dim objCtl As Control
  If CheckBox2.Value = True Then
    For Each objCtl In Frame4.Controls
      If Not TypeOf objCtl Is CheckBox Then
        objCtl.Enabled = False
      End If
    Next objCtl
  Else
    For Each objCtl In Frame4.Controls
      If Not TypeOf objCtl Is CheckBox Then
        objCtl.Enabled = True
      End If
    Next objCtl
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
Private Sub CheckBox3_Click()
  Dim objCtl As Control
  If CheckBox3.Value = True Then
    For Each objCtl In Frame5.Controls
      If Not TypeOf objCtl Is CheckBox Then
        objCtl.Enabled = False
      End If
    Next objCtl
  Else
    For Each objCtl In Frame5.Controls
      If Not TypeOf objCtl Is CheckBox Then
        objCtl.Enabled = True
      End If
    Next objCtl
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
Private Sub CommandButton4_Click()
  Unload Me
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
Public Property Let OwnerHwnd(WindowHandle As Long)
  lngHwnd = WindowHandle
End Property
 
Public Property Get OwnerHwnd() As Long
  OwnerHwnd = lngHwnd
End Property
 
Public Property Let Title(Caption As String)
  'don't allow null strings
  If Not Caption = vbNullString Then
    strTitle = Caption
  End If
End Property
 
Public Property Get Title() As String
  Title = strTitle
End Property
 
Public Property Let Filter(ByVal FilterString As String)
  'Filters change the type of files that are
  'displayed in the dialog. I have designed this
  'validation to use the same filter format the
  'Common dialog OCX uses:
  '"All Files (*.*)|*.*"
  Dim intPos As Integer
  Do While InStr(FilterString, "|") > 0
    intPos = InStr(FilterString, "|")
    If intPos > 0 Then
      FilterString = Left$(FilterString, intPos - 1) _
      & Chr$(0) & Right$(FilterString, _
      Len(FilterString) - intPos)
    End If
  Loop
  If Right$(FilterString, 2) <> Chr$(0) & Chr$(0) Then
    FilterString = FilterString & Chr$(0)
  End If
  strFilter = FilterString
End Property
 
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Display and use the File open dialog
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function ShowOpen() As String
  Dim strTemp As String
  Dim udtStruct As OPENFILENAME
  
  udtStruct.lStructSize = Len(udtStruct)
  'Use our private variable
  udtStruct.hwndOwner = lngHwnd
  'Use our private variable
  udtStruct.lpstrFilter = strFilter
  udtStruct.lpstrFile = Space$(254)
  udtStruct.nMaxFile = 255
  udtStruct.lpstrFileTitle = Space$(254)
  udtStruct.nMaxFileTitle = 255
  'Use our private variable
  udtStruct.lpstrInitialDir = strDir
  'Use our private variable
  udtStruct.lpstrTitle = strTitle
  'set the flags
  udtStruct.flags = OFS_FILE_OPEN_FLAGS
  If GetOpenFileName(udtStruct) Then
    strTemp = (Trim(udtStruct.lpstrFile))
    ShowOpen = Mid(strTemp, 1, Len(strTemp) - 1)
  End If
End Function
 
Private Function ParseOut(strIn As String, _
strChar As String) As String
  Dim intCnt As Integer
  Dim strFile As String
  On Error GoTo Err_Control
  intCnt = 1
  Do
   If Mid(strIn, intCnt, 1) = strChar Then
    strFile = Mid(strIn, 1, intCnt - 1)
    strIn = Mid(strIn, intCnt + 1, Len(strIn))
    ParseOut = strFile
    Exit Do
   End If
   intCnt = intCnt + 1
  Loop
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function
 
Private Function StripPath(strFilePath) As String
  Dim intPos As Integer
  Dim intCnt As Integer
  On Error GoTo Err_Control
  StripPath = strFilePath
  intPos = InStr(strFilePath, "\")
  Do While intPos
    intCnt = intPos
    intPos = InStr(intCnt + 1, strFilePath, "\")
  Loop
  If intCnt > 0 Then
    StripPath = Mid(strFilePath, intCnt + 1)
    'No file extenstion
    StripPath = Mid(StripPath, 1, Len(StripPath) - 4)
  End If
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function
 

Запустите форму. Нажимая кнопку Browse или Remove можно создать список файлов в списке. Файлы добавляются после их выбора в диалоговом окне Llamas Rule, появляющемся после нажатия на копку Browse. Затем, выбирав файл в списке и нажав кнопку OK можно вставить выбранный файл в чертеж как внешнюю ссылку, при этом вставка происходит в соответствии с выбранными в диалоговом окне опциями.

Отслеживание команды вставки внешней ссылки

Добавьте в модуль ThisDrawing следующий ниже код. Теперь, если Вы запустите команду вставки внешней ссылки, то в чертеж будет добавлен новый слой с именем, совпадающим с именем вставляемой ссылки, и ссылка будет вставлена именно в этот слой.

Option Explicit

Private blnWatch As Boolean
Private objXref As AcadExternalReference

Private Sub AcadDocument_BeginCommand(ByVal _
CommandName As String)
  On Error GoTo Err_Control
  'If StrComp(CommandName, "XREF") = 0 Then ' Может у Вас
  ' Сработает этот вариант?
  If StrComp(CommandName, "XATTACH") = 0 Then
    blnWatch = True
  End If
Exit_Here:
  Exit Sub
Err_Control:
  Debug.Print Err.Description
  Resume Exit_Here
End Sub

Private Sub AcadDocument_EndCommand(ByVal _
CommandName As String)
  On Error GoTo Err_Control
  If blnWatch Then
    ThisDrawing.Layers.Add objXref.Name
    objXref.Layer = objXref.Name
    Set objXref = Nothing
    blnWatch = Not blnWatch
  End If
Exit_Here:
  Exit Sub
Err_Control:
  Debug.Print Err.Description
  Resume Exit_Here
End Sub

Private Sub AcadDocument_ObjectAdded(ByVal _
Object As Object)
  On Error GoTo Err_Control
  If blnWatch Then
    If TypeOf Object Is _
    AcadExternalReference Then
      Set objXref = Object
    End If
  End If
Exit_Here:
  Exit Sub
Err_Control:
  Debug.Print Err.Description
  Resume Exit_Here
End Sub



Copyright © Сайт поддержки пользователей САПР by Victor Tkachenko