> 1 <

Автор Сообщение

piter81

Members


Статус

1 сообщений

Где: Russia
Род занятий:
Возраст:

#7690   2016-01-15 14:46 GMT+3 часа(ов)      
Добрый вечер. Нужен алгоритм проверки dwg файла. Имеется стандарт, те определенные стили, слои, шрифты. Те должно все соответствовать кодификатору.
Имеется код, вроде все библиотеки прописал. Но никак не хочет работать. При запуске функции контрол, выскакивает ошибка cant find project or library , в самом коде подсвечена строка Sub CodificatorCheck(). Подскажите где ошибка.

Option Explicit
Public strCon As String
Public strMsg As String
Public strError As String
Public strTemp As String
Public strTempNew As String
Public strStyle As String
Public strHeight As String
Public strAngle As String
Public strPrintLine As String
Public blnCancel As Boolean
Public blnWrite As Boolean
Public blnNext As Boolean
Public blnChange As Boolean
Public blnBadLayer As Boolean
Public blnBadType As Boolean
Public blnBadTxtSt As Boolean
Public blnBadLineType As Boolean
Public blnBadBlocks As Boolean
Public blnStop As Boolean
Public blnClose As Boolean
Public blnExistMenu As Boolean
Public blnLayer As Boolean
Public blnClear As Boolean
Public blnType As Boolean
Public blnTxtSt As Boolean
Public blnLineSt As Boolean
Public blnBlocks As Boolean
Public blnOpen As Boolean
Public blnCodif As Boolean
Type ControlEntity
AcLayer As String
AcType As String
AcName As String
AcColor As Integer
AcWeight As Double
AcTextHeight As Double
End Type
Type ElementEntity
objEl As AcadEntity
blnL As Boolean
blnT As Boolean
blnC As Boolean
blnN As Boolean
blnW As Boolean
blnH As Boolean
blnSum As Integer
objRule As ControlEntity
End Type
Public arrControlCodif() As ElementEntity
Public arrControlEntity() As ControlEntity
Type ControlLayer
Layer As String
arrControlProperty() As ControlEntity
End Type
 
Public arrControlLayer(1 To 49) As ControlLayer
 
Public ColLayers As Collection
Public ColTextStyles As Collection
Public ColBlocks As Collection
Public ColTypes As Collection
Public ColLineStyles As Collection
Public ColBadLayers As New Collection
Public ColBadBlocks As New Collection
Public ColBadLineTypes As New Collection
Public ColBadTextStyles As New Collection
Public ColBadTypes As New Collection
Public ColBadEntity As New Collection
Const PI = 3.14159265
 
Sub ContinueControl()
If blnCodif = True Then
CodificatorCheck
Else
ResourceCheck
End If
End Sub
 
Sub ResourceCheck()
 
Dim strName As String
Dim intCounter As Integer
Dim blnCodifElem As Boolean
Dim blnFind As Integer
'On Error GoTo ErrHandler
 
 
strPrintLine = ""
Set ColBlocks = New Collection
Set ColLayers = New Collection
Set ColTextStyles = New Collection
Set ColTypes = New Collection
Set ColLineStyles = New Collection
Set ColBadLayers = New Collection
Set ColBadTypes = New Collection
Set ColBadEntity = New Collection
Set ColBadLineTypes = New Collection
ThisDrawing.PurgeAll
ZoomExtents
'frmControl.flxList.CollapseAll
 
'удаление всех наборов
If ThisDrawing.SelectionSets.Count <> 0 Then
For intCounter = ThisDrawing.SelectionSets.Count - 1 To 0 Step -1
ThisDrawing.SelectionSets(intCounter).Delete
Next
End If
If blnExistMenu = False Then Continue
 
For intCounter = 1 To ThisDrawing.Linetypes.Count - 1
If ThisDrawing.Linetypes(intCounter).Name = "CONTINUOUS" Then
blnFind = 1
strCon = "CONTINUOUS"
Exit For
End If
Next
If blnFind = 0 Then strCon = "Continuous"
 
SuiteCollection
'проверка на незарезервированные уровни
blnBadLayer = True
blnLayer = True
' Do While blnBadLayer = True
frmErrList.Show
' If blnStop = True Then Exit Do
If blnStop = True Then
Continue
Exit Sub
End If
' Loop
blnLayer = False
 
'Дальше
If blnBadLayer = False Then blnClear = True
'проверка на незарезервированные типы элементов
If blnClear = True Then
blnType = True
frmErrList.Show
If blnStop = True Then
Continue
Exit Sub
End If
 
blnType = False
End If
 
'Текстовые стили
If blnBadType = False And blnBadLayer = False Then blnClear = True
If blnClear = True Then
blnTxtSt = True
frmErrList.Show
If blnStop = True Then
Continue
Exit Sub
End If
 
blnTxtSt = False
End If
'Стили линий
If blnBadType = False And blnBadLayer = False And blnTxtSt = False Then blnClear = True
If blnClear = True Then
blnLineSt = True
frmErrList.Show
If blnStop = True Then
Continue
Exit Sub
End If
 
blnLineSt = False
End If
'Блоки
If blnBadType = False And blnBadLayer = False And blnTxtSt = False Then blnClear = True
If blnClear = True Then
blnBlocks = True
frmErrList.Show
If blnStop = True Then
Continue
Exit Sub
End If
 
blnBlocks = False
End If
 
If blnStop = False Then blnClose = True
Continue
'If blnClose = False Then
'UnloadDVB "c:\Common\AutoCAD 2006eng\MenuFile\Кодификатор_500_2005\Control.dvb"
'End If
 
End Sub
Sub CodificatorCheck()
Dim intCounter As Long
Dim intCounter1 As Integer
Dim intCount As Integer
Dim intC As Integer
Dim intCount1 As Long
Dim SSetObj As AcadSelectionSet
Dim mode As Integer
Dim acObj As AcadObject
Dim entObj As AcadEntity
Dim txtObj As AcadText
Dim blObj As AcadBlockReference
Dim mlnObj As AcadMLine
Dim blnFind As Integer
Dim blnLay As Boolean
Dim blnTyp As Boolean
Dim blnCol As Boolean
Dim blnName As Boolean
Dim blnTextHei As Boolean
Dim blnWei As Boolean
Dim blnTxt As Boolean
Dim blnMline As Boolean
Dim blnAdd As Integer
Dim blnJust As Boolean
blnCodif = False
strPrintLine = ""
Set ColBlocks = New Collection
Set ColLayers = New Collection
Set ColTextStyles = New Collection
Set ColTypes = New Collection
Set ColLineStyles = New Collection
Set ColBadLayers = New Collection
Set ColBadTypes = New Collection
Set ColBadEntity = New Collection
Set ColBadLineTypes = New Collection
ThisDrawing.PurgeAll
ZoomExtents
'frmControl.flxList.CollapseAll
 
'удаление всех наборов
If ThisDrawing.SelectionSets.Count <> 0 Then
For intCounter = ThisDrawing.SelectionSets.Count - 1 To 0 Step -1
ThisDrawing.SelectionSets(intCounter).Delete
Next
End If
If blnExistMenu = False Then Continue
 
