Leaderboard

Here is a manual way using code above. line is created on current layer ;;----------------------------------------------------------------------;; ;; Make a Copy of Poly Segment. (defun C:CopySegment (/ x poly v Strpt Endpt ) (while (setq x (entsel "\nSelect Polyline Segment to Copy: ")) (setq poly (vlax-ename->vla-object (car x))) (setq v (fix (vlax-curve-getParamAtPoint poly (vlax-curve-getClosestPointTo poly (cadr x))))) (setq StrPt (vlax-Curve-GetPointAtParam poly v)) (setq EndPt (vlax-Curve-GetPointAtParam poly (1+ v))) (entmake (list '(0 . "LINE") (cons 10 StrPT) (cons 11 EndPt))) ) (princ) ) --Edit Only works with straight lines.

Don't have anything myself but prob do something like (ssget "_F" cords of poly 1 ((0 . poly))) to find poly 2 fence only uses x and y so will select things on different elevations. find closest point on ply1 to ply2 ??? (only crossing?) or just select poly1 mouse click near location? use point to find vertex # on ply1 (setq v (fix (vlax-curve-getParamAtPoint poly1 (vlax-curve-getClosestPointTo poly1 pt)))) use vertex to find the points on either side (setq StrPt (vlax-Curve-GetPointAtParam poly1 v)) (setq EndPt (vlax-Curve-GetPointAtParam poly1 (1+ v))) entmake (entmake (list '(0 . "LINE") (cons 10 StrPT) (cons 11 EndPt))) --Edit maybe select both polylines use intes on cords with mapcar to find point? --Edit2 https://www.theswamp.org/index.php?PHPSESSID=fa96fb880a6e370b50e4902edc7e1abf&topic=49865.msg550384#msg550384

Sent you a PM

I uninstalled and reinstalled it worked again. As soon as I import my previous settings it doesn't. I tried to look see what the difference is but I couldn't. I'll attached the settings here in case anyone likes debugging. AutoCAD 2023 - English_cust_settings.zip

haven't looked at the complete code but this isn't gonna work : (= (strcase (vla-get-TagString att)) "Quantity") try this (defun c:savinirsb4u (/ s1 i hnd ent attlst att a b lst temp_lst sel_lst file) (setq file "c:\\Temp\\savinirsb4u.xlsx"); put your own filename here (setq s1 (ssget "_x" (list '(0 . "INSERT") '(2 . "Machine,`**") '(66 . 1) (cons 410 (getvar 'CTAB))))) (repeat (setq i (sslength s1)) (setq hnd (ssname s1 (setq i (1- i)))) (setq ent (entget hnd)) (setq attlst nil) (setq obj (vlax-ename->vla-object hnd)) (setq attlst (vlax-invoke obj 'GetAttributes)) (foreach att attlst (cond ((and (= (strcase (vla-get-TagString att)) "PART_1") (/= (vla-get-TextString att) ""))(setq a (vla-get-TextString att))) ((and (= (strcase (vla-get-TagString att)) "QUANTITY")(/= (vla-get-TextString att) ""))(setq b (atof (vla-get-TextString att)))) ) ) (if (and a b) (progn (if (assoc a lst) (setq lst (subst (cons a (+ b (cdr (assoc a lst)))) (assoc a lst) lst)) (setq lst (cons (cons a b) lst)) ) (setq a nil b nil) ) ) ) (setq lst (mapcar '(lambda (x)(list (car x) (cdr x))) lst)) (if lst (progn (setq lst (vl-sort lst (function (lambda (a b) (< (car a) (car b)))))) (setq i 0) (setq tmp_lst (reverse lst)) (setq sel_lst (cons '("PART NAME." "Quantity") sel_lst)) (setq sel_lst (append sel_lst lst)) ) ) (princ) (gc:WriteExcel file nil nil sel_lst) )

Hi, Try this [uNTESTED] mods of the same program and let me know. (defun c:Blocks2Excel (/ bks int sel ent nm ds b f lst fl op) ;;--------------------------------------------;; ;; ;; ;; Author : Tharwat 10.June.2015 ;; ;; Modified on 3rd.Aug.2017 to allow users to ;; ;; select specific blocks. ;; ;;--------------------------------------------;; ;; Compute the quantity of all blocks in ;; ;; a drawing and write the outcome to an ;; ;; Excel file format in format .csv ;; ;;--------------------------------------------;; ;; Block Name,Description,QTY ;; ;; ;; ;;--------------------------------------------;; (princ"\nSelect blocks :") (if (setq bks (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object))) int -1 sel (ssget '((0 . "INSERT")))) (while (setq ent (ssname sel (setq int (1+ int)))) (if (and (setq nm (vla-get-effectivename (vlax-ename->vla-object ent))) (setq ds (if (vlax-property-available-p (setq b (vla-item bks nm)) 'comments) (vla-get-comments b) "") ) ) (if (vl-some '(lambda (x) (and (eq nm (cadr x)) (setq f x))) lst) (setq lst (subst (list nm ds (1+ (caddr f))) f lst)) (setq lst (cons (list nm ds 1) lst)) ) ) ) ) (setq lst (vl-sort lst '(lambda (j k) (< (car j) (car k))))) (cond ((not lst) (alert "Couldn't find any block in this drawing !!")) ((and (setq fl (getfiled "Specify new Excel file name" (getvar 'DWGPREFIX) "csv" 1)) (setq op (open fl "w")) ) (write-line "Block Name;Description;QTY" op) (mapcar '(lambda (x) (write-line (strcat (car x) ";" (cadr x) ";" (itoa (caddr x))) op)) lst) (close op) ) ) (princ) ) (vl-load-com)

This will get you started Author unknown '' Request reference to Microsoft Excel XX.0 Object Library Option Explicit Public Sub WriteAttributes() Dim oSset As AcadSelectionSet Dim oEnt As AcadEntity Dim oBlkRef As AcadBlockReference Dim oAtt As AcadAttributeReference Dim varAtt As Variant Dim i As Long Dim ftype(1) As Integer Dim fdata(1) As Variant ftype(0) = 0: fdata(0) = "INSERT" ftype(1) = 66: fdata(1) = 1 Dim dxftype As Variant Dim dxfdata As Variant dxftype = ftype dxfdata = fdata '--------------------- Dim xlApp As Object Dim xlBook As Workbook Dim xlSheet As Worksheet Dim lngRow As Long, lngCol As Long '--------------------- On Error Resume Next Set xlApp = GetObject(, "Excel.Application") If Err <> 0 Then Err.Clear Set xlApp = CreateObject("Excel.Application") If Err <> 0 Then MsgBox "Impossible to initialize an Excel.", vbExclamation End End If End If '--------------------- On Error Resume Next Set oSset = ThisDrawing.SelectionSets.Item("$Attribs$") If Err Then Err.Clear Set oSset = ThisDrawing.SelectionSets.Add("$Attribs$") End If On Error GoTo Err_Control oSset.SelectOnScreen dxftype, dxfdata '--------------------- xlApp.Visible = True Set xlBook = xlApp.Workbooks.Add xlBook.Sheets.Add.Name = 1 Set xlSheet = xlBook.Sheets(1) lngRow = 1 xlSheet.Cells(lngRow, 1).Value = "Block Name" xlSheet.Rows(1).Font.Bold = True xlSheet.Rows(1).Font.ColorIndex = 5 '--------------------- lngRow = 2 For Each oEnt In oSset Set oBlkRef = oEnt If oBlkRef.IsDynamicBlock Then xlSheet.Cells(lngRow, 1).Value = oBlkRef.EffectiveName Else xlSheet.Cells(lngRow, 1).Value = oBlkRef.Name End If varAtt = oBlkRef.GetAttributes lngCol = 2 For i = 0 To UBound(varAtt) Set oAtt = varAtt(i) xlSheet.Cells(lngRow, lngCol).Value = oAtt.TagString xlSheet.Cells(lngRow + 1, lngCol).Value = oAtt.TextString lngCol = lngCol + 1 Next i lngRow = lngRow + 2 Next oEnt '-------------------- Dim oRange As Range Set oRange = xlSheet.UsedRange For i = 2 To oRange.Columns.Count xlSheet.Cells(1, i).Value = "Attribue " & CStr(i - 1) Next '-------------------- xlSheet.Columns.HorizontalAlignment = xlHAlignLeft xlSheet.Columns.AutoFit xlBook.SaveAs ThisDrawing.Path & "\Attributes.xls" xlBook.Close '-------------------- xlApp.Application.Quit Set xlApp = Nothing Set xlBook = Nothing Set xlSheet = Nothing '-------------------- MsgBox "Excel file was saved as: " & vbCr & ThisDrawing.Path & "\Attributes.xls" '-------------------- Err_Control: End Sub ~'J'~