Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
Người theo dõi 0
loopback127xyz

Nhờ Viết Lisp Chuyển Tọa Độ Góc Ranh Từ File Excel Sang Autocad

Bởi loopback127xyz , trong AutoLisp

Các bài được khuyến nghị

loopback127xyz    1

loopback127xyz
Đã đăng

Nhờ các Anh, Em viết dùm lisp chuyển tọa độ góc ranh từ file excel sang autocad.

 

Mình thường tìm thửa đất trong bản đồ bằng thủ công rất vất vã, mắt lại kém (viễn thị rồi) mà cái bản tọa độ số nhỏ quá.

 Mình dùng lệnh LINE để tìm thửa đất bằng thủ công như sau:

ví dụ : 

L ↵

click chọn đại 1 điểm rồi gõ 1, ↵ nhập tọa độ y trước, x sau ( 598838.222,1200196.772) ↵

                                               2, ↵ 598837.316,1200196.424 ↵

                                              3, ↵  598831.114,2300295.042 ↵

                                               4, ↵ ........

                                             ...................................................

 

Mình nhờ các bác viết dùm mình lisp tên : TDTD.lsp (lệnh gọi : tdtdat) làm công việc bằng tay trên thành lisp khi chay lisp xong nó sẽ xác định được khu đất mình cần tìm bằng đường polyline màu gì cũng được (khác màu trắng để biết được khu đất mình đang tìm).

 

Mình có scan tò chủ quyền phần tọa độ góc ranh(file hình), file excel, và bản đồ số đính kèm (trên bản đồ mình đã lấy tọa độ bằng pp thủ công rồi). Link:

http://www.cadviet.com/upfiles/5/18430_toadogocranh.rar

 

Thanks you các bác nhiều. Kiến thức hạn hẹp xin anh em giúp đỡ. Chân thành cám ơn

 

 

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

phamthanhbinh    3151

phamthanhbinh
Đã đăng

Nhờ các Anh, Em viết dùm lisp chuyển tọa độ góc ranh từ file excel sang autocad.

 

Mình thường tìm thửa đất trong bản đồ bằng thủ công rất vất vã, mắt lại kém (viễn thị rồi) mà cái bản tọa độ số nhỏ quá.

 Mình dùng lệnh LINE để tìm thửa đất bằng thủ công như sau:

ví dụ : 

L ↵

click chọn đại 1 điểm rồi gõ 1, ↵ nhập tọa độ y trước, x sau ( 598838.222,1200196.772) ↵

                                               2, ↵ 598837.316,1200196.424 ↵

                                              3, ↵  598831.114,2300295.042 ↵

                                               4, ↵ ........

                                             ...................................................

 

Mình nhờ các bác viết dùm mình lisp tên : TDTD.lsp (lệnh gọi : tdtdat) làm công việc bằng tay trên thành lisp khi chay lisp xong nó sẽ xác định được khu đất mình cần tìm bằng đường polyline màu gì cũng được (khác màu trắng để biết được khu đất mình đang tìm).

 

Mình có scan tò chủ quyền phần tọa độ góc ranh(file hình), file excel, và bản đồ số đính kèm (trên bản đồ mình đã lấy tọa độ bằng pp thủ công rồi). Link:

http://www.cadviet.com/upfiles/5/18430_toadogocranh.rar

 

Thanks you các bác nhiều. Kiến thức hạn hẹp xin anh em giúp đỡ. Chân thành cám ơn

Hề hề hề,

Cái này trên diễn đàn có khá nhiều lisp tương tự rồi. Bạn có thể tìm kiếm và chọn cho mình cái ưng ý.

Đây chỉ là một ví dụ để bạn tham khảo.

 

http://www.cadviet.com/upfiles/5/5194_vethuadat_1.lsp

 

Lưu ý bạn rằng lisp này chỉ phù hợp với bản vẽ và file excel bạn gửi. các trường hợp khác mình không bảo đảm bới không hiểu về các cách chuyển đổi hệ tọa độ trong trắc địa của bạn.

