Export data to Excel
Accepted solution
(defun c:PolylineToExcelLive (/ excelObj workbookObj sheetObj currentRow
selTextPointNum entTextPointNumData textTypePointNum textStringPointNum pointNumberExtracted
selTextYBase entTextYBaseData textTypeYBase textStringYBase textTargetY
clickedRefPt refX refY
selPoly entPolyData polyType vtxList pt dxfValue
oldX oldY adjustedX newY
minDistance dist closestPolyPointX processGroupSuccess)
(vl-load-com) ; Load Visual LISP library (required for ActiveX)
;; --- Helper function to set cell value using Range property ---
;; ແກ້ໄຂ: ປັບປຸງການຈັດການຂໍ້ຜິດພາດ ແລະ ໃຫ້ ActiveX ຈັດການການປ່ຽນປະເພດຂໍ້ມູນໂດຍອັດຕະໂນມັດ
;; ປ່ຽນຈາກ Cells.Item ໄປໃຊ້ Range
; Reverted to original Header
(defun setcellvalue (sheet objRow objCol value / rangeObj result colChar)
;; ປ່ຽນເລກຄໍລຳ (1, 2, 3...) ໃຫ້ເປັນໂຕອັກສອນ Excel (A, B, C...)
;; ຟັງຊັນນີ້ຮອງຮັບສະເພາະຄໍລຳ A-Z (ສຳລັບ 26 ຄໍລຳທຳອິດ)
(setq colChar (chr (+ 64 objCol))) ; 64 ແມ່ນ ASCII ຂອງ '@', ເມື່ອ +1 ຈະໄດ້ 'A'
(setq rangeObj (vlax-get-property sheet 'Range (strcat colChar (itoa objRow))))
(if rangeObj
(progn
;; ໂດຍກົງກຳນົດຄ່າໄປຍັງຄຸນສົມບັດ Value ຂອງ Range object
(setq result (vl-catch-all-apply
'vlax-put-property
(list rangeObj 'Value2 value)
))
(if (vl-catch-all-error-p result)
;; ປ່ຽນຂໍ້ຄວາມຜິດພາດເພື່ອຫຼີກລ້ຽງ VL-CATCH-ALL-ERROR-ERROR-MESSAGE
(princ (strcat "\nERROR writing to Range " colChar (itoa objRow) ": ຂໍ້ຜິດພາດ ActiveX ທີ່ບໍ່ຮູ້ຈັກເກີດຂຶ້ນ (ເປັນໄປໄດ້ແມ່ນ Type Mismatch)."))
)
)
(princ (strcat "\nERROR: Could not get Range " colChar (itoa objRow) " object."))
)
)
; --- START Excel Automation ---
(setq excelObj (vlax-get-or-create-object "Excel.Application")) ; Create an Excel Application object
(if excelObj
(progn
(vlax-put-property excelObj 'Visible :vlax-true) ; Make Excel visible
;; --- DEBUG: ກວດສອບ Object ຂອງ Excel ---
(princ (strcat "\nDEBUG: Excel Object Created: " (if excelObj "YES" "NO")))
(setq workbookObj (vlax-invoke (vlax-get-property excelObj 'Workbooks) 'Add))
;; --- DEBUG: ກວດສອບ Object ຂອງ Workbook ---
(princ (strcat "\nDEBUG: Workbook Object Created: " (if workbookObj "YES" "NO")))
(if (not workbookObj)
(progn
(princ "\nຂໍ້ຜິດພາດ: ບໍ່ສາມາດສ້າງ Workbook ໃໝ່ໄດ້. ກະລຸນາກວດສອບການຕັ້ງຄ່າ Excel.")
(vlax-release-object excelObj)
(exit) ; ອອກຈາກຟັງຊັນ
)
)
(setq sheetObj (vlax-get-property (vlax-get-property workbookObj 'Sheets) 'Item 1))
;; --- DEBUG: ກວດສອບ Object ຂອງ Sheet ---
(princ (strcat "\nDEBUG: Sheet Object Created: " (if sheetObj "YES" "NO")))
(if (not sheetObj)
(progn
(princ "\nຂໍ້ຜິດພາດ: ບໍ່ສາມາດເອົາ Sheet ທີ່ເຮັດວຽກໄດ້. ກະລຸນາກວດສອບ Excel.")
(if workbookObj (vlax-release-object workbookObj))
(if excelObj (vlax-release-object excelObj))
(exit) ; ອອກຈາກຟັງຊັນ
)
)
; Write header using the new setcellvalue helper function
(setcellvalue sheetObj 1 1 "Point_Number") ; Reverted to original Header
(setcellvalue sheetObj 1 2 "X_Coordinate")
(setcellvalue sheetObj 1 3 "Y_Coordinate")
(setq currentRow 2) ; Start writing data from row 2
(princ "\n--- ເລີ່ມການປະມວນຜົນ Profile ແບບຕໍ່ເນື່ອງໄປຍັງ Excel ---")
(princ "\nກົດ Enter ເປົ່າໆ ໃນຂັ້ນຕອນທີ 1 ເພື່ອຢຸດຄຳສັ່ງ.")
; Start of the continuous loop
(while T ; Loop indefinitely until explicitly broken
(setq processGroupSuccess nil) ; Reset flag for each iteration
; --- 1. Get Point_Number value from Text ---
(princ "\n\n1. ເລືອກ Text (MTEXT ຫຼື TEXT) ສໍາລັບ Point_Number (ເຊັ່ນ 0+254 ຫຼື 1+654): ")
(setq selTextPointNum (entsel))
(if (not selTextPointNum) ; If user presses Enter (no selection)
(progn
(princ "\nບໍ່ມີ Text Point_Number ຖືກເລືອກ. ສິ້ນສຸດການດຳເນີນການ.")
(exit) ; Exit the LISP function cleanly
)
)
(setq entTextPointNumData (entget (car selTextPointNum)))
(setq textTypePointNum (cdr (assoc 0 entTextPointNumData)))
(if (or (= textTypePointNum "TEXT") (= textTypePointNum "MTEXT"))
(progn
(setq textStringPointNum (cdr (assoc 1 entTextPointNumData)))
;; --- POINT OF CHANGE: Keep "0+000" as is ---
(setq pointNumberExtracted textStringPointNum) ; Keep the original string including '+'
;; --- DEBUG: ຄ່າ Point Number ---
(princ (strcat "\nDEBUG: PointNumberExtracted = " (vl-princ-to-string pointNumberExtracted)))
(if (and pointNumberExtracted (/= pointNumberExtracted ""))
(progn
; --- 2. Get Y Base Text ---
(princ "\n2. ເລືອກ Text (MTEXT ຫຼື TEXT) ທີ່ມີຕົວເລກສຳລັບຄ່າ Y ພື້ນຖານ: ")
(setq selTextYBase (entsel "\n"))
(if selTextYBase
(progn
(setq entTextYBaseData (entget (car selTextYBase)))
(setq textTypeYBase (cdr (assoc 0 entTextYBaseData)))
(if (or (= textTypeYBase "TEXT") (= textTypeYBase "MTEXT"))
(progn
(setq textStringYBase (cdr (assoc 1 entTextYBaseData)))
;; --- DEBUG: ຕວດສອບຄ່າຂອງ textStringYBase ກ່ອນ distof ---
(princ (strcat "\nDEBUG: Value of textStringYBase before distof = \"" textStringYBase "\""))
(setq textTargetY (distof textStringYBase))
;; --- DEBUG: ຄ່າ Y Base Text ---
(princ (strcat "\nDEBUG: TextStringYBase = " (vl-princ-to-string textStringYBase)))
(princ (strcat "\nDEBUG: Debug TextTargetY (converted) = " (vl-princ-to-string textTargetY)))
(if textTargetY
(progn
; --- 3. Get X=0 and Y base reference point from user click ---
(princ "\n3. ຄລິກຈຸດໃດໜຶ່ງໃນ CAD ເພື່ອກຳນົດຄ່າ X=0 ແລະ Y ພື້ນຖານ: ")
(setq clickedRefPt (getpoint "\n"))
(if clickedRefPt
(progn
(setq refX (car clickedRefPt))
(setq refY (cadr clickedRefPt))
;; --- DEBUG: ຄ່າ Reference Point ---
(princ (strcat "\nDEBUG: Reference X = " (rtos refX 2 8) ", Reference Y = " (rtos refY 2 8)))
; --- 4. Select Polyline ---
(princ "\n4. ເລືອກ Polyline ທີ່ທ່ານຕ້ອງການສົ່ງອອກຂໍ້ມູນ: ")
(setq selPoly (entsel "\n"))
(if selPoly
(progn
(setq entPolyData (entget (car selPoly)))
(setq polyType (cdr (assoc 0 entPolyData)))
(if (or (= polyType "LWPOLYLINE") (= polyType "POLYLINE"))
(progn
; --- Start of Main Logic ---
(setq vtxList '())
(if (= polyType "LWPOLYLINE")
(foreach n entPolyData
(if (= (car n) 10)
(setq vtxList (cons (cdr n) vtxList))
)
)
(progn
(setq pt (entnext (car selPoly)))
(while (and pt (= (cdr (assoc 0 (entget pt))) "VERTEX"))
(setq vtxList (cons (cdr (assoc 10 (entget pt))) vtxList))
(setq pt (entnext pt))
)
)
)
(setq vtxList (reverse vtxList))
; Find the polyline point closest to clickedRefPt for X reference
(setq minDistance 1e9 closestPolyPointX nil)
(foreach vtx vtxList
(setq dist (distance (list (car vtx) (cadr vtx)) clickedRefPt))
(if (< dist minDistance)
(setq minDistance dist closestPolyPointX (car vtx))
)
)
(if closestPolyPointX
(progn
(setq refX closestPolyPointX) ; Use X of closest polyline point as the actual reference X for X=0
; --- Write calculated data to Excel ---
(foreach vtx vtxList
(setq oldX (car vtx))
(setq oldY (cadr vtx))
(setq adjustedX (- oldX refX))
(setq newY (+ textTargetY (- oldY refY)))
;; --- DEBUG: ຄ່າທີ່ຈະຖືກສົ່ງໄປ Excel ---
(princ (strcat "\nDEBUG: Row " (itoa currentRow) " - PointNum: " (vl-princ-to-string pointNumberExtracted)))
(princ (strcat "\nDEBUG: Row " (itoa currentRow) " - AdjustedX: " (rtos adjustedX 2 8)))
(princ (strcat "\nDEBUG: Row " (itoa currentRow) " - NewY: " (rtos newY 2 8)))
; Convert numbers to string and use setcellvalue helper
(setcellvalue sheetObj currentRow 1 pointNumberExtracted) ; Use the original point number string
(setcellvalue sheetObj currentRow 2 (rtos adjustedX 2 8)) ; rtos for X (string)
(setcellvalue sheetObj currentRow 3 (rtos newY 2 8)) ; rtos for Y (string)
(setq currentRow (1+ currentRow))
)
(princ (strcat "\nສຳເລັດ! ຂໍ້ມູນຖືກບັນທຶກລົງ Excel. ແຖວປັດຈຸບັນ: " (itoa (1- currentRow))))
(setq processGroupSuccess T) ; Mark as success
)
(princ "\nຂໍ້ຜິດພາດ: ບໍ່ສາມາດກວດພົບຈຸດ Polyline ທີ່ໃກ້ຄຽງກັບຈຸດທີ່ຄລິກໄດ້.")
)
)
(princ "\nຂໍ້ຜິດພາດ: ເອນທິຕີທີ່ເລືອກບໍ່ແມ່ນ Polyline.")
)
)
(princ "\nຂໍ້ຜິດພາດ: ບໍ່ມີ Polyline ຖືກເລືອກ.")
)
)
(princ "\nຂໍ້ຜິດພາດ: ບໍ່ມີຈຸດ X=0 ຖືກຄລິກ.")
)
)
(princ "\nຂໍ້ຜິດພາດ: Text ທີ່ເລືອກບໍ່ມີຕົວເລກ ຫຼື ບໍ່ສາມາດແປງເປັນຕົວເລກໄດ້.")
)
)
(princ "\nຂໍ້ຜິດພາດ: ເອນທິຕີທີ່ເລືອກບໍ່ແມ່ນ Text (TEXT ຫຼື MTEXT).")
)
)
(princ "\nຂໍ້ຜິດພາດ: ບໍ່ມີ Text ສໍາລັບ Y ພື້ນຖານຖືກເລືອກ.")
)
)
(princ "\nຂໍ້ຜິດພາດ: Text ສໍາລັບ Point_Number ບໍ່ຖືກຕ້ອງ.")
)
)
(princ "\nຂໍ້ຜິດພາດ: ເອນທິຕີທີ່ເລືອກບໍ່ແມ່ນ Text (TEXT ຫຼື MTEXT).")
)
(if (not processGroupSuccess)
(princ "\n--- ຂ້າມການປະມວນຜົນກຸ່ມປັດຈຸບັນ ---")
)
(princ "\n>>> ສືບຕໍ່ປະມວນຜົນກຸ່ມຕໍ່ໄປ (ກົດ Enter ໃນຂັ້ນຕອນທີ 1 ເພື່ອອອກ) <<<")
) ; End of while loop
)
(princ "\nບໍ່ສາມາດສ້າງວັດຖຸ Excel ໄດ້. ກະລຸນາກວດສອບວ່າ Microsoft Excel ຕິດຕັ້ງຢູ່.")
)
; Clean up Excel objects
(if sheetObj (vlax-release-object sheetObj))
(if workbookObj (vlax-release-object workbookObj))
(if excelObj (vlax-release-object excelObj))
(princ)
)
@chan230984 TRY