For intCounter = 1 To ThisDrawing.Linetypes.Count - 1
If ThisDrawing.Linetypes(intCounter).Name = "CONTINUOUS" Then
blnFind = 1
strCon = "CONTINUOUS"
Exit For
End If
Next
If blnFind = 0 Then strCon = "Continuous"
 
'Формирование коллекций
SuiteCollection
If LoadData = True Then
 
Set SSetObj = ThisDrawing.SelectionSets.Add("SC")
 
mode = acSelectionSetAll
SSetObj.Select mode
 
For intCounter = 0 To SSetObj.Count - 1
Set acObj = SSetObj(intCounter)
If TypeOf acObj Is AcadEntity Then
Set entObj = acObj
blnLay = False
blnAdd = 0
blnFind = 0
intC = 0
For intCounter1 = 1 To UBound(arrControlLayer)
If entObj.Layer = arrControlLayer(intCounter1).Layer Then
blnLay = True
 
 
If intCount1 = 0 Then
ReDim arrControlCodif(1 To 1)
intCount1 = 1
arrControlCodif(intCount1).blnSum = 0
End If
 
For intCount = 1 To UBound(arrControlLayer(intCounter1).arrControlProperty)
blnTyp = False
blnCol = False
blnName = False
blnTextHei = False
blnWei = False
blnTxt = False
blnMline = False
blnJust = False
intC = 1
If Right(entObj.ObjectName, Len(entObj.ObjectName) - 4) = arrControlLayer(intCounter1).arrControlProperty(intCount).AcType Then
blnTyp = True
intC = intC + 1
If entObj.color = arrControlLayer(intCounter1).arrControlProperty(intCount).AcColor Then
blnCol = True
intC = intC + 1
End If
If Right(entObj.ObjectName, Len(entObj.ObjectName) - 4) = "Text" Then
blnTxt = True
Set txtObj = entObj
If txtObj.StyleName = arrControlLayer(intCounter1).arrControlProperty(intCount).AcName Then
txtObj.Linetype = strCon
blnName = True
intC = intC + 1
End If
If txtObj.Height = arrControlLayer(intCounter1).arrControlProperty(intCount).AcTextHeight Then
blnTextHei = True
End If
ElseIf Right(entObj.ObjectName, Len(entObj.ObjectName) - 4) = "BlockReference" Then
Set blObj = entObj
If blObj.Name = arrControlLayer(intCounter1).arrControlProperty(intCount).AcName Then
blnName = True
intC = intC + 1
blObj.Linetype = strCon
End If
ElseIf Right(entObj.ObjectName, Len(entObj.ObjectName) - 4) = "Mline" Then
blnMline = True
Set mlnObj = entObj
If mlnObj.StyleName = arrControlLayer(intCounter1).arrControlProperty(intCount).AcName Then
blnName = True
intC = intC + 1
mlnObj.Linetype = strCon
End If
If mlnObj.StyleName = "M5_138" And mlnObj.Justification = acBottom Then
blnJust = True
intC = intC + 1
End If
If mlnObj.StyleName <> "M5_138" And mlnObj.Justification = acZero Then
blnJust = True
intC = intC + 1
End If
Else
strTemp = entObj.Linetype
If entObj.Linetype = strCon Then strTemp = UCase(entObj.Linetype)
If strTemp = arrControlLayer(intCounter1).arrControlProperty(intCount).AcName Then
blnName = True
intC = intC + 1
End If
End If
If entObj.Lineweight = arrControlLayer(intCounter1).arrControlProperty(intCount).AcWeight Then
blnWei = True
intC = intC + 1
End If
 
If blnTyp = True And blnCol = True And blnName = True And blnWei = True Then
 
If (blnTxt = False And blnMline = False) Or (blnTxt = True And blnTextHei = True) Or (blnMline = True And blnJust = True) Then
blnFind = 1
Exit For
End If
End If
End If
'Ввод элемента в массив
If intC > 0 And blnFind = 0 Then
If blnAdd = 0 Then
intCount1 = intCount1 + 1
ReDim Preserve arrControlCodif(1 To intCount1)
End If
 
If arrControlCodif(intCount1).blnSum < intC Then 'добавить
Set arrControlCodif(intCount1).objEl = entObj
arrControlCodif(intCount1).objRule = arrControlLayer(intCounter1).arrControlProperty(intCount)
arrControlCodif(intCount1).blnL = blnLay
arrControlCodif(intCount1).blnT = blnTyp
arrControlCodif(intCount1).blnC = blnCol
arrControlCodif(intCount1).blnN = blnName
arrControlCodif(intCount1).blnW = blnWei
If blnTxt = True Then arrControlCodif(intCount1).blnH = blnTextHei
If blnMline = True Then arrControlCodif(intCount1).blnH = blnJust
arrControlCodif(intCount1).blnSum = intC
blnAdd = 1
End If
End If
Next 'Property
End If 'уровень
 
If blnFind = 1 Then
If blnAdd = 1 Then
intCount1 = intCount1 - 1
ReDim Preserve arrControlCodif(1 To intCount1)
End If
Exit For
End If
Next 'уровень
If blnLay = False Then
MsgBox "В файле имеются объекты на незаявленных уровнях!" & vbNewLine & "Запустите программу проверки ресурсов.", vbCritical + vbOKOnly, "ВНИМАНИЕ!"
SSetObj.Delete
Exit Sub
End If
 
End If
 
Next
SSetObj.Delete
End If
 
'GroupString strMsg
'If strMsg <> "" Then
blnCodif = True
frmErrList.Show
End Sub
Function SuiteCollection()
'формирование коллекции типов
GRII_Types ColTypes
 
'формирование коллекции слоев
GRII_Layers ColLayers
 
'формирование коллекции текстовых стилей
GRII_TextStyles ColTextStyles
 
'формирование коллекции блоков
GRII_Blocks ColBlocks
 
'формирование коллекции блоков
GRII_LineType ColLineStyles
 
End Function
Sub GRII_Types(ColTypes As Collection)
 
ColTypes.Add "AcDbBlockReference"
ColTypes.Add "AcDbLWPolyline"
ColTypes.Add "AcDbPolyline"
'ColTypes.Add "AcDb2dPolyline"
ColTypes.Add "AcDbText"
ColTypes.Add "AcDbHatch"
ColTypes.Add "AcDbMline"
ColTypes.Add "AcDbCircle"
ColTypes.Add "AcDbArc"
ColTypes.Add "AcDbEllipse"
 
End Sub
 
Sub GRII_Layers(ColLayers As Collection)
 
ColLayers.Add "01_Геодезические пункты"
ColLayers.Add "02_Сетка"
ColLayers.Add "03_Здания и строения"
ColLayers.Add "04_Арки и галереи"
ColLayers.Add "05_Элементы зданий"
ColLayers.Add "06_Инженерно-технические сооружения"
ColLayers.Add "07_Объекты электропередачи"
ColLayers.Add "08_Поребрики"
ColLayers.Add "09_Путевое хозяйство"
ColLayers.Add "10_Границы покрытий и угодий"
ColLayers.Add "11_Гидрография"
ColLayers.Add "12_Рельеф"
ColLayers.Add "13_Растительность"
ColLayers.Add "14_Ограждения"
ColLayers.Add "15_Натурные промеры"
ColLayers.Add "16_Проектные линии"
ColLayers.Add "17_Топонимика"
ColLayers.Add "18_Зарамочное оформление"
ColLayers.Add "19_Кварталы"
ColLayers.Add "20_Дворы-колодцы"
ColLayers.Add "21_Зеленые массивы"
ColLayers.Add "22_Съемочные точки"
'Подземка
 