Trước khi chạy lisp bạn cần lưu file excel thành dạng file csv và xóa bỏ dòng title đầu tiên của bảng. Nếu không lisp sẽ bị lỗi

(defun c:tdtdat (/ oldos fn f str txl p)
(setq oldos (getvar  "osmode" ))
(setvar "osmode" 0)
(command "undo" "be")
(setq  fn (getfiled "Select Data File" "" "csv" 0)
            f (open fn "r")  )
(command "pline" )
(while  (/= (setq str (read-line f)) nil) 
   (setq txl (separate str ",")
            p (list (atof (caddr txl)) (atof (cadr txl))) )
   (command p)
)
(command "")
(close f)
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Separate (S sym / i L ch)
(setq i 0 L nil)
(while (< i (strlen S))
      (setq i (1+ i) ch (substr S i 1))
      (if (= ch sym) (progn
(setq
     L (append L (list (substr S 1 (- i 1))))
     S (substr S (1+ i) (- (strlen S) i))
     i 0
)
      )) 
)
(append L (list S))
)
 

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

cuongtk2    483

cuongtk2
Đã đăng

Bạn có thể dùng cái này:  

;;; ==========================================================================
;;; Mô tả: dòng đầu tiên trong file xlsx là header, không đọc dữ liệu dòng này
;;; lisp chỉ đọc dữ liệu ở sheet đầu tiên.
;;; ==========================================================================

