(defun c:DE (/ ss i e hatch_data_with_area hatch_data_without_area dcl_id dcl_file all_data area_dict with_area_count without_area_count)
  (defun regenerate-hatch-boundary (hatch_ename / hatch_data coord_list poly boundary_entity)
    (setq hatch_data (entget hatch_ename))
    (setq coord_list '())
    (foreach item hatch_data
      (if (= (car item) 11)
        (setq coord_list (cons (cdr item) coord_list))
      )
    )
    (setq boundary_entity (entmakex
                            (append
                              (list
                                '(0 . "LWPOLYLINE")
                                '(100 . "AcDbEntity")
                                '(100 . "AcDbPolyline")
                                (cons 90 (length coord_list))
                                '(70 . 1)
                              )
                              (mapcar
                                '(lambda (pt) (cons 10 pt))
                                (reverse coord_list)
                              )
                            )
                          )
    )
    (list boundary_entity coord_list)
  )
  (defun Self-intersection-check (coord_list / pl obj pt)
    (setq pl (gxl-polyselfinters coord_list))
    (mapcar
      '(lambda (x)
        (setq pt (trans x 0 1))
        (setq hzt (* (getvar "viewsize") 0.05))
        (vl-cmdf "_circle" pt "D" hzt)
        (setq obj (vlax-ename->vla-object (entlast)))
        (vla-put-color obj 1)
      )
      pl
    )
    (princ
      (strcat "\n发现 " (itoa (length pl)) " 个可疑异常点")
    )
  )
  (defun gxl-polyselfinters (coord_list / result i j seg1 seg2 intpts closed)
    (setq closed T)
    (if (> (length coord_list) 2)
      (progn
        (setq result '())
        (setq i 0)
        (while (< i (- (length coord_list) 1))
          (setq seg1 (list (nth i coord_list) (nth (1+ i) coord_list)))
          (setq j (+ i 2))
          (while (< j (- (length coord_list) 1))
            (setq seg2 (list (nth j coord_list) (nth (1+ j) coord_list)))
            (setq intpts (intersect-segments seg1 seg2))
            (if intpts (setq result (cons intpts result)))
            (setq j (1+ j))
          )
          (setq i (1+ i))
        )
        (if closed
          (progn
            (setq seg1 (list (last coord_list) (car coord_list)))
            (setq i 0)
            (while (< i (- (length coord_list) 2))
              (setq seg2 (list (nth i coord_list) (nth (1+ i) coord_list)))
              (if (and (/= i (- (length coord_list) 2)) (/= i 0))
                (progn
                  (setq intpts (intersect-segments seg1 seg2))
                  (if intpts (setq result (cons intpts result)))
                )
              )
              (setq i (1+ i))
            )
          )
        )
        (setq result (remove-duplicate-points result))
        result
      )
      nil
    )
  )
  (defun intersect-segments (seg1 seg2 / p1 p2 p3 p4 intpt tol)
    (setq p1 (car seg1)
          p2 (cadr seg1)
          p3 (car seg2)
          p4 (cadr seg2)
          tol 1e-6
    )
    (if
      (or
        (equal p1 p3 tol)
        (equal p1 p4 tol)
        (equal p2 p3 tol)
        (equal p2 p4 tol)
      )
      nil
      (progn
        (setq intpt (inters p1 p2 p3 p4 nil))
        (if intpt
          (progn
            (if
              (and
                (point-on-segment intpt p1 p2 tol)
                (point-on-segment intpt p3 p4 tol)
              )
              intpt
              nil
            )
          )
          nil
        )
      )
    )
  )
  (defun point-on-segment (pt p1 p2 tol / dist1 dist2 total-dist)
    (setq dist1 (distance pt p1)
          dist2 (distance pt p2)
          total-dist (distance p1 p2)
    )
    (< (abs (- total-dist (+ dist1 dist2))) tol)
  )
  (defun remove-duplicate-points (pts / unique-pts pt found)
    (setq unique-pts '())
    (foreach pt pts
      (setq found nil)
      (foreach existing-pt unique-pts
        (if (equal pt existing-pt 1e-6) (setq found T))
      )
      (if (not found)
        (setq unique-pts (cons pt unique-pts))
      )
    )
    unique-pts
  )
  (defun get-hatch-data ()
    (setq hatch_data_with_area nil
          hatch_data_without_area nil
          area_dict '()
    )
    (princ "\n请选择需要统计的填充（默认全选）：")
    (if (not (setq ss (ssget '((0 . "HATCH")))))
      (setq ss (ssget "x" '((0 . "HATCH"))))
    )
    (if ss
      (progn
        (setq i -1)
        (while (setq e (ssname ss (setq i (1+ i))))
          (setq area (vl-catch-all-apply
                       'vla-get-area
                       (list (vlax-ename->vla-object e))
                     )
          )
          (if (vl-catch-all-error-p area)
            (setq hatch_data_without_area (cons
                                            (list e (get-hatch-pattern-name e))
                                            hatch_data_without_area
                                          )
            )
            (progn
              (setq pattern-name (get-hatch-pattern-name e))
              (if (setq existing (assoc pattern-name area_dict))
                (setq area_dict (subst
                                  (list pattern-name (+ (cadr existing) area))
                                  existing
                                  area_dict
                                )
                )
                (setq area_dict (cons (list pattern-name area) area_dict))
              )
              (setq hatch_data_with_area (cons
                                           (list e pattern-name area)
                                           hatch_data_with_area
                                         )
              )
            )
          )
        )
        (list area_dict hatch_data_without_area)
      )
    )
  )
  (defun get-hatch-pattern-name (e / pattern)
    (setq pattern (cdr (assoc 2 (entget e))))
    (if (or (null pattern) (= pattern ""))
      "无图案"
      pattern
    )
  )
  (defun hatch-pattern-exists (PatNam / Old_HPNam result)
    (setq Old_HPNam (getvar "HPNAME"))
    (if
      (not
        (vl-catch-all-error-p
          (vl-catch-all-apply
            'setvar
            (list "HPNAME" PatNam)
          )
        )
      )
      (and (setvar "HPNAME" Old_HPNam))
    )
  )
  (defun create-hatch-in-box (pattern-name pt1 pt2 pt3 pt4)
    (entmakex
      (list
        '(0 . "HATCH")
        '(100 . "AcDbEntity")
        '(62 . 8)
        '(100 . "AcDbHatch")
        '(10 0.0 0.0 0.0)
        '(210 0.0 0.0 1.0)
        (cons 2 pattern-name)
        '(70 . 1)
        '(71 . 0)
        '(91 . 1)
        '(92 . 3)
        '(72 . 0)
        '(73 . 1)
        '(93 . 4)
        (cons 10 pt1)
        (cons 10 pt2)
        (cons 10 pt3)
        (cons 10 pt4)
        '(97 . 0)
        '(75 . 0)
        '(76 . 1)
        '(98 . 0)
      )
    )
    (vla-put-PatternScale
      (vlax-ename->vla-object (entlast))
      (if (findfile "tch_kernal.arx")
        (* 0.1 hzt)
        (* 1 hzt)
      )
    )
  )
  (defun zoom-and-regenerate-boundary (e)
    (if e
      (progn
        (command "_.zoom" "_object" e "")
        (command "_.zoom" "0.8x")
        (redraw e 3)
        (setq result (regenerate-hatch-boundary e))
        (setq new_boundary (car result))
        (setq coord_list (cadr result))
        (sssetfirst nil (ssadd new_boundary))
        (list new_boundary coord_list)
      )
    )
  )
  (defun create-table-from-hatch-data (lst / ss p1 colWidths rowHeight fontHeight totalWidth rowCount bottomY j sorted_lst hzt HATCHWidth HATCHHeight)
    (setq sorted_lst (vl-sort
                       lst
                       (function (lambda (a b) (< (car a) (car b))))
                     )
    )
    (setq ss (getpoint "\n选择表格左上角的位置: "))
    (setq p1 ss)
    (setq hzt (* (getvar "viewsize") 0.02))
    (setq fontHeight hzt)
    (setq colWidths (list
                      (* 4.5 hzt)
                      (* 4.5 hzt)
                      (* 10 hzt)
                      (* 9 hzt)
                    )
    )
    (setq HATCHWidth (* 2.3 hzt))
    (setq HATCHHeight (* 1.15 hzt))
    (setq rowHeight (* 2 hzt))
    (setq totalWidth (+ (apply '+ colWidths)))
    (setq rowCount (+ 1 (length sorted_lst)))
    (setq bottomY (- (cadr p1) (* rowCount rowHeight)))
    (defun drawRow (startPoint widths height textList isFirstRow isIndexColumn)
      (setq x (car startPoint))
      (setq y (cadr startPoint))
      (entmake
        (list
          '(0 . "LINE")
          (cons 10 startPoint)
          (cons 11 (list (+ x (apply '+ widths)) y))
          '(62 . 3)
        )
      )
      (setq xOffset 0)
      (setq xx (/ (- (nth 1 widths) HATCHWidth) 2))
      (setq yy (/ (- rowHeight HATCHHeight) 2))
      (setq i 0)
      (foreach txt textList
        (setq colWidth (nth i widths))
        (if (and (= i 1) (not isFirstRow))
          (progn
            (entmake
              (list
                '(0 . "LWPOLYLINE")
                '(100 . "AcDbEntity")
                '(100 . "AcDbPolyline")
                (cons 90 4)
                (cons 70 1)
                (cons 10 (list (+ x xOffset xx) (- y yy)))
                (cons
                  10
                  (list (+ x xOffset xx HATCHWidth) (- y yy))
                )
                (cons
                  10
                  (list
                    (+ x xOffset xx HATCHWidth)
                    (- y yy HATCHHeight)
                  )
                )
                (cons
                  10
                  (list (+ x xOffset xx) (- y yy HATCHHeight))
                )
                '(62 . 6)
              )
            )
            (setq hatchPatternName (nth 2 textList))
            (setq pt1 (list (+ x xOffset xx) (- y yy)))
            (setq pt2 (list (+ x xOffset xx HATCHWidth) (- y yy)))
            (setq pt3 (list
                        (+ x xOffset xx HATCHWidth)
                        (- y yy HATCHHeight)
                      )
            )
            (setq pt4 (list (+ x xOffset xx) (- y yy HATCHHeight)))
            (if (hatch-pattern-exists hatchPatternName)
              (progn
                (setq hatch-entity (create-hatch-in-box
                                     hatchPatternName
                                     pt1
                                     pt2
                                     pt3
                                     pt4
                                   )
                )
              )
              (progn
                (setq textCenterX (+ x xOffset xx (/ HATCHWidth 2)))
                (setq textCenterY (- y yy (/ HATCHHeight 2)))
                (entmakex
                  (list
                    '(0 . "TEXT")
                    (cons 10 (list textCenterX textCenterY))
                    (cons 40 (* 0.25 hzt))
                    (cons 1 "填充样式缺失")
                    '(50 . 0.0)
                    '(7 . "STANDARD")
                    '(41 . 0.7)
                    '(51 . 0.0)
                    '(72 . 1)
                    '(73 . 2)
                    (cons 11 (list textCenterX textCenterY))
                    '(62 . 1)
                  )
                )
              )
            )
          )
          (if (> colWidth 0)
            (progn
              (setq textX (+ x xOffset (/ colWidth 2)))
              (setq textY (- y (/ height 2) (/ fontHeight 2)))
              (entmake
                (list
                  '(0 . "TEXT")
                  (cons 10 (list textX textY))
                  (cons 40 fontHeight)
                  (cons 1 txt)
                  '(50 . 0.0)
                  '(7 . "STANDARD")
                  '(41 . 0.8)
                  '(51 . 0.0)
                  '(72 . 1)
                  '(73 . 0)
                  (cons 11 (list textX textY))
                  (if (or isFirstRow isIndexColumn)
                    '(62 . 1)
                    '(62 . 4)
                  )
                )
              )
            )
          )
        )
        (setq xOffset (+ xOffset colWidth))
        (setq i (+ i 1))
        (if isIndexColumn (setq isIndexColumn nil))
      )
    )
    (defun drawVerticalLines (startPoint endY widths)
      (setq startX (car startPoint))
      (setq curX startX)
      (entmake
        (list
          '(0 . "LINE")
          (cons 10 startPoint)
          (cons 11 (list startX endY))
          '(62 . 3)
        )
      )
      (foreach w widths
        (setq nextX (+ curX w))
        (if (> nextX startX)
          (entmake
            (list
              '(0 . "LINE")
              (cons 10 (list nextX (cadr startPoint)))
              (cons 11 (list nextX endY))
              '(62 . 3)
            )
          )
        )
        (setq curX nextX)
      )
    )
    (drawRow
      p1
      colWidths
      rowHeight
      '("序号" "图例" "填充名称" "面积小计")
      t
      t
    )
    (setq p1 (list (car p1) (- (cadr p1) rowHeight)))
    (setq j 1)
    (foreach item sorted_lst
      (setq name (car item))
      (setq value (rtos (cadr item) 2 2))
      (drawRow
        p1
        colWidths
        rowHeight
        (list
          (if (< j 10) (strcat "0" (itoa j)) (itoa j))
          ""
          (vl-princ-to-string name)
          value
        )
        nil
        t
      )
      (setq p1 (list (car p1) (- (cadr p1) rowHeight)))
      (setq j (+ j 1))
    )
    (entmake
      (list
        '(0 . "LINE")
        (cons 10 (list (car p1) bottomY))
        (cons 11 (list (+ (car p1) totalWidth) bottomY))
        '(62 . 3)
      )
    )
    (drawVerticalLines ss bottomY colWidths)
    (princ)
  )
  (vl-load-com)
  (setq data (get-hatch-data))
  (setq hatch_data_with_area (car data))
  (setq hatch_data_without_area (cadr data))
  (setq with_area_count (length hatch_data_with_area))
  (setq without_area_count (length hatch_data_without_area))
  (if
    (and
      (null hatch_data_with_area)
      (null hatch_data_without_area)
    )
    (alert "没有发现填充图案！")
    (progn
      (if (= without_area_count 0)
        (progn
          (if (> with_area_count 0)
            (create-table-from-hatch-data
              hatch_data_with_area
            )
            (alert "没有填充信息可绘制表格，请重新选择！")
          )
        )
        (progn
          (setq dcl_file (vl-filename-mktemp "hatch.dcl"))
          (setq f (open dcl_file "w"))
          (write-line "hatch_dlg : dialog {" f)
          (write-line "  label = \"填充统计\";" f)
          (write-line "  : boxed_column {" f)
          (write-line "    label = \"正常统计信息\";" f)
          (write-line
            "    : list_box { key = \"normal_list\"; width = 45; height = 13; }"
            f
          )
          (write-line
            "    : button { key = \"create_table\"; label = \"忽略异常并绘制表格\"; width = 12; fixed_width = true; }"
            f
          )
          (write-line "  }" f)
          (write-line "  : boxed_column {" f)
          (write-line "    label = \"异常信息\";" f)
          (write-line
            "    : list_box { key = \"exception_list\"; width = 45; height = 8; }"
            f
          )
          (write-line
            (strcat
              "    : text { key = \"count\"; label = \"共发现"
              (itoa without_area_count)
              "个异常填充，双击进行检查修改！\"; }"
            )
            f
          )
          (write-line "  }" f)
          (write-line "  ok_only;" f)
          (write-line "}" f)
          (close f)
          (setq dcl_id (load_dialog dcl_file))
          (if
            (and
              dcl_id
              (> dcl_id 0)
              (new_dialog "hatch_dlg" dcl_id)
            )
            (progn
              (start_list "normal_list")
              (setq index 0)
              (foreach item hatch_data_with_area
                (add_list
                  (strcat
                    (if (< (setq index (1+ index)) 10)
                      (strcat "0" (itoa index))
                      (itoa index)
                    )
                    " - "
                    (car item)
                    " - 面积: "
                    (rtos (cadr item) 2 2)
                  )
                )
              )
              (end_list)
              (start_list "exception_list")
              (setq j 0)
              (foreach item hatch_data_without_area
                (add_list
                  (strcat
                    (if (< (1+ j) 10)
                      (strcat "0" (itoa (1+ j)))
                      (itoa (1+ j))
                    )
                    " - "
                    (cadr item)
                    " - 图元: "
                    (vl-princ-to-string (car item))
                  )
                )
                (setq j (1+ j))
              )
              (end_list)
              (action_tile "normal_list" "")
              (action_tile
                "exception_list"
                "(if (= $reason 4) (progn (setq selected_index (atoi $value)) (done_dialog (+ 100 selected_index))))"
              )
              (action_tile "create_table" "(done_dialog 200)")
              (action_tile "accept" "(done_dialog 1)")
              (setq result (start_dialog))
              (unload_dialog dcl_id)
              (vl-file-delete dcl_file)
              (cond
                ((= result 200)
                  (if (> with_area_count 0)
                    (create-table-from-hatch-data
                      hatch_data_with_area
                    )
                    (alert "没有填充信息可绘制表格，请重新选择！")
                  )
                )
                ((> result 99)
                  (setq item_index (- result 100))
                  (if
                    (and
                      (>= item_index 0)
                      (< item_index without_area_count)
                    )
                    (progn
                      (setq selected_entity (car (nth item_index hatch_data_without_area)))
                      (setq boundary_result (zoom-and-regenerate-boundary selected_entity))
                      (if boundary_result
                        (progn
                          (setq new_boundary (car boundary_result))
                          (setq coord_list (cadr boundary_result))
                          (Self-intersection-check coord_list)
                          (if (entget new_boundary) (entdel new_boundary))
                        )
                      )
                    )
                  )
                )
              )
            )
          )
        )
      )
    )
  )
  (princ)
)
(princ)