Option Explicit
Call TestTableAttribute(ThisObject.Attributes("ATTR_TABLE"))
'==============================================================================
' Выполнить выбранные пользователем действия c табличным атрибутом.
'==============================================================================
Sub TestTableAttribute(TAttr)
Dim SelDlg, RetVal, strAction, ArActions, TAttrRows
'На всякий случай проверить тип атрибута
If TAttr.Type <> tdmTable Then Exit Sub
'ПОлучить ссылку на коллекцию строк табличного атрибута
Set TAttrRows = TAttr.Rows
'Если таблица пустая, выйти из процедуры
If TAttrRows.Count=0 Then Exit Sub
'Заполнить массив предлагаемых действий
ArActions = Array("Добавить строку", "Очистить строку", "Дублировать строку", _
"Удалить строку", "Поменять строки местами", _
"Перечислить заголовки столбцов", "Вывести информацию о таблице")
'Предоставить пользователю выбрать действие
Set SelDlg = ThisApplication.Dialogs.SelectDlg
SelDlg.SelectFrom = ArActions
SelDlg.Prompt = "Выберите действие над строками таблицы:"
RetVal = SelDlg.Show
'Если пользователь отменил диалог или ничего не выбрал, закончить работу.
'Диалог вернул массив, поскольку был инициализирован строковым массивом
If (RetVal <> TRUE) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
'Выполнить все заданные действия
For Each strAction In SelDlg.Objects
If StrComp(strAction, ArActions(0))=0 Then
Call AddRow(TAttrRows)
ElseIf StrComp(strAction, ArActions(1))=0 Then
Call ClearRow(TAttrRows)
ElseIf StrComp(strAction, ArActions(2))=0 Then
Call DuplicateRow(TAttrRows)
ElseIf StrComp(strAction, ArActions(3))=0 Then
Call RemoveRow(TAttrRows)
ElseIf StrComp(strAction, ArActions(4))=0 Then
Call SwapRows(TAttrRows)
ElseIf StrComp(strAction, ArActions(5))=0 Then
Call ShowColNames(TAttrRows)
ElseIf StrComp(strAction, ArActions(6))=0 Then
Call ShowInfo(TAttrRows)
msgbox 1
End If
Next
End Sub
'==============================================================================
'==============================================================================
'Добавить новую строку на заданную позицию в таблицу
'==============================================================================
Sub AddRow(TAttrRows)
Dim index, strPrompt, NewRow
'Запросить позицию вставки новой строки
strPrompt = "Введите позицию, на которую будет помещена новая строка:"
Call GetIndex(index, TAttrRows, strPrompt)
'Если вернулось отрицательное число, ввод был неправильным
If index<0 Then Exit Sub
On Error Resume Next
'Добавить новую строку в таблицу (она будет вставлена последней)
Set NewRow = TAttrRows.Create
'Теперь переместим строку на заданную позицию
TAttrRows.Move NewRow, index
'Чтобы изменения вступили в силу, коллекцию надо обновить
TAttrRows.Update
'Если была ошибка...
If Err<>0 Then MsgBox "Ошибка добавления строки в таблицу." &_
Chr(13) & "Код ошибки: " & Err, vbExclamation
End Sub
'==============================================================================
'==============================================================================
'Очистить строку с заданным номером
'==============================================================================
Sub ClearRow(TAttrRows)
Dim index, strPrompt, Row
'Запросить позицию строки
strPrompt = "Введите позицию строки, которая должна быть очищена:"
Call GetIndex(index, TAttrRows, strPrompt)
'Если вернулось отрицательное число, ввод был неправильным
If index<0 Then Exit Sub
On Error Resume Next
'Получить нужную строку
Set Row = TAttrRows.Item(Index)
'Теперь очистить строку
Row.Clear
'Если была ошибка...
If Err<>0 Then MsgBox "Ошибка обнуления данных в строке." &_
Chr(13) & "Код ошибки: " & Err, vbExclamation
End Sub
'==============================================================================
'==============================================================================
'Дублировать заданную строку
'==============================================================================
Sub DuplicateRow(TAttrRows)
Dim index, strPrompt, NewRow
'Запросить позицию строки
strPrompt = "Введите позицию строки, которая должна быть дублирована:"
Call GetIndex(index, TAttrRows, strPrompt)
'Если вернулось отрицательное число, ввод был неправильным
If index<0 Then Exit Sub
On Error Resume Next
'Дублировать нужную строку
Set NewRow = TAttrRows.Item(Index).Duplicate
'Здесь можно что-нибудь проделать с объектом NewRow...
'Если была ошибка...
If Err<>0 Then MsgBox "Ошибка дублирования строки." &_
Chr(13) & "Код ошибки: " & Err, vbExclamation
End Sub
'==============================================================================
'==============================================================================
'Удалить заданную строку из таблицы
'==============================================================================
Sub RemoveRow(TAttrRows)
Dim index, strPrompt
'Запросить позицию строки
strPrompt = "Введите позицию строки, которая должна быть удалена:"
Call GetIndex(index, TAttrRows, strPrompt)
'Если вернулось отрицательное число, ввод был неправильным
If index<0 Then Exit Sub
On Error Resume Next
'Удалить указанную строку
TAttrRows.Item(Index).Erase
'Можно удалить другим способом: TAttrRows.Remove Index
'Если была ошибка...
If Err<>0 Then MsgBox "Ошибка удаления строки." &_
Chr(13) & "Код ошибки: " & Err, vbExclamation
End Sub
'==============================================================================
'==============================================================================
'Переставить местами две строки в таблице
'==============================================================================
Sub SwapRows(TAttrRows)
Dim index1, index2, Row1, Row2, strPrompt
'Запросить позицию 1й строки
strPrompt = "Введите позицию первой строки:"
Call GetIndex(index1, TAttrRows, strPrompt)
'Запросить позицию 2й строки
strPrompt = "Введите позицию второй строки:"
Call GetIndex(index2, TAttrRows, strPrompt)
'Если один из индексов отрицательный, ввод был неправильным. Если
'индексы совпали, тоже ничего делать не будем
If (index1<0) Or (index2<0) Or (index1=index2) Then Exit Sub
On Error Resume Next
'Переставляем строки местами
TAttrRows.Swap Index1, Index2
'Чтобы изменения вступили в силу, коллекцию надо обновить
TAttrRows.Update
'Если была ошибка...
If Err<>0 Then MsgBox "Ошибка удаления строки." &_
Chr(13) & "Код ошибки: " & Err, vbExclamation
End Sub
'==============================================================================
'==============================================================================
'Сообщить названия столбцов таблицы
'==============================================================================
Sub ShowColNames(TAttrRows)
Dim Column
'Столбцам в таблице соответствуют объекты TDMSAttributeDefs
For Each Column In TAttrRows.AttributeDefs
'Сообщить заголовок столбца
ThisApplication.AddNotify Column.Description
Next
End Sub
'==============================================================================
'==============================================================================
' Вывести информацию о содержании таблицы
'==============================================================================
Sub ShowInfo(TAttrRows)
Dim StrInfo, row, i, j, RCount, CCount, Columns
RCount = TAttrRows.Count-1 'количество строк в таблице
'ссылка на коллекцию типов атрибутов, соотв. столбцам таблицы
Set Columns = TAttrRows.AttributeDefs
CCount = Columns.Count-1 'количество столбцов в таблице
'Перечислить по строкам содержимое таблицы
For i=0 To RCount
Set row = TAttrRows(i) 'получить ссылку на текущую строку
StrInfo = "Данные в строке " & i+1 & ":" & Chr(13)
'перебрать значения ячеек в текущей строке
For j=0 To CCount
StrInfo = StrInfo & Columns(j).Description & ": " & row.Attributes(j).Value & Chr(13)
Next
'Вывести информацию по строке в окно сообщений
ThisApplication.AddNotify(StrInfo)
Next
End Sub
'==============================================================================
'==============================================================================
' Запросить у пользователя индекс элемента в коллекции
'==============================================================================
Sub GetIndex(index, Col, Prompt)
Dim StrRet
index = -1
'Запросить позицию для вставки новой строки
StrRet = InputBox(Prompt & Chr(13) & "(от 0 до " & Col.Count-1 & "):")
'Если введено не-число или диалог отменен, выйти из процедуры
If (StrRet="") Or (Not IsNumeric(StrRet)) Then Exit Sub
'Получить введенный индекс
index = CLng(StrRet)
'Возможно, введенное число выходит за границы допустимого диапазона
If Not Col.Has(index) Then
MsgBox "Задан недопустимый индекс.", vbExclamation
index = -1
Exit Sub
End If
End Sub
'==============================================================================
Исходный код