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
 

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
 

Option Explicit

Public Sub DwgNotes()
    frmDwgNotes.Show
End Sub
 

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
 

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