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

Расширенные данные

Создание новых свойств объектов

Следующий пример показывает как для выбранного объекта можно создать новую группу свойств и новые свойства, отображаемые в окне "Properties" AutoCAD 2000. Перед использованием этого примера в проекте необходимо сделать ссылку на библиотеку AsdkOpmX 1.0 Type Library. Если в окне References - ACADProject нет такого пункта, то эту библиотеку вначале нужно зарегистрировать. Для этого введите в командную строку команду ARX и выберите опцию LOAD, поле этого, в появившемся диалоговом окне, выберите файл C:\…\ACAD2000\SUPPORT\asdkopmx\AsdkOpmX.arx. В командной строке должно появится сообщение "AsdkOpmX registered successfully.", после чего пункт AsdkOpmX 1.0 Type Library появляется в списке окна References - ACADProject. Если у Вас нет папки asdkopmx, и, соответственно, самой библиотеки, то ее можно взять здесь (asdkopmx.zip). После того, как в проекте создана ссылка на AsdkOpmX 1.0 Type Library можно пробовать представленные процедуры.

Вначале вставьте в чертеж какой-нибудь блок с аттрибутами. Их количество и значения не имеют никакого значения. После этого запустите процедуру AtibStrProp и на заданный запрос примитива укажите вставленный блок с аттрибутами. Теперь выделите этот блок и нажмите кнопку Свойства (Properties), отобразив тем самым окно свойств для выбранного блока. В самом низу окна добавилась новая группа свойств "Attribute Samples", которой там ранше не было, а в этой группе создано свойство "Used Values", отображающее выбранное пользователем значение аттрибута. Значение можно выбрать раскрыв раскрывающийся список этого свойства. Причем выбранное пользователем значение сохраняется в область расширенных данных с помощью функции BindXData.

Завпустив процедуру removeProp Вы удалите созданное свойство из окна Properties

Option Explicit

'Remember to add a reference to the new library!
Private objAttStr As AsdkOPMXLib.Property
 
Public Sub AtribStrProp()
  'Build the selection set
  Dim objBlkRef As AcadBlockReference
  Dim objGen As Object
  Dim varPnt As Variant
  Dim intCnt As Integer
  Dim varAtts As Variant
  Dim strPrompt As String
  Dim Tags() As Variant
  Dim Text() As String
  strPrompt = "Select a block with attributes: "
  ThisDrawing.Utility.GetEntity objGen, varPnt, strPrompt
  If TypeOf objGen Is AcadBlockReference Then
    Set objBlkRef = objGen
    Call BindXData(objBlkRef)
  ' TADA - Magic here
    Set objAttStr = Application.GetInterfaceObject("OpmX.Property.1")
  ' Now fill the arrays
    If objBlkRef.HasAttributes Then
      varAtts = objBlkRef.GetAttributes
        ReDim Tags(UBound(varAtts))
        ReDim Text(UBound(varAtts))
        For intCnt = LBound(varAtts) To UBound(varAtts)
          Tags(intCnt) = varAtts(intCnt).TagString
          Text(intCnt) = varAtts(intCnt).TextString
        Next
    End If
    'Set all of the information for the new property
  objAttStr.CategoryName = "Attribute Samples"
  objAttStr.ClassName = "AcDbBlockReference"
  objAttStr.Description = "Values from Attributes"
  objAttStr.DisplayName = "Used Values"
  objAttStr.SetDataSource "VBDESIGN", 1000, 1
  objAttStr.SetEnums Text, Tags
  objAttStr.ReadOnly = False
  ' Now add it in!
  objAttStr.Add
  End If
End Sub
 
'@~~~~~~ Dump It ~~~~~~~@
' You can use this at any
'Time.
 
Public Sub removeProp()
  objAttStr.Remove
End Sub
 
'@~~~~~~~~ Bind X Data ~~~~~~~~~~~~~@
' Read the help file for more info
' about ways to use X Data with this
' library. This is a very basic example

Public Sub BindXData(acObj As AcadBlockReference)
  Dim intDatGrp(0 To 1) As Integer
  Dim varDatVal(0 To 1) As Variant

  intDatGrp(0) = 1001
  varDatVal(0) = "VBDESIGN"
  intDatGrp(1) = 1000
  varDatVal(1) = "You can place any string in here"
  acObj.SetXData intDatGrp, varDatVal
End Sub
 

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

Для начала создайте новую форму, в которой разместите 1 блок ввода текста (TextBox) и 2 командные кнопки (CommandButton). У меня получелось следующее:

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

