| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Ошибка в коде cant find project or library Sub CodificatorCheck()(проверка на ошибки )

Ошибка в коде cant find project or library Sub CodificatorCheck()(проверка на ошибки )

Закрытая тема
Поиск в этой теме
Непрочитано 11.01.2016, 19:02 #1
Ошибка в коде cant find project or library Sub CodificatorCheck()(проверка на ошибки )
Piter81
 
Регистрация: 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
 
Автор темы   Непрочитано 14.01.2016, 22:22
#2
Piter81


 
Регистрация: 11.01.2016
Сообщений: 2


неужели никто не может помочь????
Piter81 вне форума  
Закрытая тема
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Ошибка в коде cant find project or library Sub CodificatorCheck()(проверка на ошибки )

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Какой язык перспективен для инженера-конструктора с условием 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