[griniland]

Формат файла- Xls, Txt, Doc (любой, таблица). Вид (x,y).
Не бейте ногами- форум читал и даже кое-что похожее нашел, да вот беда: во всех найденных темах полилинии снимались по координатам вершин. А для меня это несколько не то (совсем не то).
Задача: Есть полилиния. Задан шаг снятия координат (по X, шаг= 0.01). Нужно быстренько "пробежаться" по полилинии и сбросить в файл координаты. Как это выглядит в ручную-- черчу сетку (шаг 0.01) и снимаю по "ID" координаты пересечения сетки с моей полилинией.
И всё бы ничего, если бы не 12000 пересечений. Буду крайне признателен, мог бы обеспечить даже некоторое вознаграждение за работу. Единственное требование- срочность (желательно до 28 февраля).

[Alaspher]

Сообщение от griniland ... Задача: Есть полилиния. Задан шаг снятия координат (по X, шаг= 0.01). Нужно быстренько "пробежаться" по полилинии и сбросить в файл координаты. Как это выглядит в ручную-- черчу сетку (шаг 0.01) и снимаю по "ID" координаты пересечения сетки с моей полилинией. И всё бы ничего, если бы не 12000 пересечений. Буду крайне признателен, мог бы обеспечить даже некоторое вознаграждение за работу. Единственное требование- срочность (желательно до 28 февраля).

Код:

[Выделить все]

(defun demo (curve step)
  (setq dist 0)
  (while (setq tmp (vlax-curve-getpointatdist curve dist))
    (setq dist (+ dist step)
          res  (cons tmp res)
    )
  )
  (reverse res)
)

Пример вызова:

Код:

[Выделить все]

(demo (vlax-ename->vla-object (car (entsel))) 2)

первый аргумент - полилиния в виде VLA-объекта;
второй аргумент - шаг.

А дальше - берёшь ту часть, которую уже нашёл в форуме (где экспорт по вершинам), соединяешь и получаешь желаемое.

Удачи!

P.S. В данном демо, координаты берутся с шагом по длинне полилинии, а не по оси. Можно и по оси, но это немного геморойнее, см. функции vlax-curve-*.

[griniland]