Option Explicit

Private Sub UserForm_Initialize()
  TextBox1.MultiLine = True
  TextBox1.EnterKeyBehavior = True
  Me.Caption = "New Open Message"
  CommandButton1.Caption = "OK"
  CommandButton2.Caption = "Cancel"
End Sub

Private Sub CommandButton1_Click()
  Dim objLayer As AcadLayer
  Dim objLayers As AcadLayers
  Dim intType(0 To 1) As Integer
  Dim varVal(0 To 1) As Variant
  
  Set objLayers = ThisDrawing.Layers
  Set objLayer = objLayers("0")
  intType(0) = 1001
  intType(1) = 1000
  varVal(0) = "VBDOPENER"
  varVal(1) = TextBox1.Text
  objLayer.SetXData intType, varVal
  ThisDrawing.Save
  'No save, no X data!
  Unload Me
End Sub

Private Sub CommandButton2_Click()
  Unload Me
End Sub
 

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

Option Explicit

Private Sub AcadDocument_Activate()
  Dim objLayer As AcadLayer
  Dim objLayers As AcadLayers
  Static intCnt As Integer
  
  Set objLayers = ThisDrawing.Layers
  Set objLayer = ThisDrawing.Layers("0")
  'If intCnt = 0 Then
    Call DisplayMsgBox(objLayer)
  'End If
  'Only want this to show one time!
  'intCnt = intCnt + 1
End Sub

Private Sub AcadDocument_BeginClose()
  SetMsgBox
End Sub

Public Sub DisplayMsgBox(acLayer As AcadLayer)
  Dim strMsg As String
  Dim VarType As Variant
  Dim varVal As Variant

  acLayer.GetXData "VBDOPENER", VarType, varVal
  strMsg = CStr(varVal(1))
  If Len(strMsg) > 0 Then
    MsgBox strMsg, vbOKOnly
  End If
End Sub

Public Sub SetMsgBox()
  Dim strPrmt As String
  
  strPrmt = "Would you like to edit this drawings opening message?"
  If MsgBox(strPrmt, vbYesNo) = vbYes Then
    UserForm1.Show
  End If
End Sub
 

Теперь сохраните текущий чертеж и закройте файл. В момент закрытия файла Вам будет задан вопрос "Would you like to edit this drawings opening message?". Ответьте на него "Да" и в появившемся диалоговом окне наберите любой текст и нажмите кнопку OK. Теперь откройте чертеж. При открытии чертежа строка, введенная Вами и сохраненная в области расширенных данных слоя "0", будет отображена в окне сообщений

Сохранение в области расширенных данных имени пользователя, даты и примечаний

Усложним предидущий пример. Теперь мы будем сохранять имя пользователя, дату последнего сохранения файла и примечания, сделанные пользователем. Причем для работы с расширенными данными мы создадим класс clsDwgNotes.Добавьте в проект следующее:

1 модуль класса с именем clsDwgNotes
1 стандартный модуль с именем modDwgNotes
1 форму с именем frmDwgNotes

У меня форма выглядела примерно так:

Добавьте в модуль класса clsDwgNotes следующий код:

Option Explicit

Const TYPE_STRING = 1
Const DICTIONARY_NAME = "DWG_Notes"

Private Type noteRecord
    Name As String
    Date As Variant
    Note As String
End Type

Private DEFAULT_NAME As String
Private dictNotes As AcadDictionary, xrecNotes As AcadXRecord
Private noteDataType As Variant, noteData As Variant
Private nRec As noteRecord

Property Let NoteName(sName As String)
    nRec.Name = sName
End Property

Property Let NoteDate(sDate As String)
    nRec.Date = sDate
End Property

Property Let NoteText(sNote As String)
    nRec.Note = sNote
End Property

Property Get NoteName() As String
    NoteName = nRec.Name
End Property

Property Get NoteDate() As String
    NoteDate = nRec.Date
End Property

Property Get NoteText() As String
    NoteText = nRec.Note
End Property
 
