ExpErEmEnt.spb.ru

Программа для облегчения создания видовых портов из модели
Программа написана на VB.Net под AutoCAD.

Тестировалась на:

• AutoCAD 2008 (x86)
• AutoCAD 2009 (x86)
• AutoCAD 2009 (x64)
• AutoCAD 2010 (x86)
• AutoCAD 2010 (x64)
• AutoCAD 2011
• AutoCAD 2012
• AutoCAD 2013
• AutoCAD 2014
• AutoCAD 2015

Представляет из себя библиотеку (dll) загружаемую в autocad командой: _Netload
Создаем Впорты из модели.
Масштаб впорта берется из названия размерного стиля

• М100 или М100 - масштаб 1/100
• М050 или М50 - масштаб 1/50
• М025 или М25 - масштаб 1/25
• М020 или М20 - масштаб 1/20
• и т.д.

TODO Вот это необходимо корректировать. Программа должна сама, на основе примитивов попавших в прямоугольник впорта, выставить необходимый масштаб впорта. Т.о. программа должна проанализировать размеры, блоки и др. элементы и понять какой необходимо выставить масштаб или при невозможности определить масштаб запрашивала его у пользователя

• BX_VPORT_PP
• bx_datainput

• Наличие доступа в интернет.

Схема работы:

1. Запускаем команду.
2. Автокад автоматически переключается на пространство модели
3. Если программа не смогла определить масштаб, то спросит его у пользователя.
4. Далее указываем диагональ прямоугольника который нужно вывести в лист
5. После указания всех точек автокад автоматически переключается на последний использованный лист
6. Указываем точку вывода впорта, указанная точка будет соответствовать геометрическому центру порта
7. Впорт автоматически создается на нужном слое («КЖ_Видовые окна») с нужными настройками