ColLayers.Add "30_Канализация"
ColLayers.Add "31_Водопровод"
ColLayers.Add "32_Теплосеть"
ColLayers.Add "33_Газопровод"
ColLayers.Add "34_Трубопроводы спецназначения"
ColLayers.Add "35_Телефон"
ColLayers.Add "36_Слаботочные кабели"
ColLayers.Add "37_Кабель низкого напряжения"
ColLayers.Add "38_Кабели высокого напряжения"
ColLayers.Add "39_Кабель постоянного тока"
ColLayers.Add "40_Защита от электрокоррозии"
ColLayers.Add "41_Зоны кабелей"
ColLayers.Add "42_Кабельные колодцы"
ColLayers.Add "43_Футляры и каналы"
ColLayers.Add "44_Крышки колодцев"
ColLayers.Add "45_Номера колодцев"
ColLayers.Add "46_Выноски"
'Отметки
 
ColLayers.Add "60_Отметки высот на зданиях и сооружениях"
ColLayers.Add "61_Отметки высоты поверхности"
ColLayers.Add "62_Отметки высоты уреза воды и дна водоемов"
 
'слои с заливками
'обязательные
 
ColLayers.Add "28_Заливка подвальных окон"
ColLayers.Add "29_Заливка бетонных и металлических опор"
ColLayers.Add "50_Заливка камер и шахт на канализации"
ColLayers.Add "51_Заливка камер на водопроводе"
ColLayers.Add "52_Заливка камер на теплосети"
ColLayers.Add "53_Заливка камер на газопроводе"
ColLayers.Add "54_Заливка камер на трубопроводах спецназначения"
ColLayers.Add "55_Заливка камер на телефонной канализации"
ColLayers.Add "56_Заливка габаритов кабельных колодцев"
ColLayers.Add "57_Заливка туннельной канализации"
 
'необязательные
 
ColLayers.Add "Заливка гидрографии"
ColLayers.Add "Заливка островов"
ColLayers.Add "Заливка кварталов"
ColLayers.Add "Заливка зеленых массивов"
ColLayers.Add "Заливка зон теплосети надз."
ColLayers.Add "Заливка зон труб. спецназ. надз."
ColLayers.Add "Заливка зданий"
ColLayers.Add "Заливка арок и галерей"
ColLayers.Add "Заливка дворов-колодцев"
ColLayers.Add "Заливка элементов зданий"
ColLayers.Add "Заливка инженерно-технич. сооружений"
ColLayers.Add "Заливка зон водопроводов"
ColLayers.Add "Заливка зон теплосети подз."
ColLayers.Add "Заливка зон труб. спецназ. подз."
 
 
 
End Sub
 
'текстовые стили
 
Sub GRII_TextStyles(ColTextStyles As Collection)
ColTextStyles.Add "LIKE10"
ColTextStyles.Add "LIKE11"
ColTextStyles.Add "LIKE12"
ColTextStyles.Add "LIKE14"
ColTextStyles.Add "LIKE17"
ColTextStyles.Add "LIKE19"
ColTextStyles.Add "LIKE21"
ColTextStyles.Add "LIKE30"
ColTextStyles.Add "LIKE31"
ColTextStyles.Add "LIKE32"
ColTextStyles.Add "LIKE34"
ColTextStyles.Add "LIKE36"
 
ColTextStyles.Add "Standard"
ColTextStyles.Add "STANDARD"
ColTextStyles.Add ""
 
End Sub
'стили линий
Sub GRII_LineType(ColLineStyles As Collection)
ColLineStyles.Add strCon
'ColLineStyles.Add "Continuous"
ColLineStyles.Add "M5_001"
ColLineStyles.Add "M5_002"
ColLineStyles.Add "M5_003"
ColLineStyles.Add "M5_004"
ColLineStyles.Add "M5_004_A"
ColLineStyles.Add "M5_045"
ColLineStyles.Add "M5_046"
ColLineStyles.Add "M5_046_C"
ColLineStyles.Add "M5_047"
ColLineStyles.Add "M5_048"
ColLineStyles.Add "M5_070"
ColLineStyles.Add "M5_073"
ColLineStyles.Add "M5_073_A"
ColLineStyles.Add "M5_165"
ColLineStyles.Add "M5_165_A"
ColLineStyles.Add "M5_166"
ColLineStyles.Add "M5_166_A"
ColLineStyles.Add "M5_167"
ColLineStyles.Add "M5_167_A"
ColLineStyles.Add "M5_196_A"
ColLineStyles.Add "M5_196"
ColLineStyles.Add "M5_198"
ColLineStyles.Add "M5_199"
ColLineStyles.Add "M5_198_A"
ColLineStyles.Add "M5_198_B"
ColLineStyles.Add "M5_200"
ColLineStyles.Add "M5_201"
ColLineStyles.Add "M5_201_A"
ColLineStyles.Add "M5_203"
ColLineStyles.Add "M5_204"
ColLineStyles.Add "M5_205_1"
ColLineStyles.Add "M5_205_2"
ColLineStyles.Add "M5_206_1"
ColLineStyles.Add "M5_206_2"
ColLineStyles.Add "M5_207"
ColLineStyles.Add "M5_208"
ColLineStyles.Add "M5_209_A"
ColLineStyles.Add "M5_210"
ColLineStyles.Add "M5_211"
ColLineStyles.Add "M5_212"
ColLineStyles.Add "M5_213"
ColLineStyles.Add "M5_213_A"
ColLineStyles.Add "M5_215"
ColLineStyles.Add "M5_215_A"
ColLineStyles.Add "M5_216"
ColLineStyles.Add "M5_216_A"
ColLineStyles.Add "M5_218"
ColLineStyles.Add "M5_218_A"
ColLineStyles.Add "M5_219"
ColLineStyles.Add "M5_220"
ColLineStyles.Add "M5_221"
ColLineStyles.Add "M5_222"
ColLineStyles.Add "M5_222_A"
ColLineStyles.Add "M5_223"
ColLineStyles.Add "M5_224_1"
ColLineStyles.Add "M5_225"
ColLineStyles.Add "M5_226_1"
ColLineStyles.Add "M5_226_2"
ColLineStyles.Add "M5_226_A"
ColLineStyles.Add "M5_227_1"
ColLineStyles.Add "M5_227_2"
ColLineStyles.Add "M5_227_A"
ColLineStyles.Add "M5_230"
ColLineStyles.Add "M5_232"
ColLineStyles.Add "M5_232_A"
ColLineStyles.Add "M5_502"
ColLineStyles.Add "M5_040"
ColLineStyles.Add "M5_074"
ColLineStyles.Add "M5_138"
ColLineStyles.Add "M5_138_A"
ColLineStyles.Add "M5_133"
ColLineStyles.Add "M5_133_A"
ColLineStyles.Add "M5_134"
ColLineStyles.Add "M5_134_E"
ColLineStyles.Add "M5_135"
ColLineStyles.Add "M5_135_A"
ColLineStyles.Add "M5_138A"
ColLineStyles.Add "M5_224_2"
ColLineStyles.Add "M5_224_3"
ColLineStyles.Add "M5_502"
ColLineStyles.Add "M5_502_A"
 
