с IAcSmCustomPropertyValue немного разобрался. Метод GetValue рулит:-)
Дальше стоит задача передать массивы Prop_name_list и Prop_val_list в LISP-прогу. Не спрашивайте, почему нельзя все до конца сделать на VBA, он мне и так надоел:-).
Нашел в закромах этой ветки примеры работы со словарями, но что-то не получается. Записи в словаре создаются, но остаются пустыми:-(
Работающий пример из хелпа видел, но как его применить - не знаю:-(.
Код, работающий со словарем, выделен жирным. Помогите, PLS
Public Sub gss()
Dim oEnumDb As IAcSmEnumDatabase
Dim oItem As IAcSmPersist
Dim oacSht As IAcSmSheet
Dim sheet_num As String
'' Create a Reference to the Sheet Set Manager Object
Dim oSheetSetMgr As AcSmSheetSetMgr
Set oSheetSetMgr = New AcSmSheetSetMgr
Set oEnumDb = oSheetSetMgr.GetDatabaseEnumerator
Set oItem = oEnumDb.Next
Dim oSheetDb As AcSmDatabase
Do While Not oItem Is Nothing
Set oSheetDb = oItem
'' Lock the Database
If LockDatabase(oSheetDb) Then
On Error Resume Next
Dim oEnum As IAcSmEnumPersist
Dim oItemSh As IAcSmPersist
Dim cBag As AcSmCustomPropertyBag
Set cBag = oSheetDb.GetSheetSet().GetCustomPropertyBag
Dim cBagEnum As IAcSmEnumProperty
Set cBagEnum = cBag.GetPropertyEnumerator
Dim propname As String
Dim ppValue As IAcSmCustomPropertyValue
cBagEnum.Next propname, ppValue
Dim nPropCount As Integer
nPropCount = 0
Do While Not ppValue Is Nothing
cBagEnum.Next propname, ppValue
If propname Like "СМ#" Then nPropCount = nPropCount + 1
Loop
Dim Prop_name_list() As String
Dim Prop_val_list() As String
ReDim Prop_name_list(nPropCount)
ReDim Prop_val_list(nPropCount)
Dim i As Integer
i = 0
cBagEnum.Reset
cBagEnum.Next propname, ppValue
Do While Not ppValue Is Nothing
cBagEnum.Next propname, ppValue
If propname Like "СМ#" Then
nPropCount = nPropCount + 1
Prop_name_list(i) = propname
Prop_val_list(i) = CStr(ppValue.GetValue)
i = i + 1
End If
Loop
[b]Dim kp_sm_Dict As AcadDictionary
Set kp_sm_Dict = ActiveDocument.Dictionaries.Add("kp_sm_Dict")
Dim kp_sm_xrec_propname As AcadXRecord, kp_sm_xrec_propval As AcadXRecord
Dim XRecordDataType As Variant
XRecordDataType = vbArray
ReDim Preserve XRecordDataType(0 To nPropCount + 1)
Set kp_sm_xrec_propname = kp_sm_Dict.AddXRecord("kp_sm_xrec_propname")
Set kp_sm_xrec_propval = kp_sm_Dict.AddXRecord("kp_sm_xrec_propval")
kp_sm_xrec_propname.SetXRecordData vbArray, Prop_name_list
kp_sm_xrec_propval.SetXRecordData vbArray, Prop_val_list
'пробуем прочитать, а там пусто:-(
Dim XRecordDataType1 As Variant, XRecordData As Variant
kp_sm_xrec_propname.GetXRecordData XRecordDataType1, XRecordData[/b]
Set cBagVal = Nothing
'' Unlock the database
UnlockDatabase oSheetDb
'' Clear and check for next SheetSet that is open
'nSheetCount = 0
Else
MsgBox "Unable to access """ & sheetdb.GetSheetSet().GetName & """ Sheet Set."
End If
Set oItem = oEnumDb.Next
Loop
End Sub