Скачать программу можно тут: vport_pp.7z (18.39 KiB, 4y ago, 487 downloads)

Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Colors
 
 
Public Class acad__boxashu_bx_vport_pp
 
    <CommandMethod("bx_vport_pp")> _
    Public Sub bx_vport_pp()
 
        Dim Layer As String = "КЖ_Видовые окна"
 
        '' Get the current document and database, and start a transaction
        Dim acDoc As Document = Application.DocumentManager.MdiActiveDocument
        Dim acCurDb As Database = acDoc.Database
        Dim acEd As Editor = acDoc.Editor
 
        Using acTrans As Transaction = acCurDb.TransactionManager.StartTransaction()
 
            ' Сначала переключаемся в пространство модели.
            '' Get the current values of CVPORT and TILEMODE
            Dim nCvports As Integer = Application.GetSystemVariable("CVPORT")
            Dim nTilemode As Integer = Application.GetSystemVariable("TILEMODE")
 
            '' Check to see if the Model layout is active, TILEMODE is 1 when
            '' the Model layout is active
            If nTilemode = 0 Then
                '' Check to see if Model space is active in a viewport,
                '' CVPORT is 2 if Model space is active 
                If nCvports = 2 Then
                    acDoc.Editor.SwitchToPaperSpace()
                    Application.SetSystemVariable("TILEMODE", 1)
                Else
                    Application.SetSystemVariable("TILEMODE", 1)
                End If
            End If
 
            'Смотрим что там с анатотивностью
            Dim asc As AnnotationScale = New AnnotationScale()
            asc.Name = "MyScale 1:20"
            asc.PaperUnits = 1
            asc.DrawingUnits = 20
            'Смотрим текущий размерный стиль для определения ткущего масщтаба
            Dim masshtab As Double = 0
 
            Dim acDimStyleTblRec As DimStyleTableRecord = acTrans.GetObject(acCurDb.Dimstyle, OpenMode.ForRead)
            Dim cDimName As String = acDimStyleTblRec.Name.ToString
            masshtab = CType(Val(cDimName), Double)
 
            If masshtab = 0 Then
                cDimName = cDimName.Substring(1, cDimName.Length - 1)
                masshtab = CType(Val(cDimName), Double)
            End If
 
            Try
                Dim cm As ObjectContextManager = acCurDb.ObjectContextManager
                If Not IsDBNull(cm) Then
                    Dim occ As ObjectContextCollection = cm.GetContextCollection("ACDB_ANNOTATIONSCALES")
                    If Not IsDBNull(occ) Then
                        '' Create a brand new scale context
                        asc = occ.CurrentContext 'New AnnotationScale()
                        masshtab = asc.DrawingUnits
                    End If
                End If
            Catch ex As Exception
                acDoc.Editor.WriteMessage(ControlChars.CrLf & "Ошибка при получении аннотативного масштаба!")
            End Try
 
            'Если в наименование размерного стиля будет всягая дрянь и последние цифры будут ничего не значить
            'If masshtab = 0 Then
            '    Dim DimOpt As PromptIntegerOptions = New PromptIntegerOptions(ControlChars.CrLf & "Введите масштаб (для масштада 1:" & masshtab & " необходиммо ввести " & masshtab & "): ")
            '    DimOpt.AllowZero = False
            '    DimOpt.AllowNegative = False
            '    DimOpt.AllowNone = False
            '    DimOpt.DefaultValue = masshtab
            '    Dim DimRes As PromptIntegerResult = acEd.GetInteger(DimOpt)
            '    If DimRes.Status <> PromptStatus.OK Then
            '        Exit Sub
            '    Else
            '        masshtab = CType(DimRes.Value, Double)
            '    End If
            'End If
 
 
            'тут запрашиваем у пользователя 2 точки в пространстве модели
            'Указание 1 точку
            Dim getPointOptions1 As PromptPointOptions = New PromptPointOptions(ControlChars.Lf & "Укажите 1 точку : ")
            'Получить данные от редактора
            Dim getPointResult1 As PromptPointResult = acDoc.Editor.GetPoint(getPointOptions1)
            'Если все ОК
            If (getPointResult1.Status <> PromptStatus.OK) Then
                Exit Sub
            End If
 
            'Указание 2 точку
            Dim getPointOptions2 As PromptCornerOptions = New PromptCornerOptions(ControlChars.Lf & "Укажите 2 точку : ",
                                                                                  getPointResult1.Value)
            'Получить данные от редактора
            Dim getPointResult2 As PromptPointResult = acDoc.Editor.GetCorner(getPointOptions2)
            'Если все ОК
            If (getPointResult2.Status <> PromptStatus.OK) Then
                Exit Sub
            End If
 
 
            'вычисляем размер прямоугольника видового порта и его центральную точку
            Dim h As Double = Math.Abs(getPointResult1.Value.Y - getPointResult2.Value.Y)
            Dim w As Double = Math.Abs(getPointResult2.Value.X - getPointResult1.Value.X)
 
            Dim x As Double = 0
            Dim y As Double = 0
 
            If getPointResult1.Value.X >= getPointResult2.Value.X Then
                x = getPointResult2.Value.X
            Else
                x = getPointResult1.Value.X
            End If
 
            If getPointResult1.Value.Y >= getPointResult2.Value.Y Then
                y = getPointResult2.Value.Y
            Else
                y = getPointResult1.Value.Y
            End If
 
            Dim pnt_centr As Point2d = New Point2d(x + w / 2, y + h / 2)
 
 
            '' Open the Block table for read
            Dim acBlkTbl As BlockTable = acTrans.GetObject(acCurDb.BlockTableId, _
                                         OpenMode.ForRead)
 
            '' Switch to the previous Paper space layout
            Application.SetSystemVariable("TILEMODE", 0)
            acDoc.Editor.SwitchToPaperSpace()
 
            'Сохраняю текущий вид
            Dim acViewTemp As ViewTableRecord = acDoc.Editor.GetCurrentView()
            'Показать все
            '' Zoom to the limits of Model space
            Zoom(New Point3d(acCurDb.Pextmin.X, acCurDb.Pextmin.Y, 0), _
                 New Point3d(acCurDb.Pextmax.X, acCurDb.Pextmax.Y, 0), _
                 New Point3d(), 1)
 
 
            '' Open the Block table record Paper space for write
            Dim acBlkTblRec As BlockTableRecord
            acBlkTblRec = acTrans.GetObject(acBlkTbl(BlockTableRecord.PaperSpace), _
                                            OpenMode.ForWrite)
            '' Create a Viewport
            Dim acVport As Viewport = New Viewport()
            acVport.SetDatabaseDefaults()
            acVport.CenterPoint = New Point3d(0, 0, 0) 'getPointResult3.Value
            acVport.Width = w / masshtab
            acVport.Height = h / masshtab
 
            '' Add the new object to the block table record and the transaction
            acBlkTblRec.AppendEntity(acVport)
            acTrans.AddNewlyCreatedDBObject(acVport, True)
 
            '' Change the view direction
            acVport.ViewDirection = New Vector3d(0, 0, 1)
 
            '' Enable the viewport
            acVport.On = True
            acVport.CustomScale = 1 / masshtab
            acVport.ViewCenter = pnt_centr
 
            'Dim Annotation As AnnotationScale = New AnnotationScale()
            acVport.AnnotationScale = asc
 
            'прописать назначение слоя видовому порту
            crLayers(Layer)
            acVport.Layer = Layer
 
            'Возвращаю текущий вид
            acDoc.Editor.SetCurrentView(acViewTemp)
 
            Dim entJig As New VPortJig(acVport)
            acDoc.TransactionManager.QueueForGraphicsFlush()
            Dim pkr As PromptPointResult = acEd.Drag(entJig)
            If pkr.Status = PromptStatus.OK Then
                acVport.CenterPoint = pkr.Value
                acDoc.TransactionManager.QueueForGraphicsFlush()
            End If
            '' Save the new objects to the database
            Try
                '' Save the changes and dispose of the transaction
                acTrans.Commit()
            Catch ex As Exception
                acDoc.Editor.WriteMessage(ControlChars.CrLf & "Не удалось добавить VPort к листу!")
            End Try
        End Using
 
    End Sub
 
    Public Sub crLayers(ByRef str As String)
 
        Dim acDoc As Document = Application.DocumentManager.MdiActiveDocument
        Dim acCurDb As Database = acDoc.Database
 
        'Функция создания слоев
        'Начало транзакции
        Using acTrans As Transaction = acCurDb.TransactionManager.StartTransaction()
            'Открываю таблицу слоев для чтения
            Dim acLyrTbl As LayerTable
            'тут возникает ошибка при отладке.
            acLyrTbl = CType(acTrans.GetObject(acCurDb.LayerTableId, _
                                         OpenMode.ForRead), LayerTable)
            'В этой переменной наименование слоя
            Dim sLayerName As String = str.ToString
            'Если этого слоя нет, то создаем его
            If acLyrTbl.Has(sLayerName) = False Then
                Dim acLyrTblRec As LayerTableRecord = New LayerTableRecord()
 
                'Создаем новый слой с заданными параметрами
                acLyrTblRec.Name = sLayerName
                acLyrTblRec.Color = Color.FromColorIndex(ColorMethod.ByAci, 148)
                acLyrTblRec.Description = sLayerName + " создан программой"
                acLyrTblRec.LineWeight = LineWeight.LineWeight015
 
                acLyrTblRec.IsPlottable = True
                acLyrTblRec.IsOff = False
                acLyrTblRec.IsFrozen = False
                acLyrTblRec.IsLocked = False
 
                'Обновляем таблицу слоев для записи
                acLyrTbl.UpgradeOpen()
 
                'Добавляем новый слой в таблицу слоев
                acLyrTbl.Add(acLyrTblRec)
                acTrans.AddNewlyCreatedDBObject(acLyrTblRec, True)
            End If
 
            'Сохранение изменений и завершение транзакции
            acTrans.Commit()
        End Using
    End Sub
 
    Public Sub Zoom(ByVal pMin As Point3d, ByVal pMax As Point3d, _
      ByVal pCenter As Point3d, ByVal dFactor As Double)
 
        '' Получаем текущий документ и его базу данных
        Dim acDoc As Document = Application.DocumentManager.MdiActiveDocument
        Dim acCurDb As Database = acDoc.Database
        Dim nCurVport As Integer = System.Convert.ToInt32(Application.GetSystemVariable("CVPORT"))
 
        '' Получаем границы текущего пространства, когда не задано ни одной точки, или задана
        '' Только центральная точка
 
        '' проверяем, является ли пространство модели текущим.
        If acCurDb.TileMode = True Then
            If pMin.Equals(New Point3d()) = True And _
            pMax.Equals(New Point3d()) = True Then
                pMin = acCurDb.Extmin
                pMax = acCurDb.Extmax
            End If
        Else
 
            '' Проверяем, является ли пространство листа текущим.
            If nCurVport = 1 Then
                If pMin.Equals(New Point3d()) = True And _
                pMax.Equals(New Point3d()) = True Then
                    pMin = acCurDb.Pextmin
                    pMax = acCurDb.Pextmax
                End If
            Else
 
                '' Получаем границы пространства модели
                If pMin.Equals(New Point3d()) = True And _
                pMax.Equals(New Point3d()) = True Then
                    pMin = acCurDb.Extmin
                    pMax = acCurDb.Extmax
                End If
            End If
        End If
 
        '' Запускаем транзакцию
        Using acTrans As Transaction = acCurDb.TransactionManager.StartTransaction()
 
            '' Получаем текущий вид
            Using acView As ViewTableRecord = acDoc.Editor.GetCurrentView()
                Dim eExtents As Extents3d
 
                '' Переводим систему координат WCS (международную систему координат) в DCS (систему координат отображения)
                Dim matWCS2DCS As Matrix3d
                matWCS2DCS = Matrix3d.PlaneToWorld(acView.ViewDirection)
                matWCS2DCS = Matrix3d.Displacement(acView.Target - Point3d.Origin) * matWCS2DCS
                matWCS2DCS = Matrix3d.Rotation(-acView.ViewTwist, _
                acView.ViewDirection, _
                acView.Target) * matWCS2DCS
 
                '' Если центральная точка указана, определяем
                '' минимальную и максимальную точку границ
                '' для режимов Center (центр) и Scale (масштаб)
 
                If pCenter.DistanceTo(Point3d.Origin) <> 0 Then
                    pMin = New Point3d(pCenter.X - (acView.Width / 2), _
                    pCenter.Y - (acView.Height / 2), 0)
 
                    pMax = New Point3d((acView.Width / 2) + pCenter.X, _
                    (acView.Height / 2) + pCenter.Y, 0)
                End If
 
                '' Создаём границы используя отрезок
                Using acLine As Line = New Line(pMin, pMax)
 
                    eExtents = New Extents3d(acLine.Bounds.Value.MinPoint, _
                    acLine.Bounds.Value.MaxPoint)
                End Using
 
                '' Вычисляем отношение ширины  текущего вида к его высоте
                Dim dViewRatio As Double
                dViewRatio = (acView.Width / acView.Height)
 
                '' Изменяем границы вида
                matWCS2DCS = matWCS2DCS.Inverse()
                eExtents.TransformBy(matWCS2DCS)
 
                Dim dWidth As Double
                Dim dHeight As Double
                Dim pNewCentPt As Point2d
 
                '' Проверяем, что центральная точка была обеспечена(режимы Center (центр) и Scale(масштаб))
                If pCenter.DistanceTo(Point3d.Origin) <> 0 Then
                    dWidth = acView.Width
                    dHeight = acView.Height
 
                    If dFactor = 0 Then
                        pCenter = pCenter.TransformBy(matWCS2DCS)
                    End If
 
                    pNewCentPt = New Point2d(pCenter.X, pCenter.Y)
 
                Else
                    '' Работа в окне, в режимах Extents (границы) и Limits (лимиты)
                    '' Вычисляем новую ширину и высоту текущего вида
 
                    dWidth = eExtents.MaxPoint.X - eExtents.MinPoint.X
                    dHeight = eExtents.MaxPoint.Y - eExtents.MinPoint.Y
 
                    '' Получаем центральную точку вида
                    pNewCentPt = New Point2d(((eExtents.MaxPoint.X + eExtents.MinPoint.X) * 0.5), _
                    ((eExtents.MaxPoint.Y + eExtents.MinPoint.Y) * 0.5))
                End If
 
                '' Проверяем, вписывается ли новая ширина в текущее окно
                If dWidth > (dHeight * dViewRatio) Then dHeight = dWidth / dViewRatio
 
                '' Изменяем размеры и масштабируем вид
                If dFactor <> 0 Then
                    acView.Height = dHeight * dFactor
                    acView.Width = dWidth * dFactor
                End If
 
                '' Устанавливаем центральную точку вида
                acView.CenterPoint = pNewCentPt
 
                '' Устанавливаем вид текущим
                acDoc.Editor.SetCurrentView(acView)
            End Using
 
            '' Завершаем изменения
            acTrans.Commit()
        End Using
    End Sub
 
 
 
 
