Тема: Почему расширенные данные только добавляются, а не редактируются?
Написал программу на VBA для работы с расширенными данными и заметил что расширенные данные только добавляются в коллекцию а не редактируются! При каждом редактировании создаются новые элементы наряду с существующими старыми, которые остаются без изменений (как версии разработки программы). В итоге чертёж может непредсказуемо увеличиться в размерах и никто не может узнать из-за чего! Это очень опасно! Помогите и научите с этим бороться! Как контролировать количество версий расширенных данных в AutoCAD?
Для больших подробностей привожу текст своей программы которая написана в модуле UserForm на котором имеются
1) TextBox3_НазваниеВыделенногоОбъекта
2) TextBox4_УровеньВложенности
3) SpinButton1_УровеньВложенности
4) TextBox5_КолвоУровнейВложенности
5) TextBox1_ДополнительныеДаные1000
6) TextBox2_ДополнительныеДанные1001
7) CommandButton3_ВыделитьОбъект
8) CommandButton1_OK
9) CommandButton2_Выход:
Option Explicit
Dim AcadObject As AcadObject
Dim BindXDataSelSet As AcadSelectionSet
Dim xtypeOut As Variant
Dim xdataOut As Variant
Dim BindXData1000 As String, BindXData1001 As String
Dim CountLevel As Long, NumLevel As Long
Private Sub CommandButton3_ВыделитьОбъект_Click()
Dim Point As Variant
On Error Resume Next
ThisDrawing.SelectionSets("BindXDataSelSet").Delete
On Error GoTo ОбработкаОшибок
Set BindXDataSelSet = ThisDrawing.SelectionSets.Add("BindXDataSelSet")
Me.Hide
BindXDataSelSet.SelectOnScreen
Set AcadObject = BindXDataSelSet.Item(0)
TextBox3_НазваниеВыделенногоОбъекта.Value = AcadObject.ObjectName
AcadObject.GetXData "", xtypeOut, xdataOut
If IsEmpty(xdataOut) Then
MsgBox "Дополнительные данные отсутствуют!", vbInformation, НазваниеПрограммы
BindXData1000 = ""
BindXData1001 = ""
Else
CountLevel = (UBound(xdataOut) + 1) / 2
TextBox5_КолвоУровнейВложенности.Value = CountLevel
NumLevel = 1
TextBox4_УровеньВложенности.Value = NumLevel
Call ПолучитьДополнительныеДанныеЗаданногоУровняВложености(NumLevel)
End If
TextBox1_ДополнительныеДаные1000.Value = BindXData1000
TextBox2_ДополнительныеДанные1001.Value = BindXData1001
Me.Show
MsgBox "Дополнительные данные уровня вложенности """ & NumLevel & """ прочитаны!", vbInformation, НазваниеПрограммы
Exit Sub
ОбработкаОшибок:
MsgBox "Произошла ошибка при получении дополнительных данных!" & vbLf & vbLf & _
"Номер ошибки = " & Err.Number & vbLf & vbLf & _
"Название ошибки: " & Err.Description, vbExclamation, НазваниеПрограммы
Err.Clear
Resume Next
End Sub
Sub ПолучитьДополнительныеДанныеЗаданногоУровняВложености(УровеньВложености As Long)
If VBA.Len(xdataOut(2 * УровеньВложености - 2)) <> 0 Then
BindXData1000 = xdataOut(2 * УровеньВложености - 2)
Else
BindXData1000 = ""
End If
If VBA.Len(xdataOut(2 * УровеньВложености - 1)) <> 0 Then
BindXData1001 = xdataOut(2 * УровеньВложености - 1)
Else
BindXData1001 = ""
End If
If BindXData1000 & BindXData1001 = "" Then
MsgBox "Дополнительные данные уровня вложености """ & УровеньВложености & """ не заданы (строки нулевой длины)!", vbInformation, НазваниеПрограммы
End If
End Sub
Private Sub CommandButton1_OK_Click()
Dim intType(0 To 1) As Integer
Dim varVal(0 To 1) As Variant
On Error GoTo ОбработкаОшибок
intType(0) = 1001
intType(1) = 1000
varVal(0) = TextBox1_ДополнительныеДаные1000.Text
varVal(1) = TextBox2_ДополнительныеДанные1001.Text
AcadObject.SetXData intType, varVal
AcadObject.GetXData "", xtypeOut, xdataOut
If IsEmpty(xdataOut) Then
MsgBox "Дополнительные данные отсутствуют!", vbInformation, НазваниеПрограммы
BindXData1000 = ""
BindXData1001 = ""
Else
CountLevel = (UBound(xdataOut) + 1) / 2
TextBox5_КолвоУровнейВложенности.Value = CountLevel
NumLevel = CountLevel
TextBox4_УровеньВложенности.Value = NumLevel
Call ПолучитьДополнительныеДанныеЗаданногоУровняВложености(NumLevel)
End If
TextBox1_ДополнительныеДаные1000.Value = BindXData1000
TextBox2_ДополнительныеДанные1001.Value = BindXData1001
MsgBox "Дополнительные данные записаны!", vbInformation, НазваниеПрограммы
Exit Sub
ОбработкаОшибок:
MsgBox "Произошла ошибка при записи дополнительных данных!" & vbLf & vbLf & _
"Номер ошибки = " & Err.Number & vbLf & vbLf & _
"Название ошибки: " & Err.Description, vbExclamation, НазваниеПрограммы
Err.Clear
Resume Next
End Sub
Private Sub SpinButton1_УровеньВложенности_Change()
NumLevel = SpinButton1_УровеньВложенности.Value
ЗначениеДоИзмененения = TextBox4_УровеньВложенности.Text
If NumLevel <> 0 And NumLevel <= CountLevel Then
TextBox4_УровеньВложенности.Value = NumLevel
SpinButton1_УровеньВложенности.Value = NumLevel
Call ПолучитьДополнительныеДанныеЗаданногоУровняВложености(NumLevel)
TextBox1_ДополнительныеДаные1000.Value = BindXData1000
TextBox2_ДополнительныеДанные1001.Value = BindXData1001
' MsgBox "Дополнительные данные уровня вложенности """ & NumLevel & """ прочитаны!", vbInformation, НазваниеПрограммы
Else
NumLevel = VBA.CLng(ЗначениеДоИзмененения)
SpinButton1_УровеньВложенности.Value = NumLevel
End If
End Sub
Private Sub TextBox4_УровеньВложенности_Enter()
ЗначениеДоИзмененения = TextBox4_УровеньВложенности.Text
End Sub
Private Sub TextBox4_УровеньВложенности_Exit(ByVal Cancel As MSForms.ReturnBoolean)
On Error GoTo ОбработкаОшибок
TextBox4_УровеньВложенности.Value = ПолучитьЧисло(TextBox4_УровеньВложенности.Text)
NumLevel = VBA.CLng(TextBox4_УровеньВложенности.Text)
If NumLevel = 0 Then
MsgBox "Ошибка! Номер уровня вложености не может быть равен нулю!", vbExclamation, НазваниеПрограммы
TextBox4_УровеньВложенности.Text = ЗначениеДоИзмененения
ElseIf NumLevel <= CountLevel Then
NumLevel = CLng(TextBox4_УровеньВложенности.Text)
SpinButton1_УровеньВложенности.Value = NumLevel
Call ПолучитьДополнительныеДанныеЗаданногоУровняВложености(NumLevel)
TextBox1_ДополнительныеДаные1000.Value = BindXData1000
TextBox2_ДополнительныеДанные1001.Value = BindXData1001
Me.Show
MsgBox "Дополнительные данные уровня вложенности """ & NumLevel & """ прочитаны!", vbInformation, НазваниеПрограммы
Else
TextBox4_УровеньВложенности.Text = ЗначениеДоИзмененения
End If
NumLevel = VBA.CLng(TextBox4_УровеньВложенности.Text)
Exit Sub
ОбработкаОшибок:
MsgBox "Непонятная ошибка при вводе числа!" & vbLf & vbLf & _
"Номер ошибки = " & Err.Number & vbLf & vbLf & _
"Название ошибки: " & Err.Description, vbExclamation, НазваниеПрограммы
TextBox4_УровеньВложенности.Value = VBA.CDbl(ЗначениеДоИзмененения)
Resume Next
End Sub
Private Sub CommandButton2_Выход_Click()
End
End SubМогу выслать модуль FRM в текстовом виде если это необходимо.
