| Предыдущая тема :: Следующая тема |
| Автор |
Сообщение |
ivsem
Зарегистрирован: 01.02.2006
Сообщения: 63
Откуда: Киев
|
 Добавлено: Сб Сен 12, 2009 4:25 pm Заголовок сообщения: Удаление неиспользуемых в чертеже наборов TagSets |
 |
|
Получили от смежников десятки чертежей с огромным колличеством
не используемых в чертежех наборов TagSets.
Ручное удаление занимает очень много времени.
Нужно писать программку. Но я "программист-любитель", пишу небольшие программки на "процедурном" старом ALisp для Acad.
Сейчас сижу разбираюсь с "обьектно-ориентированным" VBA MicroStation. Но чувствую "песня долгая". Может, кто поможет?.
С уважением, дядя Ваня
Последний раз редактировалось: ivsem (Пн Сен 14, 2009 11:12 am), всего редактировалось 3 раз(а) |
|
| Вернуться к началу |
|
 |
ivsem
Зарегистрирован: 01.02.2006
Сообщения: 63
Откуда: Киев
|
| Добавлено: Вс Сен 13, 2009 1:09 pm Заголовок сообщения: |
|
|
И так есть первые подвижки.
Sub AAA ()
Application.ActiveDesignFile.TagSets.Remove ("NameTagSet")
End Sub
Программка удаляет из чертежа TagSet c названием - NameTagSet
Если тагого TagSet в чертеже нет, возвращается код ошибки.
Теперь надо добыть из чертежа имена наборов TagSets |
|
| Вернуться к началу |
|
|
ivsem
Зарегистрирован: 01.02.2006
Сообщения: 63
Откуда: Киев
|
| Добавлено: Вс Сен 13, 2009 7:27 pm Заголовок сообщения: |
|
|
Ковыряюсь дальше...
Удалось собрать в массив имена всех TagSet из чертежа
Sub BBB()
Dim I As Integer
Dim oCount As Integer
Dim MassivTagSet() As String
Dim oTagSet As TagSet
'Подсчитаем количество TagSet в чертеже
oCount = Application.ActiveDesignFile.TagSets.Count
'Переопределим Массив под количество TagSet
ReDim MassivTagSet(0 To oCount)
I = 0
'Использовано великое и могучее заклинание For Each !
For Each oTagSet In ActiveDesignFile.TagSets
MassivTagSet(I) = oTagSet.Name
'Посмотрим в окне "Immediate", что в массиве
Debug.Print MassivTagSet(I) ' В нем все имена TagSet
I = I + 1
Next
End Sub
Последний раз редактировалось: ivsem (Пн Сен 14, 2009 11:44 am), всего редактировалось 1 раз |
|
| Вернуться к началу |
|
|
Leonid
давно здесь сидим
Зарегистрирован: 28.01.2006
Сообщения: 598
Откуда: С.-Петербург
|
| Добавлено: Пн Сен 14, 2009 9:19 am Заголовок сообщения: |
|
|
Судя по всему, все-таки решили использовать восьмерку?
"Пгавильным путем идете, товагищи!" |
|
| Вернуться к началу |
|
|
ivsem
Зарегистрирован: 01.02.2006
Сообщения: 63
Откуда: Киев
|
| Добавлено: Пн Сен 14, 2009 11:35 am Заголовок сообщения: |
|
|
Да будем использовать MS8. Тем более. что есть лицензионные
программы MS8 валяющиеся без дела.
Я немного поковырял встроенный в MS7 BASIC.
Редактор очень примитивный. Сам язык практически не имеет
средств для работы с офисом. Почему в MS под виндовс сразу не был
встроем VBA загадка не для средних умов.
Так что продолжаю ковырять VBA, жаль времени маловато, текучка заедает. |
|
| Вернуться к началу |
|
|
ivsem
Зарегистрирован: 01.02.2006
Сообщения: 63
Откуда: Киев
|
| Добавлено: Вт Сен 15, 2009 10:19 am Заголовок сообщения: |
|
|
Теперь попробуем получить имена только присоединенных TagSet
| Код: |
Sub CCC()
Dim I As Integer
Dim MassivTagSetAttaching(0 To 1000) As String
Dim oTag As TagElement
Dim oElemEnum As ElementEnumerator
CadInputQueue.SendCommand "CHOOSE ALL "
Set oElemEnum = Application.ActiveModelReference.GetSelectedElements
I = 0
While oElemEnum.MoveNext
Select Case oElemEnum.Current.Type
Case MsdElementType.msdElementTypeTag
Set oTag = oElemEnum.Current
If oTag Is Nothing = False Then
MassivTagSetAttaching(I) = oTag.TagSetName
Debug.Print MassivTagSetAttaching(I)
I = I + 1
End If
End Select
Wend
CadInputQueue.SendCommand "CHOOSE NONE "
End Sub
|
В MassivTagSetAttaching сбрасывается большое количество повтояющихся имен TagSet. Надо будет как-то побороть это.
Последний раз редактировалось: ivsem (Ср Сен 16, 2009 8:30 pm), всего редактировалось 1 раз |
|
| Вернуться к началу |
|
|
beer
Зарегистрирован: 01.02.2006
Сообщения: 215
Откуда: Москва
|
| Добавлено: Ср Сен 16, 2009 8:52 am Заголовок сообщения: |
|
|
Все гораздо проще
| Код: |
Sub beer()
Dim i As Integer
i = 0
Do While i < ActiveDesignFile.TagSets.Count
If ActiveDesignFile.TagSets(i + 1).Name <> "Набор который надо оставить" Then
ActiveDesignFile.TagSets.Remove (i + 1)
else
i = i + 1
end if
Loop
End Sub
|
|
|
| Вернуться к началу |
|
|
ivsem
Зарегистрирован: 01.02.2006
Сообщения: 63
Откуда: Киев
|
| Добавлено: Ср Сен 16, 2009 4:47 pm Заголовок сообщения: |
|
|
Прекраcно работающая ВТОРАЯ часть программы от beer
| Код: | Sub beer()
Dim i As Integer
Dim MassivTagSet() As String
oCount = Application.ActiveDesignFile.TagSets.Count
ReDim MassivTagSet(0 To oCount)
'To, что должно остаться в чертеже (первая часть программы)
MassivTagSet(0) = "piket_s"
MassivTagSet(1) = "point_s"
MassivTagSet(2) = "XXX"
MassivTagSet(3) = "УУУ"
'...... и т. п. прикрепленные TagSet ...................
' вторая часть программы
i = 0
Do While i < ActiveDesignFile.TagSets.Count
If ActiveDesignFile.TagSets(i + 1).Name <> MassivTagSet(i) Then
ActiveDesignFile.TagSets.Remove (i + 1)
Else
i = i + 1
End If
Loop
End Sub |
Большое спасибо!!!
Но остается пока нерешенной ПЕРВАЯ часть программы в которой
надо собрать программно из ИСПОЛЬЗУЕМЫХ в чертеже TagSet
массив MassivTagSet.
Конечная цель сией "разработки":
Удалить НЕИСПОЛЬЗУЕМЫЕ в чертеже TagSet
Жаль, что нет свойства TagSet "прикреплен-неприкреплен" |
|
| Вернуться к началу |
|
|
beer
Зарегистрирован: 01.02.2006
Сообщения: 215
Откуда: Москва
|
| Добавлено: Чт Сен 17, 2009 7:23 am Заголовок сообщения: |
|
|
Стоп! Вы немножко переделали, что я написал а именно строку
| Код: | | If ActiveDesignFile.TagSets(i + 1).Name <> MassivTagSet(i) Then |
Поверьте в таком варианте это будет работать не правильно!!!! |
|
| Вернуться к началу |
|
|
beer
Зарегистрирован: 01.02.2006
Сообщения: 215
Откуда: Москва
|
| Добавлено: Чт Сен 17, 2009 7:56 am Заголовок сообщения: |
|
|
Так будет правильнее
| Код: |
options base 0
Function TagSetUsed(TSets() As String, TSetName As String) As Boolean
Dim i As Integer
For i = 1 To UBound(TSets)
If TSets(i) = TSetName Then
TagSetUsed = True
Exit Function
End If
TagSetUsed = False
Next i
End Function
Sub beer()
Dim sc As New ElementScanCriteria
sc.ExcludeAllTypes
sc.IncludeType (msdElementTypeTag)
Dim ee As ElementEnumerator
Set ee = ActiveModelReference.Scan(sc)
Dim UsedTSets() As String
ReDim UsedTSets(0)
Do While ee.MoveNext
If Not TagSetUsed(UsedTSets(), ee.Current.AsTagElement.TagSetName) Then
ReDim Preserve UsedTSets(UBound(UsedTSets) + 1)
UsedTSets(UBound(UsedTSets) ) = ee.Current.AsTagElement.TagSetName
End If
Loop
Dim i As Integer
i = 0
Do While i < ActiveDesignFile.TagSets.Count
If Not TagSetUsed(UsedTSets(), ActiveDesignFile.TagSets(i + 1).Name) Then
ActiveDesignFile.TagSets.Remove (i + 1)
Else
i = i + 1
End If
Loop
End Sub |
Но учтите, это будет правильно работать, только если в dgn файле только одна модель (что подходит для вашего случая, поскольку файлы в формате семерки). Для файлов с несколькими моделями надо будет еще сделать проход по всем моделям |
|
| Вернуться к началу |
|
|
ivsem
Зарегистрирован: 01.02.2006
Сообщения: 63
Откуда: Киев
|
| Добавлено: Чт Сен 17, 2009 9:38 am Заголовок сообщения: |
|
|
Уважаемый beer, написанная вами программа на тестовых примерах сработала правильно. Оставила в чертежах прикрепленные TagSet
и удалила неприкрепленные TagSet.
Ваша программа очень облегчит работу нашим дамам-камеральщицам.
Большое вам спасибо!!!
С уважением и восхищением, начинающий VBA "программист" дядя Ваня
Последний раз редактировалось: ivsem (Вс Сен 20, 2009 8:26 pm), всего редактировалось 2 раз(а) |
|
| Вернуться к началу |
|
|
beer
Зарегистрирован: 01.02.2006
Сообщения: 215
Откуда: Москва
|
| Добавлено: Чт Сен 17, 2009 10:47 am Заголовок сообщения: |
|
|
я еще и вышивать умею... и на машинке тоже... (с) Кот Матроскин  |
|
| Вернуться к началу |
|
|
ivsem
Зарегистрирован: 01.02.2006
Сообщения: 63
Откуда: Киев
|
| Добавлено: Вс Сен 20, 2009 7:34 pm Заголовок сообщения: |
|
|
Уважаемый beer, при запуске вашей программы компилятор останавливается на строке
options base 0 с сообщением Compile error: Expected: end of statement
Если эту сроку "заремить", то программа срабатывает нормально.
В чем может быть дело? |
|
| Вернуться к началу |
|
|
beer
Зарегистрирован: 01.02.2006
Сообщения: 215
Откуда: Москва
|
| Добавлено: Вт Сен 22, 2009 2:04 pm Заголовок сообщения: |
|
|
| Эта строка указывает, что нумерация массивов начинается с нуля. Она ВСЕГДА должна быть в начале модуля |
|
| Вернуться к началу |
|
|
ivsem
Зарегистрирован: 01.02.2006
Сообщения: 63
Откуда: Киев
|
| Добавлено: Пн Окт 05, 2009 8:47 am Заголовок сообщения: |
|
|
Слегка доработанная программа Beer
Добавлен вывод в статусную строку (что бы пользователь видел что программа работает) и в конце вывод результатов работы в MsgBox
| Код: | Option Explicit
'options base 0
Function TagSetUsed(TSets() As String, TSetName As String) As Boolean
Dim i As Double
For i = 1 To UBound(TSets)
If TSets(i) = TSetName Then
TagSetUsed = True
Exit Function
End If
TagSetUsed = False
Next i
End Function
Sub Beer()
Dim j As Double
Dim oTagSetAll As Double
Dim oTagSetPrisoed As Double
Dim oStroka As String
Dim i As Double
Dim k As Double
Dim sc As New ElementScanCriteria
sc.ExcludeAllTypes
sc.IncludeType (msdElementTypeTag)
Dim ee As ElementEnumerator
Set ee = ActiveModelReference.Scan(sc)
Dim UsedTSets() As String
ReDim UsedTSets(0)
k = 0
Do While ee.MoveNext
If Not TagSetUsed(UsedTSets(), ee.Current.AsTagElement.TagSetName) Then
ReDim Preserve UsedTSets(UBound(UsedTSets) + 1)
UsedTSets(UBound(UsedTSets)) = ee.Current.AsTagElement.TagSetName
End If
k = k + 1
ShowStatus "Выполнено: " & CStr(k)
Loop
i = 0
j = 0
k = 0
oTagSetAll = ActiveDesignFile.TagSets.Count
Do While i < ActiveDesignFile.TagSets.Count
If Not TagSetUsed(UsedTSets(), ActiveDesignFile.TagSets(i + 1).Name) Then
ActiveDesignFile.TagSets.Remove (i + 1)
j = j + 1
Else
i = i + 1
End If
k = k + 1
ShowStatus "Удаляю неиспользуемые TagSet: " & CStr(j)
Loop
oTagSetPrisoed = oTagSetAll - j
oStroka = "Используемых_в_чертеже_TagSet=" & CStr(oTagSetPrisoed) _
& " Удалено_неиспользуемых_TagSet=" & CStr(j)
MsgBox (oStroka)
ShowStatus ""
End Sub
|
|
|
| Вернуться к началу |
|
|
|
FAQ
Поиск
Пользователи
Группы
Регистрация
Профиль
Войти и проверить личные сообщения
Вход
