ADN Club > VBA
Обсуждение видеоуроков AutoCAD VBA
Nutson:
--- Цитата: Timofeev от 19-01-2021, 11:30:56 ---В листах было бы вообще замечательно если бы я смог програмно их создать и настроить под печать. Пока много одинаковых шаблонных файлов планируется создавать и хочу от проблемы распечатки уйти настроив сразу расстановку
и из эксель мне это проще делать меняя атрибуты
'On Error Resume Next - закомментировал- код отработал но Длина не берется
--- Конец цитаты ---
Вот прям отработал? и без одной ошибки?
и где отступы?? расставлены для галочки
--- Код - Visual Basic [Выбрать] ---Option ExplicitPrivate Type ScaleFactor X As Double Y As Double Z As DoubleEnd TypeSub InsertBlocks() Dim acadApp As Object Dim height As Double Dim acadDoc As Object Dim acadBlock As Object Dim attributeObj As Object Dim LastRow As Long Dim i As Long Dim InsertionPoint(0 To 2) As Double Dim BlockName As String Dim BlockScale As ScaleFactor Dim RotationAngle As Double Dim tag As String Dim value As String Dim prompt As String Dim varAttributes As Variant Dim varBlockProperties As Variant Dim Index As Variant Dim prop As Variant Dim propatr As Variant 'Activate the coordinates sheet and find the last row. With Sheets("Coordinates") .Activate LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row End With 'Check if there are coordinates for at least one circle. If LastRow < 2 Then MsgBox "There are no coordinates for the insertion point!", vbCritical, "Insertion Point Error" Exit Sub End If 'Check if AutoCAD application is open. If is not opened create a new instance and make it visible. On Error Resume Next Set acadApp = GetObject(, "AutoCAD.Application") If acadApp Is Nothing Then Set acadApp = CreateObject("AutoCAD.Application") acadApp.Visible = True End If 'Check (again) if there is an AutoCAD object. If acadApp Is Nothing Then MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error" Exit Sub End If On Error GoTo 0 'If there is no active drawing create a new one. On Error Resume Next Set acadDoc = acadApp.ActiveDocument If acadDoc Is Nothing Then Set acadDoc = acadApp.Documents.Add End If On Error GoTo 0 'Check if the active space is paper space and change it to model space. If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding End If 'On Error Resume Next ' -- здесь комментируем 'Loop through all the rows and add the corresponding blocks in AutoCAD. With Sheets("Coordinates") For i = 2 To LastRow 'Задаем имя блока BlockName = .Range("A" & i).value 'Вставляем блок если он есть If BlockName <> vbNullString Then 'Задаем координаты вставки блока InsertionPoint(0) = .Range("B" & i).value InsertionPoint(1) = .Range("C" & i).value InsertionPoint(2) = .Range("D" & i).value 'Задаем геометрию блока BlockScale.X = .Range("E" & i).value BlockScale.Y = .Range("F" & i).value BlockScale.Z = .Range("G" & i).value 'Задаем Поворот блока RotationAngle = 0 Set attributeObj = acadBlock.AddAttribute(height, prompt, InsertionPoint, tag, value) ' ошибка №1 Set acadBlock = acadDoc.ModelSpace.InsertBlock(InsertionPoint, BlockName, BlockScale.X, BlockScale.Y, BlockScale.Z, RotationAngle * 0.0174532925) End If varAttributes = acadBlock.GetAttributes varAttributes(0).TextString = .Range("L" & i).value varAttributes(1).TextString = .Range("M" & i).value varAttributes(2).TextString = .Range("N" & i).value ' ошибка №2 varAttributes(3).TextString = .Range("O" & i).value ' ошибка №3 varAttributes(4).TextString = .Range("P" & i).value ' ошибка №4 varAttributes(5).TextString = .Range("Q" & i).value ' ошибка №5 'varAttributes(6).TextString = .Range("L" & i).value 'varAttributes(7).TextString = .Range("M" & i).value acadBlock.Layer = .Range("K" & i).value If acadBlock.IsDynamicBlock = True Then varBlockProperties = acadBlock.GetDynamicBlockProperties For Index = LBound(varBlockProperties) To UBound(varBlockProperties) Set prop = varBlockProperties(Index) If prop = prop.PropertyName = "Ширина" Then ' ошибка №6 prop.value = .Range("H" & i).value ElseIf prop = prop.PropertyName = "Длина" Then ' ошибка №7 prop.value = .Range("Длина" & i).value End If acadBlock.Layer = .Range("K" & i).value ' это нафига в цикле, плюс это дубль Next End If 'varBlockProperties.Update Next i End With 'Zoom in to the drawing area. acadApp.ZoomExtents 'Release the objects. Set acadBlock = Nothing Set acadDoc = Nothing Set acadApp = NothingEnd Sub
Timofeev:
Подскажите если у дин блока имена .PropertyName - называются для обращения, то как обратится к атрибуту? какая там фраза?
Александр Ривилис:
--- Цитата: Timofeev от 19-01-2021, 13:05:12 ---Подскажите если у дин блока имена .PropertyName - называются для обращения, то как обратится к атрибуту? какая там фраза?
--- Конец цитаты ---
Эту фразу я не понял, но ты наверное говоришь про .TagString
Timofeev:
спасибо да о ней
Работа над ошибками: прокомментировал как понимаю, поправил вроде все какие замечания дали. Поглядите все ли норм
--- Код - Visual Basic [Выбрать] ---Option ExplicitPrivate Type ScaleFactor X As Double 'Объявляем переменные Y As Double Z As DoubleEnd TypeSub InsertBlocks() Dim acadApp As Object 'Объявляем переменные Dim height As Double Dim acadDoc As Object Dim acadBlock As Object Dim attributeObj As Object Dim LastRow As Long Dim i As Long Dim InsertionPoint(0 To 2) As Double Dim BlockName As String Dim BlockScale As ScaleFactor Dim RotationAngle As Double Dim tag As String Dim value As String Dim prompt As String Dim varAttributes As Variant Dim varBlockProperties As Variant Dim Index As Variant Dim prop As Variant Dim propatr As Variant With Sheets("Coordinates") 'Делаем активным лист координаты .Activate LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'Ищем последнюю заполненную строку столбца A End With If LastRow < 2 Then 'Если номер последней строки меньше чем два MsgBox "Нет ни одной координаты для вставки блока", vbCritical, "Ошибка координат вставки блока" Exit Sub End If On Error Resume Next Set acadApp = GetObject(, "AutoCAD.Application") 'Проверяем открыт ли автокад If acadApp Is Nothing Then 'Если автокад не открыт Set acadApp = CreateObject("AutoCAD.Application") 'Создаем новую сессию автокад acadApp.Visible = True 'Делаем автокад видимым End If If acadApp Is Nothing Then 'Если опять автокад не открыт MsgBox "Извините, но мы не можем запустить автокад", vbCritical, "Ошибка запуска автокад" Exit Sub End If On Error GoTo 0 'Если ошибка то идем хз куда On Error Resume Next 'Если ошибка то идем дальше Set acadDoc = acadApp.ActiveDocument 'Присваиваем переменную активному чертежу автокада If acadDoc Is Nothing Then 'Если ни один чертеж автокада не активен Set acadDoc = acadApp.Documents.Add 'Создаем новый чертеж End If On Error GoTo 0 'Если ошибка то идем хз куда If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding. Если чертеж открыт не в модели, а в листах acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding. Делаем активной модель End If With Sheets("Coordinates") 'С листом Coordinates Excel For i = 2 To LastRow 'Цикл начиная со второй строки до последней заполненной в столбце А BlockName = .Range("A" & i).value 'Присваиваем переменную имя блока по значению из ячейки А листа эксель 'Вставляем блок если он есть If BlockName <> vbNullString Then 'Если данный блок присутствует в чертеже автокад InsertionPoint(0) = .Range("B" & i).value 'Задаем координату X вставки блока InsertionPoint(1) = .Range("C" & i).value 'Задаем координату Y вставки блока InsertionPoint(2) = .Range("D" & i).value 'Задаем координату Z вставки блока BlockScale.X = .Range("E" & i).value 'Задаем масштаб по X вставки блока BlockScale.Y = .Range("F" & i).value 'Задаем масштаб по Y вставки блока BlockScale.Z = .Range("G" & i).value 'Задаем масштаб по Z вставки блока RotationAngle = 0 'Задаем угол поворота блока равным нулю Set acadBlock = acadDoc.ModelSpace.InsertBlock(InsertionPoint, BlockName, BlockScale.X, BlockScale.Y, BlockScale.Z, RotationAngle * 0.0174532925) 'Вставляем блок в чертеж acadBlock.Layer = .Range("K" & i).value 'Устанавливаем нулевой слой для блока End If varAttributes = acadBlock.GetAttributes 'Получаем атрибуты блока For Each propatr In varAttributes 'Циклом проходим по всем атрибутам Select Case propatr.TagString 'Открываем портфель атрибутов Case "КАНОН-ФОРМАТ" propatr.TagString = .Range("L" & i).value 'Задаем значение атрибута 1 Case "ОРИЕНТАЦИЯ" propatr.TagString = .Range("M" & i).value 'Задаем значение атрибута 2 End Select 'Завершаем выбор Next If acadBlock.IsDynamicBlock = True Then 'Если блок динамический (обязательно ли это?) varBlockProperties = acadBlock.GetDynamicBlockProperties 'Получаем свойства дин блока For Each prop In varBlockProperties 'Циклом проходим по всем свойствам Select Case prop.PropertyName 'Открываем портфель свойств Case "Длина" prop.value = .Range("I" & i).value * 1 'Задаем свойство 1 Case "Ширина" prop.value = .Range("H" & i).value * 1 'Задаем свойство 2 End Select 'Завершаем выбор Next End If Next i ' Переход к следующей строке эксель End With ' Завершение взятия данных с листа эксель acadApp.ZoomExtents ' Двойное нажатие на колесико мыши Set acadBlock = Nothing ' ХЗ зачем обнуляем наверное перменные Set acadDoc = Nothing ' ХЗ зачем обнуляем наверное перменные Set acadApp = Nothing ' ХЗ зачем обнуляем наверное перменныеEnd Sub
Навигация
Перейти к полной версии