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
 

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
 

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
 

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
 

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
 

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
 

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
 

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
 

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

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
 

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