Экспорт координат полилинии из автокада в excel

Импорт точек из автокада в эксель и наоборот 2014-08-13

Есть окно автокада с точками POINT,нам необходимо их экспортировать в ексель,отрываем ексель,запускаем программку,нажимаем кнопку Автокада (на панельке программы),заходим в акад и выбираем нужные точки,нажимаем интер,возвращаемся в ексель и нажимаем стрелку указывающую на ексель-экспорт точек совершен.Либо выделяем точки в экселе для импорта и жмем стрелочку указывающую на автокад-импорт совершен.Для импотрта точек формат № X Y Z.

Экспорт координат полилинии из автокада в excel

Пример процедуры, отрисовывающей полилинию по точкам, запрашиваемым у пользователя. При вводе точек возможен ввод опций Arc/Close/Length. Если пользователь выбрал опцию Arc, то вновь отрисовываему сегменту будет заданы кривизна (правда, я не понял принцип, по которому задается кривизна дугового сегмента, а именно, принцып задания тангенса ? угла дугового сегмента Bulge). При выборе опции Close полилиния замыкается. Кроме того, вместо ввода точки можно ввести рассояние, и, тогда точка будет расположена на введенном расстоянии от предидущей точки, в направлении, заданным отрезком, соединяющим предидущую точку с точкой полпжения курсора. Для прерываня команды можно нажать клавишу ESC. Для отслеживания нажатия клавиши ESC используется API функция GetAsyncKeyState

Поместите в стандартный модуль следующий код и запустите макрос DrawPline:

Option Explicit Public Const VK_ESCAPE = &H1B Declare Function GetAsyncKeyState Lib "user32" _ (ByVal vKey As Long) As Integer Public Sub DrawPline() Dim blnArc As Boolean Dim strPrompt As String Dim varpnt As Variant Dim dblAngl As Double Static objPLine As AcadPolyline Static dblStrPnt(0 To 2) As Double Dim dblRad(0 To 2) As Double Static varVertList(0 To 5) As Double Dim intNoPnts As Integer Dim KeyWords As String Dim strUserInput As String KeyWords = "Arc Close Line LEngth" strPrompt = "Specify Start Point: " On Error GoTo ErrControl ThisDrawing.Utility.InitializeUserInput 36, KeyWords varpnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrompt) strPrompt = "Specify next point or [Arc/Close/LEngth]: " Do On Error GoTo ErrControl If intNoPnts = 0 Then varVertList(0) = varpnt(0) varVertList(1) = varpnt(1) varVertList(2) = varpnt(2) intNoPnts = intNoPnts + 1 ElseIf intNoPnts = 1 Then varVertList(3) = varpnt(0) varVertList(4) = varpnt(1) varVertList(5) = varpnt(2) Set objPLine = ThisDrawing.ModelSpace.AddPolyline(varVertList) ThisDrawing.Application.Update intNoPnts = intNoPnts + 1 Else dblStrPnt(0) = varpnt(0) dblStrPnt(1) = varpnt(1) dblStrPnt(2) = varpnt(2) intNoPnts = intNoPnts + 1 objPLine.AppendVertex dblStrPnt End If If blnArc Then ' Bulge the vertex (Кривизна сегмента) dblAngl = Atn(ThisDrawing.Utility.AngleFromXAxis _ (objPLine.Coordinate(intNoPnts - 2), varpnt)) * 0.125 ' Thats not the real value, I just made it up for now. ' Честно говоря, я не понял принципа, по которому авторы ' задают кривизну дуги. Упомяну толко, что кривизна дугового ' сегмента задается параметром Bulge, равным тангенсу 1/4 угла ' дуги (Tan(dblAngl/4)). Как задавать эту величину - дело Ваше objPLine.SetBulge intNoPnts - 2, dblAngl End If ThisDrawing.Application.Update ThisDrawing.Utility.InitializeUserInput 36, KeyWords On Error Resume Next varpnt = ThisDrawing.Utility.GetPoint(varpnt, strPrompt) Select_Here: If Err Then If Err.Description = "User input is a keyword" Then strUserInput = ThisDrawing.Utility.GetInput Err.Clear If strUserInput = "Arc" Then blnArc = True strPrompt = "Specify endpoint of arc or [Line/Close]: " ThisDrawing.Utility.InitializeUserInput 36, KeyWords varpnt = ThisDrawing.Utility.GetPoint(varpnt, strPrompt) If Err Then GoTo Select_Here End If ElseIf strUserInput = "Line" Then blnArc = False strPrompt = "Specify next point or [Arc/Close/LEngth]: " ThisDrawing.Utility.InitializeUserInput 36, KeyWords varpnt = ThisDrawing.Utility.GetPoint(varpnt, strPrompt) If Err Then GoTo Select_Here End If ElseIf strUserInput = "Close" Then intNoPnts = intNoPnts + 1 objPLine.Closed = True If blnArc Then dblAngl = Atn(ThisDrawing.Utility.AngleFromXAxis _ (objPLine.Coordinate(intNoPnts - 2), varpnt)) * 0.125 objPLine.SetBulge intNoPnts - 2, dblAngl End If GoTo Exit_Here End If Else GoTo ErrControl End If End If Loop Exit_Here: Exit Sub ErrControl: ' В случе возникновения ошибки проверяем, ' не нажал ли пользователь ESC If CheckKey(VK_ESCAPE) Then Resume Exit_Here ElseIf Err.Description = "User input is a keyword" Then ' Nothing yet! Resume Exit_Here Else MsgBox Err.Description, vbOKOnly, "Llama Control Center" End If End Sub Function CheckKey(lngKey As Long) As Boolean If GetAsyncKeyState(lngKey) Then CheckKey = True Else CheckKey = False End If End Function 

Отрисовка полилинии с вставкой заданного блока в ее вершинах

Пример процедуры, отрисовывающей полилинию по точкам, запрашиваемым у пользователя. При отрисовке полилинии, кроме того, что отрисовывается собственно полилиния, в ее вершины вставляются блоки с заданым именем. Для опробывания примера поместите в стандартный модуль следующий ниже код. Затем создайте в текущем чертеже чертеже блок с именем «BlkName«. Теперь запустите макрос TEST_DrawPlineWsBlock.

Option Explicit Public Sub DrawPlineWsBlock(strBlkName As String, dblScale As Double,_ dblRot As Double) Dim strPrompt As String Dim varPnt As Variant Static objPLine As AcadPolyline Static dblStrPnt(0 To 2) As Double Static varVertList(0 To 5) As Double Static intNoPnts As Integer strPrompt = "Pick The Start Point" On Error Resume Next Do varPnt = Empty varPnt = ThisDrawing.Utility.GetPoint(Prompt:=strPrompt) If IsEmpty(varPnt) Then Exit Do If intNoPnts = 0 Then varVertList(0) = varPnt(0) varVertList(1) = varPnt(1) varVertList(2) = varPnt(2) ThisDrawing.ModelSpace.InsertBlock varPnt, strBlkName, _ dblScale, dblScale, dblScale, dblRot intNoPnts = intNoPnts + 1 ElseIf intNoPnts = 1 Then strPrompt = "Pick the next point" varVertList(3) = varPnt(0) varVertList(4) = varPnt(1) varVertList(5) = varPnt(2) Set objPLine = ThisDrawing.ModelSpace.AddPolyline(varVertList) ThisDrawing.ModelSpace.InsertBlock varPnt, strBlkName, _ dblScale, dblScale, dblScale, dblRot ThisDrawing.Application.Update intNoPnts = intNoPnts + 1 Else dblStrPnt(0) = varPnt(0) dblStrPnt(1) = varPnt(1) dblStrPnt(2) = varPnt(2) intNoPnts = intNoPnts + 1 ThisDrawing.ModelSpace.InsertBlock varPnt, strBlkName, _ dblScale, dblScale, dblScale, dblRot objPLine.AppendVertex dblStrPnt ThisDrawing.Application.Update End If Loop While Val(varPnt(0)) End Sub Public Sub TEST_DrawPlineWsBlock() Dim strBlkName As String ' Имя блока Dim dblScale As Double ' Масштаб вставки блока Dim dblRotAng As Double ' Угол поворота блока strBlkName = "BlkName" dblScale = 1 dblRotAng = 0 DrawPline strBlkName, dblScale, dblRotAng End Sub 

Определение выбранного пользователем сегмента полилинии