End Sub
 
'значки
Sub GRII_Blocks(ColBlocks As Collection)
 
ColBlocks.Add "M5_0_500"
ColBlocks.Add "M5_0001"
ColBlocks.Add "M5_0002"
ColBlocks.Add "M5_001"
ColBlocks.Add "M5_003"
ColBlocks.Add "M5_006"
ColBlocks.Add "M5_009"
ColBlocks.Add "M5_010"
ColBlocks.Add "M5_019_A"
ColBlocks.Add "M5_019_B"
ColBlocks.Add "M5_029"
ColBlocks.Add "M5_037"
ColBlocks.Add "M5_039a"
ColBlocks.Add "M5_039b"
ColBlocks.Add "M5_052"
ColBlocks.Add "M5_054"
ColBlocks.Add "M5_054_1A"
ColBlocks.Add "M5_054_1B"
ColBlocks.Add "M5_054_2"
ColBlocks.Add "M5_055_1A"
ColBlocks.Add "M5_055_1B"
ColBlocks.Add "M5_055_2"
ColBlocks.Add "M5_056_1A"
ColBlocks.Add "M5_056_1B"
ColBlocks.Add "M5_056_3"
ColBlocks.Add "M5_057_A"
ColBlocks.Add "M5_057_B"
ColBlocks.Add "M5_058_1A"
ColBlocks.Add "M5_058_1B"
ColBlocks.Add "M5_058_1D"
ColBlocks.Add "M5_059_1C"
ColBlocks.Add "M5_060_1A"
ColBlocks.Add "M5_060_1B"
ColBlocks.Add "M5_061"
ColBlocks.Add "M5_061_1B"
ColBlocks.Add "M5_061_2"
ColBlocks.Add "M5_062"
ColBlocks.Add "M5_062_1B"
ColBlocks.Add "M5_062_2"
ColBlocks.Add "M5_063"
ColBlocks.Add "M5_063_A"
ColBlocks.Add "M5_063_A1"
ColBlocks.Add "M5_063_A2"
ColBlocks.Add "M5_063_B"
ColBlocks.Add "M5_063_C"
ColBlocks.Add "M5_064"
ColBlocks.Add "M5_064_1A"
ColBlocks.Add "M5_064_1B"
ColBlocks.Add "M5_064_2"
ColBlocks.Add "M5_064_3"
ColBlocks.Add "M5_065"
ColBlocks.Add "M5_065_A"
ColBlocks.Add "M5_067"
ColBlocks.Add "M5_067_1A"
ColBlocks.Add "M5_067_1B"
ColBlocks.Add "M5_067_2"
ColBlocks.Add "M5_068_1A"
ColBlocks.Add "M5_068_1B"
ColBlocks.Add "M5_069_1A"
ColBlocks.Add "M5_069_1B"
ColBlocks.Add "M5_072"
ColBlocks.Add "M5_073"
ColBlocks.Add "M5_073v"
ColBlocks.Add "M5_074"
ColBlocks.Add "M5_075"
ColBlocks.Add "M5_089"
ColBlocks.Add "M5_089_A"
ColBlocks.Add "M5_089_B"
ColBlocks.Add "M5_089_C"
ColBlocks.Add "M5_090_A"
ColBlocks.Add "M5_090_B"
ColBlocks.Add "M5_096"
ColBlocks.Add "M5_098"
ColBlocks.Add "M5_099"
ColBlocks.Add "M5_100"
ColBlocks.Add "M5_101"
ColBlocks.Add "M5_101_1"
ColBlocks.Add "M5_102"
ColBlocks.Add "M5_103"
ColBlocks.Add "M5_104"
ColBlocks.Add "M5_111_A"
ColBlocks.Add "M5_111_B"
ColBlocks.Add "M5_111_C"
ColBlocks.Add "M5_111_D"
ColBlocks.Add "M5_111_G"
ColBlocks.Add "M5_113"
ColBlocks.Add "M5_113_A"
ColBlocks.Add "M5_113_B"
ColBlocks.Add "M5_113_S"
ColBlocks.Add "M5_114"
ColBlocks.Add "M5_115"
ColBlocks.Add "M5_117"
ColBlocks.Add "M5_118"
ColBlocks.Add "M5_118_A"
ColBlocks.Add "M5_119"
ColBlocks.Add "M5_120"
ColBlocks.Add "M5_120_A"
ColBlocks.Add "M5_123"
ColBlocks.Add "M5_124"
ColBlocks.Add "M5_125"
ColBlocks.Add "M5_126C"
ColBlocks.Add "M5_126D"
ColBlocks.Add "M5_127"
ColBlocks.Add "M5_131"
ColBlocks.Add "M5_136"
ColBlocks.Add "M5_137"
ColBlocks.Add "M5_137_A"
ColBlocks.Add "M5_137B"
ColBlocks.Add "M5_137C"
ColBlocks.Add "M5_143_A"
ColBlocks.Add "M5_143_B"
ColBlocks.Add "M5_148"
ColBlocks.Add "M5_150"
ColBlocks.Add "M5_153"
ColBlocks.Add "M5_154"
ColBlocks.Add "M5_154_A"
ColBlocks.Add "M5_155"
ColBlocks.Add "M5_156"
ColBlocks.Add "M5_156_A"
ColBlocks.Add "M5_156_S"
ColBlocks.Add "M5_157"
ColBlocks.Add "M5_158"
ColBlocks.Add "M5_160_A"
ColBlocks.Add "M5_160_B"
ColBlocks.Add "M5_161"
ColBlocks.Add "M5_161_A"
ColBlocks.Add "M5_162"
ColBlocks.Add "M5_163"
ColBlocks.Add "M5_163_A"
ColBlocks.Add "M5_164"
ColBlocks.Add "M5_169"
ColBlocks.Add "M5_174"
ColBlocks.Add "M5_176"
ColBlocks.Add "M5_180"
ColBlocks.Add "M5_181"
ColBlocks.Add "M5_182"
ColBlocks.Add "M5_183"
ColBlocks.Add "M5_204_A"
ColBlocks.Add "M5_204_B"
ColBlocks.Add "M5_214"
ColBlocks.Add "M5_214_B"
ColBlocks.Add "M5_214_C"
ColBlocks.Add "M5_214_D"
ColBlocks.Add "M5_214_E"
ColBlocks.Add "M5_214_L"
ColBlocks.Add "M5_214_Z"
ColBlocks.Add "M5_214_ZB"
ColBlocks.Add "M5_214_ZH"
ColBlocks.Add "M5_227_A"
ColBlocks.Add "M5_233_A"
ColBlocks.Add "M5_234"
ColBlocks.Add "M5_236"
ColBlocks.Add "M5_236_A"
ColBlocks.Add "M5_239_A"
ColBlocks.Add "M5_242_A"
ColBlocks.Add "M5_242_B"
ColBlocks.Add "M5_500"
ColBlocks.Add "M5_500_A"
ColBlocks.Add "M5_501A"
ColBlocks.Add "M5_501B"
ColBlocks.Add "M5_501C"
ColBlocks.Add "M5_501D"
ColBlocks.Add "M5_501E"
ColBlocks.Add "M5_502"
ColBlocks.Add "M5_503"
ColBlocks.Add "M5_504"
ColBlocks.Add "M5_505"
ColBlocks.Add "M5_506"
ColBlocks.Add "M5_140_1"
ColBlocks.Add "M5_140_2"
ColBlocks.Add "M5_140"
ColBlocks.Add "M5_040"
ColBlocks.Add "M5_156_K"
ColBlocks.Add "M5_S-JU"
ColBlocks.Add "M5_LOGO"
 
