|
||
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны | Справка по форуму | Файлообменник | |
|
Поиск в этой теме |
11.01.2016, 19:02 | #1 | |
Ошибка в коде cant find project or library Sub CodificatorCheck()(проверка на ошибки )
Регистрация: 11.01.2016
Сообщений: 2
Добрый вечер. Нужен алгоритм проверки dwg файла. Имеется стандарт, те определенные стили, слои, шрифты. Те должно все соответствовать кодификатору.
Имеется код, вроде все библиотеки прописал. Но никак не хочеn работать. При запуске функции контрол, выскакивает ошибка cant find project or library , в самом коде подсвечена строка Sub CodificatorCheck(). Подскажите где ошибка. __________________________________________ сам код control.dvb Код:
[Выделить все]
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\Projects\500\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 |
||
Просмотров: 3278
|
|
||||
Регистрация: 11.01.2016
Сообщений: 2
|
неужели никто не может помочь????
|
|||
|
Опции темы | Поиск в этой теме |
|
|
Похожие темы | ||||
Тема | Автор | Раздел | Ответов | Последнее сообщение |
Какой язык перспективен для инженера-конструктора с условием | The_Mercy_Seat | Программирование | 705 | 17.03.2021 14:19 |
Расчет пространственных стержневых систем и наличие шарниров в расчетных схемах | Jenec | Лира / Лира-САПР | 17 | 27.09.2013 22:23 |
Несоответствие результатов в Лире | s.vas | Лира / Лира-САПР | 19 | 11.11.2009 07:31 |
Помощь по Лире | Серега М | Лира / Лира-САПР | 52 | 28.05.2007 02:47 |