После запуска AddSelectedPoint у пользователя запрашивается полилиния. После указания полилинии к ней добавляется вершина, координаты которой совпадают с точкой указания полилинии. К сожалению функция ThisDrawing.Utility.GetEntity используемая для запроса у пользователя полилинии, и возвращающая точку указания, работает не совсем точно. Точка указания, возвращаемая этой функцией, не находится на указанном объекте, что вызвано тем, что курсор мыши имеет квадратную форму и собственные размеры, а точка указания находится в центре этого курсора. К сожалению разработчики (в версии AutoCAD 2000) не позаботились о том, чтобы функция ThisDrawing.Utility.GetEntit при возвращени точки указания вычисляла координаты точки, лежащей на указанном объекте и ближайшей к точке курсора мыши. Может в более поздних версиях ситуация изменится?

Option Explicit Private Declare Function PtInRegion Lib "gdi32" _ (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long Private Declare Function CreateRectRgn Lib "gdi32" _ (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _ ByVal Y2 As Long) As Long Private Declare Function DeleteObject Lib "gdi32" _ (ByVal hObject As Long) As Long ' Добавление к выбранной полилинии вершины в ' указанной пользователем точке. Вершина добавляется в ' сегмент, ближайший к указанной точке Public Sub AddSelectedPoint() Dim varPnt As Variant Dim objPline As AcadLWPolyline Dim varStart As Variant Dim varEnd As Variant Dim lngRgn As Long Dim intVCnt As Integer Dim varCords As Variant Dim varVert As Variant Dim varCord As Variant Dim varNext As Variant Dim intCrdCnt As Integer Dim dblTemp As Double Dim intCnt As Integer Dim dblVertex(0 To 1) As Double On Error GoTo Err_Control intCnt = 1 ThisDrawing.Utility.GetEntity objPline, varPnt varCords = objPline.Coordinates For Each varVert In varCords intVCnt = intVCnt + 1 Next For intCrdCnt = 0 To intVCnt / 2 - 1 If intCrdCnt < intVCnt / 2 - 1 Then varCord = objPline.Coordinate(intCrdCnt) varNext = objPline.Coordinate(intCrdCnt + 1) lngRgn = CreateRectRgn(CLng(varCord(0)), _ CLng(varCord(1)), CLng(varNext(0)), CLng(varNext(1))) If PtInRegion(lngRgn, CLng(varPnt(0)), CLng(varPnt(1))) <> 0 Then dblVertex(0) = varPnt(0) dblVertex(1) = varPnt(1) objPline.AddVertex intCnt, dblVertex Exit For End If DeleteObject lngRgn End If intCnt = intCnt + 1 Next intCrdCnt Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub ' Second Function ' This one returns the nearest segment to the picked point: ' Функция возвращает номер сегмента, ближайшего к указанной ' точке Public Function ReturnSegment() As Integer Dim varPnt As Variant Dim objPline As AcadLWPolyline Dim varStart As Variant Dim varEnd As Variant Dim lngRgn As Long Dim intVCnt As Integer Dim varCords As Variant Dim varVert As Variant Dim varCord As Variant Dim varNext As Variant Dim intCrdCnt As Integer Dim dblTemp As Double Dim intCnt As Integer On Error GoTo Err_Control intCnt = 1 ThisDrawing.Utility.GetEntity objPline, varPnt varCords = objPline.Coordinates For Each varVert In varCords intVCnt = intVCnt + 1 Next For intCrdCnt = 0 To intVCnt / 2 - 1 If intCrdCnt < intVCnt / 2 - 1 Then varCord = objPline.Coordinate(intCrdCnt) varNext = objPline.Coordinate(intCrdCnt + 1) lngRgn = CreateRectRgn(CLng(varCord(0)), _ CLng(varCord(1)), CLng(varNext(0)), CLng(varNext(1))) If PtInRegion(lngRgn, CLng(varPnt(0)), CLng(varPnt(1))) <> 0 Then ReturnSegment = intCnt Exit For End If DeleteObject lngRgn End If intCnt = intCnt + 1 Next intCrdCnt Exit_Here: Exit Function Err_Control: MsgBox Err.Description Resume Exit_Here End Function 

В данном примере при определении номера указанного пользователем сегмента используется API функции CreateRectRgn и PtInRegion. В цыкле перебираются все сегменты полилинии. Через вершины сегментов строится прямоугольный регион, а затем проверяется, находится ли точка внутри полигона. Если точка внутри полигона, то, считается, что сегмент найден. Такой способ очень не точен. взгляните на рисунок с низу. В случае а) все сработает, а вот в случае б) функция может вернуть не верный номер сегмента, здесь все зависит от того, в каком порядке сегменты добавлялись к полилинии. Какой сегмент был создан раньше, тот и будет возвращен. А в случе в) функция вообще не найдет ближайшего сегмента. Также этот метод не сработает в случае с вертикальными или горизонтальными прямолинейными сегментами.

Попробуйте сами решить эту проблему. Я решил ее находя в цикле рассояния от точки, возвращаемой функцией GetEntity до каждого сегмента полилинии по нормали. До какого сегмента расстояние меньше, тот и считается выбранным. Честно говоря, код получился не из изящных, поэтому, хоть я и не заметил ошибок в его работе, здесь я его размещать не буду.

Набор функций для получения свойств сегмента полилинии

Набор приведенных ниже функций позволит определить вид сегмента (Линия, Окружность, Дуга), и, если сегмент является дугой, то можно определить радиус дугового сегмента и координаты его центра.

' Функция, определяющая является ли сегмент перед вершиной ' Vertex полилинии PolyLin дуговым сегментом Public Function IsArc(PolyLin As AcadLWPolyline, _ Optional Vertex As Integer) As Boolean Dim Bulg As Double If Vertex = Empty Then Vertex = 0 Bulg = PolyLin.GetBulge(Vertex) If Bulg <> 0 Then IsArc = True End Function ' Функция, определяющая является ли сегмент перед вершиной ' Vertex полилинии PolyLin окружностью Public Function IsSemiCircle(PolyLin As AcadLWPolyline, _ Optional Vertex As Integer) As Boolean Dim Bulg As Double If Vertex = Empty Then Vertex = 0 Bulg = PolyLin.GetBulge(Vertex) If Bulg = 1 Or Bulg = -1 Then IsArc = True End Function ' Функция принимает значение True, если ли сегмент перед ' вершиной Vertex полилинии PolyLin описан по часовой ' стрелке Public Function ClockWise(PolyLin As AcadLWPolyline, _ Optional Vertex As Integer) As Boolean Dim Bulg As Double If Vertex = Empty Then Vertex = 0 Bulg = PolyLin.GetBulge(Vertex) If Bulg < 0 Then ClockWise = True End Function ' Функция определяющая радиус дугового сегмента полилинии Public Function Radius(PolyLin As AcadLWPolyline, _ Optional Vertex As Integer) As Double Dim PolyPts As Variant Dim PolySp(0 To 2) As Double Dim PolyEp(0 To 2) As Double Dim Lin1 As AcadLine Dim Ang As Double Dim IsoAng As Double Dim Bulg As Double If Vertex = Empty Then Vertex = 0 Bulg = PolyLin.GetBulge(Vertex) Ang = Atn(Bulg) * 4 IsoAng = Ang / 3.141592654 * 180 If IsoAng < 0 Then IsoAng = (IsoAng + 180) / 2 Else IsoAng = (180 - IsoAng) / 2 End If IsoAng = IsoAng / 180 * 3.141592654 PolyPts = PolyLin.Coordinates PolySp(0) = PolyPts(0): PolySp(1) = PolyPts(1) PolyEp(0) = PolyPts(2): PolyEp(1) = PolyPts(3) Set Lin1 = ThisDrawing.ModelSpace.AddLine(PolySp, PolyEp) Radius = (Lin1.Length / 2) / Cos(IsoAng) Lin1.Delete End Function ' Функция определяющая радиус дугового сегмента полилинии ' В отличие от предидущей функции как параметры здесь ' используютсе не Полилиния и Номер сегмента а собственно ' Начальная и Конечнная точки сегмента и параметр, харак- ' терезующий кривизну сегмента полилинии, равный ' Tg(SAng/4), где SAng - угол дугового сегмента Public Function BulgeRadius(varSPnt As Variant, _ varEPnt As Variant, dblbulge As Double) As Double Dim dblLen As Double Dim dblInclAng As Double Dim dblRad As Double Dim dblAng As Double dblLen = Sqr(((varSPnt(0) - varEPnt(0)) ^ 2) + _ ((varSPnt(1) - varEPnt(1)) ^ 2)) dblInclAng = Atn(Abs(dblbulge)) * 4 dblAng = (dblInclAng / 2) - ((Atn(1) * 4) / 2) dblRad = (dblLen / 2) / (Cos(dblAng)) BulgeRadius = dblRad End Function ' Функция, возвращающая координаты точки центра дугового ' сегмента полилинии Public Function CenterPt(PolyLin As AcadLWPolyline, _ Optional Vertex As Integer) As Variant Dim PolyPts As Variant Dim PolySp(0 To 2) As Double Dim PolyEp(0 To 2) As Double Dim Lin1 As AcadLine Dim Ang As Double Dim IsoAng As Double Dim Radius As Double Dim ClockWise As Boolean Dim RadAng As Double Dim Bulg As Double If Vertex = Empty Then Vertex = 0 Bulg = PolyLin.GetBulge(Vertex) PolyPts = PolyLin.Coordinates PolySp(0) = PolyPts(0): PolySp(1) = PolyPts(1) PolyEp(0) = PolyPts(2): PolyEp(1) = PolyPts(3) Set Lin1 = ThisDrawing.ModelSpace.AddLine(PolySp, PolyEp) Ang = Atn(Bulg) * 4 IsoAng = Ang / 3.141592654 * 180 If IsoAng < 0 Then IsoAng = (IsoAng + 180) / 2 ClockWise = True Else IsoAng = (180 - IsoAng) / 2 End If IsoAng = IsoAng / 180 * 3.141592654 If ClockWise Then RadAng = Lin1.Angle + IsoAng + 3.141592654 Else RadAng = Lin1.Angle - IsoAng + 3.141592654 End If Radius = (Lin1.Length / 2) / Cos(IsoAng) CenterPt = ThisDrawing.Utility.PolarPoint(PolyEp, RadAng, Radius) Lin1.Delete End Function ' Функция определяющая центр дугового сегмента полилинии ' В отличие от предидущей функции как параметры здесь ' используютсе не Полилиния и Номер сегмента а собственно ' Начальная и Конечнная точки сегмента и параметр, харак- ' терезующий кривизну сегмента полилинии, равный ' Tg(SAng/4), где SAng - угол дугового сегмента Public Function BulgeCenterPnt(varSPnt As Variant, _ varEPnt As Variant, dblbulge As Double) As Variant Dim dblLen As Double Dim dblInclAng As Double Dim dblRad As Double Dim dblAng As Double Dim dblStart(2) As Double Dim dblEnd(2) As Double Dim varCenter As Variant Dim dblBase As Double Dim dblMid(2) As Double dblStart(0) = varSPnt(0) dblStart(1) = varSPnt(1) dblEnd(0) = varEPnt(0) dblEnd(1) = varEPnt(1) 'To keep these functions encapsulated I recreated 'The code you see in the radius function. dblLen = Sqr(((varSPnt(0) - varEPnt(0)) ^ 2) + _ ((varSPnt(1) - varEPnt(1)) ^ 2)) dblInclAng = Atn(Abs(dblbulge)) * 4 dblAng = (dblInclAng / 2) - ((Atn(1) * 4) / 2) dblRad = (dblLen / 2) / (Cos(dblAng)) dblBase = ThisDrawing.Utility.AngleFromXAxis(dblStart, _ dblEnd) If dblbulge > 0 Then varCenter = ThisDrawing.Utility.PolarPoint(dblStart, _ dblBase - dblAng, dblRad) Else varCenter = ThisDrawing.Utility.PolarPoint(dblStart, _ dblBase + dblAng, dblRad) End If BulgeCenterPnt = varCenter End Function 