End Sub
 
'поиск ресурса в списке зарезервированных
Function FindItem(strItem As String, Col As Collection) As Boolean
Dim intCounter As Integer
For intCounter = 1 To Col.Count
If Col(intCounter) = strItem Then
FindItem = True
Exit Function
End If
Next
End Function
 
 
Function LoadData() As Boolean
 
Dim intF As Integer
Dim strCol As New Collection
Dim intCounter As Integer
Dim intCount1 As Integer
Dim intCount2 As Integer
Dim Col As Collection
Dim strS As String
 
 
'считываем содержимое *.csv - файла
 
intF = FreeFile
'Open "C:\Common\Bentley\Workspace\Projects00\dgnlib\GRII500.csv" For Input As intF
Open "C:\Common\AutoCAD 2006Eng\MenuFile\Кодификатор_500_2005\GRII500.csv" For Input As intF
Do Until EOF(intF)
Line Input #intF, strS
strCol.Add strS
Loop
Close intF
 
'создаем массив правил соответствия
intCounter = 1
Do While intCounter <= strCol.Count
strS = strCol(intCounter)
Set Col = New Collection
VarFound ";", strS, 5, Col
If intCounter = 1 Then
ReDim arrControlEntity(1 To 1)
Else
ReDim Preserve arrControlEntity(1 To UBound(arrControlEntity) + 1)
End If
arrControlEntity(intCounter).AcLayer = Col(1)
arrControlEntity(intCounter).AcType = Col(2)
arrControlEntity(intCounter).AcName = Col(3)
arrControlEntity(intCounter).AcColor = Col(4)
If Col(2) = "Text" Then
arrControlEntity(intCounter).AcTextHeight = Col(5)
arrControlEntity(intCounter).AcWeight = 13
Else
arrControlEntity(intCounter).AcWeight = Col(5)
End If
intCounter = intCounter + 1
Set Col = Nothing
Loop
intCounter = 1
For intCount1 = 1 To UBound(arrControlEntity)
intCount2 = 1
arrControlLayer(intCounter).Layer = arrControlEntity(intCount1).AcLayer
Do While arrControlLayer(intCounter).Layer = arrControlEntity(intCount1).AcLayer
If intCount2 = 1 Then
ReDim arrControlLayer(intCounter).arrControlProperty(1 To 1)
Else
ReDim Preserve arrControlLayer(intCounter).arrControlProperty(1 To UBound(arrControlLayer(intCounter).arrControlProperty) + 1)
End If
arrControlLayer(intCounter).arrControlProperty(intCount2) = arrControlEntity(intCount1)
intCount2 = intCount2 + 1
If intCount1 = UBound(arrControlEntity) Then Exit For
intCount1 = intCount1 + 1
Loop
intCounter = intCounter + 1
intCount1 = intCount1 - 1
Next
Set strCol = Nothing
 
LoadData = True
 
End Function
 
Sub ChangeLayer(strTemp As String, strTempNew As String)
Dim SSetObjL As AcadSelectionSet
Dim mode As Integer
Dim entObj As AcadEntity
Dim acObj As AcadObject
Dim intCounter As Integer
Dim layerObj As AcadLayer
Dim strS As String
 
Set SSetObjL = ThisDrawing.SelectionSets.Add("SL")
 
mode = acSelectionSetAll
SSetObjL.Select mode
 
For intCounter = 0 To SSetObjL.Count - 1
Set acObj = SSetObjL(intCounter)
If TypeOf acObj Is AcadEntity Then
Set entObj = acObj
If entObj.Layer = strTemp Then
entObj.Layer = strTempNew
End If
End If
Next
ThisDrawing.ActiveLayer = ThisDrawing.Layers(strTempNew)
ThisDrawing.Save
 
SSetObjL.Clear
ThisDrawing.PurgeAll
'проверка удален ли слой
If strTemp <> "0" Then
For intCounter = 0 To ThisDrawing.Layers.Count - 1
If ThisDrawing.Layers(intCounter).Name = strTemp Then
strS = "Не удается удалить незарезервированный слой," & vbNewLine & _
"попробуйте воспользоваться командой ""_WBLOCK""."
MsgBox strS, vbOKOnly, "ВНИМАНИЕ"
Continue
blnStop = True
End If
Next
End If
'включить видимость всех слоев
If blnStop = False Then
For intCounter = 0 To ThisDrawing.Layers.Count - 1
Set layerObj = ThisDrawing.Layers(intCounter)
layerObj.LayerOn = True
Next
End If
Set ColBadEntity = Nothing
ThisDrawing.Regen acAllViewports
ZoomExtents
SSetObjL.Delete
 
End Sub
Function ChangeType(strTemp As String)
Dim SSetObjT As AcadSelectionSet
Dim mode As Integer
Dim entObj As AcadEntity
Dim acObj As AcadObject
Dim intCounter As Integer
Dim intCount As Integer
Dim intC As Integer
Dim blnFind As Boolean
Dim layerObj As AcadLayer
Dim strC As String
Dim splObj As AcadSpline
Dim linObj As AcadLine
Dim txtObj As AcadMText
Dim pntObj As AcadPoint
Dim blcObj As AcadBlockReference
Dim regObj As AcadRegion
Dim pline3dObj As Acad3DPolyline
Dim plineObj As AcadPolyline
Dim lwplineObj As AcadLWPolyline
Dim Point1(0 To 2) As Double
Dim Coord(0 To 3) As Double
Dim Coords() As Double
Dim strLib As String
Set SSetObjT = ThisDrawing.SelectionSets.Add("ST")
 
mode = acSelectionSetAll
SSetObjT.Select mode
 