Private Sub Class_Initialize()
    'DEFAULT_NAME = ThisDrawing.GetVariable("LOGINNAME")
    DEFAULT_NAME = ""
    Do While DEFAULT_NAME = ""
      DEFAULT_NAME = InputBox("Введите имя пользователя")
    Loop
    nRec.Name = DEFAULT_NAME
    
    On Error GoTo CREATE
    Set dictNotes = ThisDrawing.Dictionaries(DICTIONARY_NAME)
    Set xrecNotes = dictNotes.GetObject(nRec.Name)
    On Error GoTo 0
    
    xrecNotes.GetXRecordData noteDataType, noteData
    If VarType(noteData) = vbEmpty Then 'no note found
        ReDim noteDataType(0 To 1) As Integer
        ReDim noteData(0 To 1) As Variant
        noteDataType(0) = TYPE_STRING: noteData(0) = CStr(Now)
        noteDataType(1) = TYPE_STRING: noteData(1) = "Type note here."
    End If
    
    nRec.Date = noteData(0)
    nRec.Note = noteData(1)
    Exit Sub
CREATE:
'    If dictNotes Is Nothing Then
        Set dictNotes = ThisDrawing.Dictionaries.Add(DICTIONARY_NAME)
        Set xrecNotes = dictNotes.AddXRecord(nRec.Name)
'    End If
    Resume
End Sub

Private Sub Class_Terminate()
    Set dictNotes = Nothing
    Set xrecNotes = Nothing
End Sub
 
Public Sub Save()
    noteData(0) = nRec.Date
    noteData(1) = nRec.Note
    Set dictNotes = ThisDrawing.Dictionaries(DICTIONARY_NAME)
    Set xrecNotes = dictNotes.GetObject(nRec.Name)
    xrecNotes.SetXRecordData noteDataType, noteData
End Sub
 
Public Sub Clear()
    nRec.Note = ""
End Sub
 

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

Option Explicit

Private xNote As New clsDwgNotes

Private Sub UserForm_Initialize()
  Me.Caption = "Drawing Notes"
  Frame1.Caption = "Note"
  Label1.Caption = "User Name:"
  Label2.Caption = "Date:"
  Label3.Caption = "Notes:"
  CommandButton1.Caption = "Clear"
  CommandButton2.Caption = "Save"
  CommandButton2.Default = True
  CommandButton3.Caption = "Cancel"
  CommandButton3.Cancel = True
  TextBox1.Enabled = False
  TextBox2.Enabled = False
  TextBox3.MultiLine = True
  TextBox3.EnterKeyBehavior = True
  
  TextBox1.Text = xNote.NoteName
  TextBox2.Text = xNote.NoteDate
  TextBox3.Text = xNote.NoteText
End Sub

Private Sub CommandButton1_Click()
    xNote.Clear
    TextBox3.Text = xNote.NoteText
End Sub

Private Sub CommandButton3_Click()
    Set xNote = Nothing
    Unload Me
End Sub

Private Sub CommandButton2_Click()
    xNote.NoteDate = Now
    xNote.NoteText = TextBox3.Text
    xNote.Save
    Unload Me
End Sub
 

Ну и в заключении добавьте в стандартный модуль modDwgNotes процедуру для запуска диалогового окна:

Option Explicit

Public Sub DwgNotes()
    frmDwgNotes.Show
End Sub
 
Теперь запустите процедуру DwgNotes. В появившемся окне введите имя пользователя (например "AAAAA"). Не забудьте его, оно нам еще пригодится. Теперь в окне Drawing Notes введите какое-нибудь примечание в поле ввода Note и нажмите кнопку Save. Теперь опять запустите DwgNotes. В появившемя окне введите то-же самое имя пользователя ("AAAAA"), в результате Вы увидете окно, в котором сохраненные нами примечания. Нажмите кнопку Cancel и опять запустите DwgNotes, но теперь введите другое имя пользователя (например "BBBBB") и повторите операцию сохранения новых примечаний. Теперь можно в любой момент иметь доступ к примечаниям, сохраненным пользователями "AAAAA" и "BBBBB". Как этоможно исользовать - это Ваше дело. Как Вам, например, идея сохранять информацию о имени пользователя (LOGINNAME) и дату последнего сохранения, сделанного этим пользователем, без его ведома?

Нахождение всех примитивов, содержащих в области расширенных данных заданное значение

Для начала попробуем записать в область расширенных данных выбранных примитивов заданную нами строку. Добавьте в проект стандартный модуль и добавьте в него следующий код:

Option Explicit

' Функция для создания нового пустого набора объектов
' с заданным именем
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

