Giới thiệu
Trên bản vẽ mặt bằng, chỗ các dầm, tường hay đường giao thông gặp nhau luôn để lại những nét cắt chéo qua nút giao. Dọn từng nút bằng TRIM, BREAK rất mất thời gian, nhất là với bản vẽ có hàng trăm nút giao.
Auto Join (lệnh AJ) là lisp miễn phí giúp cắt các nút giao tự động: chỉ cần quét một khung, lisp tự bẻ các đối tượng tại giao điểm và xóa các đoạn thừa ở nút, xử lý riêng theo từng layer.
Áp dụng cho: nút giao dầm, tường trên mặt bằng kiến trúc, kết cấu và nút giao đường giao thông.
Tính năng chính
• Quét vùng bằng khung chọn có tô màu, chọn được nhiều vùng liên tục trong một lần chạy lệnh.
• Hỗ trợ Line, Arc, Circle, Polyline, Ellipse, Spline, Region (Ellipse/Spline được đổi thành Polyline, Region được explode trước khi xử lý).
• Xử lý theo từng layer: chỉ cắt các đối tượng cùng layer với nhau.
• Tự bẻ tại giao điểm và xóa đoạn có chiều dài ≤ 1,5 lần bề rộng lớn nhất đã nhập.
• Tự mở khóa layer bị khóa khi chạy và khóa lại khi xong; gom thành một lần Undo.
Cách sử dụng cơ bản
1 Tải file lisp bên dưới (hoặc copy phần code và lưu thành tệp .lsp), gõ APPLOAD để nạp vào AutoCAD.
2 Gõ lệnh AJ. Lần đầu sẽ hiện hộp thoại Auto Join License: bấm Copy để lấy Request Code, gửi cho chúng tôi để nhận License Number và dán vào để kích hoạt.
3 Nhập bề rộng lớn nhất của đối tượng (dòng lệnh Enter maximum width of beam, mặc định 200, Enter để giữ). Các đoạn ngắn hơn hoặc bằng 1,5 lần giá trị này tại nút giao sẽ bị xóa.
4 Bấm điểm thứ nhất, rê chuột và bấm điểm thứ hai để quét vùng có các nút giao cần cắt. Lặp lại cho vùng khác.
5 Bấm Esc để kết thúc. Gõ U nếu muốn trả lại toàn bộ thao tác.
Lưu ý: nhập đúng bề rộng lớn nhất của dầm/tường/đường. Giá trị quá lớn có thể xóa cả những đoạn ngắn có ích, nên thử trên bản sao bản vẽ trước. Lisp chạy trên AutoCAD bản Windows.
Code lisp
-------------------------------------------------------------------------------------------------------------------
(defun C:AJ ( /
CheckStop
LengthSegmentMax
ListVlaLayerLock
ListVarSystem_OldValue
ToleranceDistance
ToleranceSelection
ToleranceValue
; ToleranceWidthMax
ToleranceWidthMaxTemp
VlaDrawingCurrent
VlaSpace)
-------------------------------------------------------------------------------------------------------------------
(defun LIC_REQUESTCODE ( /
CheckLicense
CodeSoftware
ListCharTotal
ListNumHash
ListSerialNumTotal
ListSerialString
ListStringQuery
NameSoftware
NumCharTotal
NumCodeSoftware
NumRequestCode
NumHash
NumSeedMax
NumSeed
Pos
RequestCode
LicenseKey
LicenseKeyExact)
(setq NameSoftware "Auto Join")
(defun LIC_LOAD_DIALOG ( NameSoftware /
End_Main_DCL
Main_DCL
LicenseKey)
(defun LIC_GET_TILE_LICENSENUMBER ( / )
(setq LicenseKey (vl-string-trim " " (get_tile "Tile_LicenseNumber")))
(setq ListNumHash (vl-string->list RequestCode))
(setq NumSeed (rem (apply '+ ListNumHash) NumSeedMax))
(setq LicenseKeyExact "")
(foreach NumHash ListNumHash
(setq LicenseKeyExact (strcat LicenseKeyExact (nth (rem (setq NumSeed (rem (abs (fix (+ NumHash (* (sin NumSeed) NumSeedMax)))) NumSeedMax)) NumCharTotal) ListCharTotal)))
)
(if (= LicenseKeyExact LicenseKey)
(progn
(vl-registry-write (strcat "HKEY_CURRENT_USER\\Software\\Cad Standard\\" NameSoftware) "License Key" LicenseKey)
(set_tile "Tile_ActivateText" "The official version has been activated!")
(mode_tile "Tile_ActivateText" 1)
(mode_tile "Tile_LicenseNumber" 1)
)
(progn
(set_tile "Tile_ActivateText" "License number is incorrect!")
(mode_tile "Tile_ActivateText" 1)
(mode_tile "Tile_LicenseNumber" 0)
)
)
(setq LicenseKeyExact Nil)
)
(LIC_MAKE_FILE_DCL NameSoftware)
(setq Main_DCL (load_dialog (strcat NameSoftware " License.dcl")))
(new_dialog (strcat (LIC_REMOVE_SPACE_OF_STRING NameSoftware) "License") Main_DCL)
(setq LicenseKey "")
(LIC_SET_TILE_DECORATION 4)
(set_tile "Tile_RequestCode" RequestCode)
(action_tile "Tile_LicenseNumber" "(LIC_GET_TILE_LICENSENUMBER)")
(action_tile "Tile_CopyRequestCode" "(vlax-invoke (vlax-get (vlax-get (vlax-create-object \"HTMLFile\") 'ParentWindow) 'ClipBoardData) 'setData \"Text\" RequestCode)")
(setq End_Main_DCL (start_dialog))
(cond
(
(or
(= End_Main_DCL 0)
(= End_Main_DCL 1)
)
(unload_dialog Main_DCL)
)
)
(setq LIC_GET_TILE_LICENSENUMBER Nil)
(princ)
)
-------------------------------------------------------------------------------------------------------------------
(defun LIC_MAKE_FILE_DCL ( NameSoftware /
Num
DclFile
DirectoryDes)
(setq DirectoryDes (strcat (getvar "roamablerootprefix") "Support"))
(setq DclFile (open (strcat DirectoryDes "\\" NameSoftware " License.dcl") "w"))
(write-line "///------------------------------------------------------------------------" DclFile)
(write-line (strcat "/// " NameSoftware " License.dcl") DclFile)
(write-line (strcat (LIC_REMOVE_SPACE_OF_STRING NameSoftware) "License:dialog{") DclFile)
(write-line (strcat "label = \"" NameSoftware " License\";") DclFile)
(write-line " :text{" DclFile)
(write-line " key = \"Tile_ActivateText\";" DclFile)
(write-line " alignment = centered;" DclFile)
(write-line " width = 60;" DclFile)
(write-line " }" DclFile)
(write-line " :text{" DclFile)
(write-line " key = \"sep0\";" DclFile)
(write-line " }" DclFile)
(write-line " :column{" DclFile)
(write-line " width = 60;" DclFile)
(write-line " :text{" DclFile)
(write-line " label = \" You are using the trial version of this app.\";" DclFile)
(write-line " }" DclFile)
(write-line " :text{" DclFile)
(write-line " label = \" If you find it useful, you can pay 5 USD per license.\";" DclFile)
(write-line " }" DclFile)
(write-line " :text{" DclFile)
(write-line " label = \" Then you will not see this message board every time you use the application.\";" DclFile)
(write-line " }" DclFile)
(write-line " :text{" DclFile)
(write-line " label = \" Please contact phamhoangnhat@gmail.com (+84 933 648 160) .\";" DclFile)
(write-line " }" DclFile)
(write-line " :text{" DclFile)
(write-line " label = \" Thank you for using and supporting.\";" DclFile)
(write-line " }" DclFile)
(write-line " }" DclFile)
(write-line " :text{" DclFile)
(write-line " key = \"sep1\";" DclFile)
(write-line " }" DclFile)
(write-line " :row{" DclFile)
(write-line " :text{" DclFile)
(write-line " label = \" Request code\";" DclFile)
(write-line " width = 15;" DclFile)
(write-line " }" DclFile)
(write-line " :text{" DclFile)
(write-line " key = \"Tile_RequestCode\";" DclFile)
(write-line " width = 45;" DclFile)
(write-line " }" DclFile)
(write-line " }" DclFile)
(write-line " :text{" DclFile)
(write-line " key = \"sep2\";" DclFile)
(write-line " }" DclFile)
(write-line " :row{" DclFile)
(write-line " :text{" DclFile)
(write-line " label = \" Enter license\";" DclFile)
(write-line " width = 15;" DclFile)
(write-line " }" DclFile)
(write-line " :edit_box{" DclFile)
(write-line " key = \"Tile_LicenseNumber\";" DclFile)
(write-line " width = 45;" DclFile)
(write-line " }" DclFile)
(write-line " }" DclFile)
(write-line " :text{" DclFile)
(write-line " key = \"sep3\";" DclFile)
(write-line " }" DclFile)
(write-line " :row{" DclFile)
(write-line " :button{" DclFile)
(write-line " label = \"&Continue\";" DclFile)
(write-line " key = \"Ok\";" DclFile)
(write-line " is_default = true;" DclFile)
(write-line " is_cancel = true;" DclFile)
(write-line " width = 30;" DclFile)
(write-line " }" DclFile)
(write-line " :button{" DclFile)
(write-line " label = \"Copy &request code\";" DclFile)
(write-line " key = \"Tile_CopyRequestCode\";" DclFile)
(write-line " width = 30;" DclFile)
(write-line " }" DclFile)
(write-line " }" DclFile)
(write-line "}" DclFile)
(close DclFile)
)
-------------------------------------------------------------------------------------------------------------------
(defun LIC_SET_TILE_DECORATION ( NumTotal / Num Tile)
(setq Num 0)
(repeat NumTotal
(setq Tile (strcat "sep" (itoa Num)))
(set_tile Tile "--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------")
(setq Num (+ Num 1))
)
)
-------------------------------------------------------------------------------------------------------------------
(defun LIC_REMOVE_SPACE_OF_STRING ( String / )
(while (/= String (setq StringTemp (vl-string-subst "" " " String)))
(setq String StringTemp)
)
)
-------------------------------------------------------------------------------------------------------------------
(defun LIC_GETSERIALNUMBER ( StringQuery StringNameSerial /
SerialNumber
VlaObjectLocal
VlaObjectServive
VlaObjectSet)
(setq VlaObjectLocal (vlax-create-object "WbemScripting.SWbemLocator"))
(setq VlaObjectServive (vlax-invoke VlaObjectLocal 'ConnectServer nil nil nil nil nil nil nil nil))
(setq Server (vlax-invoke VlaObjectLocal 'ConnectServer "." "root\\cimv2"))
(setq VlaObjectSet
(vlax-invoke
VlaObjectServive
"ExecQuery"
StringQuery
)
)
(vlax-for VlaObject VlaObjectSet
(setq SerialNumber (vlax-get VlaObject StringNameSerial))
)
SerialNumber
)
-------------------------------------------------------------------------------------------------------------------
(vl-load-com)
(setq ListStringQuery
(list
(cons "Select * from Win32_BaseBoard" "SerialNumber")
(cons "Select * from Win32_BIOS" "SerialNumber")
)
)
(setq ListSerialString (cons NameSoftware (mapcar '(lambda (x) (LIC_GETSERIALNUMBER (car x) (cdr x))) ListStringQuery)))
(setq ListSerialString (vl-remove Nil ListSerialString))
(setq ListSerialNumTotal (mapcar 'vl-string->list ListSerialString))
(setq LIC_GETSERIALNUMBER Nil)
(setq ListCharTotal (list "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
(setq NumCharTotal (length ListCharTotal))
(setq NumSeedMax 100000000)
(setq ListNumHash (vl-string->list NameSoftware))
(setq NumSeed (rem (apply '+ ListNumHash) NumSeedMax))
(setq CodeSoftware "")
(setq NumCodeSoftware 6)
(setq Pos 0)
(while (< (strlen CodeSoftware) NumCodeSoftware)
(setq NumHash (nth 0 ListNumHash))
(if (not NumHash)
(setq NumHash NumSeed)
)
(setq CodeSoftware (strcat CodeSoftware (nth (rem (setq NumSeed (rem (abs (fix (+ NumHash (* (sin NumSeed) NumSeedMax)))) NumSeedMax)) NumCharTotal) ListCharTotal)))
)
(setq RequestCode CodeSoftware)
(setq Pos 0)
(setq NumRequestCode 36)
(while (< (strlen RequestCode) NumRequestCode)
(foreach ListSerialNum ListSerialNumTotal
(setq NumHash Nil)
(vl-catch-all-apply (function (lambda ( / )
(setq NumHash (nth Pos ListSerialNum))
)))
(if (not NumHash)
(setq NumHash NumSeed)
)
(setq RequestCode (strcat RequestCode (nth (rem (setq NumSeed (rem (abs (fix (+ NumHash (* (sin NumSeed) NumSeedMax)))) NumSeedMax)) NumCharTotal) ListCharTotal)))
)
(setq Pos (+ Pos 1))
)
(setq LicenseKey (vl-registry-read (strcat "HKEY_CURRENT_USER\\Software\\Cad Standard\\" NameSoftware) "License Key"))
(setq ListNumHash (vl-string->list RequestCode))
(setq NumSeed (rem (apply '+ ListNumHash) NumSeedMax))
(setq LicenseKeyExact "")
(foreach NumHash ListNumHash
(setq LicenseKeyExact (strcat LicenseKeyExact (nth (rem (setq NumSeed (rem (abs (fix (+ NumHash (* (sin NumSeed) NumSeedMax)))) NumSeedMax)) NumCharTotal) ListCharTotal)))
)
(if (= LicenseKeyExact LicenseKey)
(setq CheckLicense T)
(setq CheckLicense Nil)
)
(setq LicenseKeyExact Nil)
(if (not CheckLicense)
(LIC_LOAD_DIALOG NameSoftware)
)
)
-------------------------------------------------------------------------------------------------------------------
(LIC_REQUESTCODE)
(setq LIC_REQUESTCODE nil)
(setq VlaDrawingCurrent (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark VlaDrawingCurrent)
(AJOIN_SET_VARSYSTEM)
(if (= (getvar "CVPORT") 1)
(setq VlaSpace (vla-get-PaperSpace VlaDrawingCurrent))
(setq VlaSpace (vla-get-ModelSpace VlaDrawingCurrent))
)
(if
(not
(and
ToleranceWidthMax
(or
(= (type ToleranceWidthMax) 'REAL)
(= (type ToleranceWidthMax) 'INT)
)
(> ToleranceWidthMax 0.0)
)
)
(setq ToleranceWidthMax 200.0)
)
(setq ToleranceValue 1e-8)
(setq CheckStop (vl-catch-all-error-p (vl-catch-all-apply (function (lambda ( / )
(initget 4)
(setq ToleranceWidthMaxTemp (getreal (strcat "\nEnter maximum width of beam or <" (rtos ToleranceWidthMax 2) ">:")))
(if ToleranceWidthMaxTemp
(setq ToleranceWidthMax ToleranceWidthMaxTemp)
)
)))))
(setq ToleranceDistance (* ToleranceWidthMax 0.5))
(setq LengthSegmentMax (* ToleranceWidthMax 1.0))
(setq ToleranceSelection (* ToleranceDistance 0.5))
(AJOIN_CREATE_LISTVLALAYERLOCK)
(while (not CheckStop)
(setq CheckStop (vl-catch-all-error-p (vl-catch-all-apply (function (lambda ( / )
(AJOIN_MAIN_PROGRAM)
)))))
)
(AJOIN_RESTORE_LOCK_LAYER)
(AJOIN_RESET_VARSYSTEM)
(vla-endundomark VlaDrawingCurrent)
(princ)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_MAIN_PROGRAM ( /
ListTemp
ListVlaObject
ListVlaObjectNormal
ListVlaObjectNormalAdd
ListVlaObjectPolyline
ListVlaObjectRegion
ListVlaObjectSpecial
ListVlaObjectSpecialAdd
PointMax
PointMin
SelectionSet)
(while
(or
(not SelectionSet)
(= (sslength SelectionSet) 0)
)
(progn
(setq ListTemp (AJOIN_CREATE_SELECTION_REGION))
(setq PointMin (nth 0 ListTemp))
(setq PointMax (nth 1 ListTemp))
(setq SelectionSet
(ssget
"_CP"
(list
(list (nth 0 PointMin) (nth 1 PointMin))
(list (nth 0 PointMax) (nth 1 PointMin))
(list (nth 0 PointMax) (nth 1 PointMax))
(list (nth 0 PointMin) (nth 1 PointMax))
)
(list
(cons -4 "<OR")
(cons 0 "ARC")
(cons 0 "CIRCLE")
(cons 0 "ELLIPSE")
(cons 0 "LINE")
(cons 0 "LWPOLYLINE")
(cons 0 "REGION")
(cons 0 "SPLINE")
(cons -4 "OR>")
)
)
)
)
)
(setq ListVlaObject (AJOIN_CONVERT_SELECTIONSET_TO_LISTVLAOBJECT SelectionSet))
(setq ListTemp (AJOIN_CLASSIFICATION_OBJECT_BY_TYPEOBJECT ListVlaObject))
(setq ListVlaObjectNormal (nth 0 ListTemp))
(setq ListVlaObjectSpecial (nth 1 ListTemp))
(setq ListVlaObjectRegion (nth 2 ListTemp))
(setq ListTemp (AJOIN_CONVERT_OBJECTREGION_TO_OBJECTNORMAL_AND_OBJECTSPECIAL ListVlaObjectRegion))
(setq ListVlaObjectNormalAdd (nth 0 ListTemp))
(setq ListVlaObjectSpecialAdd (nth 1 ListTemp))
(setq ListVlaObjectSpecial (append ListVlaObjectSpecial ListVlaObjectSpecialAdd))
(setq ListVlaObjectPolyline (AJOIN_CONVERT_OBJECTSPECIAL_TO_OBJECTNORMAL ListVlaObjectSpecial))
(setq ListVlaObject (append ListVlaObjectNormal ListVlaObjectPolyline ListVlaObjectNormalAdd))
(setq ListVlaObject (AJOIN_STRAGHITEN_SMALL_SEGMENT_LISTVLAOBJECT ListVlaObject))
(setq ListVlaObjectByNameLayer (AJOIN_CLASSIFICATION_OBJECT_BY_LAYER ListVlaObject))
(foreach ListVlaObject ListVlaObjectByNameLayer
(setq ListVlaObject (AJOIN_SPLIT_SHAPE_INTERSECTION ListVlaObject))
(setq ListVlaObject (AJOIN_DELETE_SMALL_OBJECT ListVlaObject))
)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CLASSIFICATION_OBJECT_BY_TYPEOBJECT ( ListVlaObject /
ListVlaObjectNormal
ListVlaObjectRegion
ListVlaObjectSpecial
TypeObject)
(foreach VlaObject ListVlaObject
(setq TypeObject (vla-get-ObjectName VlaObject))
(if
(or
(= TypeObject "AcDbEllipse")
(= TypeObject "AcDbSpline")
)
(setq ListVlaObjectSpecial (cons VlaObject ListVlaObjectSpecial))
)
(if
(or
(= TypeObject "AcDbArc")
(= TypeObject "AcDbCircle")
(= TypeObject "AcDbLine")
(= TypeObject "AcDbPolyline")
)
(setq ListVlaObjectNormal (cons VlaObject ListVlaObjectNormal))
)
(if (= TypeObject "AcDbRegion")
(setq ListVlaObjectRegion (cons VlaObject ListVlaObjectRegion))
)
)
(list ListVlaObjectNormal ListVlaObjectSpecial ListVlaObjectRegion)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CLASSIFICATION_OBJECT_BY_LAYER ( ListVlaObject /
ListVlaObjectByNameLayer
NameLayer
Temp)
(foreach VlaObject ListVlaObject
(setq NameLayer (AJOIN_VLA_GET_LAYER VlaObject))
(if (setq Temp (assoc NameLayer ListVlaObjectByNameLayer))
(setq ListVlaObjectByNameLayer (subst (append Temp (list VlaObject)) Temp ListVlaObjectByNameLayer))
(setq ListVlaObjectByNameLayer (append ListVlaObjectByNameLayer (list (list NameLayer VlaObject))))
)
)
(setq ListVlaObjectByNameLayer (mapcar 'cdr ListVlaObjectByNameLayer))
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CONVERT_OBJECTREGION_TO_OBJECTNORMAL_AND_OBJECTSPECIAL ( ListVlaObjectRegion /
ListTemp
ListVlaObjectNormalSegment
ListVlaObjectSegment
ListVlaObjectSpecialSegment)
(foreach VlaObjectRegion ListVlaObjectRegion
(setq ListVlaObjectSegment (append ListVlaObjectSegment (AJOIN_EXPLODE_OBJECT VlaObjectRegion)))
)
(setq ListTemp (AJOIN_CLASSIFICATION_OBJECT_BY_TYPEOBJECT ListVlaObjectSegment))
(setq ListVlaObjectNormalSegment (nth 0 ListTemp))
(setq ListVlaObjectSpecialSegment (nth 1 ListTemp))
(list ListVlaObjectNormalSegment ListVlaObjectSpecialSegment)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CONVERT_OBJECTSPECIAL_TO_OBJECTNORMAL ( ListVlaObjectSpecial /
ListVlaObjectPolyline
VlaObjectPolyline)
(foreach VlaObjectSpecial ListVlaObjectSpecial
(setq VlaObjectPolyline (AJOIN_CURVATURE_OBJECT_SPECIAL VlaObjectSpecial))
(setq ListVlaObjectPolyline (cons VlaObjectPolyline ListVlaObjectPolyline))
)
ListVlaObjectPolyline
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_SPLIT_SHAPE_INTERSECTION ( ListVlaObject1 /
ListDataBreakObject
ListVlaObject2
ListVlaObjectNew
ListVlaObjectTemp)
(AJOIN_SET_LISTNAMEVAR_NIL)
(AJOIN_CREATE_LISTNAMEVAROBJECTSPLIT ListVlaObject1)
(foreach VlaObject1 ListVlaObject1
(setq ListVlaObject2 (AJOIN_FIND_LISTVLAOBJECT_NEAR VlaObject1))
(setq ListVlaObject2 (vl-remove VlaObject1 ListVlaObject2))
(setq ListVlaObject2 (AJOIN_STRAGHITEN_SMALL_SEGMENT_LISTVLAOBJECT ListVlaObject2))
(foreach VlaObject2 ListVlaObject2
(AJOIN_FIND_LISTDATABREAKOBJECT VlaObject1 VlaObject2)
)
)
(foreach DataBreakObject ListDataBreakObject
(setq ListVlaObjectTemp (AJOIN_BREAK_OBJECT DataBreakObject))
(setq ListVlaObjectNew (append ListVlaObjectNew ListVlaObjectTemp))
)
(AJOIN_SET_LISTNAMEVAR_NIL)
ListVlaObjectNew
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_DELETE_SMALL_OBJECT ( ListVlaObject /
LengthCurveMax
ListVlaObjectNew)
(setq LengthCurveMax (* ToleranceWidthMax 1.5))
(foreach VlaObject ListVlaObject
(setq LengthCurve (vlax-curve-getDistAtParam VlaObject (vlax-curve-getEndParam VlaObject)))
(if (<= LengthCurve LengthCurveMax)
(vla-delete VlaObject)
(setq ListVlaObjectNew (cons VlaObject ListVlaObjectNew))
)
)
ListVlaObjectNew
)
-------------------------------------------------------------------------------------------------------------------
; (defun AJOIN_FIND_LISTVLAOBJECT_NEAR ( VlaObject /
; ListVlaObjectNear
; SelectionFrame
; SelectionSet)
; (setq SelectionFrame (AJOIN_CREATE_SELECTIONFRAME_FOR_OBJECT VlaObject))
; (setq SelectionSet (ssget "_CP" SelectionFrame))
; (setq ListVlaObjectNear (AJOIN_CONVERT_SELECTIONSET_TO_LISTVLAOBJECT SelectionSet))
; ListVlaObjectNear
; )
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_FIND_LISTVLAOBJECT_NEAR ( VlaObject /
CheckObjectSplit
ListFilter
ListVlaObjectNear
ListVlaObjectTemp
PointMax
PointMin
SelectionFrame
SelectionSet)
(vla-GetBoundingBox VlaObject 'PointMin 'PointMax)
(setq PointMin (vlax-safearray->list PointMin))
(setq PointMax (vlax-safearray->list PointMax))
(setq SelectionFrame
(list
(list (- (nth 0 PointMin) ToleranceDistance) (- (nth 1 PointMin) ToleranceDistance))
(list (+ (nth 0 PointMax) ToleranceDistance) (- (nth 1 PointMin) ToleranceDistance))
(list (+ (nth 0 PointMax) ToleranceDistance) (+ (nth 1 PointMax) ToleranceDistance))
(list (- (nth 0 PointMin) ToleranceDistance) (+ (nth 1 PointMax) ToleranceDistance))
)
)
(setq ListFilter
(list
(cons -4 "<OR")
(cons 0 "ARC")
(cons 0 "CIRCLE")
(cons 0 "LINE")
(cons 0 "LWPOLYLINE")
(cons -4 "OR>")
)
)
(setq SelectionSet (ssget "_CP" SelectionFrame ListFilter))
(setq ListVlaObjectTemp (AJOIN_CONVERT_SELECTIONSET_TO_LISTVLAOBJECT SelectionSet))
(foreach VlaObjectTemp ListVlaObjectTemp
(setq CheckObjectSplit (AJOIN_CHECK_OBJECTSPLIT VlaObjectTemp))
(if CheckObjectSplit
(setq ListVlaObjectNear (cons VlaObjectTemp ListVlaObjectNear))
)
)
ListVlaObjectNear
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CONVERT_SELECTIONSET_TO_LISTVLAOBJECT ( SelectionSet /
VlaObject
ListVlaObject
Num)
(if SelectionSet
(progn
(setq Num 0)
(repeat (sslength SelectionSet)
(setq EnameObject (ssname SelectionSet Num))
(if (entget EnameObject)
(progn
(setq VlaObject (vlax-ename->vla-object EnameObject))
(setq ListVlaObject (cons VlaObject ListVlaObject))
)
)
(setq Num (+ Num 1))
)
)
)
ListVlaObject
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_FIND_LISTDATABREAKOBJECT ( VlaObject1 VlaObject2 /
CheckEnd1
CheckEnd2
CheckObjectBreak
CheckOnObject1
CheckOnObject2
CheckStart1
CheckStart2
CheckStartEnd1
CheckStartEnd2
CheckValidPoint
ListPointIntersect
ListTemp
PointEnd1
PointEnd2
PointStart1
PointStart2)
(setq CheckObjectBreak (AJOIN_CHECK_OBJECT_BREAK VlaObject1 VlaObject2))
(if (not CheckObjectBreak)
(progn
(setq ListPointIntersect (AJOIN_FIND_LISTPOINTINTERSECT VlaObject1 VlaObject2 acExtendBoth))
(setq ListPointIntersect (AJOIN_REMOVE_DUPLICATE_POINT_IN_LISTPOINT ListPointIntersect))
(setq PointStart1 (AJOIN_GET_POINTSTART VlaObject1))
(setq PointEnd1 (AJOIN_GET_POINTEND VlaObject1))
(setq PointStart2 (AJOIN_GET_POINTSTART VlaObject2))
(setq PointEnd2 (AJOIN_GET_POINTEND VlaObject2))
(foreach Point ListPointIntersect
(if
(and
(>= (nth 0 Point) (nth 0 PointMin))
(<= (nth 0 Point) (nth 0 PointMax))
(>= (nth 1 Point) (nth 1 PointMin))
(<= (nth 1 Point) (nth 1 PointMax))
)
(setq CheckValidPoint T)
(setq CheckValidPoint Nil)
)
(if CheckValidPoint
(progn
(setq ListTemp (AJOIN_CHECKSTARTEND Point PointStart1 PointEnd1))
(setq CheckStart1 (nth 0 ListTemp))
(setq CheckEnd1 (nth 1 ListTemp))
(setq CheckStartEnd1 (nth 2 ListTemp))
(setq CheckOnObject1
(or
(vlax-curve-getParamAtPoint VlaObject1 Point)
CheckStartEnd1
)
)
(setq ListTemp (AJOIN_CHECKSTARTEND Point PointStart2 PointEnd2))
(setq CheckStart2 (nth 0 ListTemp))
(setq CheckEnd2 (nth 1 ListTemp))
(setq CheckStartEnd2 (nth 2 ListTemp))
(setq CheckOnObject2
(or
(vlax-curve-getParamAtPoint VlaObject2 Point)
CheckStartEnd2
)
)
(if
(and
CheckStart1
CheckOnObject2
)
(AJOIN_PUT_POINTSTART VlaObject1 Point)
)
(if
(and
CheckEnd1
CheckOnObject2
)
(AJOIN_PUT_POINTEND VlaObject1 Point)
)
(if
(and
CheckStart2
CheckOnObject1
)
(AJOIN_PUT_POINTSTART VlaObject2 Point)
)
(if
(and
CheckEnd2
CheckOnObject1
)
(AJOIN_PUT_POINTEND VlaObject2 Point)
)
(if
(and
(not CheckStartEnd1)
(not CheckStartEnd2)
CheckOnObject1
CheckOnObject2
)
(AJOIN_ADD_DATA_TO_LISTDATABREAKOBJECT VlaObject1 Point)
)
(if
(and
(not CheckStartEnd1)
(not CheckStartEnd2)
CheckOnObject1
CheckOnObject2
)
(AJOIN_ADD_DATA_TO_LISTDATABREAKOBJECT VlaObject2 Point)
)
)
)
)
)
)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_STRAGHITEN_SMALL_SEGMENT_LISTVLAOBJECT ( ListVlaObject /
CheckObjectStraighten
ListVlaObjectNew
TypeObject
VlaObjectNew)
(foreach VlaObject ListVlaObject
(setq VlaObjectNew Nil)
(setq CheckObjectStraighten (AJOIN_CHECK_OBJECT_STRAIGHTEN VlaObject))
(if (not CheckObjectStraighten)
(progn
(setq TypeObject (vla-get-ObjectName VlaObject))
(if (= TypeObject "AcDbPolyline")
(AJOIN_STRAGHITEN_SMALL_SEGMENT_POLYLINE VlaObject)
)
(if (= TypeObject "AcDbArc")
(setq VlaObjectNew (AJOIN_STRAGHITEN_SMALL_SEGMENT_ARC VlaObject))
)
)
)
(if VlaObjectNew
(setq ListVlaObjectNew (cons VlaObjectNew ListVlaObjectNew))
(setq ListVlaObjectNew (cons VlaObject ListVlaObjectNew))
)
)
ListVlaObjectNew
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_STRAGHITEN_SMALL_SEGMENT_POLYLINE ( VlaObject /
DataPolyline
LengthSegment
ListPoint
ListPosBulgeZero
Num
NumPoint
Point1
Point2)
(setq DataPolyline (AJOIN_GET_DATAPOLYLINE VlaObject))
(setq ListPoint (nth 0 DataPolyline))
(setq NumPoint (length ListPoint))
(setq Num 0)
(setq Point1 (nth Num ListPoint))
(repeat (- NumPoint 1)
(setq Point2 (nth (+ Num 1) ListPoint))
(setq LengthSegment (- (vlax-curve-getDistAtPoint VlaObject Point2) (vlax-curve-getDistAtPoint VlaObject Point1)))
(if (<= LengthSegment LengthSegmentMax)
(setq ListPosBulgeZero (cons Num ListPosBulgeZero))
)
(setq Point1 Point2)
(setq Num (+ Num 1))
)
(foreach Pos ListPosBulgeZero
(vla-SetBulge VlaObject Pos 0.0)
)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_STRAGHITEN_SMALL_SEGMENT_ARC ( VlaObject /
LengthCurve
VlaObjectNew)
(setq LengthCurve (vlax-curve-getDistAtParam VlaObject (vlax-curve-getEndParam VlaObject)))
(if (<= LengthCurve LengthSegmentMax)
(setq VlaObjectNew (vla-addline VlaSpace (vla-get-startpoint VlaObject) (vla-get-endpoint VlaObject)))
)
(if VlaObjectNew
(vla-delete VlaObject)
)
VlaObjectNew
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CHECKSTARTEND ( Point PointStart PointEnd /
CheckEnd
CheckStart
CheckStartEnd
DistanceEnd
DistanceStart)
(if PointStart
(progn
(setq DistanceStart (distance Point PointStart))
(setq CheckStart (equal DistanceStart 0.0 ToleranceDistance))
)
)
(if PointEnd
(progn
(setq DistanceEnd (distance Point PointEnd))
(setq CheckEnd (equal DistanceEnd 0.0 ToleranceDistance))
)
)
(if (and CheckStart CheckEnd)
(progn
(if (< DistanceStart DistanceEnd)
(setq CheckEnd Nil)
(setq CheckStart Nil)
)
)
)
(setq CheckStartEnd (or CheckStart CheckEnd))
(list CheckStart CheckEnd CheckStartEnd)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CHECK_SAME_POINT ( Point1 Point2 ToleranceValue / DistanceLength)
(setq DistanceLength (distance Point1 Point2))
(equal DistanceLength 0.0 ToleranceValue)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_FIND_LISTPOINTINTERSECT ( VlaObject1 VlaObject2 ModeExtend /
ListPointIntersect
ListCoordinates)
(setq ListCoordinates (AJOIN_VARIANT_TO_LIST (vla-intersectwith VlaObject1 VlaObject2 ModeExtend)))
(setq ListPointIntersect (AJOIN_CONVERT_LISTCOORDINATES_TO_LISTPOINT ListCoordinates 3))
ListPointIntersect
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_VARIANT_TO_LIST ( VariantPoint / ListPoint)
(vl-catch-all-apply (function (lambda ( / )
(setq ListPoint (vlax-safearray->list (vlax-variant-value VariantPoint)))
)))
ListPoint
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CONVERT_LISTCOORDINATES_TO_LISTPOINT ( ListCoordinates NumElement /
ListPoint
Num1
Num2
Point)
(setq Num1 0)
(repeat (/ (length ListCoordinates) NumElement)
(setq Point nil)
(setq Num2 0)
(repeat NumElement
(setq Point (cons (nth (+ (* Num1 NumElement) Num2) ListCoordinates) Point))
(setq Num2 (+ Num2 1))
)
(setq Point (reverse Point))
(setq ListPoint (cons Point ListPoint))
(setq Num1 (+ Num1 1))
)
(setq ListPoint (reverse ListPoint))
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_GET_POINTSTART ( VlaObject /
Point
TypeObject)
(setq TypeObject (vla-get-ObjectName VlaObject))
(if
(or
(= TypeObject "AcDbArc")
(= TypeObject "AcDbLine")
(and
(= TypeObject "AcDbPolyline")
(= (vla-get-closed VlaObject) :vlax-false)
)
)
(setq Point (vlax-curve-getStartPoint VlaObject))
)
Point
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_PUT_POINTSTART ( VlaObject Point /
AngleStart
PointCenter
TypeObject)
(setq TypeObject (vla-get-ObjectName VlaObject))
(if
(= TypeObject "AcDbArc")
(progn
(setq PointCenter (AJOIN_VARIANT_TO_LIST (vla-get-Center VlaObject)))
(setq AngleStart (angle PointCenter Point))
(vla-put-StartAngle VlaObject AngleStart)
)
)
(if
(= TypeObject "AcDbLine")
(vla-put-StartPoint VlaObject (vlax-3d-point Point))
)
(if
(= TypeObject "AcDbPolyline")
(AJOIN_PUT_POINTSTART_POLYLINE VlaObject Point)
)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CREATE_POLYLINE ( DataPolyline CheckClosed /
ListBulge
ListPoint
ListCoordinates
Num
VlaObjectPolyline)
(setq ListPoint (nth 0 DataPolyline))
(setq ListBulge (nth 1 DataPolyline))
(setq ListCoordinates (apply 'append (mapcar '(lambda (x) (list (nth 0 x) (nth 1 x))) ListPoint)))
(setq VlaObjectPolyline
(vla-AddLightWeightPolyline
VlaSpace
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbDouble
(cons 0 (- (length ListCoordinates) 1))
)
ListCoordinates
)
)
)
(setq Num 0)
(repeat (length ListBulge)
(setq Bulge (nth Num ListBulge))
(vla-SetBulge VlaObjectPolyline Num Bulge)
(setq Num (+ Num 1))
)
(if CheckClosed
(vla-put-closed VlaObjectPolyline :vlax-true)
)
VlaObjectPolyline
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_MODIFY_POLYLINE ( VlaObjectPolyline DataPolyline /
ListBulge
ListCoordinates
ListPoint
Num)
(setq ListPoint (nth 0 DataPolyline))
(setq ListBulge (nth 1 DataPolyline))
(setq ListCoordinates (apply 'append (mapcar '(lambda (x) (list (nth 0 x) (nth 1 x))) ListPoint)))
(vla-put-Coordinates
VlaObjectPolyline
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbDouble
(cons 0 (- (length ListCoordinates) 1))
)
ListCoordinates
)
)
(setq Num 0)
(repeat (length ListBulge)
(setq Bulge (nth Num ListBulge))
(vla-SetBulge VlaObjectPolyline Num Bulge)
(setq Num (+ Num 1))
)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_GET_POINTEND ( VlaObject /
Point
TypeObject)
(setq TypeObject (vla-get-ObjectName VlaObject))
(if
(or
(= TypeObject "AcDbArc")
(= TypeObject "AcDbLine")
(and
(= TypeObject "AcDbPolyline")
(= (vla-get-closed VlaObject) :vlax-false)
)
)
(setq Point (vlax-curve-getEndPoint VlaObject))
)
Point
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_PUT_POINTEND ( VlaObject Point /
AngleEnd
PointCenter
TypeObject)
(setq TypeObject (vla-get-ObjectName VlaObject))
(if
(= TypeObject "AcDbArc")
(progn
(setq PointCenter (AJOIN_VARIANT_TO_LIST (vla-get-Center VlaObject)))
(setq AngleEnd (angle PointCenter Point))
(vla-put-EndAngle VlaObject AngleEnd)
)
)
(if
(= TypeObject "AcDbLine")
(vla-put-EndPoint VlaObject (vlax-3d-point Point))
)
(if
(= TypeObject "AcDbPolyline")
(AJOIN_PUT_POINTEND_POLYLINE VlaObject Point)
)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_PUT_POINTSTART_POLYLINE ( VlaObject Point /
Bulge
DataPolyline
ListBulge
ListPoint
Param1
Param2
Param3
Point1
Point2
Point3)
(setq DataPolyline (AJOIN_GET_DATAPOLYLINE VlaObject))
(setq ListPoint (nth 0 DataPolyline))
(setq ListBulge (nth 1 DataPolyline))
(setq Bulge (nth 0 ListBulge))
(if (/= Bulge 0.0)
(progn
(setq Point1 (nth 0 ListPoint))
(setq Point3 (nth 1 ListPoint))
(setq Param1 (vlax-curve-getParamAtPoint VlaObject Point1))
(setq Param3 (vlax-curve-getParamAtPoint VlaObject Point3))
(setq Param2 (* (+ Param1 Param3) 0.5))
(setq Point2 (vlax-curve-getPointAtParam VlaObject Param2))
(setq Bulge (AJOIN_THREE_POINT_TO_BULGE Point Point2 Point3))
(setq ListBulge (cons Bulge (cdr ListBulge)))
)
)
(setq ListPoint (cons Point (cdr ListPoint)))
(setq DataPolyline (list ListPoint ListBulge))
(AJOIN_MODIFY_POLYLINE VlaObject DataPolyline)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_PUT_POINTEND_POLYLINE ( VlaObject Point /
Bulge
DataPolyline
ListBulge
ListPoint
Param1
Param2
Param3
Point1
Point2
Point3)
(setq DataPolyline (AJOIN_GET_DATAPOLYLINE VlaObject))
(setq ListPoint (nth 0 DataPolyline))
(setq ListBulge (nth 1 DataPolyline))
(setq Pos (- (length ListPoint) 2))
(setq Bulge (nth Pos ListBulge))
(if (/= Bulge 0.0)
(progn
(setq Point1 (nth Pos ListPoint))
(setq Point3 (nth (+ Pos 1) ListPoint))
(setq Param1 (vlax-curve-getParamAtPoint VlaObject Point1))
(setq Param3 (vlax-curve-getParamAtPoint VlaObject Point3))
(setq Param2 (* (+ Param1 Param3) 0.5))
(setq Point2 (vlax-curve-getPointAtParam VlaObject Param2))
(setq Bulge (AJOIN_THREE_POINT_TO_BULGE Point1 Point2 Point))
(setq ListBulge (append (reverse (cddr (reverse ListBulge))) (list Bulge (last ListBulge))))
)
)
(setq ListPoint (append (reverse (cdr (reverse ListPoint))) (list Point)))
(setq DataPolyline (list ListPoint ListBulge))
(AJOIN_MODIFY_POLYLINE VlaObject DataPolyline)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_THREE_POINT_TO_BULGE ( Point1 Point2 Point3 /
Bulge
Theta)
(setq Theta (/ (+ (- Pi (angle Point2 Point1)) (angle Point2 Point3)) 2))
(setq Bulge (/ (sin Theta) (cos Theta)))
(setq BulgeTemp (AJOIN_ROUNDOFF_NUMBER Bulge ToleranceValue))
(if (= BulgeTemp 0.0) (setq Bulge 0.0))
Bulge
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CHECK_POINT_IS_MEMBER_LISTPOINT ( Point ListPoint / CheckMember)
(while
(and
(not CheckMember)
ListPoint
)
(if (AJOIN_CHECK_SAME_POINT Point (car ListPoint) ToleranceValue)
(setq CheckMember T)
)
(setq ListPoint (cdr ListPoint))
)
CheckMember
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_REMOVE_DUPLICATE_POINT_IN_LISTPOINT ( ListPoint / ListPointResult)
(foreach Point ListPoint
(if (not (AJOIN_CHECK_POINT_IS_MEMBER_LISTPOINT Point ListPointResult))
(setq ListPointResult (cons Point ListPointResult))
)
)
ListPointResult
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_ADD_DATA_TO_LISTDATABREAKOBJECT ( VlaObject Point / Temp)
(if (setq Temp (assoc VlaObject ListDataBreakObject))
(setq ListDataBreakObject (subst (append Temp (list Point)) Temp ListDataBreakObject))
(setq ListDataBreakObject (append ListDataBreakObject (list (list VlaObject Point))))
)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CREATE_LISTVLAOBJECT_ON_POINT ( Point /
ListVlaObject
SelectionFramePoint
SelectionSet
Size)
(setq Size ToleranceSelection)
(setq SelectionFramePoint
(list
(list (- (nth 0 Point) Size) (- (nth 1 Point) Size))
(list (+ (nth 0 Point) Size) (- (nth 1 Point) Size))
(list (+ (nth 0 Point) Size) (+ (nth 1 Point) Size))
(list (- (nth 0 Point) Size) (+ (nth 1 Point) Size))
)
)
(setq SelectionSet (ssget "_CP" SelectionFramePoint))
(setq ListVlaObject (AJOIN_CONVERT_SELECTIONSET_TO_LISTVLAOBJECT SelectionSet))
ListVlaObject
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_GET_DATAPOLYLINE ( VlaObject /
ListBulge
ListCoordinates
ListPoint
Num
NumPoint)
(setq ListCoordinates (AJOIN_VARIANT_TO_LIST (vla-get-Coordinates VlaObject)))
(setq ListPoint (AJOIN_CONVERT_LISTCOORDINATES_TO_LISTPOINT ListCoordinates 2))
(setq ListPoint (mapcar '(lambda (x) (append x (list 0.0))) ListPoint))
(setq NumPoint (length ListPoint))
(setq Num 0)
(repeat NumPoint
(setq ListBulge (cons (vla-GetBulge VlaObject Num) ListBulge))
(setq Num (+ Num 1))
)
(setq ListBulge (reverse ListBulge))
(list ListPoint ListBulge)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_ROUNDOFF_NUMBER ( Number ValueRoundOff /
Temp1
Temp2
ValueResult
NumberActive
NumSwitchPositveActive)
(setq NumberActive (abs (* Number 1.0)))
(if (>= Number 0.0)
(setq NumSwitchPositveActive 1.0)
(setq NumSwitchPositveActive -1.0)
)
(setq Temp1 (/ NumberActive ValueRoundOff))
(setq Temp2 (fix Temp1))
(if (>= (abs (- Temp1 Temp2)) 0.4999999999)
(setq ValueResult (* ValueRoundOff (+ Temp2 1.0)))
(setq ValueResult (* ValueRoundOff (+ Temp2 0.0)))
)
(setq ValueResult (* NumSwitchPositveActive ValueResult))
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CHECK_OBJECT_BREAK ( VlaObject1 VlaObject2 /
CheckObjectBreak
HandleObject1
HandleObject2
NameVar)
(setq HandleObject1 (vla-get-handle VlaObject1))
(setq HandleObject2 (vla-get-handle VlaObject2))
(setq NameVar
(read
(strcat
"CheckObjectBreak"
HandleObject1
"-"
HandleObject2
)
)
)
(if (eval NameVar)
(setq CheckObjectBreak T)
(progn
(setq CheckObjectBreak Nil)
(set NameVar T)
(setq ListNameVarCheckObjectBreak (cons NameVar ListNameVarCheckObjectBreak))
(setq NameVar
(read
(strcat
"CheckObjectBreak"
HandleObject2
"-"
HandleObject1
)
)
)
(set NameVar T)
(setq ListNameVarCheckObjectBreak (cons NameVar ListNameVarCheckObjectBreak))
)
)
CheckObjectBreak
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CHECK_OBJECT_STRAIGHTEN ( VlaObject /
CheckObjectStraighten
HandleObject
NameVar)
(setq HandleObject (vla-get-handle VlaObject))
(setq NameVar
(read
(strcat "CheckObjectStraighten" HandleObject)
)
)
(if (eval NameVar)
(setq CheckObjectStraighten T)
(progn
(setq CheckObjectStraighten Nil)
(set NameVar T)
(setq ListNameVarCheckObjectStraighten (cons NameVar ListNameVarCheckObjectStraighten))
)
)
CheckObjectStraighten
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CREATE_LISTNAMEVAROBJECTSPLIT ( ListVlaObject /
HandleObject
NameVar)
(foreach VlaObject ListVlaObject
(setq HandleObject (vla-get-handle VlaObject))
(setq NameVar
(read
(strcat "ObjectSplit" HandleObject)
)
)
(set NameVar T)
(setq ListNameVarObjectSplit (cons NameVar ListNameVarObjectSplit))
)
)
--------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CHECK_OBJECTSPLIT ( VlaObject /
CheckObjectSplit
HandleObject
NameVar)
(setq HandleObject (vla-get-handle VlaObject))
(setq NameVar
(read
(strcat "ObjectSplit" HandleObject)
)
)
(setq CheckObjectSplit (eval NameVar))
)
--------------------------------------------------------------------------------------------------------------------
(defun AJOIN_SET_LISTNAMEVAR_NIL ( / )
(foreach NameVar (append ListNameVarCheckObjectBreak ListNameVarCheckObjectStraighten ListNameVarObjectSplit)
(set NameVar Nil)
)
(setq ListNameVarCheckObjectBreak Nil)
(setq ListNameVarCheckObjectStraighten Nil)
(setq ListNameVarObjectSplit Nil)
)
--------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CURVATURE_OBJECT_SPECIAL ( VlaObject /
CheckClosed
DataPolyline
ListPropertyObject
ListVlaObjectSegment
VlaObjectPolyline
TypeObject)
(setq ListPropertyObject (AJOIN_GET_PROPERTIES_OBJECT VlaObject))
(setq TypeObject (vla-get-ObjectName VlaObject))
(if
(and
(= TypeObject "AcDbEllipse")
(equal (vla-get-EndAngle VlaObject) (* Pi 2))
)
(setq CheckClosed T)
)
(if (= TypeObject "AcDbSpline")
(setq CheckClosed (= (vla-get-closed VlaObject) :vlax-true))
)
(setq ListVlaObjectSegment (AJOIN_EXPLODE_OBJECT VlaObject))
(setq ListVlaObjectSegment (AJOIN_CHECK_DIRECTION_LISTVLAOBJECTSEGMENT ListVlaObjectSegment))
(setq DataPolyline (AJOIN_CREATE_DATAPOLYLINE ListVlaObjectSegment CheckClosed))
(setq VlaObjectPolyline (AJOIN_CREATE_POLYLINE DataPolyline CheckClosed))
(AJOIN_PUT_PROPERTIES_OBJECT VlaObjectPolyline ListPropertyObject)
(foreach VlaObjectSegment ListVlaObjectSegment
(vla-delete VlaObjectSegment)
)
VlaObjectPolyline
)
--------------------------------------------------------------------------------------------------------------------
(defun AJOIN_EXPLODE_OBJECT ( VlaObject /
EnameTemp
EnameErase
ListVlaObjectSegment)
(setq EnameTemp (vlax-vla-object->ename (vla-AddPoint VlaSpace (vlax-3d-point (list 0.0 0.0 0.0)))))
(setq EnameErase EnameTemp)
(command "_.EXPLODE" (vlax-vla-object->ename VlaObject))
(while (/= (getvar "CMDACTIVE") 0) (command ""))
(if (entnext EnameTemp)
(while (setq EnameTemp (entnext EnameTemp))
(setq ListVlaObjectSegment (cons (vlax-ename->vla-object EnameTemp) ListVlaObjectSegment))
)
(setq ListVlaObjectSegment (list VlaObject))
)
(entdel EnameErase)
ListVlaObjectSegment
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CHECK_DIRECTION_LISTVLAOBJECTSEGMENT ( ListVlaObjectSegment /
DataObjectSegment
ListDataObjectSegment
ListPoint
ListVlaObjectSegmentNew
Point
VlaObjectSegment)
(setq ListDataObjectSegment (mapcar '(lambda (x) (list x (vlax-curve-getStartPoint x) (vlax-curve-getEndPoint x))) ListVlaObjectSegment))
(while ListDataObjectSegment
(setq DataObjectSegment (car ListDataObjectSegment))
(setq ListDataObjectSegment (cdr ListDataObjectSegment))
(setq ListVlaObjectSegmentNew (list (nth 0 DataObjectSegment)))
(setq ListPoint (cdr DataObjectSegment))
(setq Point (car ListPoint))
(while
(setq DataObjectSegment
(car
(vl-member-if
'(lambda (x)
(or
(AJOIN_CHECK_SAME_POINT Point (nth 1 x) ToleranceValue)
(AJOIN_CHECK_SAME_POINT Point (nth 2 x) ToleranceValue)
)
)
ListDataObjectSegment
)
)
)
(setq VlaObjectSegment (nth 0 DataObjectSegment))
(if (AJOIN_CHECK_SAME_POINT Point (nth 1 DataObjectSegment) ToleranceValue)
(progn
(vla-reverse VlaObjectSegment)
(setq Point (nth 2 DataObjectSegment))
)
(setq Point (nth 1 DataObjectSegment))
)
(setq ListVlaObjectSegmentNew (cons VlaObjectSegment ListVlaObjectSegmentNew))
(setq ListDataObjectSegment (AJOIN_REMOVE_ONE_ITEM_IN_LIST DataObjectSegment ListDataObjectSegment))
)
(setq Point (last ListPoint))
(while
(setq DataObjectSegment
(car
(vl-member-if
'(lambda (x)
(or
(AJOIN_CHECK_SAME_POINT Point (nth 1 x) ToleranceValue)
(AJOIN_CHECK_SAME_POINT Point (nth 2 x) ToleranceValue)
)
)
ListDataObjectSegment
)
)
)
(setq VlaObjectSegment (nth 0 DataObjectSegment))
(if (AJOIN_CHECK_SAME_POINT Point (nth 2 DataObjectSegment) ToleranceValue)
(progn
(vla-reverse VlaObjectSegment)
(setq Point (nth 1 DataObjectSegment))
)
(setq Point (nth 2 DataObjectSegment))
)
(setq ListVlaObjectSegmentNew (append ListVlaObjectSegmentNew (list VlaObjectSegment)))
(setq ListDataObjectSegment (AJOIN_REMOVE_ONE_ITEM_IN_LIST DataObjectSegment ListDataObjectSegment))
)
)
ListVlaObjectSegmentNew
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_REMOVE_ONE_ITEM_IN_LIST ( Data ListData /
CheckRemove
ListDataNew)
(foreach DataTemp ListData
(if
(and
(not CheckRemove)
(equal DataTemp Data)
)
(setq CheckRemove T)
(setq ListDataNew (cons DataTemp ListDataNew))
)
)
(setq ListDataNew (reverse ListDataNew))
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CREATE_DATAPOLYLINE ( ListVlaObjectSegment CheckClosed /
DataPolyline
DataPolylineSegment
Num
Numlast
ListBulge
ListBulgeSegment
ListPoint
ListPointSegment
VlaObjectSegment)
(setq Num 0)
(setq Numlast (- (length ListVlaObjectSegment) 1))
(repeat (length ListVlaObjectSegment)
(setq VlaObjectSegment (nth Num ListVlaObjectSegment))
(setq DataPolylineSegment (AJOIN_CREATE_DATAPOLYLINESEGMENT VlaObjectSegment))
(setq ListPointSegment (nth 0 DataPolylineSegment))
(setq ListBulgeSegment (nth 1 DataPolylineSegment))
(if (/= Num Numlast)
(progn
(setq ListPointSegment (reverse (cdr (reverse ListPointSegment))))
(setq ListBulgeSegment (reverse (cdr (reverse ListBulgeSegment))))
)
)
(setq ListPoint (append ListPoint ListPointSegment))
(setq ListBulge (append ListBulge ListBulgeSegment))
(setq Num (+ Num 1))
)
(if CheckClosed
(progn
(setq ListPoint (reverse (cdr (reverse ListPoint))))
(setq ListBulge (reverse (cdr (reverse ListBulge))))
)
)
(setq DataPolyline (list ListPoint ListBulge))
DataPolyline
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CREATE_DATAPOLYLINESEGMENT ( VlaObjectSegment /
Bulge
DataPolyline
DataPolylineTemp
LengthCurve
LengthSegment
LengthSegmentMaxLocal
ListBulge
ListPoint
ListTemp
Num
NumSegment
ParamEnd
ParamMiddle
ParamStart
Point1
Point2
Point3
PointCenterCurrent
PointCenterPrevious
PointEnd
PointMiddle
PointStart
RadiusCurrent
RadiusPrevious
TypeObject)
(setq TypeObject (vla-get-ObjectName VlaObject))
(if
(and
(= TypeObject "AcDbPolyline")
(setq DataPolylineTemp (AJOIN_GET_DATAPOLYLINE VlaObjectSegment))
(= (length (nth 0 DataPolylineTemp)) 2)
)
(setq DataPolyline DataPolylineTemp)
)
(if (not DataPolyline)
(progn
(setq LengthCurve (vlax-curve-getDistAtParam VlaObjectSegment (vlax-curve-getEndParam VlaObjectSegment)))
(setq LengthSegmentMaxLocal (min LengthSegmentMax (/ LengthCurve 4)))
(setq NumSegment (/ LengthCurve LengthSegmentMaxLocal))
(setq NumSegment (fix (AJOIN_ROUNDOFF_NUMBER NumSegment 1.0)))
(setq LengthSegment (/ LengthCurve NumSegment))
(setq Num 0)
(while (< Num NumSegment)
(setq Point1 (vlax-curve-getPointAtDist VlaObjectSegment (* Num LengthSegment)))
(setq Point2 (vlax-curve-getPointAtDist VlaObjectSegment (* (+ Num 0.5) LengthSegment)))
(setq Point3 (vlax-curve-getPointAtDist VlaObjectSegment (* (+ Num 1.0) LengthSegment)))
(setq PointStart Point1)
(setq PointEnd Nil)
(setq ListTemp (AJOIN_THREE_POINT_TO_ARC Point1 Point2 Point3))
(setq PointCenterPrevious (nth 0 ListTemp))
(setq RadiusPrevious (nth 1 ListTemp))
(setq Num (+ Num 1))
(while
(and
(< Num NumSegment)
(not PointEnd)
)
(setq Point1 (vlax-curve-getPointAtDist VlaObjectSegment (* Num LengthSegment)))
(setq Point2 (vlax-curve-getPointAtDist VlaObjectSegment (* (+ Num 0.5) LengthSegment)))
(setq Point3 (vlax-curve-getPointAtDist VlaObjectSegment (* (+ Num 1.0) LengthSegment)))
(setq ListTemp (AJOIN_THREE_POINT_TO_ARC Point1 Point2 Point3))
(setq PointCenterCurrent (nth 0 ListTemp))
(setq RadiusCurrent (nth 1 ListTemp))
(if
(not
(and
PointCenterCurrent
PointCenterPrevious
(AJOIN_CHECK_SAME_POINT PointCenterPrevious PointCenterCurrent (* 0.1 LengthSegmentMaxLocal))
(equal RadiusPrevious RadiusCurrent (* 0.1 LengthSegmentMaxLocal))
)
)
(setq PointEnd Point3)
)
(setq PointCenterPrevious PointCenterCurrent)
(setq RadiusPrevious RadiusCurrent)
(setq Num (+ Num 1))
)
(setq ParamStart (vlax-curve-getParamAtPoint VlaObjectSegment PointStart))
(if (= Num NumSegment)
(progn
(setq PointEnd (vlax-curve-getEndPoint VlaObjectSegment))
(setq ParamEnd (vlax-curve-getEndParam VlaObjectSegment))
)
(progn
(setq PointEnd (vlax-curve-getPointAtDist VlaObjectSegment (* Num LengthSegment)))
(setq ParamEnd (vlax-curve-getParamAtPoint VlaObjectSegment PointEnd))
)
)
(setq ParamMiddle (/ (+ ParamStart ParamEnd) 2.0))
(setq PointMiddle (vlax-curve-getPointAtParam VlaObjectSegment ParamMiddle))
(setq Bulge (AJOIN_THREE_POINT_TO_BULGE PointStart PointMiddle PointEnd))
(setq ListPoint (append ListPoint (list PointStart)))
(setq ListBulge (append ListBulge (list Bulge)))
)
(setq ListPoint (append ListPoint (list PointEnd)))
(setq ListBulge (append ListBulge (list 0.0)))
(setq DataPolyline (list ListPoint ListBulge))
)
)
DataPolyline
)
-------------------------------------------------------------------------------------------------------------------
; (defun AJOIN_CREATE_DATAPOLYLINESEGMENT ( VlaObjectSegment /
; Bulge
; DataPolyline
; LengthCurve
; LengthSegment
; LengthSegmentMaxLocal
; ListBulge
; ListPoint
; ListTemp
; Num
; NumSegment
; ParamEnd
; ParamMiddle
; ParamStart
; Point1
; Point2
; Point3
; PointCenterCurrent
; PointCenterPrevious
; PointEnd
; PointMiddle
; PointStart
; RadiusCurrent
; RadiusPrevious)
; (setq LengthCurve (vlax-curve-getDistAtParam VlaObjectSegment (vlax-curve-getEndParam VlaObjectSegment)))
; (setq LengthSegmentMaxLocal (min LengthSegmentMax (/ LengthCurve 16)))
; (setq NumSegment (/ LengthCurve LengthSegmentMaxLocal))
; (setq NumSegment (fix (AJOIN_ROUNDOFF_NUMBER NumSegment 1.0)))
; (setq LengthSegment (/ LengthCurve NumSegment))
; (setq Num 0)
; (while (< Num NumSegment)
; (setq Point1 (vlax-curve-getPointAtDist VlaObjectSegment (* Num LengthSegment)))
; (setq Point2 (vlax-curve-getPointAtDist VlaObjectSegment (* (+ Num 0.5) LengthSegment)))
; (setq Point3 (vlax-curve-getPointAtDist VlaObjectSegment (* (+ Num 1.0) LengthSegment)))
; (setq PointStart Point1)
; (setq PointEnd Nil)
; (setq ListTemp (AJOIN_THREE_POINT_TO_ARC Point1 Point2 Point3))
; (setq PointCenterPrevious (nth 0 ListTemp))
; (setq RadiusPrevious (nth 1 ListTemp))
; (setq Num (+ Num 1))
; (while
; (and
; (< Num NumSegment)
; (not PointEnd)
; )
; (setq Point1 (vlax-curve-getPointAtDist VlaObjectSegment (* Num LengthSegment)))
; (setq Point2 (vlax-curve-getPointAtDist VlaObjectSegment (* (+ Num 0.5) LengthSegment)))
; (setq Point3 (vlax-curve-getPointAtDist VlaObjectSegment (* (+ Num 1.0) LengthSegment)))
; (setq ListTemp (AJOIN_THREE_POINT_TO_ARC Point1 Point2 Point3))
; (setq PointCenterCurrent (nth 0 ListTemp))
; (setq RadiusCurrent (nth 1 ListTemp))
; (if
; (not
; (and
; (AJOIN_CHECK_SAME_POINT PointCenterPrevious PointCenterCurrent (* 1.0 LengthSegmentMaxLocal))
; (equal RadiusPrevious RadiusCurrent (* 1.0 LengthSegmentMaxLocal))
; )
; )
; (setq PointEnd Point3)
; )
; (setq PointCenterPrevious PointCenterCurrent)
; (setq RadiusPrevious RadiusCurrent)
; (setq Num (+ Num 1))
; )
; (setq ParamStart (vlax-curve-getParamAtPoint VlaObjectSegment PointStart))
; (if (= Num NumSegment)
; (progn
; (setq PointEnd (vlax-curve-getEndPoint VlaObjectSegment))
; (setq ParamEnd (vlax-curve-getEndParam VlaObjectSegment))
; )
; (progn
; (setq PointEnd (vlax-curve-getPointAtDist VlaObjectSegment (* Num LengthSegment)))
; (setq ParamEnd (vlax-curve-getParamAtPoint VlaObjectSegment PointEnd))
; )
; )
; (setq ParamMiddle (/ (+ ParamStart ParamEnd) 2.0))
; (setq PointMiddle (vlax-curve-getPointAtParam VlaObjectSegment ParamMiddle))
; (setq Bulge (AJOIN_THREE_POINT_TO_BULGE PointStart PointMiddle PointEnd))
; (setq ListPoint (append ListPoint (list PointStart)))
; (setq ListBulge (append ListBulge (list Bulge)))
; )
; (setq ListPoint (append ListPoint (list PointEnd)))
; (setq ListBulge (append ListBulge (list 0.0)))
; (setq DataPolyline (list ListPoint ListBulge))
; )
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_THREE_POINT_TO_ARC ( Point1 Point2 Point3 /
PointCenter
PointMid1
PointMid2
Radius
Vector1
Vector2)
(setq PointMid1 (mapcar '(lambda (a b) (/ (+ a b) 2.0)) Point1 Point2))
(setq PointMid2 (mapcar '(lambda (a b) (/ (+ a b) 2.0)) Point2 Point3))
(setq Vector1 (mapcar '- Point1 Point2))
(setq Vector2 (mapcar '- Point2 Point3))
(setq PointCenter
(inters
PointMid1
(mapcar '+ PointMid1 (list (- (nth 1 Vector1)) (nth 0 Vector1) 0.0))
PointMid2
(mapcar '+ PointMid2 (list (- (nth 1 Vector2)) (nth 0 Vector2) 0.0))
Nil
)
)
(if PointCenter
(setq Radius (distance PointCenter Point1))
)
(list PointCenter Radius)
)
-------------------------------------------------------------------------------------------------------------------
; (defun AJOIN_CREATE_SELECTIONFRAME_FOR_OBJECT ( VlaObject /
; AngleDeriv
; FirstDeriv
; LengthCurve
; LengthSegment
; ListPoint
; Num
; NumSegment
; Param
; Point
; Point1
; Point2
; PointTemp
; SelectionFrame)
; (setq LengthCurve (vlax-curve-getDistAtParam VlaObject (vlax-curve-getEndParam VlaObject)))
; (setq NumSegment (/ LengthCurve (* ToleranceDistance 5.0)))
; (setq NumSegment (fix (AJOIN_ROUNDOFF_NUMBER NumSegment 1.0)))
; (setq LengthSegment (/ LengthCurve NumSegment))
; (setq Num 0)
; (repeat (+ NumSegment 1)
; (if (= Num NumSegment)
; (setq Point (vlax-curve-getEndPoint VlaObject))
; (setq Point (vlax-curve-getPointAtDist VlaObject (* Num LengthSegment)))
; )
; (setq Param (vlax-curve-getParamAtPoint VlaObject point))
; (setq FirstDeriv (vlax-curve-getFirstDeriv VlaObject param))
; (setq AngleDeriv (angle (list 0.0 0.0 0.0) (list (nth 0 FirstDeriv) (nth 1 FirstDeriv) 0.0)))
; (setq Point1 (polar Point (+ AngleDeriv (/ Pi 2.0)) LengthSegment))
; (setq Point2 (polar Point (- AngleDeriv (/ Pi 2.0)) LengthSegment))
; ; (if (= Num 0)
; ; (progn
; ; (setq PointTemp (polar Point1 (- AngleDeriv Pi) LengthSegment))
; ; (setq ListPoint (append (list PointTemp) ListPoint))
; ; (setq PointTemp (polar Point2 (- AngleDeriv Pi) LengthSegment))
; ; (setq ListPoint (append ListPoint (list PointTemp)))
; ; )
; ; )
; (setq ListPoint (append (list Point1) ListPoint))
; (setq ListPoint (append ListPoint (list Point2)))
; ; (if (= Num NumSegment)
; ; (progn
; ; (setq PointTemp (polar Point1 AngleDeriv LengthSegment))
; ; (setq ListPoint (append (list PointTemp) ListPoint))
; ; (setq PointTemp (polar Point2 AngleDeriv LengthSegment))
; ; (setq ListPoint (append ListPoint (list PointTemp)))
; ; )
; ; )
; (setq Num (+ Num 1))
; )
; (setq SelectionFrame (mapcar '(lambda (x) (list (nth 0 x) (nth 1 x))) ListPoint))
; )
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_BREAK_OBJECT ( DataBreakObject /
ListPoint
ListPropertyObject
ListVlaObjectNew
ListVlaObjectTemp
TypeObject
VlaObject)
(setq VlaObject (car DataBreakObject))
(setq ListPoint (cdr DataBreakObject))
(setq ListPoint (AJOIN_REMOVE_DUPLICATE_POINT_IN_LISTPOINT ListPoint))
(setq TypeObject (vla-get-ObjectName VlaObject))
(if (= TypeObject "AcDbArc")
(progn
(setq ListVlaObjectTemp (AJOIN_BREAK_OBJECT_ARC VlaObject ListPoint))
(setq ListVlaObjectNew (append ListVlaObjectNew ListVlaObjectTemp))
)
)
(if (= TypeObject "AcDbCircle")
(progn
(setq ListVlaObjectTemp (AJOIN_BREAK_OBJECT_CIRCLE VlaObject ListPoint))
(setq ListVlaObjectNew (append ListVlaObjectNew ListVlaObjectTemp))
)
)
(if (= TypeObject "AcDbLine")
(progn
(setq ListVlaObjectTemp (AJOIN_BREAK_OBJECT_LINE VlaObject ListPoint))
(setq ListVlaObjectNew (append ListVlaObjectNew ListVlaObjectTemp))
)
)
(if (= TypeObject "AcDbPolyline")
(progn
(setq ListVlaObjectTemp (AJOIN_BREAK_OBJECT_POLYLINE VlaObject ListPoint))
(setq ListVlaObjectNew (append ListVlaObjectNew ListVlaObjectTemp))
)
)
(setq ListPropertyObject (AJOIN_GET_PROPERTIES_OBJECT VlaObject))
(foreach VlaObjectNew ListVlaObjectNew
(AJOIN_PUT_PROPERTIES_OBJECT VlaObjectNew ListPropertyObject)
)
(vla-delete VlaObject)
ListVlaObjectNew
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_BREAK_OBJECT_LINE ( VlaObject ListPointBreak /
ListDataLine
ListPoint
ListDataCurve
ListPointAll
ListVlaObjectLine
Num
PointEnd
PointStart
VlaObjectLine)
(setq ListPoint (list (vlax-curve-getStartPoint VlaObject) (vlax-curve-getEndPoint VlaObject)))
(setq ListDataCurve
(append
(mapcar '(lambda ( Point ) (list Point (vlax-curve-getParamAtPoint VlaObject Point))) ListPoint)
(mapcar '(lambda ( Point ) (list Point (vlax-curve-getParamAtPoint VlaObject Point))) ListPointBreak)
)
)
(setq ListDataCurve (vl-sort ListDataCurve '(lambda (a b) (< (nth 1 a) (nth 1 b)))))
(setq ListPointAll (mapcar 'car ListDataCurve))
(setq PointStart (car ListPointAll))
(setq Num 1)
(repeat (- (length ListPointAll) 1)
(setq PointEnd (nth Num ListPointAll))
(setq ListDataLine (cons (list PointStart PointEnd) ListDataLine))
(setq PointStart PointEnd)
(setq Num (+ Num 1))
)
(foreach DataLine ListDataLine
(setq VlaObjectLine (AJOIN_CREATE_LINE DataLine))
(setq ListVlaObjectLine (cons VlaObjectLine ListVlaObjectLine))
)
ListVlaObjectLine
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CREATE_LINE ( DataLine /
PointEnd
PointStart)
(setq PointStart (nth 0 DataLine))
(setq PointEnd (nth 1 DataLine))
(setq VlaObjectLine (vla-addline VlaSpace (vlax-3d-point PointStart) (vlax-3d-point PointEnd)))
VlaObjectLine
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_BREAK_OBJECT_ARC ( VlaObject ListPointBreak /
DataCurveEnd
DataCurveStart
ListDataArc
ListDataCurve
ListVlaObjectArc
Num
ParamEnd
ParamMiddle
ParamStart
PointEnd
PointMiddle
PointStart
VlaObjectArc)
(setq ListDataCurve (mapcar '(lambda ( Point ) (list Point (vlax-curve-getParamAtPoint VlaObject Point))) ListPointBreak))
(setq ListDataCurve (vl-sort ListDataCurve '(lambda (a b) (< (nth 1 a) (nth 1 b)))))
(setq ListDataCurve (append (list (list (vlax-curve-getStartPoint VlaObject) (vlax-curve-getStartParam VlaObject))) ListDataCurve))
(setq ListDataCurve (append ListDataCurve (list (list (vlax-curve-getEndPoint VlaObject) (vlax-curve-getEndParam VlaObject)))))
(setq DataCurveStart (car ListDataCurve))
(setq Num 1)
(repeat (- (length ListDataCurve) 1)
(setq PointStart (nth 0 DataCurveStart))
(setq ParamStart (nth 1 DataCurveStart))
(setq DataCurveEnd (nth Num ListDataCurve))
(setq PointEnd (nth 0 DataCurveEnd))
(setq ParamEnd (nth 1 DataCurveEnd))
(setq ParamMiddle (/ (+ ParamStart ParamEnd) 2.0))
(setq PointMiddle (vlax-curve-getPointAtParam VlaObject ParamMiddle))
(setq ListDataArc (cons (list PointStart PointMiddle PointEnd) ListDataArc))
(setq DataCurveStart DataCurveEnd)
(setq Num (+ Num 1))
)
(foreach DataArc ListDataArc
(setq VlaObjectArc (AJOIN_CREATE_ARC DataArc))
(setq ListVlaObjectArc (cons VlaObjectArc ListVlaObjectArc))
)
ListVlaObjectArc
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CREATE_ARC ( DataArc /
AngleEnd
AngleStart
ListTemp
PointCenter
PointEnd
PointMiddle
PointStart
Radius)
(setq PointStart (nth 0 DataArc))
(setq PointMiddle (nth 1 DataArc))
(setq PointEnd (nth 2 DataArc))
(setq ListTemp (AJOIN_THREE_POINT_TO_ARC PointStart PointMiddle PointEnd))
(setq PointCenter (nth 0 ListTemp))
(setq Radius (nth 1 ListTemp))
(setq AngleStart (angle PointCenter PointStart))
(setq AngleEnd (angle PointCenter PointEnd))
(setq VlaObjectArc (vla-AddArc VlaSpace (vlax-3d-point PointCenter) Radius AngleStart AngleEnd))
VlaObjectArc
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_BREAK_OBJECT_CIRCLE ( VlaObject ListPointBreak /
DataCurveEnd
DataCurveStart
ListDataArc
ListDataCurve
ListVlaObjectArc
Num
ParamEnd
ParamMiddle
ParamStart
PointEnd
PointMiddle
PointStart
VlaObjectArc)
(if (> (length ListPointBreak) 1)
(progn
(setq ListDataCurve (mapcar '(lambda ( Point ) (list Point (vlax-curve-getParamAtPoint VlaObject Point))) ListPointBreak))
(setq ListDataCurve (vl-sort ListDataCurve '(lambda (a b) (< (nth 1 a) (nth 1 b)))))
(setq DataCurveStart (car ListDataCurve))
(setq Num 1)
(repeat (- (length ListDataCurve) 1)
(setq PointStart (nth 0 DataCurveStart))
(setq ParamStart (nth 1 DataCurveStart))
(setq DataCurveEnd (nth Num ListDataCurve))
(setq PointEnd (nth 0 DataCurveEnd))
(setq ParamEnd (nth 1 DataCurveEnd))
(setq ParamMiddle (/ (+ ParamStart ParamEnd) 2.0))
(setq PointMiddle (vlax-curve-getPointAtParam VlaObject ParamMiddle))
(setq ListDataArc (cons (list PointStart PointMiddle PointEnd) ListDataArc))
(setq DataCurveStart DataCurveEnd)
(setq Num (+ Num 1))
)
(setq PointStart (nth 0 DataCurveStart))
(setq ParamStart (nth 1 DataCurveStart))
(setq PointEnd (nth 0 (car ListDataCurve)))
(setq ParamEnd (nth 1 DataCurveEnd))
(setq ParamMiddle (/ (+ ParamStart ParamEnd) 2.0))
(setq ListDataArc (cons (list PointStart PointMiddle PointEnd) ListDataArc))
(foreach DataArc ListDataArc
(setq VlaObjectArc (AJOIN_CREATE_ARC DataArc))
(setq ListVlaObjectArc (cons VlaObjectArc ListVlaObjectArc))
)
)
(setq ListVlaObjectArc (list VlaObject))
)
ListVlaObjectArc
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_BREAK_OBJECT_POLYLINE ( VlaObject ListPointBreak /
BulgeSegment
CheckClosed
CheckPointEnd
CheckPointStart
CheckSamePoint
CheckStartPart
DataPolyline
DataPolylineSegment
LengthTotal
ListBulgeSegment
ListDataCurve
ListDataCurve1
ListDataCurve2
ListPoint
ListPointNew
ListPointSegment
ListPointSegmentTotal
ListPointTemp
ListVlaObjectPolyline
NumPoint
NumSegment
NumSegmentSum
ParamEnd
ParamMiddle
ParamStart
Point
PointEnd
PointMiddle
PointStart
VlaObjectPolyline)
(setq DataPolyline (AJOIN_GET_DATAPOLYLINE VlaObject))
(setq ListPoint (nth 0 DataPolyline))
(setq LengthTotal (length ListPoint))
(setq NumPoint 0)
(while (< NumPoint LengthTotal)
(setq PointStart (nth NumPoint ListPoint))
(setq CheckSamePoint T)
(while CheckSamePoint
(setq PointEnd (nth (+ NumPoint 1) ListPoint))
(if PointEnd
(setq CheckSamePoint (AJOIN_CHECK_SAME_POINT PointStart PointEnd ToleranceDistance))
(setq CheckSamePoint Nil)
)
(setq NumPoint (+ NumPoint 1))
)
(setq ListPointNew (cons PointStart ListPointNew))
)
(if (AJOIN_CHECK_SAME_POINT (car ListPointNew) (last ListPointNew) ToleranceDistance)
(progn
(setq ListPointNew (cdr ListPointNew))
(setq CheckClosed T)
)
(setq CheckClosed (= (vla-get-closed VlaObject) :vlax-true))
)
(setq ListPoint (reverse ListPointNew))
(if
(and
CheckClosed
(= (length ListPointBreak) 1)
)
(progn
(setq ListVlaObjectPolyline (list VlaObject))
)
(progn
;; (setq DataPolyline (AJOIN_GET_DATAPOLYLINE VlaObject))
;; (setq ListPoint (nth 0 DataPolyline))
(foreach Point ListPoint
(if (not (AJOIN_CHECK_POINT_IS_MEMBER_LISTPOINT Point ListPointBreak))
(setq ListPointTemp (cons Point ListPointTemp))
)
)
(setq ListPoint ListPointTemp)
(setq ListDataCurve
(append
(mapcar '(lambda ( Point ) (list Nil Point (vlax-curve-getParamAtPoint VlaObject Point))) ListPoint)
(mapcar '(lambda ( Point ) (list T Point (vlax-curve-getParamAtPoint VlaObject Point))) ListPointBreak)
)
)
(setq ListDataCurve (vl-sort ListDataCurve '(lambda (a b) (< (nth 2 a) (nth 2 b)))))
(if CheckClosed
(progn
(foreach DataCurve ListDataCurve
(if CheckStartPart
(setq ListDataCurve1 (append ListDataCurve1 (list DataCurve)))
(progn
(if (nth 0 DataCurve)
(progn
(setq CheckStartPart T)
(setq DataCurve (subst Nil T DataCurve))
(setq ListDataCurve1 (append ListDataCurve1 (list DataCurve)))
(setq ListDataCurve2 (append ListDataCurve2 (list DataCurve)))
)
(setq ListDataCurve2 (append ListDataCurve2 (list DataCurve)))
)
)
)
)
(setq ListDataCurve (append ListDataCurve1 ListDataCurve2))
)
)
(foreach DataCurve ListDataCurve
(setq Point (nth 1 DataCurve))
(setq ListPointSegment (append ListPointSegment (list Point)))
(if (nth 0 DataCurve)
(progn
(setq ListPointSegmentTotal (append ListPointSegmentTotal (list ListPointSegment)))
(setq ListPointSegment (list Point))
)
)
)
(setq ListPointSegmentTotal (append ListPointSegmentTotal (list ListPointSegment)))
(setq NumSegment 1)
(setq NumSegmentSum (length ListPointSegmentTotal))
(foreach ListPointSegment ListPointSegmentTotal
(setq ListBulgeSegment Nil)
(setq NumPoint 0)
(repeat (- (length ListPointSegment) 1)
(setq PointStart (nth NumPoint ListPointSegment))
(setq PointEnd (nth (+ NumPoint 1) ListPointSegment))
(if (= NumSegment NumSegmentSum)
(progn
(setq CheckPointStart (AJOIN_CHECK_SAME_POINT PointStart (vlax-curve-getStartPoint VlaObject) ToleranceValue))
(setq CheckPointEnd (AJOIN_CHECK_SAME_POINT PointEnd (vlax-curve-getEndPoint VlaObject) ToleranceValue))
)
(progn
(setq CheckPointStart Nil)
(setq CheckPointEnd Nil)
)
)
(if CheckPointStart
(setq ParamStart (vlax-curve-getStartParam VlaObject))
(setq ParamStart (vlax-curve-getParamAtPoint VlaObject PointStart))
)
(if CheckPointEnd
(setq ParamEnd (vlax-curve-getEndParam VlaObject))
(setq ParamEnd (vlax-curve-getParamAtPoint VlaObject PointEnd))
)
(setq ParamMiddle (/ (+ ParamStart ParamEnd) 2.0))
(setq PointMiddle (vlax-curve-getPointAtParam VlaObject ParamMiddle))
(setq BulgeSegment (AJOIN_THREE_POINT_TO_BULGE PointStart PointMiddle PointEnd))
(setq ListBulgeSegment (append ListBulgeSegment (list BulgeSegment)))
(setq NumPoint (+ NumPoint 1))
)
(setq ListBulgeSegment (append ListBulgeSegment (list 0.0)))
(setq DataPolylineSegment (list ListPointSegment ListBulgeSegment))
(setq VlaObjectPolyline (AJOIN_CREATE_POLYLINE DataPolylineSegment Nil))
(setq ListVlaObjectPolyline (cons VlaObjectPolyline ListVlaObjectPolyline))
(setq NumSegment (+ NumSegment 1))
)
)
)
ListVlaObjectPolyline
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_VLA_GET_LAYER ( VlaObject / NameLayer)
(setq NameLayer (cdr (assoc 8 (entget (vlax-vla-object->ename VlaObject)))))
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_GET_PROPERTIES_OBJECT ( VlaObject /
ListNameProperty
ListPropertyObject)
(setq ListNameProperty
(list
"EntityTransparency"
"Layer"
"Linetype"
"LinetypeScale"
"Lineweight"
"Material"
"PlotStyleName"
"TrueColor"
)
)
(foreach NameProperty ListNameProperty
(vl-catch-all-error-p (vl-catch-all-apply (function (lambda ( / )
(setq ListPropertyObject (cons (cons NameProperty (vlax-get-property VlaObject NameProperty)) ListPropertyObject))
))))
)
ListPropertyObject
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_PUT_PROPERTIES_OBJECT ( VlaObject ListPropertyObject /
NameProperty
ValueProperty)
(foreach PropertyObject ListPropertyObject
(vl-catch-all-error-p (vl-catch-all-apply (function (lambda ( / )
(setq NameProperty (car PropertyObject))
(setq ValueProperty (cdr PropertyObject))
(vlax-put-property VlaObject NameProperty ValueProperty)
))))
)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CREATE_SELECTION_REGION ( /
CodeMouse
Color
PointA
PointB
PointC
PointD
PointTemp
Opacity
ListCoordinates
ListPoint
Temp
VlaObjectSolid)
(setq PointA (getpoint "\nSpecify region to join:"))
(setq PointB PointA)
(setq VlaObjectSolid
(vla-AddSolid
VlaSpace
(vlax-3d-point PointA)
(vlax-3d-point (list (nth 0 PointB) (nth 1 PointA) 0.0))
(vlax-3d-point (list (nth 0 PointA) (nth 1 PointB) 0.0))
(vlax-3d-point PointB)
)
)
(vl-catch-all-apply (function (lambda ( / )
(setq Color (getvar "CROSSINGAREACOLOR"))
)))
(vl-catch-all-apply (function (lambda ( / )
(setq Opacity (getvar "SELECTIONAREAOPACITY"))
(setq Opacity (itoa (/ (- 100 Opacity))))
)))
(if (not Color) (setq Color 100))
(if (not Opacity) (setq Color "75"))
(vla-put-color VlaObjectSolid Color)
(vl-catch-all-apply (function (lambda ( / )
(vla-put-EntityTransparency VlaObjectSolid Opacity)
)))
(if
(not (vl-catch-all-error-p (vl-catch-all-apply (function (lambda ( / )
(setq CodeMouse 5)
(while (= CodeMouse 5)
(setq Temp (grread T))
(setq CodeMouse (nth 0 Temp))
(if (or (= CodeMouse 5) (= CodeMouse 3))
(progn
(setq PointTemp (nth 1 Temp))
(if (not (AJOIN_CHECK_SAME_POINT PointB PointTemp ToleranceValue))
(progn
(redraw)
(setq PointB PointTemp)
(setq PointC (list (nth 0 PointB) (nth 1 PointA) 0.0))
(setq PointD (list (nth 0 PointA) (nth 1 PointB) 0.0))
(grvecs (list 7 PointA PointC 7 PointC PointB 7 PointB PointD 7 PointD PointA))
(setq ListCoordinates (append PointA PointC PointD PointB))
(vla-put-Coordinates
VlaObjectSolid
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbDouble
(cons 0 (- (length ListCoordinates) 1))
)
ListCoordinates
)
)
)
)
)
)
)
)))))
(setq ListPoint
(list
(list (min (nth 0 PointA) (nth 0 PointB)) (min (nth 1 PointA) (nth 1 PointB)) 0.0)
(list (max (nth 0 PointA) (nth 0 PointB)) (max (nth 1 PointA) (nth 1 PointB)) 0.0)
)
)
)
(redraw)
(vla-delete VlaObjectSolid)
ListPoint
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_CREATE_LISTVLALAYERLOCK ( / VlaLayersGroup)
(setq VlaLayersGroup (vla-get-layers VlaDrawingCurrent))
(vlax-for VlaLayer VlaLayersGroup
(if
(= (vla-get-Lock VlaLayer) :vlax-true)
(progn
(vla-put-Lock VlaLayer :vlax-false)
(setq ListVlaLayerLock (cons VlaLayer ListVlaLayerLock))
)
)
)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_RESTORE_LOCK_LAYER ( / )
(foreach VlaLayerLock ListVlaLayerLock
(vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Lock (list VlaLayerLock :vlax-true)))
)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_SET_VARSYSTEM ( / Temp VarSystem)
(foreach Temp (list (list "CMDECHO" 0) (list "MODEMACRO" "") (list "DIMZIN" 8) (list "OSMODE" 0) (list "TRANSPARENCYDISPLAY" 1))
(setq VarSystem (car Temp))
(setq ListVarSystem_OldValue (cons (list VarSystem (getvar VarSystem)) ListVarSystem_OldValue))
(setvar VarSystem (cadr Temp))
)
)
-------------------------------------------------------------------------------------------------------------------
(defun AJOIN_RESET_VARSYSTEM ( / Temp VarSystem)
(foreach Temp ListVarSystem_OldValue
(setvar (car Temp) (cadr Temp))
)
)
Link tải
---------------------------------------------------------------------------------------------
Lisp được chia sẻ bởi HNP.
Mọi thông tin xin liên hệ Fanpage AutoLISP Thật là đơn giản hoặc Zalo/điện thoại 0365.870.365!
Cảm ơn bạn đã theo dõi!
Không có nhận xét nào:
Đăng nhận xét