For intCounter = 0 To SSetObjT.Count - 1
Set acObj = SSetObjT(intCounter)
If TypeOf acObj Is AcadEntity Then
Set entObj = acObj
If Right(entObj.ObjectName, Len(entObj.ObjectName) - 4) = strTemp Then
blnFind = False
'Spline
If strTemp = "Spline" Then
Set splObj = entObj
Point1(0) = splObj.GetFitPoint(1)(0)
Point1(1) = splObj.GetFitPoint(1)(1)
Point1(2) = splObj.GetFitPoint(1)(2)
strC = "DSTP_CVSPL2PL" & vbCr & CStr(Point1(0)) & "," & CStr(Point1(1)) & "," & CStr(Point1(2)) & vbCr & vbCr & "_D" & vbCr & "0.2" & vbCr & "_N" & vbCr
ThisDrawing.SendCommand strC
End If
'Region
If strTemp = "Region" Then
Set regObj = entObj
Point1(0) = regObj.Centroid(0)
Point1(1) = regObj.Centroid(1)
strC = "DSTP_CVREGPL" & vbCr & CStr(Point1(0)) & "," & CStr(Point1(1)) & vbCr & vbCr
ThisDrawing.SendCommand strC
End If
'Line
If strTemp = "Line" Then
blnFind = True
Set linObj = entObj
Coord(0) = linObj.StartPoint(0)
Coord(1) = linObj.StartPoint(1)
Coord(2) = linObj.EndPoint(0)
Coord(3) = linObj.EndPoint(1)
Set lwplineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(Coord)
End If
'3dPolyline
If strTemp = "3dPolyline" Then
blnFind = True
Set pline3dObj = entObj
ReDim Coords(0 To (Fix(UBound(pline3dObj.Coordinates) / 3) + 1) * 2 - 1)
For intCount = 0 To UBound(pline3dObj.Coordinates) Step 3
Coords(intC) = pline3dObj.Coordinates(intCount)
Coords(intC + 1) = pline3dObj.Coordinates(intCount + 1)
intC = intC + 2
Next
Set lwplineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(Coords)
End If
'"Polyline" Or "2dPolyline"
If strTemp = "2dPolyline" Then
blnFind = True
Set plineObj = entObj
ReDim Coords(0 To UBound(plineObj.Coordinates) - 1)
For intCount = 0 To UBound(plineObj.Coordinates) Step 1
Coords(intC) = plineObj.Coordinates(intCount)
Next
Set lwplineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(Coords)
End If
 
If blnFind = True Then
lwplineObj.Layer = entObj.Layer
lwplineObj.color = entObj.color
lwplineObj.Linetype = entObj.Linetype
lwplineObj.Lineweight = entObj.Lineweight
lwplineObj.Update
 
entObj.Delete
blnFind = False
End If
'Text
If strTemp = "MText" Then
Set txtObj = entObj
Point1(0) = txtObj.InsertionPoint(0)
Point1(1) = txtObj.InsertionPoint(1)
Point1(2) = txtObj.InsertionPoint(2)
 
strC = "_explode" & vbCr & CStr(Point1(0)) & "," & CStr(Point1(1)) & "," & CStr(Point1(2)) & vbCr & vbCr
ThisDrawing.SendCommand strC
End If
'Point
Dim insertedBlock As AcadExternalReference
If strTemp = "Point" Then
Set pntObj = entObj
If Exist_Block(strTempNew) = False Then
Point1(0) = 0
Point1(1) = 0
Point1(2) = 0
strLib = "c:\Common\AutoCAD 2006Eng\MenuFile\Кодификатор_500_2005\m500_grii_blocks_2000(8)\" & strTempNew & ".dwg"
Set insertedBlock = ThisDrawing.ModelSpace.AttachExternalReference(strLib, strTempNew, Point1, 1, 1, 1, 0, False)
ThisDrawing.Blocks.Item(insertedBlock.Name).Bind True
insertedBlock.Delete
End If
 
Point1(0) = pntObj.Coordinates(0)
Point1(1) = pntObj.Coordinates(1)
Point1(2) = pntObj.Coordinates(2)
If ThisDrawing.ActiveLayer.Name <> pntObj.Layer Then Set ThisDrawing.ActiveLayer = pntObj.Layer
Set blcObj = ThisDrawing.ModelSpace.InsertBlock(Point1, strTempNew, 1, 1, 1, 0)
blcObj.color = pntObj.color
blcObj.Lineweight = pntObj.Lineweight
pntObj.Delete
End If
End If
End If
Next
ThisDrawing.Save
SSetObjT.Delete
 
End Function
Function ChangeLineStyle(strTemp As String, strTempNew As String)
Dim intCounter As Integer
Dim entObj As AcadEntity
Dim intC As Integer
Dim blnFind As Integer
For intCounter = 1 To ColBadEntity.Count
Set entObj = ColBadEntity(intCounter)
If entObj.Linetype = strTemp Then
For intC = 1 To ThisDrawing.Linetypes.Count - 1
blnFind = 0
If ThisDrawing.Linetypes(intC).Name = strTempNew Then
blnFind = 1
Exit For
End If
Next
If blnFind = 0 Then ThisDrawing.Linetypes.Add strTempNew
entObj.Linetype = strTempNew
End If
Next
End Function
 
Function ChangeTextStyle(strName As String, strTempNew As String)
Dim intCounter As Integer
Dim SSetObjT As AcadSelectionSet
Dim mode As Integer
Dim entObj As AcadEntity
Dim acObj As AcadObject
Dim txtObj As AcadText
Dim txtStyleObj As AcadTextStyle
Dim blnFind As Integer
 