End Class
 
 
 
Class VPortJig
    Inherits EntityJig
    Private mCenterPt As Point3d, mActualPoint As Point3d
 
    Public Sub New(br As Viewport)
        MyBase.New(br)
        mCenterPt = br.CenterPoint
    End Sub
 
    Protected Overrides Function Sampler(prompts As JigPrompts) As SamplerStatus
        Dim jigOpts As New JigPromptPointOptions()
        jigOpts.UserInputControls = (UserInputControls.Accept3dCoordinates Or UserInputControls.NoZeroResponseAccepted Or UserInputControls.NoNegativeResponseAccepted)
        jigOpts.Message = ControlChars.CrLf & "Укажите точку вставки: "
        Dim dres As PromptPointResult = prompts.AcquirePoint(jigOpts)
        If mActualPoint = dres.Value Then
            Return SamplerStatus.NoChange
        Else
            mActualPoint = dres.Value
        End If
        Return SamplerStatus.OK
    End Function
 
    Protected Overrides Function Update() As Boolean
        mCenterPt = mActualPoint
        Try
            DirectCast(Entity, Viewport).CenterPoint = mCenterPt
            DirectCast(Entity, Viewport).UpdateDisplay()
        Catch generatedExceptionName As System.Exception
            Return False
        End Try
        Return True
    End Function
 
    Public Function GetEntity() As Entity
        Return Entity
    End Function
End Class

Обновляются в основном версии для автокадов 2011 … 2015

ссылка на youtube