Public Sub BindXData()
  Dim acSelSet As AcadSelectionSet
  Dim strString As String
  Dim intDatGrp(0 To 1) As Integer
  Dim varDatVal(0 To 1) As Variant
  Dim acEnt As AcadEntity
  Dim i As Integer
  
  On Error GoTo Exit_Here
  ' Создаемновый набор объектов
  Set acSelSet = vbdPowerSet("EntityForBindXData")
  acSelSet.SelectOnScreen
  strString = ""
  Do While strString = ""
    strString = InputBox("Введите строку сохраняемую " & _
    "в области расширенных данных", "BindXData", "String 1")
  Loop
  intDatGrp(0) = 1001
  varDatVal(0) = "TESTAPP"
  intDatGrp(1) = 1000
  varDatVal(1) = strString
  ' Сохраняем введенную строку в области
  ' расширенных данных всех выбранных примитивов
  For i = 0 To acSelSet.Count - 1
    Set acEnt = acSelSet.Item(i)
    acEnt.SetXData intDatGrp, varDatVal
  Next i
  
Exit_Here:
  ' Освобождаем память
  Set acSelSet = Nothing
  Set acEnt = Nothing
End Sub
 

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

Option Explicit

'@~~~~~~~~~~~ "SelectByXdata" ~~~~~~~~~~~~~~~~~~~@
'Argument List information
'strXDataApp:
'A string representing a registered application name
'That the extended data you are looking for was placed
'Under (DXF Group code 1001)
'strXData:
'string (up to 255 bytes long) that matches the extended
'data (group code 1000) that you are looking for.
'strSelSetName:
'string - a valid selection set name (a name that
'Is not currently being used by the drawings
'Selection set collection). See the example program
'For more information
'@------------------------------------------------@

Public Function SelectByXdata(strXDataApp As String, _
strXData As String, strSelSetName As String) _
As AcadSelectionSet
  Dim objSelSet As AcadSelectionSet
  Dim objEnt As AcadEntity
  Dim objArray() As Object
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Dim varXType As Variant
  Dim varXValue As Variant
  Dim intCnt As Integer
  Dim intRemCnt As Integer
  Dim blnMatch As Boolean
  
  On Error GoTo Err_Control
  intType(0) = 1001
  varData(0) = strXDataApp
  Set objSelSet = ThisDrawing.SelectionSets.Add(strSelSetName)
  objSelSet.Select acSelectionSetAll, filtertype:=intType, _
  filterdata:=varData
  For Each objEnt In objSelSet
    objEnt.GetXData strXDataApp, varXType, varXValue
    For intCnt = LBound(varXValue) To UBound(varXValue)
      If varXValue(intCnt) = strXData Then
        blnMatch = True
        Exit For
      End If
    Next intCnt
    If blnMatch Then
      blnMatch = False
    Else
      ReDim Preserve objArray(intRemCnt)
      Set objArray(intRemCnt) = objEnt
      intRemCnt = intRemCnt + 1
    End If
  Next objEnt
  If Not IsEmpty(objArray) Then
    objSelSet.RemoveItems objArray
  End If
  Set SelectByXdata = objSelSet
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function

Public Sub ExampleUse()
  Dim objSelSet As AcadSelectionSet
  Dim objAllSets As AcadSelectionSets
  Dim objEnt As AcadEntity
  Dim strString As String
  
  Do While strString = ""
    strString = InputBox("Введите строку для поиска " & _
    "в области расширенных данных", "BindXData", "String 1")
  Loop
  Set objAllSets = ThisDrawing.SelectionSets
  'Here we clear the selection set name for use
  'AutoCAD R14 users don't have to worry about this
  For Each objSelSet In objAllSets
    If objSelSet.Name = "xdataselection" Then
      ThisDrawing.SelectionSets.Item("xdataselection").Delete
      Exit For
    End If
  Next objSelSet
  'Now we use the new function to return an XData
  'Filtered Selection set
  Set objSelSet = SelectByXdata("TESTAPP", strString, "xdataselection")
  'Now we can do something with it
  For Each objEnt In objSelSet
    objEnt.Highlight True
  Next
  MsgBox "Selection Set Count = " & objSelSet.Count
End Sub
 

Запустите процедуру SelectByXData, введите строку, которую Вы сохранили в области расширенных данных для первой группы выбранных примитивов. В результате все примитивы этой группы будут подсвечены. Выберите команду Вид а Регенерировать Все, чтобы снять подсветку с найденных примитивов. Опять запустите SelectByXData и введите строку, сохраненную в области расширенных данных второй группы примитивов. Теперь, в результате работы функции, будут подсвечены только те объекты, которые Вы выбрали во второй раз.



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