blnFind = 0
For intCounter = 1 To ThisDrawing.TextStyles.Count - 1
If ThisDrawing.TextStyles(intCounter).Name = strTempNew Then
blnFind = 1
Exit For
End If
Next
If blnFind = 0 Then
Set txtStyleObj = ThisDrawing.TextStyles.Add(strTempNew)
TextStyleSettings txtStyleObj
Else
Set txtStyleObj = ThisDrawing.TextStyles.Item(strTempNew)
End If
ThisDrawing.ActiveTextStyle = txtStyleObj
Set SSetObjT = ThisDrawing.SelectionSets.Add("
Text")
 
mode = acSelectionSetAll
SSetObjT.Select mode
Set ColBadEntity = Nothing
For intCounter = 0 To SSetObjT.Count - 1
Set acObj = SSetObjT(intCounter)
If TypeOf acObj Is AcadText Then
Set entObj = acObj
If entObj.ObjectName = "
AcDbText" Then
Set txtObj = entObj
If txtObj.StyleName = strName Then txtObj.StyleName = strTempNew
End If
End If
Next
SSetObjT.Delete
ThisDrawing.PurgeAll
ThisDrawing.Save
End Function
Function ChangeBlocks(strTemp As String, strTempNew As String)
Dim intCounter As Integer
Dim entObj As AcadEntity
Dim intC As Integer
Dim blnFind As Integer
Dim blcObj As AcadBlockReference
Dim InsPnt(0 To 2) As Double
Dim Rot As Double
Dim strN As String
Dim ColTemp As New Collection
Dim blcOrigin As AcadBlockReference
Dim objLType As AcadLineType
'If (InStr(1, strName, "
*Paper_Space", vbTextCompare) = 0 And InStr(1, strName, "*Model_Space", vbTextCompare) = 0 And strName <> "new block") Then
For intCounter = 1 To ColBadEntity.Count
Set entObj = ColBadEntity(intCounter)
If entObj.Name = strTemp Then
For intC = 1 To ThisDrawing.Blocks.Count - 1
blnFind = 0
If ThisDrawing.Blocks(intC).Name = strTempNew Then
blnFind = 1
Exit For
End If
Next
 
Set blcObj = entObj
Rot = blcObj.Rotation
InsPnt(0) = blcObj.InsertionPoint(0): InsPnt(1) = blcObj.InsertionPoint(1): InsPnt(2) = blcObj.InsertionPoint(2)
If ThisDrawing.ActiveLinetype.Name <> strCon And ThisDrawing.ActiveLinetype.Name <> "
ByLayer" _
And ThisDrawing.ActiveLinetype.Name <> "
ByBlock" Then
Set objLType = ThisDrawing.Linetypes.Item(strCon)
ThisDrawing.ActiveLinetype = objLType
End If
strN = entObj.Layer
ThisDrawing.ActiveLayer = ThisDrawing.Layers(strN)
If blnFind = 0 Then
strN = "
c:\Common\AutoCAD 2006Eng\MenuFile\Кодификатор_500_2005\m500_grii_blocks_2000(8)\" & strTempNew & ".dwg"
Else
strN = strTempNew
End If
Set blcObj = ThisDrawing.ModelSpace.InsertBlock(InsPnt, strN, 1, 1, 1, Rot)
ColTemp.Add entObj
End If
Next
If ColTemp.Count <> 0 Then
For Each entObj In ColTemp
entObj.Delete
Next
End If
End Function
Public Function Search_BadLayers() As Boolean
Dim intCounter As Integer
Dim intC As Integer
Dim strName As String
Dim blnFind As Boolean
Dim SSetObj As AcadSelectionSet
Dim mode As Integer
Dim entObj As AcadEntity
Dim acObj As AcadObject
 
ThisDrawing.PurgeAll
ThisDrawing.Save
Set SSetObj = ThisDrawing.SelectionSets.Add("
SS")
mode = acSelectionSetAll
SSetObj.Select mode
For intCounter = 0 To SSetObj.Count - 1
Set acObj = SSetObj(intCounter)
If TypeOf acObj Is AcadEntity Then
Set entObj = acObj
If entObj.Layer = "
0" Then
ColBadEntity.Add entObj
End If
End If
Next
ThisDrawing.SelectionSets("
SS").Delete
If ThisDrawing.Layers.Count > 1 Then
Set ColBadLayers = Nothing
For intCounter = 1 To ThisDrawing.Layers.Count - 1
strName = ThisDrawing.Layers(intCounter).Name
For intC = 1 To ColLayers.Count
If ColLayers(intC) = strName Then
blnFind = True
Exit For
End If
Next
If blnFind = False Then
ColBadLayers.Add strName
Search_BadLayers = True
End If
blnFind = False
Next
End If
 
End Function
Function Search_BadTypes() As Boolean
Dim mode As Integer
Dim intCounter As Integer
Dim SSetObj As AcadSelectionSet
Dim acObj As AcadObject
Dim entObj As AcadEntity
Dim intC As Integer
Dim strName As String
Dim blnFind As Boolean
Dim viewObj As AcadViewport
Set ColBadEntity = Nothing
Set SSetObj = ThisDrawing.SelectionSets.Add("
SS")
mode = acSelectionSetAll
SSetObj.Select mode
For intCounter = 0 To SSetObj.Count - 1
Set acObj = SSetObj(intCounter)
If TypeOf acObj Is AcadEntity Then
Set entObj = acObj
For intC = 1 To ColTypes.Count
If ColTypes(intC) = entObj.ObjectName Then
blnFind = True
Exit For
End If
Next
 
If blnFind = False Then
ColBadEntity.Add entObj
End If
End If
blnFind = False
Next
 
If ColBadEntity.Count <> 0 Then
Set entObj = ColBadEntity(1)
ColBadTypes.Add Right(entObj.ObjectName, Len(entObj.ObjectName) - 4)
For intCounter = 1 To ColBadEntity.Count
Set entObj = ColBadEntity(intCounter)
strName = Right(entObj.ObjectName, Len(entObj.ObjectName) - 4)
If FindItem(strName, ColBadTypes) = True Then
For intC = 1 To ColBadTypes.Count
If ColBadTypes(intC) = strName Then
blnFind = True
Exit For
End If
Next
End If
If blnFind = False Then ColBadTypes.Add strName
 
blnFind = False
Search_BadTypes = True
Next
blnClear = False
ElseIf ColBadEntity.Count = 0 Then
blnClear = True
Search_BadTypes = False
End If
ThisDrawing.SelectionSets.Item("
SS").Delete
End Function
Function Search_BadTxtStyle() As Boolean
 
Dim intCounter As Integer
Dim intC As Integer
Dim strName As String
Dim blnFind As Integer
 
If ThisDrawing.TextStyles.Count > 1 Then
Set ColBadTextStyles = Nothing
For intCounter = 0 To ThisDrawing.TextStyles.Count - 1
strName = ThisDrawing.TextStyles(intCounter).Name
For intC = 1 To ColTextStyles.Count
If ColTextStyles(intC) = strName Then
blnFind = 1
Exit For
End If
Next
 
If blnFind = 0 Then
ColBadTextStyles.Add strName
End If
blnFind = 0
Next
ThisDrawing.PurgeAll
ThisDrawing.Save
If ColBadTextStyles.Count <> 0 Then
Search_BadTxtStyle = True
Else
Search_BadTxtStyle = False
End If
End If
End Function
Function Search_BadLineTypes() As Boolean
Dim SSetObjL As AcadSelectionSet
Dim mode As Integer
Dim entObj As AcadEntity
Dim acObj As AcadObject
Dim intCounter As Integer
Dim intCount As Integer
Dim blnFind As Integer
Dim ColTemp As New Collection
Dim strN As String
Dim objLay As AcadLayer
Set ColBadEntity = Nothing
Set SSetObjL = ThisDrawing.SelectionSets.Add("
SL")
 
mode = acSelectionSetAll
SSetObjL.Select mode
 
For intCounter = 0 To SSetObjL.Count - 1
Set acObj = SSetObjL(intCounter)
If TypeOf acObj Is AcadEntity Then
Set entObj = acObj
strN = entObj.Linetype
' If strN = "
Continuous" Or strN = "CONTI" Or strN = "Conti" Then
' strN = "
CONTINUOUS"
' entObj.Linetype = strN
' End If
For intCount = 1 To ColLineStyles.Count
If ColLineStyles(intCount) = strN Then
blnFind = 1
Exit For
End If
blnFind = 0
Next
If blnFind = 0 Then
ColBadEntity.Add entObj
End If
End If
 
Next
If ColBadEntity.Count <> 0 Then
Set entObj = ColBadEntity(1)
ColBadLineTypes.Add entObj.Linetype
For intCounter = 1 To ColBadEntity.Count
Set entObj = ColBadEntity(intCounter)
strN = entObj.Linetype
If FindItem(strN, ColBadLineTypes) = True Then
For intCount = 1 To ColBadLineTypes.Count
If ColBadLineTypes(intCount) = strN Then
blnFind = 1
Exit For
End If
Next
End If
If blnFind = 0 Then ColBadLineTypes.Add strN
 
blnFind = 0
Search_BadLineTypes = True
Next
blnClear = False
ElseIf ColBadEntity.Count = 0 Then
blnClear = True
Search_BadLineTypes = False
End If
ThisDrawing.SelectionSets.Item("
SL").Delete
 
End Function
Function Search_BadBlocks() As Boolean
Dim SSetObjB As AcadSelectionSet
Dim mode As Integer
Dim entObj As AcadEntity
Dim acObj As AcadObject
Dim intCounter As Integer
Dim intCount As Integer
Dim blnFind As Integer
Dim blcObj As AcadBlockReference
Dim ColTemp As New Collection
Dim strN As String
 
Set ColBadEntity = Nothing
Set SSetObjB = ThisDrawing.SelectionSets.Add("
S")
 
mode = acSelectionSetAll
SSetObjB.Select mode
 
For intCounter = 0 To SSetObjB.Count - 1
Set acObj = SSetObjB(intCounter)
' If TypeOf acObj Is AcadEntity Then
' Set entObj = acObj
If TypeOf acObj Is AcadBlockReference Then
Set blcObj = acObj
strN = blcObj.Name
blnFind = 0
For intCount = 1 To ColBlocks.Count
If ColBlocks(intCount) = strN Then
blnFind = 1
Exit For
End If
Next
If blnFind = 0 Then ColBadEntity.Add blcObj
 
End If
Next
 
If ColBadEntity.Count <> 0 Then
Set entObj = ColBadEntity(1)
ColBadBlocks.Add entObj.Name
For intCounter = 1 To ColBadEntity.Count
Set entObj = ColBadEntity(intCounter)
strN = entObj.Name
If FindItem(strN, ColBadBlocks) = True Then
For intCount = 1 To ColBadBlocks.Count
If ColBadBlocks(intCount) = strN Then
blnFind = 1
Exit For
End If
Next
End If
If blnFind = 0 Then ColBadBlocks.Add strN
 
blnFind = 0
Search_BadBlocks = True
Next
blnClear = False
ElseIf ColBadEntity.Count = 0 Then
blnClear = True
Search_BadBlocks = False
End If
ThisDrawing.SelectionSets.Item("
S").Delete
 
End Function
Function Exist_Block(strName As String) As Boolean
Dim intCounter As Integer
Exist_Block = False
For intCounter = 1 To ThisDrawing.Blocks.Count - 1
If ThisDrawing.Blocks(intCounter).Name = strName Then
Exist_Block = True
Exit For
End If
Next
End Function
Function TextStyleSettings(txtStyleObj As AcadTextStyle)
Dim strStyle As String
Dim Font As String
Dim txtSetting As TextStyleSettings
 
strStyle = txtStyleObj.Name
Select Case strStyle
Case "
LIKE10"
Font = "
p151.shx"
Case "
LIKE11"
Font = "
bm431.shx"
Case "
LIKE12"
Font = "
ch132.shx"
Case "
LIKE14"
Font = "
p131.shx"
Case "
LIKE17"
Font = "
d431.shx"
Case "
LIKE19"
Font = "
bo2.shx"
Case "
LIKE21"
Font = "
ch131.shx"
Case "
LIKE30"
Font = "
peter.shx"
Case "
LIKE31"
Font = "
peterb.shx"
Case "
LIKE32"
Font = "
peteri.shx"
Case "
LIKE34"
Font = "
pragma.shx"
Case "
LIKE36"
Font = "
pragmai.shx"
End Select
Font = "
C:\Common\AutoCAD 2006Eng\Fonts\" & Font
txtStyleObj.fontFile = Font
' txtStyleObj.Height = 0
' txtStyleObj.Width = 1
End Function
Sub Continue()
Dim currMenuGroup As AcadMenuGroup
Dim strName As String
Dim intCounter As Integer
Dim newMenu As AcadPopupMenu
Dim newMenuItem As AcadPopupMenuItem
Dim openMacro As String
Dim blnFind As Boolean
 
strName = "
Проверка"
Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(1)
 
For intCounter = 0 To currMenuGroup.Menus.Count - 1
If currMenuGroup.Menus(intCounter).Name = strName Then
Set newMenu = currMenuGroup.Menus(intCounter)
 
If blnClose = True Then
If newMenu.OnMenuBar = True Then newMenu.RemoveFromMenuBar
' currMenuGroup.Menus(intCounter).RemoveFromMenuBar
currMenuGroup.Save acMenuFileSource
' blnClose = False
blnExistMenu = False
Exit Sub
End If
blnFind = True
Exit For
End If
Next
'Включить или загрузить меню
If blnClose = False Then
If blnFind = True Then
If newMenu.OnMenuBar = False Then
newMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)
blnExistMenu = True
End If
End If
If blnFind = False Then
Set newMenu = currMenuGroup.Menus.Add(strName)
openMacro = "
(command " & """vbaRun"" " & """ContinueControl""" & ")" & vbCr
Set newMenuItem = newMenu.AddMenuItem(newMenu.Count + 1, "
Продолжить", openMacro)
newMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)
blnExistMenu = True
End If
End If
End Sub
Public Sub VarFound(symbol As String, strS As String, intVarCounter As Integer, Col As Collection)
 
Dim intCounter As Integer
Dim strVariable As String
Dim intC As Integer
 
 
Do While intC < intVarCounter - 1
 
For intCounter = 1 To Len(strS)
If Mid(strS, intCounter, 1) = symbol Then
strVariable = Trim(Left(strS, intCounter - 1))
 
Col.Add strVariable
strS = Trim(Right(strS, Len(strS) - intCounter))
intC = intC + 1
 
Exit For
End If
Next
Loop
Col.Add Trim(strS)
 
End Sub
 
Public Function StrToTab(strS As String) As String
strS = Left(strS, (InStr(1, strS, vbTab)) - 1)
End Function
'функция для генерации строки пробелов нужной длины
Public Function Space(intCounter As Integer) As String
Dim strS As String
Dim strAll As String
Dim intC As Integer
strS = "
"
For intC = 1 To intCounter
strAll = strAll & strS
Next
Space = strAll
End Function
'функция для генерации горизонтальных линий нужной длины
Public Function strLine(intCounter As Integer) As String
Dim strS As String
Dim strAll As String
Dim intC As Integer
strS = "
-"
For intC = 1 To intCounter
strAll = strAll & strS
Next
strLine = strAll
End Function
 
Public Function PrintLine(strS As String, blnTitle As Boolean)
 
If blnTitle = True Then
strPrintLine = strPrintLine & Space(2) & "
|" & strLine(60) & "|" _
& vbNewLine & Space(2) & "
|" & Space(2) & strS & Space(58 - Len(strS)) & "|" & vbNewLine _
& Space(2) & "
|" & strLine(60) & "|" & vbNewLine
Else
strPrintLine = strPrintLine & Space(2) & "
|" & Space(5) & strS & Space(55 - Len(strS)) & "|" & vbNewLine
End If
 
End Function
> 1 <


Онлайн :

0 пользователь(ей), 10 гость(ей) :




Реклама на сайте: