ADN Club > VBA
Создание нового чертежа dxf
Anatoly:
Надо из открытого документа dwg взять нужные объекты и сохранить как dxf.
Или сначала создать dxf, а потом скопировать объекты.
Александр Ривилис:
Document.Export в dxf - но насколько я помню экспортируется все из чертежа. Поэтому лишнее придётся в чертеже предварительно стереть. Ну или забыть про VBA.
Можно еще Document.SaveAs если нужно в формат определённой версии DXF.
Anatoly:
Если кому-то нужно, то вот.
--- Код - Visual Basic [Выбрать] ---Sub test()Dim ent As AcadEntityDim sset As AcadSelectionSetDim intData() As Integer, varData() As VariantDim objCollection() As ObjectDim activeDoc As AcadDocument'..............................................'dxfnam=.....'intData'varData'..............................................Set sset = ThisDrawing.SelectionSets.Add("SS1")sset.Select acSelectionSetAll, , , intData, varDataIf sset.Count = 0 Then Exit Sub Set activeDoc = ThisDrawing.Application.ActiveDocumentdocpath = activeDoc.Path ReDim objCollection(0 To sset.Count - 1)i = 0 For Each ent In sset Set objCollection(i) = ent i = i + 1Next CopyObjects activeDoc, objCollection, docpath, dxfnam ThisDrawing.SelectionSets.Item("SS1").Delete: Set sset = NothingExit SubEnd Sub'######################################################################################Sub CopyObjects(activeDoc As AcadDocument, objCollection() As Object, docpath, dxfnam)Dim ent As AcadEntityDim newDoc As AcadDocument Set newDoc = Documents.Add ' Create a new drawing retObjects = activeDoc.CopyObjects(objCollection, newDoc.ModelSpace) ' retObjects что-то делаем со скопированными объектами ThisDrawing.SaveAs docpath & "\" & dxfnam, ac2007_dxfnewDoc.CloseExit SubEnd Sub
Александр Ривилис:
А почему ThisDrawing.SaveAs, а не newDoc.SaveAs? Ты же копируешь сохраняешь полный исходный чертеж.
Anatoly:
Нет, я копирую только то, что нужно, что предварительно выбрано SelectionSet'ом.
А ThisDrawing это в данный момент новый документ.
Наверное можно и newDoc.
Навигация
Перейти к полной версии