(defun c:DrawRanhDat ( / xlApp xlWb xlSheet filename row ptList txtStt txtX txtY 
                          valStt valX valY numVerts entHeader emptyCount checkStt 
                          xlSheetObj cellsObj cellStt cellX cellY)
  (vl-load-com)
  
  ;; 1. Cho người dùng chọn file Excel
  (setq filename (getfiled "Select Excel File" "" "xlsx;xls" 0))
  (if (not filename)
    (progn
      (princ "\nNo file selected.")
      (exit)
    )
  )
  
  ;; 2. Kết nối và mở Excel ngầm
  (setq xlApp (vlax-get-or-create-object "Excel.Application"))
  (if (not xlApp)
    (progn
      (princ "\nCannot start Excel application.")
      (exit)
    )
  )
  (vla-put-visible xlApp :vlax-false)
  
  (setq xlWb (vlax-invoke-method (vlax-get-property xlApp 'Workbooks) 'Open filename))
  (setq xlSheet (vlax-get-property (vlax-get-property xlWb 'Sheets) 'Item 1))
  
  ;; Ép kiểu từ Variant sang VLA-Object thực thụ để tránh lỗi "bad argument type"
  (if (= (type xlSheet) 'VARIANT)
    (setq xlSheetObj (vlax-variant-value xlSheet))
    (setq xlSheetObj xlSheet)
  )
  
  ;; Lấy đối tượng Cells tổng thể trước khi vào vòng lặp để tăng tốc độ đọc
  (setq cellsObj (vlax-get-property xlSheetObj 'Cells))
  (if (= (type cellsObj) 'VARIANT)
    (setq cellsObj (vlax-variant-value cellsObj))
  )
  
  (setq row 2)        ; Bắt đầu đọc từ dòng 2 (bỏ qua tiêu đề)
  (setq ptList '()) 
  (setq emptyCount 0) ; Biến đếm số dòng trống liên tiếp để ngắt vòng lặp
  
  ;; Hàm phụ trợ chuyển đổi chuỗi số từ Excel sang số thực CAD
  (defun clean-and-parse (val / str)
    (cond
      ((= (type val) 'REAL) val)
      ((= (type val) 'INT) (float val))
      ((= (type val) 'STR)
        (setq str (vl-string-translate "," "." val))
        (atof str)
      )
      (t 0.0)
    )
  )

  ;; 3. Vòng lặp duyệt tuyến tính an toàn (Chặn trên tối đa 1000 dòng trống để chống treo)
  (while (and (< emptyCount 10) (< row 10000))
    
    ;; Đọc ô cột A trực tiếp qua đối tượng Cells đã được ép kiểu chuẩn
    (setq cellStt (vlax-variant-value (vlax-get-property cellsObj 'Item row 1)))
    (setq txtStt (vlax-get-property cellStt 'Value))
    (vlax-release-object cellStt)
    
    ;; Trích xuất giá trị an toàn từ Variant cột A
    (if txtStt
      (cond
        ((= (vlax-variant-type txtStt) vlax-vbString)
         (setq valStt (vl-string-trim " " (vlax-variant-value txtStt))))
        ((or (= (vlax-variant-type txtStt) vlax-vbInteger) 
             (= (vlax-variant-type txtStt) vlax-vbDouble)
             (= (vlax-variant-type txtStt) vlax-vbLong))
         (setq valStt (vl-princ-to-string (vlax-variant-value txtStt))))
        (t (setq valStt ""))
      )
      (setq valStt "")
    )

    ;; Kiểm tra dữ liệu cột A để xử lý hoặc tích lũy dòng trống
    (if (or (= valStt "") (= valStt " ") (= valStt "0") (= valStt "0.0"))
      (setq emptyCount (1+ emptyCount)) ; Nếu trống, tăng bộ đếm dòng trống
      (progn
        (setq emptyCount 0) ; Nếu có dữ liệu, reset bộ đếm dòng trống về 0
        
        ;; Đọc tiếp cột B và C
        (setq cellX (vlax-variant-value (vlax-get-property cellsObj 'Item row 2)))
        (setq txtX (vlax-get-property cellX 'Value))
        (vlax-release-object cellX)
        
        (setq cellY (vlax-variant-value (vlax-get-property cellsObj 'Item row 3)))
        (setq txtY (vlax-get-property cellY 'Value))
        (vlax-release-object cellY)
        
        ;; Tiến hành giải mã Variant và parse sang số thực
        (if (and txtX txtY)
          (progn
            (setq valX (clean-and-parse (vlax-variant-value txtX)))
            (setq valY (clean-and-parse (vlax-variant-value txtY)))
            
            ;; Thuật toán tự động đảo trục tọa độ trắc địa dựa trên số ký tự trước dấu phẩy:
            ;; Trục có 7 chữ số (> 1000000.0) là X_TrắcĐịa -> đưa vào Y_CAD
            ;; Trục có 6 chữ số là Y_TrắcĐịa -> đưa vào X_CAD
            (if (and (> valX 0.0) (> valY 0.0))
              (progn
                (if (> valX valY)
                  (setq ptList (append ptList (list (list valY valX)))) ; Cột B lớn hơn Cột C (Cột B là X_trắcđịa)
                  (setq ptList (append ptList (list (list valX valY)))) ; Cột C lớn hơn Cột B (Cột C là X_trắcđịa)
                )
              )
            )
          )
        )
      )
    )
    
    ;; ĐẢM BẢO LUÔN TĂNG DÒNG: Không bao giờ bị kẹt lại tại một dòng gây lặp vô hạn
    (setq row (1+ row))
  )
  
  ;; Giải phóng đối tượng Cells tổng thể
  (vlax-release-object cellsObj)
  
  ;; 4. Đóng Excel giải phóng bộ nhớ hệ thống
  (vlax-invoke-method xlWb 'Close :vlax-false)
  (vlax-invoke-method xlApp 'Quit)
  (vlax-release-object xlSheet)
  (vlax-release-object xlWb)
  (vlax-release-object xlApp)
  (setq xlApp nil)
  
  ;; 5. Tạo thực thể LWPOLYLINE khép kín bằng entmake
  (setq numVerts (length ptList))
  (if (> numVerts 2)
    (progn
      (setq entHeader (list
                        '(0 . "LWPOLYLINE")
                        '(100 . "AcDbEntity")
                        '(100 . "AcDbPolyline")
                        (cons 90 numVerts)
                        '(70 . 1) ; 1 = Closed Polyline
                      ))
      
      (foreach pt ptList
        (setq entHeader (append entHeader (list (cons 10 pt))))
      )
      
      (entmake entHeader)
      (vl-cmdf "_.regen")
      (princ (strcat "\nSuccessfully generated closed polyline with " (itoa numVerts) " vertices using entmake."))
    )
    (princ "\nError: Not enough valid points found in Excel file to create a polyline.")
  )
  (princ)
)

(princ "\n[Loaded] Type 'DrawRanhDat' to run the command.")
(princ)

 

  • Like 1

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

huytnmt    0

huytnmt
Đã đăng
Vào lúc 21/5/2026 tại 10:34, cuongtk2 đã nói:

Bạn có thể dùng cái này:  


;;; ==========================================================================
;;; Mô tả: dòng đầu tiên trong file xlsx là header, không đọc dữ liệu dòng này
;;; lisp chỉ đọc dữ liệu ở sheet đầu tiên.
;;; ==========================================================================

(defun c:DrawRanhDat ( / xlApp xlWb xlSheet filename row ptList txtStt txtX txtY 
                          valStt valX valY numVerts entHeader emptyCount checkStt 
                          xlSheetObj cellsObj cellStt cellX cellY)
  (vl-load-com)
  
  ;; 1. Cho người dùng chọn file Excel
  (setq filename (getfiled "Select Excel File" "" "xlsx;xls" 0))
  (if (not filename)
    (progn
      (princ "\nNo file selected.")
      (exit)
    )
  )
  
  ;; 2. Kết nối và mở Excel ngầm
  (setq xlApp (vlax-get-or-create-object "Excel.Application"))
  (if (not xlApp)
    (progn
      (princ "\nCannot start Excel application.")
      (exit)
    )
  )
  (vla-put-visible xlApp :vlax-false)
  
  (setq xlWb (vlax-invoke-method (vlax-get-property xlApp 'Workbooks) 'Open filename))
  (setq xlSheet (vlax-get-property (vlax-get-property xlWb 'Sheets) 'Item 1))
  
  ;; Ép kiểu từ Variant sang VLA-Object thực thụ để tránh lỗi "bad argument type"
  (if (= (type xlSheet) 'VARIANT)
    (setq xlSheetObj (vlax-variant-value xlSheet))
    (setq xlSheetObj xlSheet)
  )
  
  ;; Lấy đối tượng Cells tổng thể trước khi vào vòng lặp để tăng tốc độ đọc
  (setq cellsObj (vlax-get-property xlSheetObj 'Cells))
  (if (= (type cellsObj) 'VARIANT)
    (setq cellsObj (vlax-variant-value cellsObj))
  )
  
  (setq row 2)        ; Bắt đầu đọc từ dòng 2 (bỏ qua tiêu đề)
  (setq ptList '()) 
  (setq emptyCount 0) ; Biến đếm số dòng trống liên tiếp để ngắt vòng lặp
  
  ;; Hàm phụ trợ chuyển đổi chuỗi số từ Excel sang số thực CAD
  (defun clean-and-parse (val / str)
    (cond
      ((= (type val) 'REAL) val)
      ((= (type val) 'INT) (float val))
      ((= (type val) 'STR)
        (setq str (vl-string-translate "," "." val))
        (atof str)
      )
      (t 0.0)
    )
  )

  ;; 3. Vòng lặp duyệt tuyến tính an toàn (Chặn trên tối đa 1000 dòng trống để chống treo)
  (while (and (< emptyCount 10) (< row 10000))
    
    ;; Đọc ô cột A trực tiếp qua đối tượng Cells đã được ép kiểu chuẩn
    (setq cellStt (vlax-variant-value (vlax-get-property cellsObj 'Item row 1)))
    (setq txtStt (vlax-get-property cellStt 'Value))
    (vlax-release-object cellStt)
    
    ;; Trích xuất giá trị an toàn từ Variant cột A
    (if txtStt
      (cond
        ((= (vlax-variant-type txtStt) vlax-vbString)
         (setq valStt (vl-string-trim " " (vlax-variant-value txtStt))))
        ((or (= (vlax-variant-type txtStt) vlax-vbInteger) 
             (= (vlax-variant-type txtStt) vlax-vbDouble)
             (= (vlax-variant-type txtStt) vlax-vbLong))
         (setq valStt (vl-princ-to-string (vlax-variant-value txtStt))))
        (t (setq valStt ""))
      )
      (setq valStt "")
    )

    ;; Kiểm tra dữ liệu cột A để xử lý hoặc tích lũy dòng trống
    (if (or (= valStt "") (= valStt " ") (= valStt "0") (= valStt "0.0"))
      (setq emptyCount (1+ emptyCount)) ; Nếu trống, tăng bộ đếm dòng trống
      (progn
        (setq emptyCount 0) ; Nếu có dữ liệu, reset bộ đếm dòng trống về 0
        
        ;; Đọc tiếp cột B và C
        (setq cellX (vlax-variant-value (vlax-get-property cellsObj 'Item row 2)))
        (setq txtX (vlax-get-property cellX 'Value))
        (vlax-release-object cellX)
        
        (setq cellY (vlax-variant-value (vlax-get-property cellsObj 'Item row 3)))
        (setq txtY (vlax-get-property cellY 'Value))
        (vlax-release-object cellY)
        
        ;; Tiến hành giải mã Variant và parse sang số thực
        (if (and txtX txtY)
          (progn
            (setq valX (clean-and-parse (vlax-variant-value txtX)))
            (setq valY (clean-and-parse (vlax-variant-value txtY)))
            
            ;; Thuật toán tự động đảo trục tọa độ trắc địa dựa trên số ký tự trước dấu phẩy:
            ;; Trục có 7 chữ số (> 1000000.0) là X_TrắcĐịa -> đưa vào Y_CAD
            ;; Trục có 6 chữ số là Y_TrắcĐịa -> đưa vào X_CAD
            (if (and (> valX 0.0) (> valY 0.0))
              (progn
                (if (> valX valY)
                  (setq ptList (append ptList (list (list valY valX)))) ; Cột B lớn hơn Cột C (Cột B là X_trắcđịa)
                  (setq ptList (append ptList (list (list valX valY)))) ; Cột C lớn hơn Cột B (Cột C là X_trắcđịa)
                )
              )
            )
          )
        )
      )
    )
    
    ;; ĐẢM BẢO LUÔN TĂNG DÒNG: Không bao giờ bị kẹt lại tại một dòng gây lặp vô hạn
    (setq row (1+ row))
  )
  
  ;; Giải phóng đối tượng Cells tổng thể
  (vlax-release-object cellsObj)
  
  ;; 4. Đóng Excel giải phóng bộ nhớ hệ thống
  (vlax-invoke-method xlWb 'Close :vlax-false)
  (vlax-invoke-method xlApp 'Quit)
  (vlax-release-object xlSheet)
  (vlax-release-object xlWb)
  (vlax-release-object xlApp)
  (setq xlApp nil)
  
  ;; 5. Tạo thực thể LWPOLYLINE khép kín bằng entmake
  (setq numVerts (length ptList))
  (if (> numVerts 2)
    (progn
      (setq entHeader (list
                        '(0 . "LWPOLYLINE")
                        '(100 . "AcDbEntity")
                        '(100 . "AcDbPolyline")
                        (cons 90 numVerts)
                        '(70 . 1) ; 1 = Closed Polyline
                      ))
      
      (foreach pt ptList
        (setq entHeader (append entHeader (list (cons 10 pt))))
      )
      
      (entmake entHeader)
      (vl-cmdf "_.regen")
      (princ (strcat "\nSuccessfully generated closed polyline with " (itoa numVerts) " vertices using entmake."))
    )
    (princ "\nError: Not enough valid points found in Excel file to create a polyline.")
  )
  (princ)
)

(princ "\n[Loaded] Type 'DrawRanhDat' to run the command.")
(princ)

 

em cảm ơn nhiều nhiều ngen

Chia sẻ bài đăng này

Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay
Đăng nhập để thực hiện theo  
Người theo dõi 0
Về Đầu Trang AutoLisp
×