Определение длины полилинии с помощью метода Explode

Представленная ниже функция определяет длину полилинии, не зависимо то того, из каких сегментов состоит эта полилиния (прямолинейных или дуговых), замкнута она или нет. Способ очень оригинальный. Здесь используется метод Explode, разбивающий полилинию на отрезки и дуги, эквивалентные ее сегментам. При этом все полученные таким образом примитивы оказываются в массиве объектов varExploded. Остается только пройтись по членам массива узнавая их длины и суммируя полученные значения, и, не забывая удалять их из чертежа. Все основано на том, чт окоманда Explode и метод Explode работают по разному. Команда удаляет взорваный объект, а метод не удаляет. Для опробывания функции поместите в стандартный модуль следующий код, создайте в чертеже несколько полилиний и запустите процедуру TEST_PolyLength

Option Explicit ' Функция, определяющая длину полилинии Public Function PolyLength(objPline As AcadLWPolyline) As Double Dim intCnt As Integer Dim varExploded As Variant Dim dblLen As Double On Error GoTo Error_Control varExploded = objPline.Explode ' Создаем масив примитивов, ' эквивалентных сегментам полилинии For intCnt = LBound(varExploded) To UBound(varExploded) If TypeOf varExploded(intCnt) Is AcadLine Then ' Текущий примитив - Отрезок dblLen = dblLen + varExploded(intCnt).Length ' Определяем длину varExploded(intCnt).Delete ' Удаляем отрезок ElseIf TypeOf varExploded(intCnt) Is AcadArc Then ' Текущий примитив - Дуга dblLen = dblLen + varExploded(intCnt).ArcLength ' Определяем длину varExploded(intCnt).Delete ' Удаляем дугу End If Next intCnt PolyLength = dblLen Exit_Here: Exit Function Error_Control: MsgBox Err.Description, Err.Number Resume Exit_Here End Function Public Sub TEST_PolyLength() Dim objGen As Object Dim varPnt As Variant Dim dblVal As Double On Error GoTo Err_Control ThisDrawing.Utility.GetEntity objGen, varPnt, "Select a polyline: " dblVal = PolyLength(objGen) MsgBox dblVal Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub 

Определение длины полилинии расчетным путем

Не смотря на то, чт опредидущий способ мне больше по душе, тем не менее, расчетный способ тоже имеет право на существование. Итак:

Option Explicit Public Function PlineLenEX(objPLine As AcadLWPolyline) As Double Dim intVCnt As Integer Dim varCords As Variant Dim varVert As Variant Dim varCord As Variant Dim varNext As Variant Dim intCrdCnt As Integer Dim dblTemp As Double Dim dblArc As Double Dim dblAng As Double Dim dblChord As Double Dim dblInclAng As Double Dim dblRad As Double varCords = objPLine.Coordinates For Each varVert In varCords intVCnt = intVCnt + 1 Next 'For intCrdCnt = 0 To intVCnt / 3 - 1 ' Для AcadPolyline ' If intCrdCnt For intCrdCnt = 0 To intVCnt / 2 - 1 ' Для AcadLWPolyline If intCrdCnt Then ' Для AcadLWPolyline If objPLine.GetBulge(intCrdCnt) = 0 Then varCord = objPLine.Coordinate(intCrdCnt) 'If intCrdCnt < intVCnt / 3 - 1 Then ' Для AcadPolylineIf intCrdCnt < intVCnt / 2 - 1 Then ' Для AcadLWPolyline varNext = objPLine.Coordinate(intCrdCnt + 1) Else If objPLine.Closed Then varNext = objPLine.Coordinate(0) Else Exit For End If End If 'computes a simple Pythagorean length ' Для AcadPolyline 'dblTemp = dblTemp + Sqr((Sqr(((varCord(0) - varNext(0)) ^ 2) + _ '((varCord(1) - varNext(1)) ^ 2)) ^ 2) + ((varCord(2) - varNext(2)) ^ 2)) ' Для AcadLWPolyline dblTemp = dblTemp + Sqr((Sqr(((varCord(0) - varNext(0)) ^ 2) + _ ((varCord(1) - varNext(1)) ^ 2)) ^ 2)) Else 'If there is a bulge we need to get an arc length varCord = objPLine.Coordinate(intCrdCnt) varNext = objPLine.Coordinate(intCrdCnt + 1) ' Для AcadPolyline 'dblChord = Sqr((Sqr(((varCord(0) - varNext(0)) ^ 2) + _ '((varCord(1) - varNext(1)) ^ 2)) ^ 2) + ((varCord(2) - varNext(2)) ^ 2)) ' Для AcadLWPolyline dblChord = Sqr((Sqr(((varCord(0) - varNext(0)) ^ 2) + _ ((varCord(1) - varNext(1)) ^ 2)) ^ 2)) 'Bulge is the tangent of 1/4 of the included angle between 'vertices. So we reverse the process to get the included angle dblInclAng = Atn(Abs(objPLine.GetBulge(intCrdCnt))) * 4 dblAng = (dblInclAng / 2) - ((Atn(1) * 4) / 2) dblRad = (dblChord / 2) / (Cos(dblAng)) dblArc = dblInclAng * dblRad dblTemp = dblTemp + dblArc End If End If Next PlineLenEX = dblTemp End Function Public Sub TEST_PlineLenEX() Dim objPLine As AcadLWPolyline Dim varPnt As Variant Dim dblPlLenght As Double On Error GoTo Err_Handler ThisDrawing.Utility.GetEntity objPLine, varPnt, "Выберите полилинию" dblPlLenght = PlineLenEX(objPLine) MsgBox "Длина выбранной полилинии " & CStr(dblPlLenght), _ vbInformation + vbOKOnly, "TEST_PlineLenEX" Exit Sub Err_Handler: MsgBox Err.Description Err.Clear End Sub 

Реверс точек полилинии (изменеие направления)

Имеется в виду, что первая точка полилинии становится последней, вторая предпоследней и т.д. Если линия замкнутая, то она разравается. Для опробывания функции поместите в стандартный модуль следующий код, создайте в чертеже несколько полилиний и запустите процедуру TEST_ReverseLWPLine

Option Explicit ' Функция, определяющая длину полилинии Public Function ReverseLWPLine(objPline As AcadLWPolyline) _ As AcadLWPolyline Dim objRet As AcadLWPolyline Dim intVCnt As Integer Dim varCords As Variant Dim intDiv As Integer Dim dblPnts() As Double Dim objSpace As AcadBlock Dim intCnt As Integer Dim intSegCnt As Integer On Error GoTo Err_Control 'Using this method allows you to reverse PLines in blocks! Set objSpace = ThisDrawing.ObjectIdToObject(objPline.OwnerID) intDiv = 2 varCords = objPline.Coordinates ReDim dblPnts(UBound(varCords)) intSegCnt = ((UBound(varCords) - 1) / 2) - 1 For intVCnt = UBound(varCords) To LBound(varCords) Step -intDiv dblPnts(intCnt + 1) = varCords(intVCnt) dblPnts(intCnt) = varCords(intVCnt - 1) intCnt = intCnt + intDiv Next Set objRet = objSpace.AddLightWeightPolyline(dblPnts) For intCnt = 0 To intSegCnt 'Get the Bulge from the original and reverse it objRet.SetBulge intCnt, -objPline.GetBulge(intSegCnt - intCnt) Next intCnt objPline.Delete Set ReverseLWPLine = objRet Exit_Here: Exit Function Err_Control: Select Case Err.Number Case Else MsgBox Err.Description Err.Clear Resume Exit_Here End Select End Function Public Sub TEST_ReverseLWPLine() Dim objGen As Object Dim objPline As AcadLWPolyline Dim varPnt As Variant On Error GoTo Err_Control ThisDrawing.Utility.GetEntity objGen, varPnt, "Select a polyline: " Set objPline = objGen Set objPline = ReverseLWPLine(objPline) Exit_Here: Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub 

Связь площади полилинии с текстовым объектом

Очень интересный пример. Наводит, так сказать, на размышления. Поместите в модуль «ThisDrawing» текущего чертежа следующий ниже код, создайте в чертеже полилинию и текстовый объект (не Мультитекст, а однострочный текст). Запустите макрос Bind и на заданные запросы выберите сначала полилинию, а затем текст. В результате текстовый объект будет отображать площадь полилинии. Но самое интересное в переди. Измените полилинию. Просто ухватитесь за одну из ее вершин мышью и перенесите ее. Если все зделано правильно, то содержимое текстового объекта автоматически обновиться. Вот тут-то и появляются размышления. А что если вместо обычных переменных использовать массивы? Тогда можно будет связывать между собой несколько объетов чертежа. А что если при редактировании одного объекта обновлять не содержимое текстового объекта, а, например, длину другого объекта, задавая его длину расчитанной по формуле величиной, зависящей от длины редактируемого объекта? А что если при закрытии файла соответствующим образом скидывать в базу данных (в текстовый или ini файл, в реестр, наконец) метки связанных между собой примитивов, а при открытии считывать сохраненные метки, обновляя необходимые связи? Как Вам поле для деятельности? Кто сказал что в AutoCAD нет параметризации? Зделаем ее сами!

Option Explicit Dim blnEdit As Boolean Dim WithEvents objPl As AcadLWPolyline Dim objText As AcadText Public Sub Bind() Dim varPnt As Variant Dim objEnt As AcadEntity Dim strPrmt As String On Error GoTo Err_Control strPrmt = vbCr & "Выберите полилинию: " Me.Utility.GetEntity objEnt, varPnt, strPrmt Set objPl = objEnt strPrmt = vbCr & "Выберите текстовый объект: " Me.Utility.GetEntity objEnt, varPnt, strPrmt Set objText = objEnt objText.TextString = objPl.Area Exit_Here: Exit Sub Err_Control: If Err.Description = "Type mismatch" Then Resume Else MsgBox Err.Description Resume Exit_Here End If End Sub Private Sub objPl_Modified(ByVal pObject As AutoCAD.IAcadObject) blnEdit = True End Sub Private Sub AcadDocument_EndCommand(ByVal CommandName As String) On Error GoTo Error_Handler If blnEdit Then objText.TextString = objPl.Area blnEdit = Not blnEdit End If Error_Handler: End Sub 

Сохранение координат полилинии в текстовом файле

Очень часто геодезисты спрашивают: «А нельзя ли сохранить координаты вершин указанной полилинии в текстовом или каком другом файле?» Мне даже попадались примеры на AutoLISP, выполняющие эту задачу. Представляю Вашему вниманю вариант решения этой задачи с помощью VBA. Поместите в стандартный модуль следующий код, создайте полилинию и запустите макрос ExportVerts.

Option Explicit Public Declare Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long Public Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ ' Display and use the File open dialog '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ Public Function ShowOpen() As String Dim strTemp As String Dim VertName As OPENFILENAME VertName.lStructSize = Len(VertName) VertName.hwndOwner = ThisDrawing.HWND VertName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + _ "*.txt" + Chr$(0) VertName.lpstrFile = Space$(254) VertName.nMaxFile = 255 VertName.lpstrFileTitle = Space$(254) VertName.nMaxFileTitle = 255 VertName.lpstrInitialDir = CurDir VertName.lpstrTitle = "Llamas Are Supreme" VertName.flags = 0 If GetOpenFileName(VertName) Then strTemp = (Trim(VertName.lpstrFile)) ShowOpen = Mid(strTemp, 1, Len(strTemp) - 1) End If End Function '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ ' The main procedure, if using normal PLines (Z val) ' Read the comments to get the Z coordinate '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ Public Sub ExportVerts() Dim intVCnt As Integer Dim intFile As Integer Dim strFileName As String Dim strVert As String Dim retCoord As Variant Dim plineObj As AcadLWPolyline Dim intCnt As Integer Dim varVert As Variant Dim varPnt As Variant Dim varCord As Variant Dim intCrdCnt As Integer ThisDrawing.Utility.GetEntity plineObj, varPnt, _ "select the polyline to get vertices from" retCoord = plineObj.Coordinates intCnt = 1 intFile = FreeFile 'This assumes you are opening an existing file! strFileName = ShowOpen If Not Right(strFileName, 4) = ".txt" Then strFileName = strFileName & ".txt" End If Open strFileName For Append As intFile Print #intFile, " " Print #intFile, " Вершины полилинии:" For Each varVert In retCoord intVCnt = intVCnt + 1 Next For intCrdCnt = 0 To intVCnt / 2 - 1 'For normal poly 3 - 1 varCord = plineObj.Coordinate(intCrdCnt) strVert = "Вершина " & CStr(intCrdCnt + 1) & " - X=" & _ CStr(vbdRoundToDecimal(varCord(0), 2)) strVert = strVert & Space(25 - Len(strVert)) & _ "Y #008000"> '@~~~~~~~~~~~~~~~~ POWER CHANGE ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ ' If using normal Polylines, uncomment the next line 'strVert = strVert & Space(40 - Len(strVert)) & _ ' "Z #000080">Print #intFile, strVert Next Close intFile End Sub '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ ' Round it to any place you need, Jon. '@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@ Private Function vbdRoundToDecimal(dblNumber As Variant, _ intPlace As Integer) As Double Dim dblDecimal As Double dblDecimal = 10 ^ intPlace vbdRoundToDecimal = Int(dblNumber * dblDecimal + 0.05) / dblDecimal End Function 

Импорт точек полилинии виз AutoCAD в Excel и экспорт точек из Excel в AutoCAD

Вот еще один пример импорта координат вершин полилинии. На этот раз координаты импортируются из AutoCAD в таблицу Excel.

Создайте новую книгу в MS Excel, перейдите в редактор VBA и выберите пункт меню Tools -> References. В появившемся окне поставьте галочку у пункта AutoCAD 2000 Type Library. Если Вы не находите этого пункта, то нажмите кнопку Browse… и найдите файл acad.tlb. Обычно он находится в корневой папке AutoCAD. Только что мы добавили в проект ссылку на библиотеку AutoCAD, что обеспечит нам доступ ко всем функциям и объектам AutoCAD.Теперь добавьте в стандартный модуль Excel следующий ниже код. Запустите AutoCAD и создайте полилинию. Перейдите к Excel и запустите макрос ImportPoints. При этом AutoCAD активизируется и у Вас запрашивается полилиния. Выберите ее. В текущей таблице в первых двух столбцах появились координаты выбранной Вами полилинии. Теперь сделаем обратную операцию. Вернитесь к AutoCAD и удалите ту полилинию, импорт точек которой Вы только что выполнили. Вернитесь к Excel, выделите те ячейки, в которых содержаться полученные только что координаты и запустите макрос ExportPoints. Перейдите к AutoCAD и Вы увидите, что удаленная полилиния опять на месте.

'***********************ВНИМАНИЕ*************************' ' Следующий ниже код нужно добавить в стандартный модуль ' ' MS Excel. ' '********************************************************* '//////////////////NOTE///////////////////////////////// ' You will need to add a reference to the AutoCAD 2000 ' Type Library to run this example book. Use the "Tools - ' References" menu. If you prefere you can switch to late ' binding by changeing the AutoCAD types to generic objects '//////////////////ПРИМЕЧАНИЕ/////////////////////////////// ' Перед использованием представленных в этом блоке процедур ' Вы должны создать в проекте ссылку на библиотеку AutoCAD 2000 ' Type Library (файл acad.tlb, обычно он находится в корневой ' папке AutoCAD). Для этого выберите пункт меню "Tools - ' References в редакторе VBA от MS Excel Option Explicit Public Sub ImportPoints() Dim objApp As AcadApplication Dim objDoc As AcadDocument Dim objEnt As AcadEntity Dim varPnt As Variant Dim strPrmpt As String Dim intVCnt As Integer Dim varCords As Variant Dim varVert As Variant Dim varCord As Variant Dim varNext As Variant Dim intCrdCnt As Integer On Error GoTo Err_Control Set objApp = GetObject(, "AutoCAD.Application") Set objDoc = objApp.ActiveDocument AppActivate objApp.Caption objDoc.Utility.GetEntity objEnt, varPnt If TypeOf objEnt Is AcadLWPolyline Then AppActivate Application.Caption varCords = objEnt.Coordinates For Each varVert In varCords intVCnt = intVCnt + 1 Next For intCrdCnt = 0 To intVCnt / 2 - 1 varCord = objEnt.Coordinate(intCrdCnt) Application.Cells(intCrdCnt + 1, 1).Value = varCord(0) Application.Cells(intCrdCnt + 1, 2).Value = varCord(1) Next intCrdCnt Else MsgBox "Selected entity was not a LWPolyline" End If Exit_Here: If Not objApp Is Nothing Then Set objApp = Nothing Set objDoc = Nothing End If Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub Public Sub ExportPoints() Dim vertlist() As Double Dim objApp As AcadApplication Dim objDoc As AcadDocument Dim RowCount As Integer Dim strPrmpt As String Dim intCnt As Integer Dim objCell As Object Dim objSheet As Worksheet On Error GoTo Err_Control Set objSheet = ThisWorkbook.Sheets(1) Set objApp = GetObject(, "AutoCAD.Application") Set objDoc = objApp.ActiveDocument RowCount = objSheet.UsedRange.Rows.Count ReDim vertlist((RowCount * 2) - 1) RowCount = 1 For intCnt = LBound(vertlist) To UBound(vertlist) Step 2 vertlist(intCnt) = objSheet.Cells(RowCount, 1).Value vertlist(intCnt + 1) = objSheet.Cells(RowCount, 2).Value RowCount = RowCount + 1 Next objDoc.ModelSpace.AddLightWeightPolyline vertlist objDoc.Regen acActiveViewport Exit_Here: If Not objApp Is Nothing Then Set objApp = Nothing Set objDoc = Nothing End If Exit Sub Err_Control: MsgBox Err.Description Resume Exit_Here End Sub 

Выделение объектов, находящихся на заданном расстоянии от полилинии

Пример выбора объектов, находящихся на заданном расстоянии от выбранной полилинии. Авторы представленого примера слегка лукавят. На самом деле происходит следующее: Пользователь выбирает полилинии и задает дисстанцию. Процедура выясняет габариты полилинии и выбирает все объекты заданного типа на заданном слое, попадающие в прямоугольное окно, стороны которого больше чем габариты полилинии на заданную пользователем величину. К стати, вместо acSelectionSetWindow (при котором выбираются только те объекты, которые полностью попадают в окно) можно подставить acSelectionSetCrossing (тогда будут выбраны и те объекты, которые не попадают в рамку полностью, но пересекаются ею.). Дла того. чтобы посмотреть как работает этот пример создайте в чертеже полилинию, создайте слой с именем Layer1, создайте несколько текстовых объектов рядом и в отдалении от полилинии и на разных слоях. Поместите код в стандартный модуль и запустите процедуру TEST_SelectTextInDist.

Option Explicit Public Function SelectTextInDist(strLayerName As String) _ As AcadSelectionSet Dim objBound As Variant Dim varMin As Variant Dim varMax As Variant Dim varPnt As Variant Dim dblDist As Double Dim strPrompt As String Dim dblFilPntMin(0 To 2) As Double Dim dblFilPntMax(0 To 2) As Double Dim intType(0 To 3) As Integer Dim varData(0 To 3) As Variant Dim objEnt As AcadEntity Dim objSelSet As AcadSelectionSet Dim objSelCol As AcadSelectionSets On Error GoTo Err_Control ' Создаем пустой набор объектов Set objSelCol = ThisDrawing.SelectionSets For Each objSelSet In objSelCol ' Проверяем все существующие наборы If objSelSet.Name = "textindistance" Then ' Если имя любого из существующих набора "trxtindistance" ThisDrawing.SelectionSets.Item("textindistance").Delete ' Удаляем этот набор во избежании ошибки, т.к. 2 набора ' с одинаковыми именами не могут сосуществовать Exit For End If Next Set objSelSet = ThisDrawing.SelectionSets.Add("textindistance") ' Присваеваем вновь созданному набору имя "trxtindistance" strPrompt = vbCrLf & "Select entity: " ' Запрашиваем объект ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrompt ' Запрашиваем расстояние strPrompt = vbCrLf & "Distance around entity to search: " dblDist = ThisDrawing.Utility.GetDistance(Prompt:=strPrompt) ' Определяем габариты выбранного объекта objEnt.GetBoundingBox varMin, varMax ' Расчитываем навые координаты для окна выбора dblFilPntMin(0) = varMin(0) - dblDist dblFilPntMin(1) = varMin(1) - dblDist dblFilPntMax(0) = varMax(0) + dblDist dblFilPntMax(1) = varMax(1) + dblDist ' Обеспечиваем фильтр выбора объектов intType(0) = -4 intType(1) = 0 intType(2) = 8 intType(3) = -4 varData(0) = "" ' Выбираем объекты рамкой с расчитанными габаритами objSelSet.Select acSelectionSetWindow, dblFilPntMin, _ dblFilPntMax, intType, varData Set SelectTextInDist = objSelSet Exit_Here: Exit Function Err_Control: MsgBox Err.Description Resume Exit_Here End Function Public Sub TEST_SelectTextInDist() Dim objEnt As AcadText Dim TestSet As AcadSelectionSet Set TestSet = SelectTextInDist("Layer1") For Each objEnt In TestSet ' Просматриваем все выбранные объекты objEnt.Highlight True ' и подсвечиваем их Next objEnt End Sub 

Аutocad 2011 «извлечение данных» из полилинии

Здравствуйте.
Пытаюсь извлечь данные из полилинии мне нужны координаты вершин X, Y, в мастере извлечения данных в «фильтре категорий» в свойстве «геометрия» этих данных для полилинии нет. Как можно решить мою задачу?

Просмотров: 38625
Регистрация: 29.10.2004
Сообщений: 16,333
команда _list
Регистрация: 14.06.2011
Сообщений: 2

Спасибо.
А нет возможности получить координаты в виде таблицы excel, или другой какой либо таблицы которую можно в excel вставить. Просто когда у полилинии три десятка вершин очень долго копировать поштучно 60 координат в excel таблицу.

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

Я поражен! Первым же вопросом новичок приятно порадовал глубиной проникновения в Акад.
Действительно, у полилинии при извлечении данных нет координат ее вершин. Что, впрочем и понятно, 1 полилиния = 1 примитив, хотя и составной.
Тут смотря какая цель стоит, так и надо действовать. Для одной полилинии и одноразовой работы — List, как уже сказали. Для автоматизации надо доработать.
1. Расставить блоки или точки в каждой вершине полилинии (кажется, есть такой лисп)
2. Извлекать инфо для расставленных блоков.
Как-то так.

__________________
В MEP моя буква — Е
Последний раз редактировалось Andi55, 16.06.2011 в 12:42 .
Регистрация: 02.09.2009
Тында, Дальний Восток
Сообщений: 404

В AutoCAD Civil 3d есть функция расстановки точек по узлам полилинии, с последующим выводом их в табличную форму, можно и в Эксель

Оснащение проходки горных выработок, ПОС, нормоконтроль, КР, АР

Регистрация: 30.01.2008
Сообщений: 18,648

Не сочтите некрофилом, но помогите разобраться поподробнее, пожалуйста.
Точки я научился ставить по полилинии, а как таблицу с координатами получить ?

И у меня почему то дикие координаты.
Сделал новую пользовательскую систему (верх Х вправо y) в точке с координатой 0;0.
Но всё равно в «Редактор точек » координаты видимо пишутся из системы мировой МСК.

Пишутся :
Восточное положение
Северное положение

А
Восточное положение в координатах сетки
и Северное положение в координатах сетки
не пишутся

__________________
«Безвыходных ситуаций не бывает» барон Мюнхаузен
Регистрация: 11.05.2005
Сообщений: 6,991
Сообщение от avax

А нет возможности получить координаты в виде таблицы excel, или другой какой либо таблицы которую можно в excel вставить

__________________
Как использовать код на Лиспе читаем здесь
Регистрация: 31.07.2011
Сообщений: 12

Уважаемый, VVA, давно и с большим удовольствием пользуюсь Вашим скриптами из серии Coord (CoorN и ECoor), спасибо за Ваш труд! Но тут вдруг задача возникла нетипичная и кроме как с этим Лиспом решить не получается, что собственно и причина моего обращения. Если Вам не особо сложно, подскажите пожалуйста, в каком месте кода надо подправить, чтоб для COORT и COORNP можно было возвратить в результате нечто похожее на это:

 
;(setq ptLst (mapcar '(lambda(x)(mapcar 'rtos x)) ptlst)) ;возвратить результат в ед. чертежа 1:1 (setq ptLst (mapcar '(lambda(x)(mapcar 'rtos (mapcar '(lambda(y)(* y 0.001)) x))) ptlst)) ;возвратить результат 1:1000
по аналогии с тем, как я поступал по Вашему совету с кодом COORN в таких случаях, но теперь я использую Ecoor и сам конечно же не могу разобраться с Lisp. 
обычно это сильно не беспокоило, но сейчас такая задача, что надо работать со своими чертежами, а они обычно 1:1, но в файл надо выводить в метрах.
И ещё, если не трудно посмотрите пожалуйста, что можно сделать, чтоб последняя точка на замкнутом POLYLINE не отрисовывалась в чертеж, но в списке присутствовала и в файл выводилась как первая точка? 
Спасибо!
Последний раз редактировалось baleew, 31.07.2011 в 19:14 . Причина: зы

Регистрация: 11.05.2005

Сообщений: 6,991

baleew, Там все очень просто. 
Берем за основу ECoor. Там все сделано функциями. 
Для COORN 
Было 






(defun c:COORN ( / ptLst) (vl-load-com) (if (setq ptLst (vva-get-final-points-list)) ;_В ptlst список полученных точек (vva-export-point ptLst t nil) ;_Экспорт списка ptlst ) (princ) )
(defun c:COORN ( / ptLst) (vl-load-com) (if (setq ptLst (vva-get-final-points-list)) ;_В ptlst список полученных точек (progn (setq ptLst(mapcar '(lambda(x)(mapcar '* x (list 0.001 0.001 0.001)))ptlst)) ;_Возвратить результат М 1:1000 (vva-export-point ptLst t nil) ;_Экспорт списка ptlst );_end of progn ) (princ) )
Для COORT найди строчки 
(setq txtList (reverse txtList)) (princ "\n+++++++ Coordinates list +++++++\n")
И добавь после txtlist 
(setq txtList (reverse txtList)) (setq ptLst(mapcar '(lambda(x)(mapcar '* x (list 0.001 0.001 0.001)))ptlst)) ;_Возвратить результат М 1:1000 (princ "\n+++++++ Coordinates list +++++++\n")
По поводу последней просьбы: внес изменения в Ecoor.lsp Пока выкладываю здесь. Потестируй и обязательно отпишись. Тогда обновлю по ссылке


ECoor.LSP (26.1 Кб, 547 просмотров)


__________________ 
Как использовать код на Лиспе читаем здесь

Последний раз редактировалось VVA, 02.08.2011 в 20:38 .

Регистрация: 31.07.2011

Сообщений: 12
Спасибо, VVA, с масштабом вроде всё понятно, хотя в случае с COORNP рекомендованный способ не вполне срабатывает, т.е. задача с выводом списка в файл решается, но отрисовки нет. В общем я немного поправил код в самой функции vva-export-point, в месте где было:






 
(setq ptLst (mapcar '(lambda (x) (mapcar 'rtos x)) ptlst))
 
(setq scale 0.001) ;_потом доделаю с вводом переменной (setq ptLst (mapcar '(lambda(x)(mapcar 'rtos (mapcar '(lambda(xx)(* xx scale)) x))) ptlst)) ;_возвратить результат M 1:scale
так пока всё работает, с этим вопросом решено, спасибо!
С новым вариантом ECoor.LSP проблема! Скрипт завершается (похоже аварийно) после ввода step. Т.е., что вводится -- значения не имеет, просто ломается на этой процедуре.
Регистрация: 24.09.2010

Сообщений: 215

Сообщение от Tyhig

как таблицу с координатами получить ?

Экспорт точек или групп точек в любом удобном Вам формате файла и порядком данных.

Регистрация: 11.05.2005

Сообщений: 6,991

baleew, Обновил #9. Забыл добавить библиотечную функцию. Тестируй

__________________ 
Как использовать код на Лиспе читаем здесь

Регистрация: 31.07.2011

Сообщений: 12
VVA, теперь работает, _.-TEXT вводит так как и хотелось -- на 1 раз меньше чем в списке, вернее чем должно быть в списке. С отрисовкой в чертёж всё в порядке. 
Но теперь в списке на 1 элемент больше чем надо:
+++++++ Coordinates list +++++++ 41759.704,20823.350,0.000 67609.351,45879.144,0.000 66230.217,57772.704,0.000 75151.045,57713.885,0.000 75375.554,45050.840,0.000 91383.441,28535.769,0.000 61943.562,0.000,0.000 41759.704,20823.350,0.000 41759.704,20823.350,0.000 +++++++++ End of list +++++++++
и возникла ещё очень неприятная штука с выводом в файл, а именно -- на LUPREC вообще не обращает внимания, выводит после дес.точки всё подряд: 






1;41759.70447416601;20823.35011575372;0.000000000000 2;67609.35080235823;45879.14403409230;0.000000000000 3;66230.21693950517;57772.70379885008;0.000000000000 4;75151.04496178588;57713.88493783308;0.000000000000 5;75375.55402835457;45050.84007264581;0.000000000000 6;91383.44074345006;28535.76929118578;0.000000000000 7;61943.56163667888;0.000000000007;0.000000000000 1;41759.70447416601;20823.35011575372;0.000000000000 1;41759.70447416601;20823.35011575372;0.000000000000
ps. ну с этим я тоже вроде разобрался, там в строчках: (rtos (cadr ln) 2 12) -- это можно отрегулировать и по аналогии с первым вариантом ECoor.LSP, если без двух последних аргументов, то используются текущие значения LUNITS и LUPREC. Если так, то этот вопрос тоже снят.
Последний раз редактировалось baleew, 02.08.2011 в 12:29 . Причина: ps

Регистрация: 11.05.2005

Сообщений: 6,991
baleew, Обновил #9 Пробуй. Я считал, что нужно выводить в отчет все точки полилиний. Получается, что нужно выводить в отчет все различные точки?
__________________ 
Как использовать код на Лиспе читаем здесь

Регистрация: 31.07.2011

Сообщений: 12
VVA, да в отчёт надо выводить все точки полилиний, но в случае если полилиния замкнута (т.е. координаты первой и последней точек совпадают), в отчете последняя точка тоже присутствует, но не как №4 (в случае с треугольником), а как №1 и со своими координатами (или координатами №1, что собственно без разницы). Другими словами, в отчете должно всё выглядеть так же как и в самом первом варианте ECoor.lsp, с той только разницей, что в колонке "N" для последней точки должно использоваться имя первой точки, они должны выглядеть как будто бы это одна и та же точка. По сути первый вариант скрипта делает всё правильно, надо только в отчете переименовать последнюю точку на первую. Ну и в чертеже сейчас выглядит всё так как надо.






ps/ для наглядности привожу результат исполнения последнего варианта ECoor.LSP
1;41759.704;20823.350;0.000 2;67609.351;45879.144;0.000 3;66230.217;57772.704;0.000 4;75151.045;57713.885;0.000 5;75375.554;45050.840;0.000 6;91383.441;28535.769;0.000 7;61943.562;0.000;0.000
но ожидается такое:
1;41759.704;20823.350;0.000 2;67609.351;45879.144;0.000 3;66230.217;57772.704;0.000 4;75151.045;57713.885;0.000 5;75375.554;45050.840;0.000 6;91383.441;28535.769;0.000 7;61943.562;0.000;0.000 1;41759.704;20823.350;0.000
Последний раз редактировалось baleew, 02.08.2011 в 13:30 .

Регистрация: 11.05.2005

Сообщений: 6,991

Обновил еще раз #9. Надеюсь последний

__________________ 
Как использовать код на Лиспе читаем здесь

Регистрация: 31.07.2011

Сообщений: 12
VVA, да, спасибо большое, всё работает! А со своими чертежами, так вообще -- красота, скрипт теперь можно считать совсем близким к идеальному. 
Но, Владимир, я наверное сразу невнятно обрисовал задачу. Мне хотелось
Моя проблема состояла в том, что сейчас вот пришлось разбираться с чужим планом, который во-первых был нарисован в 1000 раз мельче моих и во-вторых "грязный". Все многоугольники нарисованы так, что количество сегментов полилинии равно количеству сторон (если честно, я сам не сразу увидел), т.е. не как обычная замкнутая поллиния, а такая которая если даже не замкнута выглядит в чертеже как многоугольник (замкнутая полилиния). И если даже точки у неё "дотянуты", но их всё равно на одну больше, чем должно быть, а координаты двух последних совпадают с первой. К примеру для прямоугольного треугольника, где a,b =10, в свойствах полилинии получается такое:






0.000,0.000,0.000 0.000,10.000,0.000 10.000,0.000,0.000 0.000,0.000,0.000
но в своих планах я обычно рисую не так (как это делают разные прилады у кадастровых инженеров, в пред. варианте), а просто, как делает ACAD
0.000,0.000,0.000 0.000,10.000,0.000 10.000,0.000,0.000
в этом случае и старый скрипт делал всё правильно в отчете, за исключением нумерации последней вершины.
Потому я и попросил тебя, чтоб ты научил скрипт приводить такие (кадастровые) варианты к виду:
1;0.000;0.000;0.000 2;0.000;10.000;0.000 3;10.000;0.000;0.000 1;0.000;0.000;0.000
Чистить все чужие полилинии или наоборот -- перерисовывать свои, сам понимаешь, весьма муторное занятие, поэтому огромное тебе спасибо за существенное облечение труда. 
А вообще-то я иногда очень жалею, что я не кодер, на базе одного твоего ECoor можно было бы собрать великолепную утилиту, которая бы решила абсолютно все геодезические проблемы. 
Спасибо, Владимир.
Регистрация: 11.05.2005

Сообщений: 6,991






Обновил #9 Раньше обрабатывались варианты: 
- начало/конец совпадают, полилиния незамкнутая 
- начало/конец не совпадают, полилиния замкнутая 
В варианте начало/конец совпадают, полилиния замкнутая появлялась лишняя точка. В принципе такое так же может быть в середине полилинии, если пару раз подряд ткнули в одну точку. Добавил функцию удаления из списка одинаковых (до 1e-6) подряд идущих точек. Тестируй
__________________ 
Как использовать код на Лиспе читаем здесь

Регистрация: 31.07.2011

Сообщений: 12
VVA, да, это кажется именно то, что надо, только желательно такую же процедуру наверное и к ptLst применить тоже, ибо сейчас из отчёта номер точки удаляется, а X,Y,Z остаются. 
в варианте -- начало/конец почти совпадают, полилиния замкнутая:
1;0.000;0.000;0.000 2;0.000;10.000;0.000 3;10.000;0.000;0.000 ;0.000;0.001;0.000 1;0.000;0.000;0.000
в варианте -- начало/конец почти совпадают, полилиния незамкнутая:
1;0.000;0.000;0.000 2;0.000;10.000;0.000 3;10.000;0.000;0.000 ;0.000;0.001;0.000
но отрисовка в чертеж в обоих случаях срабатывает великолепно! 
ps/ оба варианта с "грязным" многоугольником, в случае с нормальным построением к скрипту претензий никаких. Понимаю, что в идеале надо было бы "почистить" весь план, удалить из всех полилиний последние (и очень близко лежащие) вершины и замкнуть полилинии, но если бы их было поменьше о скрипте и мысль бы не возникла. В общем я не знаю уже, что тут проще, может быть даже нет смысла различать их по свойству замкнуто/незамкнуто, а просто в обоих случаях удалять из списка последнюю точку (с координатами очень близкими к началу) и вместо неё записывать первую. То есть список для отчета формировать так же как и список для отрисовки точек. 
Т.е. если последняя точка очень близка к первой (с допуском определенной точности, от 1e-2 и менее) то в результате она просто не появляется в списках и в отчете полилиния описывется так:






1;0.000;0.000;0.000 2;0.000;10.000;0.000 3;10.000;0.000;0.000 1;0.000;0.000;0.000
Форум для экологов

Есть еще один хитрый и универсальный способ переносить координаты из а-када в эксель или наоборот. С макросом IZACoords для источников выбросов он наверное уже не актуален, но подойдет если надо снять большой массив вершин какой-нибудь изолинии или если нет возможности установить этот макрос. 
Спойлер
1. Чертим полилинию (или обводим ИЗА или др.объекты) и выделяем ее. Жмакаем на кнопку "Список" на панельке "Сведения".
2. Координаты высветятся в окошке.

3. Копируем их в Word.
4. Автозаменой (Ctrl+H) меняем "••••••••••в•точке••X=••••" и "••Z=••••••••0" на пустое поле "", а "••Y=•••" на знак табуляции "^t". Все без кавычек, конечно. Текст в кавычках, который нужно заменить, копируется в окно автозамены из документа (Ctrl+C, Ctrl+V), то есть ничего набирать не надо.






5. Выделяем все (Ctrl+A) и копируем в Excel (чтобы сбросить формат, можно сначала скопировать из Word в блокнот, а от туда в Excel).
1. Выделяем массив X, Y в Экселе. 
2. Копируем в блокнот (не в Ворд) 
3. Если разделителем дробной части были запятые, то автозаменой меняем на точки 
4. Знаки табуляций меняем за запятые (табуляцию можно скопировать из блокнота) 
5. Копируем весь массив из блокнота 
6. Выбираем команду в автокаде, например, полилиния или копирование 
7. Вставляем массив в командную строку
Этот способ юзаю много лет. При определенной сноровке, перенос координат становится минутным делом.

masm0
Che Guevara Эколог Сообщения: 115 Зарегистрирован: 11 авг 2014, 10:50 Откуда: Вологда Благодарил (а): 112 раз Поблагодарили: 36 раз






Re: Как перенести координаты из AutoCad в Excel 
 Сообщение Che Guevara » 13 сен 2014, 18:05
А разве ткнув любую точку на съемке нам не выдает справа в панели ее коордианаты? 
А там все просто ctrl+c ctrl+v! Мне так наши геодезисты объясняли! Вот только х - это y и наоборот y - это х!
Будьте реалистами - требуйте невозможного.
Che Guevara
Эколог Сообщения: 231 Зарегистрирован: 08 окт 2013, 22:00 Награды: 2 Откуда: Санкт-Петербург Благодарил (а): 17 раз Поблагодарили: 92 раза
Re: Как перенести координаты из AutoCad в Excel 
 Сообщение Yasva » 13 сен 2014, 19:59






cheslav писал(а): А там все просто ctrl+c ctrl+v! Мне так наши геодезисты объясняли!
А если хотя бы 100 точек? Точки можно снять через Сервис-Извлечение данных, выдаст список координат точек в порядке их создания. Только фиг упомнишь в каком порядке тыкал точки и какие координаты к какой из них относятся.
Yasva
Автор темы
  
Модератор Сообщения: 2334 Зарегистрирован: 10 сен 2008, 09:41 Награды: 12 Откуда: Ленинград Благодарил (а): 598 раз Поблагодарили: 1330 раз Контактная информация:
Re: Как перенести координаты из AutoCad в Excel 
 Сообщение masm0 » 14 сен 2014, 06:43
cheslav, есть. Но для одной точки. А я привожу способ для тысяч или миллионов точек. Я его изобрел, когда делал объединенную СЗЗ для 50+ предприятий. У них были разные системы координат. В половине проектов (СЗЗ, ПДВ) жопорукие проектировщики не соблюдали масштаб. Мне приходилось сначала накладывать источники на карту, потом их править, а потом обратно снимать координаты. Если бы я снимал координаты по свойствам, то работа бы заняла годы. А так сделал всё за неделю.

masm0
Алена Юсупова Новичок Сообщения: 1 Зарегистрирован: 03 дек 2022, 14:33 Откуда: Уфа
Re: Как перенести координаты из AutoCad в Excel 
 Сообщение Алена Юсупова » 03 дек 2022, 19:46
Здравствуйте, попробовала установить на 2017 автокад, поместила файл IZACoords в корневой каталог установленной версии и добавила в приложения автозагрузки, но при установлении «Классического Автокада» не появилась вкладка «Координаты ИЗА». Подскажите пожалуйста, может вы усовершенствовали приложение или пользуетесь другими методами? Очень бы помогло в работе. Заранее большое спасибо.
Алена Юсупова
Эколог Сообщения: 396 Зарегистрирован: 21 май 2010, 10:16 Награды: 2 Откуда: Далеко Благодарил (а): 42 раза Поблагодарили: 144 раза
Re: Как перенести координаты из AutoCad в Excel 
 Сообщение nightroad » 05 дек 2022, 09:14
Алена Юсупова , пользуйтесь командной строкой для загрузки и выгрузки данного модуля - команда "_APPLOAD", далее Enter - в открывшемся окне заходите в каталог, где лежит IZACoords - два клика мышкой. Для выгрузки открываете также через командную строку диалоговое окно, в нижней части будет список загруженных модулей, находим IZACoords, выделяем и нажимаем "Выгрузить".
nightroad
Сообщений: 6 • Страница 1 из 1

Программы для экологов
↳ Online сервисы для экологов
↳ ЭкоПлатформа
↳ Программные продукты серии "Эколог" - программы для экологов
↳ УПРЗА "Эколог" - программа для расчета рассеивания
↳ "ПДВ-Эколог" - программа для разработки проекта ПДВ
↳ "Эколог-Шум" 2 - программа для расчета шума
↳ "СЗЗ-Эколог" - программа для разработки и корректировки СЗЗ
↳ Отходы - программы по безопасному обращению с отходами
↳ "АТП-Эколог" - программа для расчета выбросов от АТП
↳ Воздух - программы для расчета выбросов загрязняющих веществ
↳ Серия "ЭкоМастер"
↳ Электронные ключи
Нормативно-методические вопросы
↳ Законодательство - экологическое законодательство
↳ Законодательство по воздуху
↳ Законодательство по воде
↳ Законодательство по земле
↳ Законодательство по отходам
↳ Законодательство по плате
↳ Законодательство по СЗЗ
↳ Законодательство по проектной документации
↳ Охрана атмосферного воздуха
↳ Литература
↳ Коды и ПДК веществ
↳ Теплоэнергетика
↳ Транспорт
↳ Лакокраска
↳ Сварка
↳ Деревообработка
↳ Металообработка
↳ Сельское хозяйство + Пищевая промышленность
↳ Строительство
↳ Резервуары и АЗС
↳ Объекты добычи, переработки, транспортировки нефти и газа
↳ Дизель
↳ Отчетность
↳ Парниковые газы
↳ Безопасное обращение с отходами
↳ Литература
↳ Расчет количества отходов
↳ Лицензирование
↳ ПНООЛР
↳ Паспортизация
↳ Компонентный состав, расчет класса опасности, ФККО
↳ Перечень образующихся отходов
↳ Отчетность
↳ Утилизация отходов
↳ Обращение с твердыми коммунальными отходами (ТКО)
↳ Охрана водной среды
↳ Литература
↳ Законодательство
↳ Отчетность
↳ Акустика
↳ Литература
↳ Шумовые характеристики
↳ Экологическая отчетность, производственный экологический контроль и экологический аудит
↳ Экологические платежи
↳ Отчетность в области охраны атмосферного воздуха
↳ Отчетность в области обращения с отходами
↳ Отчетность в области охраны водной среды
↳ Производственный экологический контроль
↳ Экологический аудит
↳ СЗЗ - санитарно защитная зона
↳ Законодательство
↳ "СЗЗ-Эколог" - программа для разработки и корректировки СЗЗ
↳ Разделы проектной документации
↳ Вопросы связанные с ОВОС
↳ Вопросы связанные с ПМООС (ООС)
↳ Общие вопросы: ОВОС, ПМООС(ООС)
↳ ПОС
↳ ИТМ ГОЧС
↳ Пожаробезопасность
↳ Прочие вопросы проектно-сметной документации
↳ Инженерные изыскания
↳ Экологические платежи
↳ Платежи за выбросы ЗВ в атмосферный воздух
↳ Платежи за сброс ЗВ
↳ Платежи за размещение отходов
↳ Ущерб
↳ Электромагнитное излучение
↳ Вибрация
↳ Охрана земельных ресурсов
↳ Законодательство
↳ Растительный и животный мир
↳ Водные биоресурсы
↳ Литература для экологов
↳ Литература по воздуху
↳ Литература по отходам
↳ Литература по акустике
↳ Литература по воде
↳ Общее
Курсы и семинары для экологов
↳ Учебный центр ИПК "Интеграл" - курсы для экологов
Прочее
↳ Общение
↳ Конкурсы
↳ Люблю готовить
↳ Юмор
↳ Наш сайт, форум
↳ Новости Фирмы "Интеграл"
↳ Новости в сфере экологии
↳ Работа, вакансии, резюме
↳ Ищу работу
↳ Предлагаю работу
Экологам предприятий
↳ Экологические платежи
↳ Отчетность
↳ Отчетность в области охраны атмосферного воздуха
↳ Отчетность в области обращения с отходами
↳ Отчетность в области охраны водной среды
↳ Производственный экологический контроль
↳ Экологический аудит
↳ Экологическое законодательство
↳ Лицензирование
Правила
↳ Правила
Корзина
↳ Корзина
АРХИВ
↳ "Эколог-Шум"
↳ УПРЗА "Эколог" 3

Ответственность
Форум "Форум для экологов" является общедоступным для всех зарегистрированных пользователей и осуществляет свою деятельность с соблюдением действующего законодательства РФ. 
Администрация форума не осуществляет контроль и не может отвечать за размещаемую пользователями на форуме "Форум для экологов" информацию. 
Вместе с тем, Администрация форума резко отрицательно относится к нарушению авторских прав на территории "Форум для экологов". 
Поэтому, если Вы являетесь обладателем исключительных имущественных прав, включая:
- исключительное право на воспроизведение; 
- исключительное право на распространение; 
- исключительное право на публичный показ; 
- исключительное право на доведение до всеобщего сведения
и Ваши права тем или иным образом нарушаются с использованием данного форума, мы просим незамедлительно сообщать нам по электронной почте. 
Ваше сообщение в обязательном порядке будет рассмотрено. Вам поступит сообщение о результатах проведенных действий, относительно предполагаемого нарушения исключительных прав. 
При получении Вашего сообщения с корректно и максимально полно заполненными данными жалоба будет рассмотрена в срок, не превышающий 5 (пяти) рабочих дней.
Наш email: eco@integral.ru
ВНИМАНИЕ! Мы не осуществляем контроль за действиями пользователей, которые могут повторно размещать ссылки на информацию, являющуюся объектом Вашего исключительного права. 
Любая информация на форуме размещается пользователем самостоятельно, без какого-либо контроля с чьей-либо стороны, что соответствует общепринятой мировой практике размещения информации в сети интернет. 
Однако мы в любом случае рассмотрим все Ваши корректно сформулированные запросы относительно ссылок на информацию, нарушающую Ваши права. 
Запросы на удаление НЕПОСРЕДСТВЕННО информации со сторонних ресурсов, нарушающей права, будут возвращены отправителю.

ИнтегралПорталСписок форумов
Часовой пояс: UTC+03:00
Удалить cookies
Связаться с администрацией



Похожие публикации:

Неизвестная команда m2p автокад
Ни один из созданных элементов не является видимым на виде в revit
Овальные отверстия для чего применяют
От чего зависит электроемкость проводника