Программа для облегчения создания видовых портов из модели
Программа написана на VB.Net под AutoCAD.
Тестировалась на:
Представляет из себя библиотеку (dll) загружаемую в autocad командой: _Netload
Создаем Впорты из модели.
Масштаб впорта берется из названия размерного стиля
TODO Вот это необходимо корректировать. Программа должна сама, на основе примитивов попавших в прямоугольник впорта, выставить необходимый масштаб впорта. Т.о. программа должна проанализировать размеры, блоки и др. элементы и понять какой необходимо выставить масштаб или при невозможности определить масштаб запрашивала его у пользователя
Схема работы:
Скачать программу можно тут: 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