Большое спасибо! Эх, если бы я ещё знал ЛИСП на достойном уровне =(. Если не трудно, напишите по подробнее...

[Alaspher]

Сообщение от griniland Большое спасибо! Эх, если бы я ещё знал ЛИСП на достойном уровне =(. Если не трудно, напишите по подробнее...

Поподробнее что? Если нужно обязательно отсечки по оси, то тут могут быть 2 варианта. Если полилиния не имеет возвратов (т.е. у неё не может быть 2-х пересечений на одной отсечке, то всё элементарно - используй функцию: vlax-curve-getClosestPointToProjection - там всё достаточно просто. Если же полилиния может иметь возвраты по исследуемой оси, то немного сложнее. Ниже код, который решает эту задачу, но сделан он за 10 минут, из функции предназначенной для других целей, т.ч. за безошибочность не поручусь:

Код:

[Выделить все]

(defun demo (curve step / axi box curve doc lay lock res space start stop)
  (setq doc   (vla-get-document curve)
        lay   (vla-get-activelayer doc)
        space (vla-objectidtoobject doc (vla-get-ownerid curve))
        box   (vla-getboundingbox curve 'start 'stop)
        start (car (vlax-safearray->list start))
        stop  (car (vlax-safearray->list stop))
  )
  (if (= :vlax-true (vla-get-lock lay))
    (progn (vla-put-lock lay :vlax-false) (setq lock t))
  )
  (while (<= start stop)
    (setq axi   (vla-addxline space (vlax-3d-point (list start 0.0)) (vlax-3d-point (list start 1.0)))
          res   (cons (pl:lst-to-lsts
                        (vlax-safearray->list
                          (vlax-variant-value (vla-intersectwith axi curve acextendnone))
                        )
                        3
                      )
                      res
                )
          start (+ start step)
    )
    (vla-delete axi)
  )
  (if lock
    (vla-put-lock lay :vlax-true)
  )
  (mapcar (function cdr)
          (vl-sort (mapcar (function (lambda (a) (cons (vlax-curve-getparamatpoint curve a) a)))
                           (apply (function append) res)
                   )
                   (function (lambda (a b) (< (car a) (car b))))
          )
  )
)

(defun pl:lst-to-lsts (lst modul / _pl:lst-to-lsts)
  (defun _pl:lst-to-lsts (slst i mod / tmp)
    (cond ((not slst) nil)
          ((zerop i) (cons (list (car slst)) (_pl:lst-to-lsts (cdr slst) mod mod)))
          (t
           (setq tmp (_pl:lst-to-lsts (cdr slst) (1- i) mod))
           (cons (cons (car slst) (car tmp)) (cdr tmp))
          )
    )
  )
  (_pl:lst-to-lsts lst (1- modul) (1- modul))
)

Вызов аналогичен предыдущему примеру.

Удачи!

P.S. Предпочитаю обращение на "ТЫ".

[griniland]

Ещё раз спасибо!
Всё. Сдаюсь. Я совсем не знаю ЛИСПа =(. Все моё программирование ограничивается начальным С++.. Здесь же даже синтаксис кажется вражьим.
Кривые могут быть и возвратными. Шаг 0.01.
(Программа, которая считывает вершины без учета шагов)

Код:

[Выделить все]

 
(defun c:coordex (/ e ptl oex wkbs awb mainsh c r) 
  (princ  "\nУкажите сплайн или полилинию > ") 
  (if (and (setq e (ssget "_:S" '((-4 . "<OR") (0 . "LWPOLYLINE") (0 . "SPLINE") (-4 . "OR>")))) 
           (setq e (ssname e 0)) 
           (setq ptl (apply 'append ;_ список точек для вывода 
                            (mapcar '(lambda (el) 
                                       (if (= 10 (car el)) 
                                         (list (cdr el)) 
                                       ) ;_  if 
                                     ) ;_  lambda 
                                    (entget e) 
                            ) ;_  mapcar 
                     ) ;_  apply 
           ) ;_  setq 
      ) ;_  and 

    (progn 
      ;; Установить связь c Excel 
      (setq oex (vlax-get-or-create-object "Excel.Application")) ;_ VLA-объект приложение 
      (if (null oex) ;_ Если связь не установлена, то аварийно завершить работу 
        (progn (alert "Не удается запустить Microsoft Excel") (exit)) 
      ) ;_ if 
      (vlax-put-property oex "Visible" :vlax-true) ;_ сделать Excel видимым 
      (setq wkbs (vlax-get-property oex "Workbooks")) ; Указатель семейства Workbooks 
      (setq awb (vlax-invoke-method wkbs "Add")) ; Создать новую книгу и получить указатель книги 
      (setq mainsh (vlax-get-property awb "ActiveSheet")) ; Указатель на активный лист 

      ;; запись списка 
      (setq r 1) ;_ строка 
      (foreach n ptl 
        (setq c 1) ;_ колонка 
        (foreach m n 
          (setq cell (vlax-variant-value ; получить указатель на ячейку 
                       (vlax-invoke-method 
                         mainsh 
                         "Evaluate" 
                         (strcat (chr (+ 64 c)) (itoa r)) ; номер ячейкм в формате A1 
                       ) ;_  vlax-invoke-method 
                     ) ;_  vlax-variant-value 
          ) ;_  setq 
          (vlax-put-property cell "NumberFormat" (vlax-make-variant "0,0000000000" 8)) ; установить формат 
          (vlax-put-property cell "Value2" (vlax-make-variant m 5)) ; записать данные 
          (vlax-release-object cell) ;_ освободить ячейку 
          (setq c (1+ c)) ;_ следующая колонка 
        ) ;_  foreach 
        (setq r (1+ r)) ;_ следующая строка 
      ) ;_  foreach 

      (vlax-release-object mainsh) ;_ освободить лист 
      (vlax-invoke-method awb "Close" :vlax-true) ; Закрыть книгу 
      (vlax-release-object awb) ;_ освободить книгу 
      (vlax-release-object wkbs) ;_ освободить семейство книг 
;;;          (vlax-invoke-method oex "Quit") ; отключиться и закрыть Excel 
      (vlax-release-object oex) ;_ освободить Excel 
      (princ "\nФайл Excel необходимо сохранить!") 
    ) ;_  progn 
    (princ "\nФайл Excel не создан.") 
  ) ;_  if 
  (princ) 
) ;_  defun 
(vl-load-com)

В какое место надо "врубить" приведенные тобой листинги?
Сам вижу только, что до вызова экселя и после выбора линии...
(я конечно понимаю, что, как в анекдоте: " Ламер подходит к хакеру с текстом программы: " Посмотри, где у меня ошибка?- Хакер: В ДНК!!!"
Зачем это вообще нужно-- не вылететь с 5 курса из института=)))

[Alaspher]

Мне не очень понравились пара моментов в найденном тобой коде, поэтому собрал из своих функций:

Код:

[Выделить все]

(defun c:aprex () (pl:apr-to-ex) (princ))

(defun pl:apr-to-ex (/ books c ccells cols dat excel k nbook next sheet sheets torel)
  (if (setq excel (vlax-get-or-create-object "Excel.Application"))
    (progn (setq books  (vlax-get-property excel 'workbooks)
                 nbook  (vlax-invoke-method books 'add 1)
                 sheets (vlax-get-property nbook 'worksheets)
                 sheet  (vlax-get-property nbook 'activesheet)
                 dat    (pl:get-apr-data)
                 c      0
           )
           (princ (strcat "\nПоиск точек завершён. Обработано полилиний: "
                          (itoa (length dat))
                          "\nНачинается сброс данных в Excel. Пожалуйста, ждите!"
                  )
           )
           (foreach v dat
             (princ (strcat "\nПолилиния: "
                            (itoa (setq c (1+ c)))
                            ", узлов: "
                            (rtos (length v) 2 0)
                    )
             )
             (if next
               (setq torel (cons sheet torel)
                     sheet (vlax-invoke-method sheets 'add)
               )
             )
             (setq ccells (vlax-get-property sheet 'cells)
                   cols   (vlax-get-property sheet 'columns)
                   i      0
             )
             (foreach y v
               (setq i (1+ i)
                     k 0
               )
               (foreach x y (setq k (1+ k)) (pl:put-real-to-cell ccells i k x))
             )
             (vlax-invoke-method cols 'autofit)
             (vlax-release-object cols)
             (vlax-release-object ccells)
             (setq next t)
           )
           (if torel
             (vlax-invoke-method (last torel) 'activate)
           )
           (if (= (vlax-get-property excel 'visible) :vlax-false)
             (vlax-put-property excel 'visible :vlax-true)
           )
           (foreach x (cons sheet
                            (if torel
                              (append torel (list sheets nbook books excel))
                              (list sheets nbook books excel)
                            )
                      )
             (vlax-release-object x)
           )
    )
    (alert "Не могу запустить Excel!")
  )
)

(defun pl:get-apr-data (/ how res sel step)
  (initget "Axi Length")
  (setq how (getkword "\nСпособ апроксимации [Length/Axi] <Axi>: "))
  (initget 7)
  (setq step (getreal "\nШаг апроксимации: ")
        sel  (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
  )
  (vla-clear sel)
  (pl:ent-obj-selectonscreen sel "*POLYLINE")
  (vlax-for i sel
    (setq res (cons (if (= how "Length")
                      (pl:aprox-lwpl-bylen i step)
                      (pl:aprox-lwpl-byaxi i step)
                    )
                    res
              )
    )
  )
)

(defun pl:aprox-lwpl-bylen (curve step / dist res tmp)
  (setq dist 0)
  (while (setq tmp (vlax-curve-getpointatdist curve dist))
    (setq dist (+ dist step)
          res  (cons tmp res)
    )
  )
  (reverse res)
)

(defun pl:aprox-lwpl-byaxi (curve step / axi box doc lay lock res space start stop)
  (setq doc   (vla-get-document curve)
        lay   (vla-get-activelayer doc)
        space (vla-objectidtoobject doc (vla-get-ownerid curve))
        box   (vla-getboundingbox curve 'start 'stop)
        start (car (vlax-safearray->list start))
        stop  (car (vlax-safearray->list stop))
  )
  (if (= :vlax-true (vla-get-lock lay))
    (progn (vla-put-lock lay :vlax-false) (setq lock t))
  )
  (while (<= start stop)
    (setq axi   (vla-addxline
                  space
                  (vlax-3d-point (list start 0.0))
                  (vlax-3d-point (list start 1.0))
                )
          res   (cons (pl:lst-to-lsts
                        (vlax-safearray->list
                          (vlax-variant-value (vla-intersectwith axi curve acextendnone))
                        )
                        3
                      )
                      res
                )
          start (+ start step)
    )
    (vla-delete axi)
  )
  (if lock
    (vla-put-lock lay :vlax-true)
  )
  (mapcar
    (function cdr)
    (vl-sort
      (mapcar (function (lambda (a) (cons (vlax-curve-getparamatpoint curve a) a)))
              (apply (function append) res)
      )
      (function (lambda (a b) (< (car a) (car b))))
    )
  )
)

(defun pl:lst-to-lsts (lst modul / _pl:lst-to-lsts)
  (defun _pl:lst-to-lsts (slst i mod / tmp)
    (cond ((not slst) nil)
          ((zerop i) (cons (list (car slst)) (_pl:lst-to-lsts (cdr slst) mod mod)))
          (t
           (setq tmp (_pl:lst-to-lsts (cdr slst) (1- i) mod))
           (cons (cons (car slst) (car tmp)) (cdr tmp))
          )
    )
  )
  (_pl:lst-to-lsts lst (1- modul) (1- modul))
)

(defun pl:ent-obj-selectonscreen (sel enttype)
  (vla-selectonscreen
    sel
    (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0))
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list enttype))
  )
)

(defun pl:put-real-to-cell (ccells x y val)
  (vlax-put-property
    (vlax-variant-value
      (vlax-get-property
        ccells
        'item
        (vlax-make-variant x vlax-vbinteger)
        (vlax-make-variant y vlax-vbinteger)
      )
    )
    "Value2"
    (vlax-make-variant val vlax-vbdouble)
  )
)

(vl-load-com)

Не исключены недочёты, но в целом - должно работать. Но имей ввиду - механизм связи с Экселем очень медленный, при 12000 узлов - работать будет долго, действительно долго! Прежде чем задавать мелкий шаг, попробуй на крупном (так, что бы было несколько сот узлов) и постепенно уменьшай шаг, что бы сориентироваться - какой для тебя приемлем. Возможно, этот механизм можно подстегнуть, но разбираться - не было нужды. Если скорость критична, то надо делать экспорт в текстовый файл, который потом импортировать в Эксель.

[griniland]

Спасибо огромное! Действительно, выручил! 12000 точек не сразу, а по одной поли- это штук по 500.
Хотя, я и сам уже кое-как написал программу(только что закончил) (оказалось, не такой уж и бестолочь. На VBA, правда по кадовскому встроенному хелпу из кусков.
принцип- по сканируемой прямой перемещается другая прямая с заданным шагом (функция move) и снимается intersectionWith
Воть. Не бей ногами за стиль...

Код:

[Выделить все]

Dim fFile As Integer
fFile = FreeFile

Open "c:\coords.txt" For Output As #fFile 'before start, CREATE this File!!!


' Varaibles
Dim ScanLinePos(0 To 2) As Variant     ' array for x,y,z
Dim ScanLine As AcadObject             '
Dim Line2Scan As AcadObject            '
Dim ScanStep As Double                 ' Offset Distance
Dim PickedPoint As Variant             ' Coords of curve's point
Dim NewPos      As Variant             ' Coords of offsetted curve
Dim UselessPoint As Variant             ' Useless point
Dim IntPoints As Variant                ' Intersection Points
Dim ExtI As Integer                     ' External Cycle
Dim InternI As Integer                  ' Internal Cycle
Dim J As Integer
Dim K As Integer
Dim str As String
Dim TestPoint As AcadPoint
Dim TpLoc(0 To 2) As Double            ' TestPoint Location




  


'Selection of curves
ThisDrawing.Utility.GetEntity ScanLine, PickedPoint, "Select Scanline"
ScanLine.Color = acRed
ScanLine.Update
ThisDrawing.Utility.GetEntity Line2Scan, UselessPoint, "Select Line 2 Scan"

Line2Scan.Color = acYellow
Line2Scan.Update
'cycle Moving and IntersectWith ()
For ExtI = 1 To 100
  J = 0
  K = 0
  IntPoints = Line2Scan.IntersectWith(ScanLine, acExtendNone)
  If VarType(IntPoints) <> vbEmpty Then
        For InternI = LBound(IntPoints) To UBound(IntPoints)
            str = "Intersection Point[" & K & "] is:     " & IntPoints(J) & "     " & IntPoints(J + 1)
            'MsgBox str, , "IntersectWith Example"
            InternI = InternI + 2
            Print #fFile, str
            str = ""
           'TpLoc(0) = IntPoints(J)
           'TpLoc(1) = IntPoints(J + 1)
           'TpLoc(2) = IntPoints(J + 2)
            'Set TestPoint = ThisDrawing.ModelSpace.AddPoint(TpLoc)
            J = J + 3
            K = K + 1
            
        Next
  End If
  
  NewPos = PickedPoint
  NewPos(0) = PickedPoint(0) + 0.01 'CHANGE to your step!!!
  ScanLine.Move PickedPoint, NewPos
  PickedPoint = NewPos
  
Next
ScanLine.Color = acByLayer
ScanLine.Update
Line2Scan.Color = acByLayer
Line2Scan.Update
Close #fFile
End Sub

За желание помочь- искренне человеческое!

[Alaspher]

Я, не настолько знаю Васик, что-бы оценивать чужой код. Если код делает то, для чего разрабатывался, то он, как минимум удовлетворительный. А то, что он сделан своими руками - делает его вдвойне замечательным.

[forgod]

Спасибо мужики!