提取多属性块做缩略块为啥变成了普同块？

xskfq

统计块程序，提取图中多属性块做缩略块为啥变成了普同块了呢？

图中多属性块如图1


做成块缩略图后，变成图2






程序源码如下：
怎么让缩略图变成多属性块呢，高手解答一下，谢谢啊！

;;;------------------------------------------------------------------------ ;;;在当前图层、当前空间插入块 ;;;调用形式 ( InsertBlock  块名  插入点  旋转角度 ) ;;;成功时，返回dxf组码，否则返回nil (defun InsertBlock ( strBlockName listInsertPoint floatRotateAngle ) (entmake (list '(0 . "INSERT") '(100 . "AcDbEntity") '(100 . "AcDbBlockReference") (cons 2 strBlockName) (cons 10 listInsertPoint) (cons 50 floatRotateAngle))) ) --------------------------------------- entmake做不出多属性块吗？那用什么方法做多属性块比较好？

xskfq

难度我没说明白？？？

那我发下测试图和源代码吧。帮看看测试图里 ：表格内的块 和 表格外的块 怎么不一样？

junkegg

;;==============================块统计

;;;----------------------------------------------------------------------------------------------
;;;检查输入的原始参数表是否使用了组件的别名，如果使用了，便把别名改成组件全名。无论是否已使用组件的别名，都返回可供后续程序使用的参数表。
(defun listFormatInputList (listInput             /                     listComponentAlias    listFormatedInput     listMemberOfInput
                            boolIsAlias           intDefinedAliasNumber k                     strInputComponentName strAlias
                           )
;;;----------------------------------------------------------------------------------------------
;;;定义组件别名表，形式为  ( (  组件别名 组件原名) )
(setq listComponentAlias '(("bt" "button")
                            ("edit" "edit_box")
                            ("edit12" "edit12_box")
                            ("edit32" "edit32_box")
                            ("listbox" "list_box")
                            ("ComboBox" "popup_list")
                            ("btRadio" "radio_button")
                            ("tg" "toggle")
                            ("btOK" "ok_only")
                            ("btCancel" "cancel_button")
                            ("btErrer" "errtile")
                            ("btHelp" "help_button")
                            ("btInfo" "info_button")
                            ("btOC" "ok_cancel")
                            ("btOCH" "ok_cancel_help")
                            ("btOCHE" "ok_cancel_help_errtile")
                            ("btOCHI" "ok_cancel_help_info")
                            ("color17" "color_palette_1_7")
                            ("color19" "color_palette_1_9")
                            ("color09" "color_palette_0_9")
                            ("color250255" "color_palette_250_255")
                            ("stdColor" "std_rq_color")
                           )
)
;;;----------------------------------------------------------------------------------------------
(setq listFormatedInput nil)
(foreach listMemberOfInput listInput
  (setq k 0
        boolIsAlias "No"
  )
  (setq strInputComponentName (strcase (car listMemberOfInput) T))
  (setq intDefinedAliasNumber (length listComponentAlias))
  (while (and (< k intDefinedAliasNumber) (= boolIsAlias "No"))
   (setq strAlias (strcase (car (nth k listComponentAlias)) T))
   (if (= strInputComponentName strAlias)
    (progn (setq boolIsAlias "Yes")
           (setq listFormatedInput (append listFormatedInput
                                           (list (cons (cadr (nth k listComponentAlias))
                                                       (cdr listMemberOfInput)
                                                 )
                                           )
                                   )
           )
    )
   )
   (setq k (1+ k))
  )
  (if (= boolIsAlias "No")
   (setq listFormatedInput (append listFormatedInput
                                   (list (cons (strcase (car listMemberOfInput) T)
                                               (cdr listMemberOfInput)
                                         )
                                   )
                           )
   )
  )
)
listFormatedInput
)
;;;----------------------------------------------------------------------------------------------
;;;把输入的参数表转换为字符串表
(defun listInputToString (listInput                /                        listMemberOfInput        listCdrMemberOfInput
                          listMemberOfComponentParameters                   listComponentParameters  listCadrMemberOfComponentParameters
                          listResult               k                        j                        boolDefinementFound
                          strTmp                   test1                    test2
                         )
;;;----------------------------------------------------------------------------------------------
;;;组件定义参数表，形式为 ( ( 组件名列表) ( 对应参数名列表) )
;;; 无属性控件，生成dcl文件时，在组件名后添加" ; “即可；如为“end”,在dcl文件里加上"}"字符即可
;;; 容器控件及带属性控件，需要在名前添加” : "，名后加 "{"
(setq listComponentParameters '((("容器控件" "dialog")
                                  ("label"               "key"                 "value"               "initial_focus"
                                   "height"              "width"               "children_alignment"  "children_fixed_height"
                                   "children_fixed_width"
                                  )
                                 )
                                 (("容器控件"          "boxed_column"      "boxed_row"         "boxed_radio_column"
                                   "boxed_radio_row"   "column"            "row"               "radio_row"         "radio_column"
                                   "concatenation"     "paragraph"
                                  )
                                  ("label"               "key"                 "is_enabled"          "alignment"
                                   "height"              "width"               "fixed_height"        "fixed_width"
                                   "children_alignment"  "children_fixed_height"                     "children_fixed_width"
                                  )
                                 )
                                 (("带属性控件" "button")
                                  ("label"         "key"           "action"        "alignment"     "height"        "width" "horizontal_margin"
                                   "vertical_margin" "fixed_height"  "fixed_width"   "is_cancel"     "is_default"    "is_enabled"    "is_tab_stop"
                                   "mnemonic"
                                  )
                                 )
                                 (("带属性控件" "edit_box" "edit12_box" "edit32_box" "fcf_ebox" "fcf_ebox1")
                                  ("label"          "key"            "value"          "action"         "alignment"      "height"
                                   "width"          "fixed_height"   "fixed_width"    "allow_accept"   "edit_limit"     "edit_width"
                                   "is_enabled"     "is_tab_stop"    "mnemonic"       "password_char"
                                  )
                                 )
                                 (("带属性控件" "image" "image_block" "icon_image")
                                  ("key"           "value"         "action"        "alignment"     "height"        "width"
                                   "fixed_height"  "fixed_width"   "is_enabled"    "is_tab_stop"   "mnemonic"      "aspect_ratio"
                                   "color"
                                  )
                                 )
                                 (("带属性控件" "image_button" "swatch" "fcf_ibut" "fcf_ibut1")
                                  ("key"            "action"         "alignment"      "height"         "width"          "fixed_height"
                                   "fixed_width"    "is_enabled"     "is_tab_stop"    "mnemonic"       "allow_accept"   "aspect_ratio"
                                   "color"
                                  )
                                 )
                                 (("带属性控件" "list_box")
                                  ("label"          "key"            "value"          "action"         "alignment"      "height"
                                   "width"          "fixed_height"   "fixed_width"    "allow_accept"   "fixed_width_font"
                                   "is_enabled"     "is_tab_stop"    "list"           "mnemonic"       "multiple_select"
                                   "tabs"           "tab_truncate"
                                  )
                                 )
                                 (("带属性控件" "popup_list")
                                  ("label"         "key"           "value"         "action"        "alignment"     "height"
                                   "width"         "fixed_height"  "fixed_width"   "edit_width"    "fixed_width_font"
                                   "is_enabled"    "is_tab_stop"   "list"          "mnemonic"      "tabs"          "tab_truncate"
                                  )
                                 )
                                 (("带属性控件" "radio_button")
                                  ("label"         "key"           "value"         "action"        "is_enabled"    "is_tab_stop"
                                   "mnemonic"      "alignment"     "height"        "width"         "fixed_height"  "fixed_width"
                                  )
                                 )
                                 (("带属性控件" "slider")
                                  ("label"         "key"           "value"         "action"        "alignment"     "height"
                                   "width"         "fixed_height"  "fixed_width"   "big_increment" "layout"        "max_value"
                                   "min_value"     "mnemonic"      "small_increment"
                                  )
                                 )
                                 (("带属性控件" "spacer")
                                  ("value" "height" "width" "fixed_height" "fixed_width")
                                 )
                                 (("带属性控件" "text" "text_part" "text_25")
                                  ("label" "key" "value" "alignment" "height" "width" "fixed_height" "fixed_width" "is_bold")
                                 )
                                 (("带属性控件" "toggle")
                                  ("label" "key" "value" "action" "alignment" "height" "width" "fixed_height" "fixed_width" "is_enabled"
                                   "is_tab_stop")
                                 )
                                 (("无属性控件"           "cancel_button"        "errtile"              "help_button"
                                   "info_button"          "ok_cancel"            "ok_cancel_help"       "ok_cancel_help_errtile"
                                   "ok_cancel_help_info"  "ok_only"              "spacer"               "spacer_0"
                                   "spacer_1"             "color_palette_1_7"    "color_palette_1_9"    "color_palette_0_9"
                                   "color_palette_250_255"                       "std_rq_color"
                                  )
                                 )
                                 (("无属性控件" "end")) ;以"end"作为单个组件定义的结束，生成dcl文件时，以“}“代替
                                )
)
;;;----------------------------------------------------------------------------------------------        
(setq listResult nil)
(setvar "dimzin" 8)
(foreach listMemberOfInput listInput
  (setq k 0
        boolDefinementFound "NotYet"
  )
  (while (and (= boolDefinementFound "NotYet")
              (< k (length listComponentParameters))
         ) ;未找到组件参数名列表且未搜索完组件预定义列表时循环
   (setq listMemberOfComponentParameters (nth k listComponentParameters))
   (if (and (member (car listMemberOfInput)
                    (car listMemberOfComponentParameters)
            )
            (if (= "spacer" (car listMemberOfInput))
             (>= (length listMemberOfInput)
                 (length listMemberOfComponentParameters)
             )
             T
            ) ;因spacer既可为无属性控件也可为带属性控件，故特别处理
       )
    (progn (setq boolDefinementFound  "Found"
                 listCdrMemberOfInput (cdr listMemberOfInput)
           )
           (cond ((or (= "容器控件" (car (car listMemberOfComponentParameters)))
                      (= "带属性控件" (car (car listMemberOfComponentParameters)))
                  )
                  listCdrMemberOfInput ;组件参数值有数据时
                  (setq listResult (append listResult
                                           (list (strcat ":" (car listMemberOfInput) "{\n"))
                                   )
                  )
                  (setq j                                   0
                        listCadrMemberOfComponentParameters (cadr listMemberOfComponentParameters)
                  )
                  (while (< j (length listCdrMemberOfInput))
                   (if (not (= "" (nth j listCdrMemberOfInput)))
                    (progn ;参数值非空时
                     (if (numberp (nth j listCdrMemberOfInput))
                      (setq strTMP (strcat (nth j listCadrMemberOfComponentParameters)
                                           "="
                                           (rtos (nth j listCdrMemberOfInput) 2 3)
                                           ";\n"
                                   )
                      ) ;参数为数值时
                      (setq strTMP (strcat (nth j listCadrMemberOfComponentParameters)
                                           "=\""
                                           (nth j listCdrMemberOfInput)
                                           "\";\n"
                                   )
                      ) ;参数非数值时
                     )
                     (setq listResult (append listResult (list strTMP)))
                    )
                   )
                   (setq j (1+ j))
                  )
                  (if (= "带属性控件" (car (car listMemberOfComponentParameters)))
                   (setq listResult (append listResult (list "}\n")))
                  ) ;带属性控件时，在字符串末尾加上组件结束标志 "}"
                 )
                 ((= (car listMemberOfInput) "end")
                  (setq listResult (append listResult (list "}\n")))
                 )
                 (T ;(= "无属性控件" (car (car listMemberOfComponentParameters))) ,默认为无属性控件
                  (setq listResult (append listResult
                                           (list (strcat (car listMemberOfInput) ";\n"))
                                   )
                  )
                 )
           )
    )
    (setq k (1+ k))
   )
  )
)
listResult
)
;;;----------------------------------------------------------------------------------------------
;;;生成并显示输入对话框
;;;调用形式 ( listGenerateDCL  DCL文件名(无路径及后缀)
;;;                 表( ( ( "组件名或别名")  ( 参数值表 )  )   ...)
;;;                 表( (  "组件编号"  "组件初始值"  )   ...)    ;组件显示值初始化
;;;                 表( (  "组件编号"  "动作代码"  )   ...)      ;需设置动作的组件及对应的动作
;;;                 表("组件编号"  ...)   )    ;用户点“确定”键时，需获取输入值的组件名
;;;注意，调用参数均为字符串形式
;;;返回值为表,形式为 ( 关闭对话框的整数代码       指定组件返回值列表)
(defun listGenerateDCL (strDCLFileName      listInputDefinements                    listKeysAndValues   listKeysAndActions
                        listKeysToGetValue  /                   listFormatedInput   intDialogCloseType  listKeysValue
                        listResult          fStream             strFileFullName     objectFile          fileStream
                        templist            i                   dclid
                       )
;;;----------------------------------------------------------------------------------------------
;;;按 ( ( “组件名”  “值"  ) ) 表，设置各组件的值
(defun SetDCLValues (listKeysAndValues / listEachKeyAndValue)
  (foreach listEachKeyAndValue listKeysAndValues
   (set_tile (car listEachKeyAndValue)
             (cadr listEachKeyAndValue)
   )
  )
)
;;;----------------------------------------------------------------------------------------------
;;;按 ( ( “组件名”  “动作"  ) ) 表，把组件与动作关联
(defun SetDCLActions (listKeysAndActions / listEachKeyAndAction)
  (foreach listEachKeyAndAction listKeysAndActions
   (action_tile (car listEachKeyAndAction)
                (cadr listEachKeyAndAction)
   )
  )
)
;;;----------------------------------------------------------------------------------------------
;;;按 ( “组件名” ) 表，查询各组件值并返回值表
(defun listGetDCLValues (listKeys / listEachKey listValues)
  (setq listValues nil)
  (foreach listEachKey listKeys
   (setq listValues (append listValues (list (get_tile listEachKey))))
  )
  listValues
)
;;;----------------------------------------------------------------------------------------------                 
(setq strFileFullName (vl-filename-mktemp (strcat strDCLFileName ".dcl")))
(setq objectFile (open strFileFullName "w"))
(setq listFormatedInput (listFormatInputList listInputDefinements))
(setq fileStream (append (list strDCLFileName)
                          (listInputToString listFormatedInput)
                  )
)
(foreach fStream fileStream (princ fStream objectFile))
(close objectFile)
;;以上生成dcl文件,以下调用DCL，设置组件值、关联动作，获取返回值
(setq listResult nil)
(setq dclid (load_dialog strFileFullName))
(if (not (new_dialog strDCLFileName dclid ""))
  (progn (alert "对话框加载失败!") (exit))
)
(if listKeysAndValues
  (SetDCLValues listKeysAndValues)
)
(if listKeysAndActions
  (SetDCLActions listKeysAndActions)
)
(if listKeysToGetValue
  (action_tile "accept"  "(setq listKeysValue (listGetDCLValues listKeysToGetValue)) (done_dialog 1)" )
)
(setq intDialogCloseType (start_dialog))
(unload_dialog dclid)
(vl-file-delete strFileFullName)
(setq listResult (append (list intDialogCloseType) listKeysValue))
listResult
)
;;;----------------------------------------------------------------------------------------------
;;;----------------------------------------------------------------------------------------------
;;;----------------------------------------------------------------------------------------------
;;;----------------------------------------------------------------------------------------------
;;;----------------------------------------------------------------------------------------------
;;;;funlib.lsp
;;; -------------------------------------------------------------------------
;;;计算以当前设置书写的文本占用长度
;;;调用参数形式 (  字符串 )
(defun strLength (str / sLength x1 x2 lst)
(setq lst (textbox (list (cons 1 str))))
(setq x1 (car (nth 0 lst))
       x2 (car (nth 1 lst))
)
(setq sLength (abs (- x2 x1)))
sLength
)
;;; -------------------------------------------------------------------------
;;;以当前设置初始化文本高、宽
(defun initText (/ pt str eTextN)
(setq pt (list 0 0))
(setq str "初始化")
(command "text" pt #ZiGao# 0 str)
(setq eTextN (entlast))
(entdel eTextN)
)
;;; -------------------------------------------------------------------------
;;; 返回polyline的点表
;;;调用参数形式 (  多义线图元名 )
(defun getplpts (pl / mark pts ver1 i ee pt)
(if (= "POLYLINE" (cdr (assoc 0 (entget pl))))
  (progn  ; read points of ployline
   (setq mark "VERTEX"
         i    0
         ver1 (entnext pl)
   )
   (while (= "VERTEX" mark)
    (setq pts (append pts (list (cdr (assoc 10 (entget ver1))))))
    (setq ver1 (entnext ver1)
          i    (1+ i)
    )
    (setq mark (cdr (assoc 0 (entget ver1))))
   )
  )
  (progn  ; read points of lwployline
   (setq ee (entget pl))
   (foreach pt ee
    (if (= 10 (car pt))
     (setq
      pts (append
           pts
           (list (append (cdr pt) (list (cdr (assoc 38 ee)))))
          )
     )
    )
   )
  )
)
pts
)
;;; -------------------------------------------------------------------------
;;;实数转换为桩号，并返回转换后的结果
;;;调用参数形式 (  里程的数值　里程的前缀 )
(defun rtoZhuanHao (rZhuanHao QianZhui / sZhuanHao QianMi)
          ; rZhuanHao为需要转换为桩号的实数
          ; bzZhuanHao为桩号的前缀
          ; SZhuanHao为转换后的桩号字串
(if (< rZhuanHao 0)
  (progn
   (setq QianZhui (strcat "-" QianZhui))
   (setq rZhuanHao (abs rZhuanHao))
  )
)
(setq rZhuanHao (fixreal rZhuanHao 2))
(setq QianMi (fix (/ rZhuanHao 1000)))
(setq rZhuanHao (- rZhuanHao (* QianMi 1000)))
(setq sZhuanHao (strcat QianZhui (rtos QianMi 2 0) "+"))
(if (< rZhuanHao 10)
  (setq sZhuanHao (strcat sZhuanHao "00"))
  (if (< rZhuanHao 100)
   (setq sZhuanHao (strcat sZhuanHao "0"))
  )
)        ;不足位数桩号在前缀补位
(setq sZhuanHao (strcat sZhuanHao (rtos rZhuanHao 2 2)))
sZhuanHao
)
;;; -------------------------------------------------------------------------
;;;将ag调整到-pi/2~pi/2，并返回调整后的结果
(defun AngInHalfPi (ag)
(setq ag (if (and (> ag (/ pi 2)) (< ag (* pi 1.5)))
           (- ag pi)
           ag
          )
)
ag
)
;;; -------------------------------------------------------------------------
;;;将ag调整到0~pi，并返回调整后的结果
(defun AngInPi (ag / twoPi)
(setq twoPi (* 2 pi))
(if (< ag 0)
  (while (< ag 0)
   (setq ag (+ ag twoPi))
  )
  (while (>= ag twoPi)
   (setq ag (- ag twoPi))
  )
)
ag
)
;;; -------------------------------------------------------------------------
;;; 读取纬地道路软件格式的纵断面文件，并返回数据表，失败时返回nil
;|
(defun GetDateFromZDMFile
                          (/ FileName File1 LST STR zdmList nt n ZH GaoCheng R ch zdmDateFormat)
(setq zdmList nil)
(if (setq FileName (getfiled "选择纬地纵断面文件" "" "zdm" 4))
  (progn
   ;;读模式打开纵断面数据文件
   (setq File1 (open FileName "r"))
   ;;逐行读入
   (setq n 1
         zdmDateFormat
         "正确格式"
   )
;;;n用于记录当前行序号为第一行或非第一行
   (while (and (setq STR (read-line File1))
               (= zdmDateFormat "正确格式")
          )
    (if (= n 1)
     (progn
      (setq nt (read str))
      (if (numberp nt)
       (setq zdmList (list (list nt)))
       (progn
        (setq zdmList nil)
        (setq zdmDateFormat "错误格式")
        (princ (strcat "\n纵断面数据文件第1行数格式有误:不是整数!"))
       )
      )
     )
     (progn
      (setq ZH nil
            GaoCheng nil
            R nil
      )
      (setq ZH (read str))
      (while (and (/= (setq ch (substr str 1 1)) " ")
                  (>= (strlen str) 1)
             )
       (setq str (substr str 2))
      )
      (while (and (= (setq ch (substr str 1 1)) " ")
                  (>= (strlen str) 1)
             )
       (setq str (substr str 2))
      )
      (setq GaoCheng (read str))
;;;取得高程
      (while (and (/= (setq ch (substr str 1 1)) " ")
                  (>= (strlen str) 1)
             )
       (setq str (substr str 2))
      )
      (while (and (= (setq ch (substr str 1 1)) " ")
                  (>= (strlen str) 1)
             )
       (setq str (substr str 2))
      )
      (setq R (read str))
;;;取得高程
      (if (and (numberp ZH)
               (numberp GaoCheng)
               (numberp R)
          )
       (setq zdmList (append zdmList (list (list ZH GaoCheng R))))
       (progn
        (setq zdmList nil)
        (setq zdmDateFormat "错误格式")
        (princ
         (strcat "\n纵断面数据文件第" (rtos n 2 0) "行数据格式有误!")
        )
       )
      )
     )
    )
    (setq n (1+ n))
   )
   ;;关闭文件
   (close File1)
  )
)
(if (/= nt (- n 2))
  (progn
   (setq zdmList nil)
   (princ
    "\n纵断面数据文件格式有误:数据文件中指定的变坡点总数与实际的变坡点总数不符!"
   )
  )
)
zdmList
) ;_ 结束defun
|;
(defun GetDateFromZDMFile (/ strFileName objectFile LineN listN zdmList )
(setq zdmList nil)
(if (setq strFileName (getfiled "选择纬地道路软件或鸿业市政道路软件的纵断面设计数据文件(*.zdm或*.bgs)" "" "" 4))
  (progn
   ;;读模式打开纵断面数据文件
   (setq objectFile (open strFileName "r"))
   ;;逐行读入
   (while (setq LineN (read-line objectFile))   
    (setq listN (read  LineN)) ;单行字符串以"("开始，以")"结尾时，如鸿业市政道路软件数据文件格式
    (if (not (listp listN))   
     (setq listN (read (strcat "(" LineN ")" ))) ;单行字符串无小括号时，如纬地道路软件数据文件格式
    )
    (if (and (> (length listN) 2)
             (numberp (car listN))
             (numberp (cadr listN))
             (numberp (caddr listN))
         )
        (setq zdmList (append zdmList (list listN)))
     )
   )
   (close objectFile)
   (if (> (length zdmList) 1)
     (setq zdmList (append  (list (list (length zdmList))) zdmList))
     (progn
      (setq zdmList nil)
      (princ "\n纵断面数据文件格式有误,有效变坡点可能不足两个!" )
     )
    )
  )
)
zdmList
)
;;;------------------------------------------------------------------------
;;;计算指定里程点的高程，成功则返回计算结果，否则返回提示出错原因的字符串
;;;调用参数形式 (  纵断面设计数据表( 由GetDateFromZDMFile计算得到 )　需查询高程的里程 )
(defun ZDMBiaoGao (zdmList     ZhuanHao    /     zhQ   bgQ   zhA   bgA   rA    TA    zhTA  TB    zhTB  zhB   bgB
                   rB    zhH   bgH   iQA   iAB   iBH   diA   diB
;;;zh开头表示桩号;bg开头表示标高;r开头表示竖曲线;
;;;A,B当前里程所在区间前后点
;;;Q,A点之前变坡点;Ta,A处竖曲线,A点后切线点;TB,B处竖曲线,B点前切线点;H,B点后变坡点
;;;iQA iAB iB  di,分别为前坡段坡度,AB坡度,后坡段坡度,坡度差
;;;T表示切点
                   h0
;;;未计竖曲线时高程
                   hc
;;;竖曲线高程修正高程
                   h
;;;设计高程
                   AoTuR
;;;竖曲线凹凸,ao,凹;tu,凸
                   n     nt    x     rStr  OK    RorS
                  )
(setq nt (car (nth 0 zdmList)))
(setq RorS "str")
(if (>= nt 2)
  (progn
   (setq zhA (car (nth 1 zdmList)))
   (setq zhB (car (nth nt zdmList)))
   (cond
    　
    ((< ZhuanHao zhA) (setq rStr "桩号过小"))
    　
    ((> ZhuanHao zhB) (setq rStr "桩号过大"))
    　
    ((<= zhA ZhuanHao zhB)
     　
     (progn
      　
      (setq n 2)
      (setq OK 0)
      　
      (while (= OK 0)
       　
       (setq zhB (car (nth n zdmList)))
       (if (<= ZhuanHao zhB)
        (progn
;;;开始数据准备
         (setq bgA (cadr (nth (1- n) zdmList)))
         (setq bgB (cadr (nth n zdmList)))
         (setq iAB (/ (- bgB bgA) (- zhB zhA)))
         (if (= n 2)
          (progn
           (setq diA 0)
           (setq rA 1)
           (if (> nt 2)
;;;纵断面不只有一个坡段时
            (progn
             (setq rB (caddr (nth 2 zdmList)))
             (setq zhH (car (nth 3 zdmList)))
             (setq bgH (cadr (nth 3 zdmList)))
             (setq iBH (/ (- bgH bgB) (- zhH zhB)))
             (setq diB (- iBH iAB))
            )
           )
          )
         )
;;;点在第一段纵坡上时
         (if (= n nt)
          (progn
           (setq diB 0)
           (setq rB 1)
           (if (> nt 2)
;;;纵断面不只有一个坡段时
            (progn
             (setq rA (caddr (nth (1- n) zdmList)))
             (setq zhQ (car (nth (- n 2) zdmList)))
             (setq bgQ (cadr (nth (- n 2) zdmList)))
             (setq iQA (/ (- bgA bgQ) (- zhA zhQ)))
             (setq diA (- iAB iQA))
            )
           )
          )
         )
;;;点在最后一段纵坡上时
         (if (and (/= n 2) (/= n nt))
          (progn
           (setq rA (caddr (nth (1- n) zdmList)))
           (setq zhQ (car (nth (- n 2) zdmList)))
           (setq bgQ (cadr (nth (- n 2) zdmList)))
           (setq rB (caddr (nth n zdmList)))
           (setq zhH (car (nth (1+ n) zdmList)))
           (setq bgH (cadr (nth (1+ n) zdmList)))
           (setq iQA (/ (- bgA bgQ) (- zhA zhQ)))
           (setq iBH (/ (- bgH bgB) (- zhH zhB)))
           (setq diA (- iAB iQA))
           (setq diB (- iBH iAB))
          )
         )
;;;点不在第一段也不在最后一段纵坡上时
         (setq TA (abs (* diA (* 0.5 rA))))
         (setq TB (abs (* diB (* 0.5 rB))))
         (setq zhTA (+ zhA TA))
         (setq zhTB (- zhB TB))
;;;结束数据准备
         (cond
          ((< ZhuanHao zhTA)
           (progn
            (setq x (- zhTA ZhuanHao))
            (setq hc (* 0.5 (/ (* x x) rA)))
            (if (< diA 0)
             (setq AoTuR "tu")
             (setq AoTuR "ao")
            )
           )
          )
;;;里程点在A点竖曲线上时
          ((<= zhTA ZhuanHao zhTB)
           (progn
            (setq hc 0)
            ;;竖曲线修正值为0
            (setq AoTuR "ao")
;;;里程点不在竖曲线上,采用凹曲线的计算公式
           )
          )
;;;里程点不在竖曲线上时
          ((> ZhuanHao zhTB)
           (progn
            (setq x (- ZhuanHao zhTB))
            (setq hc (* 0.5 (/ (* x x) rB)))
            (if (< diB 0)
             (setq AoTuR "tu")
             (setq AoTuR "ao")
            )
           )
          )
;;;里程点在B点竖曲线上时
          　
         )
;;;计算竖曲线高程修正值，并判断曲线的凹凸
         (setq h (+ bgA (* iAB (- ZhuanHao zhA))))
;;;计算未含竖曲线修正值时的设计高程
         (if (= AoTuR "ao")
          (setq h (+ h hc))
          (setq h (- h hc))
         )
;;;计算最终设计高程
         (setq OK 1)
         (setq RorS "real")
        )
        (progn
         (setq zhA zhB)
         (setq n (1+ n))
        )
        　
       )
      )
     )
     　
    )
   )
  )
  (setq rStr "数据文件有误")
)
(if (= RorS "real")
  h
  rStr
)
;;;输出返回值
) ;_ 结束defun
;;;------------------------------------------------------------------------
;;;判断点位位曲线的左侧、右侧、还是在曲线上
;;;返回结果为字符串，有三种："右侧"　"左侧"　"在中线上"
;;;调用参数形式 ( 曲线图元名　需判断左右的点　点与曲线的垂足　垂足到曲线起点的曲线长度　里程增加方向 )
(defun strZhuoYou (oblname PJ PjP LPjP FS / ZhuoYou PP agPJ agPP agD)
(if (/= (distance PJ PjP) 0)
  (progn
   (if (= FS "同向")
    (setq PP (vlax-curve-getPointAtDist oblname (- LPjP 0.001)))
    (setq PP (vlax-curve-getPointAtDist oblname (+ LPjP 0.001)))
   )
;;;取得里程比井里程小0.001的点坐标
   (setq agPP (angle PjP PP))
;;;PjP->PP方位角(0~2 Pi)
   (setq agPJ (angle PjP PJ))
;;;PjP->PJ方位角(0~2 Pi)
   (setq agD (- agPJ agPP))
;;;方位角差
   (if (or (< (abs (- agD (* pi 0.5))) 0.5)
           (< (abs (+ agD (* pi 1.5))) 0.5)
       )
;;;方位角差为pi/2或1.5pi,最大误差为0.5
    (setq ZhuoYou "右侧")
    (setq ZhuoYou "左侧")
   )
;;;点位于道路左侧或右侧
  )
  (setq ZhuoYou "在中线上")
)
ZhuoYou
)
;;;------------------------------------------------------------------------
;;;回四舍五入函数，返四舍五入后的实数
;;;调用参数形式 (  数值　小数位数 )
(defun fixReal (数值 小数位数 / N2 n10 NReturn)
(setq n10 (expt 10 小数位数))
(setq N2 (fix (* 数值 2 n10)))
(setq NReturn (+ (/ N2 2) (rem N2 2)))
(setq NReturn (/ (float NReturn) (float N10)))
NReturn
)
;;; -------------------------------------------------------------------------
;;; 选择圆，允许按直径条件过滤，并返回选择集表
;;;调用参数形式 (  “提示需要进行的操作”+“圆及其修饰” 的文本 )
(defun SelectCircles (OperationStr / obcName nob obc obcK i KeyW KeyR cR cList nList obType)
(if (ssgetfirst)  　
  (setq obc (ssget "_P" '((0 . "circle"))))
)        ;有预选择时，从预选择集中找出被选择的圆选择集
(if (not obc)
  (progn
   (princ (strcat "\n选择需要" OperationStr ":"))
   (setq obc (ssget '((0 . "circle")))) ; 创建选择集 obc
  )       ;无预选择或预选择中无圆图元时
)
(if obc
  (progn
   (setq nob (sslength obc))
   (initget "Y N R _Yes No ReSelect")
   (setq KeyW
         (getkword
          (strcat "\n是否选择了不需要"
                  OperationStr
                  "[是(Y)/否(N)/重新选择(R)]<N>:"
          )
         )
   )
(cond
   ((= KeyW "Yes")
     (initget 6)
     (setq
      KeyR (getreal
            (strcat
             "\n指定需要"
             OperationStr
             "的直径(右键或回车表示所有选择的圆均需要进行操作):"
            )
           )
     )
     (if (numberp KeyR)
      (progn
       (setq i 0
             cList nil
       )
       (repeat nob
        (setq obcK (ssname obc i))
        (setq cR (cdr (assoc 40 (entget obcK))))
        (if (/= cR (/ KeyR 2.0))
         (setq cList (append cList (list obcK)))
        )
        (setq i (1+ i))
       )  ;计算需要从选择集中去除的图元的名称表
       (setq i 0)
       (repeat (length cList)
        (ssdel (nth i cList) obc)
        (setq i (1+ i))
       )
       　 ;从选择集中去除不符合条件的图元
      )
     )
   )
   ((= KeyW "ReSelect")
     (princ (strcat "\n重新选择需要" OperationStr ":"))
     (setq obc (ssget '((0 . "circle")))) ; 创建选择集 obc
    )
   (T nil)
   )
  )
)
obc
)
;;; -------------------------------------------------------------------------
;;;根据里程计算井点的坐标，成功则返回表　（　坐标，点所在里程处中线在里程增加方向的切线角）　，　否则返回nil
;;;为减少程序的计算量，调用参数多设置了两个
;;;调用参数形式 (  中线对象　中线长度　起点里程　里程方向　终点里程　里程　左右　距离  )
(defun getPointByLiChengZhuoYouJuLi (中线对象 中线长度 起点里程 里程方向 终点里程 里程 左右 距离 / ag Dst obPoint lst)
(setq obPoint nil
       ag 0
       lst nil
)
(if (or (and (= 里程方向 "同向") (<= 起点里程 里程 终点里程))
         (and (/= 里程方向 "同向") (>= 起点里程 里程 终点里程))
     )
  (progn
   (setq Dst (abs (- 里程 起点里程)))
   (setq ZhongDian (vlax-curve-getPointAtDist 中线对象 Dst))
   ;;根据里程计算中点坐标
   (if (= 距离 0) ;判断井是否在路中线上
    (setq obPoint ZhongDian)
    (progn
     (setq ag (AngleQieXiang 中线对象 ZhongDian))
     ;;计算切线角
     (if (or (and (= 里程方向 "同向") (= 左右 "左侧"))
             (and (/= 里程方向 "同向") (/= 左右 "左侧"))
         )
      (setq obPoint (polar ZhongDian (+ ag (* pi 0.5)) 距离))
      (setq obPoint (polar ZhongDian (+ ag (* pi 1.5)) 距离))
     )
    )     ;计算要求点不在路中线上时的坐标
   )
   (if (and (/= 距离 0)
            (/= 里程方向 "同向")
       )
    (setq ag (+ ag pi))
   )      ;点所在里程处中线在里程增加方向的切线角
   (setq lst (list obPoint ag)) ;计算成功时，生成结果表
  )
)        ;里程有效时，计算坐标及切线角度
lst      ;返回结果表
)
;;; -------------------------------------------------------------------------
;;;如果成功，返回表： ( 中线  中线起点里程  里程增加与曲线正向的关系  终点里程  中线长 ) ;否则返回nil
;;;调用形式(  GetZhongXiang nil或任意值)  如果参数不为nil时，将强制重新设置路中线扩展数据
;;;生成的扩展数据格式为:(  "PS_DLZX" (1040 起点里程) (1040 终点里程)  )  注：此处的起终点为cad线图的起终点，非道路真实起终点
(defun GetZhongXiang (strResetXData    /                      intSelectedSetNumber   ssSelected
                      strZhongXiangEntityName                       listZhongXiangXData    LZhongXiang
                      QiDianLiCheng          ZhongDianLiCheng       LiChengFangXiang   strLiChengQianZhui  listResult      keyW
                     )
;;;-------------------------------------------------------------
;;;获取中线的xdata数据，并计算道路资料
(defun GetFromXData (/ keyword tmpList )
  (setq strLiChengQianZhui (cdr (cadr listZhongXiangXData)))
  (setq tmpList (caddr listZhongXiangXData))
  (setq QiDianLiCheng (cadr tmpList))
  (setq ZhongDianLiCheng (caddr tmpList))
  (if (<= QiDianLiCheng ZhongDianLiCheng)
   (setq LiChengFangXiang "同向")
   (setq LiChengFangXiang "反向")
  )
  (setq LZhongXiang
        (vlax-curve-getDistAtParam
         strZhongXiangEntityName
         (- (vlax-curve-getEndParam strZhongXiangEntityName)
            (vlax-curve-getStartParam strZhongXiangEntityName)
         )
        )
  )       ;中线长度
  (if (< -1
         (- (abs (- ZhongDianLiCheng QiDianLiCheng)) LZhongXiang)
         1
      )   ;判断定义路中线后，中线对象是否被改变
   (if (<= QiDianLiCheng ZhongDianLiCheng) ;中线对象未被修改或仅被微调时
    (setq ZhongDianLiCheng (+ QiDianLiCheng LZhongXiang))
    (setq QiDianLiCheng (+ ZhongDianLiCheng LZhongXiang))
   )      ;根据实际的道路起点里程及 道路长度重新计算路终里程，以免若路中线被微调，所计得到的设置不正确
   (progn ;中线对象已被修改时
    (initget "A R _AutoSet Reset")
    (setq keyword (getkword
                   "路中线在定义后已被改变[按原定义的起点及方向自动调整(A)/重新定义(R)]<A>:"
                  )
    )
    (if (= keyword "Reset")
     (InterSet)
     (if (<= QiDianLiCheng ZhongDianLiCheng)
      (setq ZhongDianLiCheng (+ QiDianLiCheng LZhongXiang))
      (setq QiDianLiCheng (+ ZhongDianLiCheng LZhongXiang))
     )    ;根据实际的道路起点里程及 道路长度重新计算路终里程
    )
   )
  )
)
;;;-------------------------------------------------------------
;;;以交互形式设置中线信息
(defun InterSet (/ ckPointA KCKPA ckPointB kw zhFangShang LCKPA LCKPB LinShiPoint)
   ;;zhFangShang为用于判断里程增加方向，为正时，曲线开始点为里程起点，反之为终点
  (setvar "osmode" 431)
  (setq ckPointA nil
        ckPointB nil
        LinShiPoint nil
  )
  (while (not ckPointA)
   (setq ckPointA (getpoint "\n指定中线上一点:"))
   (setq LinShiPoint (vlax-curve-getClosestPointTo strZhongXiangEntityName   ckPointA  T ) )
   (if (<= (distance ckPointA LinShiPoint) 0.5) ;两点的距离在0~0.5之间时
    (setq ckPointA LinShiPoint)
    (progn
     (setq ckPointA nil)
     (princ "\n所指定的点不在指定的道路中心线上,请重新指定!")
    )
   )
  )
  (if (not (setq KCKPA (getreal "\n输入参考点的里程数值<0>:")))
   (setq KCKPA 0)
  )
  (while (not ckPointB)
   (setq ckPointB (getpoint "\n指定路中线上的另一点:"))
   (setq LinShiPoint (vlax-curve-getClosestPointTo strZhongXiangEntityName   ckPointB   T  ) )
   (if (<= (distance ckPointB LinShiPoint) 5.0) ;两点的距离在0~5.0之间时
    (setq ckPointB LinShiPoint)
    (progn
     (setq ckPointB nil)
     (princ "\n所指定的点不在指定的道路中心线上,请重新指定!")
    )
   )
   (if (and ckPointB
            (<= (distance ckPointB ckPointA) 0.1) ;如果两点的距离在0~0.1之间时，两点看做为同一点
       )
    (progn
     (setq ckPointB nil)
     (princ
      "\n第二次指定的点与第一次指定的点相同,请重新指定与第一点不同的点!"
     )
    )
   )
  )
  (setvar "osmode" 0)
  (initget "A S _Add Sub")
  (setq kw (getkword
            "\n第二点里程相对第一点的里程是[增加(A)/减少(S)]<A>:"
           )
  )
  (if (= kw "Sub")
   (setq zhFangShang -1)
   (setq zhFangShang 1)
  )       ; 默认相对里程为增加
  (setq LCKPA (vlax-curve-getDistAtPoint strZhongXiangEntityName ckPointA)) ; 第一点到曲线起点的长度
  (setq LCKPB (vlax-curve-getDistAtPoint strZhongXiangEntityName ckPointB)) ; 第二点到曲线起点的长度
  (setq LZhongXiang
        (vlax-curve-getDistAtParam
         strZhongXiangEntityName
         (- (vlax-curve-getEndParam strZhongXiangEntityName)
            (vlax-curve-getStartParam strZhongXiangEntityName)
         )
        )
  )       ;中线长度
  (if (> (* zhFangShang (- LCKPB LCKPA)) 0)
   (progn
    (setq QiDianLiCheng (- KCKPA LCKPA)) ; 中线起点(曲线起点)里程
    (setq ZhongDianLiCheng (+ QiDianLiCheng LZhongXiang))
    ;;终点里程
    (setq LiChengFangXiang "同向") ; 里程增加方向与中线起点到终点方向相同
   )
   (progn
    (setq QiDianLiCheng (+ KCKPA LCKPA)) ; 中线起点(曲线起点)里程
    (setq ZhongDianLiCheng (- QiDianLiCheng LZhongXiang)) ;终点里程
    (setq LiChengFangXiang "反向") ; 里程增加方向与中线起点到终点方向不同
   )
  )       ;判断里程方向与曲线方向的关系，并确定曲线起终点的里程
  (if (= "" (setq strLiChengQianZhui (getstring "\n输入里程的前缀<K>:")))
    (setq strLiChengQianZhui "K")
   )
  (SetXdata strZhongXiangEntityName
            (list "PS_DLZX"
                  (cons 1000 strLiChengQianZhui)
                  (list 1010 QiDianLiCheng ZhongDianLiCheng 0)
            )
  )
  ;;把起点里程及 终点里程定义添加到中线对象的标记为"PS_DLZX" 的扩展数据中
)
;;;-------------------------------------------------------------
(setq listResult nil)
(vl-cmdf "ucs" "w")
(setq intSelectedSetNumber 2)
(while (> intSelectedSetNumber 1)
  (princ "\n选择路中线(只能选择一条线):")
  (setq ssSelected (ssget '((0 . "*line,arc")))) ; 创建选择集 ssSelected
  (if ssSelected
   (setq intSelectedSetNumber (sslength ssSelected))
   (setq intSelectedSetNumber 2)
  )
)
(setq strZhongXiangEntityName (ssname ssSelected 0)) ; oblname，取得中线对象名
(setq listZhongXiangXData (cadr (assoc -3   (entget strZhongXiangEntityName  '("PS_DLZX")) )))
(if listZhongXiangXData
  (if (= strResetXData "是")
   (progn
      (initget "S R _Set Remain")
      (setq keyW (getkword "该路中线已经被定义![重新定义(S)/保留原定义(R)]<R>:"  ) )
     (if (= keyW "Set")
      (InterSet) ;如果指定重新设置，设置路中线信息
     )
    )
   (GetFromXData) ;不指定重新设置时，从扩展数据计算路中线信息
  )       ;存在已定义的路中线扩展数据时
  (InterSet) ;未设置有扩展的路中线数据时，重头设置路中线信息
)
(setq listResult (list strZhongXiangEntityName QiDianLiCheng LiChengFangXiang ZhongDianLiCheng LZhongXiang strLiChengQianZhui) )
listResult
)
;;;-------------------------------------------------------------
;| (SetXdata strEntityName listApp) = entmod方式,给实体添加或更新或删除扩展数据.-----
参数: strEntityName = 实体名.
      listApp = '("注册名" 项1 项2 ...) ;用于添加或更新. 如(list "test" '(1070 . 1234)'(1003 . "0"))
            '("注册名") ; 用于删除相关注册项的xdata.
            nil ; 用于删除实体全部的xdata.
说明: 支持所有实体.非图形实体不支持viewport(必须用 vlax-ldata-put.或setxdata方法).
      参考 entmod 帮助.
相关: 参照 ()函数=vla方式,支持所有的扩展数据修改.
实例: 1.增加(如已经有,则为更新)指定注册名的xdata:
        (SetXdata (car(entsel)) (list "test" (cons 1070 1234)))
      2.删除指定注册名的xdata:
        (SetXdata (car(entsel)) '("test"))
      3.删除所有的扩展数据:
        (SetXdata (setq strEntityName(car(entsel))) nil)
|;
(defun SetXdata (strEntityName listApp / listApps)
(if listApp
  (regapp (car listApp))
)
;;无论是否已经有,均注册.有重复的话无不利影响.
(if listApp
  (entmod (list (cons -1 strEntityName) (list -3 listApp)))
  ;;新建,更新,或删除指定app,{用 '("注册名") }.
  (progn ;;删除所有的扩展数据.
         (setq listApps (mapcar 'car (cdr (assoc -3 (entget strEntityName '("*"))))))
         (entmod (list (cons -1 strEntityName)
                       (cons -3 (mapcar 'list listApps))
                 )
         )
  )
)
)
;;;-------------------------------------------------------------
;;;计算曲线上一点处的正向切线角0～2 pi
;;;调用形式　（曲线对象名 曲线上一点的坐标） ：未处理坐标不在曲线上的情况
(defun AngleQieXiang (曲线 pt / para Pt1 ag)
(setq para (vlax-curve-getParamAtPoint 曲线 pt))
(setq Pt1 (vlax-curve-getFirstDeriv 曲线 para))
(setq ag (angle '(0 0) Pt1))
;;计算切线角
ag
)
;;;-------------------------------------------------------------
;;;在当前图层、当前空间画直线
;;;调用形式 (  AddLine 起点坐标  终点坐标 )，如果成功，返回定义数据的图元表，否则返回 nil。
(defun AddLine (listStartPoint listEndPoint)
(entmake (list '(0 . "LINE")
                (cons 10 listStartPoint)
                (cons 11 listEndPoint)
          )
)
)
;;;-------------------------------------------------------------
;;;计算从角1到角2逆时针的角度差
;;;返回0~2 pi的正值
(defun AngleDelta ( fStartAngle fTargetAngle / fDelta)
(setq fDelta (-  fTargetAngle fStartAngle ))
(if (< fDelta 0)
   (setq fDelta (+ fDelta (* 2 pi)))
  )
  fDelta
)
;;;-------------------------------------------------------------
;;;在当前图层、当前空间画圆
;;;调用形式 (  AddCircle 圆心坐标  半径 )，如果成功，返回定义数据的图元表，否则返回 nil。
(defun AddCircle (listCenterPoint floatRadius)
(entmake (list '(0 . "CIRCLE")
                (cons 10 listCenterPoint)
                (cons 40 floatRadius)
          )
)
)
;;;------------------------------------------------------------------------
;;;在当前图层、当前空间、按文本居中方式，写单行文本
;;;调用形式 (  AddText_AlignmentMiddle  插入点坐标 字高 文本旋转角度(rad)  文本内容  宽高比例 字体样式名)，如果成功，返回定义数据的图元表，否则返回 nil。
(defun AddText_AlignmentMiddle  (listInsertPoint floatTextHigh floatRotateAngle strText floatScaleFactor  strStyleName)
(entmake (list '(0 . "TEXT")
                '(10 0 0 0)
                (cons 11 listInsertPoint)
                (cons 40 floatTextHigh)
                (cons 1 strText)
                (cons 50 floatRotateAngle)
                (cons 41 floatScaleFactor)
                (cons 7 strStyleName)
                '(72 . 1)
                '(100 . "AcDbText")
          )
)
)
;;;------------------------------------------------------------------------
;;;在当前图层、当前空间、按文本左对齐方式，写单行文本
;;;调用形式 (  AddText_AlignmentLeft  插入点坐标 字高 文本旋转角度(rad)  文本内容  宽高比例 字体样式名)，如果成功，返回定义数据的图元表，否则返回 nil。
(defun AddText_AlignmentLeft  (listInsertPoint floatTextHigh floatRotateAngle strText floatScaleFactor  strStyleName)
(entmake (list '(0 . "TEXT")
                (cons 10 listInsertPoint)
                (cons 40 floatTextHigh)
                (cons 1 strText)
                (cons 50 floatRotateAngle)
                (cons 41 floatScaleFactor)
                (cons 7 strStyleName)
                '(100 . "AcDbText")
          )
)
)
;;;------------------------------------------------------------------------
;;;在当前图层、当前空间插入块
;;;调用形式 ( InsertBlock  块名  插入点  旋转角度 )
;;;成功时，返回dxf组码，否则返回nil
(defun InsertBlock ( strBlockName listInsertPoint floatRotateAngle )
(entmake (list '(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
(cons 2 strBlockName)
(cons 10 listInsertPoint)
(cons 50 floatRotateAngle)))
)
;;;-------------------------------------------------------------
;;;标记undo编组开始点
(defun BeginUndoGroup()
(command "undo" "be")
)
;;; -------------------------------------------------------------------------
;;;标记undo编组结束点
(defun EndUndoGroup()
(command "undo" "e")
)
;;; -------------------------------------------------------------------------
;;; -------------------------------------------------------------------------
;;; -------------------------------------------------------------------------
;;; -------------------------------------------------------------------------
;;; -------------------------------------------------------------------------
;;块统计.LSP


;;;--------------------------------------------------------------------------------
;;;从块选择集中选择指定块名的对象，并返回结果选择集
(defun intCountSingleBlock (ssOriginal strTargetBlockName /
                  strEntityName listEntityDXF strBlockName intSingleBlockCount k)
(setq intSingleBlockCount 0
       k -1 )
(repeat (sslength ssOriginal) ; 循环与所选择的对象数量相等的次数
  (setq strEntityName (ssname ssOriginal (setq k (1+ k)))) ; strEntityName，取得第k个对象名
  (setq listEntityDXF (entget strEntityName))
  (setq strBlockName (cdr (assoc 2 listEntityDXF)))
  (if (= strBlockName strTargetBlockName)
   (setq intSingleBlockCount (1+ intSingleBlockCount))
  )
)
intSingleBlockCount
)
;;;--------------------------------------------------------------------------------
;;;从块选择集中删除指定块名的对象，并返回结果选择集
(defun ssDelEntitysFromBlockSelectionSet (ssOriginal strTargetBlockName
                       / strEntityName listEntityDXF strBlockName ssResult k)
(setq ssResult (ssadd)
       k -1 )
(repeat (sslength ssOriginal) ; 循环与所选择的对象数量相等的次数
  (setq strEntityName (ssname ssOriginal (setq k (1+ k)))) ; strEntityName，取得第k个对象名
  (setq listEntityDXF (entget strEntityName))
  (setq strBlockName (cdr (assoc 2 listEntityDXF)))
  (if (/= strBlockName strTargetBlockName)
   (setq ssResult (ssadd strEntityName ssResult))
  )
)
ssResult
)
;;;--------------------------------------------------------------------------------
;;;插入块缩略图
(defun PrintBlockMiniature (floatBasicPointX                  floatBasicPointY                  strBlockName
                            /                                 floatMaxBlockWidth                floatMaxBlockHigh
                            floatBlockOriginalWidth           floatBlockOriginalHigh            floatBlockWidthScale
                            floatBlockHighScale               floatBlockBoundingBoxTargetMinPointX
                            floatBlockBoundingBoxTargetMinPointY   floatBlockBoundingBoxTargetMaxPointX
                            floatBlockBoundingBoxTargetMaxPointY   listTargetBlockCenterPoint
                            listBlockBoundingBoxMinPoint      listBlockBoundingBoxMaxPoint      objectBlockEntity
                            strEntityName                     listInsertPoint                   floatBlockScale
                            listBlockEntityDXF                listBlockCenterPoint
                           )
;; floatBasicPointX floatBasicPointY 缩略图所在表格单元左下角点坐标
;;计算图块缩略图在图中允许放置范围的左下及右上角点坐标的X、Y数值
(setq floatMaxBlockWidth 21
       floatMaxBlockHigh 8
)
(setq floatBlockBoundingBoxTargetMinPointX (+ floatBasicPointX 2)
       floatBlockBoundingBoxTargetMinPointY (+ floatBasicPointY 1)
       floatBlockBoundingBoxTargetMaxPointX (+ floatBasicPointX floatMaxBlockWidth 2)
       floatBlockBoundingBoxTargetMaxPointY (+ floatBasicPointY floatMaxBlockHigh 1)
)
(setq listTargetBlockCenterPoint (list (/ (+ floatBlockBoundingBoxTargetMinPointX  floatBlockBoundingBoxTargetMaxPointX ) 2)
                                        (/ (+ floatBlockBoundingBoxTargetMinPointY floatBlockBoundingBoxTargetMaxPointY )  2 )
                                        0
                                  )
)
(setq listInsertPoint (list floatBlockBoundingBoxTargetMinPointX  floatBlockBoundingBoxTargetMinPointY  ) )
(InsertBlock strBlockName listInsertPoint 0)
;;以块缩略图允许放置范围的左下角点为块缩略图的基点插入图块
(setq strEntityName (entlast))
(setq objectBlockEntity (vlax-ename->vla-object strEntityName))
(if  (vl-catch-all-error-p (vl-catch-all-apply 'vla-GetBoundingBox
                                                (list objectBlockEntity  'listBlockBoundingBoxMinPoint 'listBlockBoundingBoxMaxPoint ))
         ) ;判断块是否存在边框，若块含无限长直线等时，则不存在边框
    (AddText_AlignmentMiddle listBlockCenterPoint 3 0 "本块无缩略图" 0.8 "standard")
   
    (progn
(setq listBlockBoundingBoxMinPoint (vlax-safearray->list listBlockBoundingBoxMinPoint) )
(setq listBlockBoundingBoxMaxPoint (vlax-safearray->list listBlockBoundingBoxMaxPoint) )
  
(if (> (car listBlockBoundingBoxMaxPoint)  (car listBlockBoundingBoxMinPoint) )
      (setq floatBlockWidthScale (/ floatMaxBlockWidth
                                     (- (car listBlockBoundingBoxMaxPoint) (car listBlockBoundingBoxMinPoint) )
                                     )
         )
       (setq  floatBlockWidthScale 0)
     )

(if (> (cadr listBlockBoundingBoxMaxPoint) (cadr listBlockBoundingBoxMinPoint)  )
    (setq   floatBlockHighScale  (/ floatMaxBlockHigh
                                    (- (cadr listBlockBoundingBoxMaxPoint) (cadr listBlockBoundingBoxMinPoint) )
                                  )
      )
     (setq   floatBlockHighScale 0)
    )
;计算块缩略图允许放置范围的边框长宽与块外框长宽的比值
  
(cond
  ((= (+ floatBlockWidthScale floatBlockHighScale) 0)  (setq floatBlockScale 1)) ;块为单点时,缩放比例取为1
  ((=  floatBlockWidthScale 0)  (setq floatBlockScale floatBlockHighScale) ) ;块为竖直短线时
  ((=  floatBlockHighScale 0)  (setq floatBlockScale floatBlockWidthScale) ) ;块为水平短线时
  ((> floatBlockWidthScale floatBlockHighScale )  (setq floatBlockScale floatBlockHighScale) ) ;数值较小者为块的控制缩放比例
  (T  (setq floatBlockScale floatBlockWidthScale) )  
  )
(setq listBlockEntityDXF (entget strEntityName))
(entmod (subst (cons 41 floatBlockScale) (assoc 41 listBlockEntityDXF) listBlockEntityDXF ) )
(entupd strEntityName)
(setq listBlockEntityDXF (entget strEntityName))
(entmod (subst (cons 42 floatBlockScale) (assoc 42 listBlockEntityDXF) listBlockEntityDXF ) )
(entupd strEntityName)
(setq listBlockEntityDXF (entget strEntityName))
(entmod (subst (cons 43 floatBlockScale) (assoc 43 listBlockEntityDXF) listBlockEntityDXF ) )
(entupd strEntityName)
;;缩放块
(vla-GetBoundingBox objectBlockEntity 'listBlockBoundingBoxMinPoint 'listBlockBoundingBoxMaxPoint)
(setq listBlockBoundingBoxMinPoint (vlax-safearray->list listBlockBoundingBoxMinPoint) )
(setq listBlockBoundingBoxMaxPoint (vlax-safearray->list listBlockBoundingBoxMaxPoint) )
(setq listBlockCenterPoint (list (* 0.5 (+ (car listBlockBoundingBoxMaxPoint) (car listBlockBoundingBoxMinPoint) ) )
                                  (* 0.5 (+ (cadr listBlockBoundingBoxMaxPoint) (cadr listBlockBoundingBoxMinPoint) ) )
                                  0
                            )
)
(vla-move objectBlockEntity (vlax-3d-point listBlockCenterPoint) (vlax-3d-point listTargetBlockCenterPoint))
)
)
)
;;;--------------------------------------------------------------------------------
;;;打印统计结果表
(defun PrintCountResultList (listResult       /                i                ListLength       strBlockName
                             intNumberOfSSSingleBlockName      strNumberOfSSSingleBlockName      pt               pt1
                             pt2              pt3              x                y                x1               y1
                             x2               x3               floatTextHigh
                            )
(setq pt (getpoint "\n点取要标注块统计结果信息的位置:"))
(setq x (car pt)
       y (cadr pt)
       i 0
       floatTextHigh 4
)
(setq ListLength (length listResult))
(setq y1 (- y (* (1+ ListLength) 10))) ;行高取10
(while (<= i 4)
  (setq x1 (+ x (* i 25))) ;列宽取25
  (setq pt1 (list x1 y 0)
        pt2 (list x1 y1 0)
  )
  (AddLine pt1 pt2)
  (setq i (1+ i))
)
;;;画竖向表格线
(setq i 0)
(setq x1 (+ x (* 4 25)))
(while (<= i (1+ ListLength))
  (setq y1 (- y (* i 10)))
  (setq pt1 (list x y1 0)
        pt2 (list x1 y1 0)
  )
  (AddLine pt1 pt2)
  (setq i (1+ i))
)
;;;画横向表格线
;;;------------------------------------------------------------------------
(setq x1 (+ x (* 0.5 25))
       x2 (+ x (* 1.5 25))
       x3 (+ x (* 2.5 25))
       x4 (+ x (* 3.5 25))
       x5 (+ x (* 4.5 25))
       y1 (- y 7)
)
(setq pt1 (list x1 y1 0)
       pt2 (list x2 y1 0)
       pt3 (list x3 y1 0)
       pt4 (list x4 y1 0)
       pt5 (list x5 y1 0)
)
(AddText_AlignmentMiddle pt1 floatTextHigh 0 "块缩略图" 0.8 "standard")
(AddText_AlignmentMiddle pt2 floatTextHigh 0 "块名称" 0.8 "standard")
(AddText_AlignmentMiddle pt3 floatTextHigh 0 "规格" 0.8 "standard")
  ;(AddText_AlignmentMiddle pt4 floatTextHigh 0 "单价" 0.8 "standard")
  (AddText_AlignmentMiddle pt4 floatTextHigh 0 "块数量" 0.8 "standard")
;;输出表头
;;;------------------------------------------------------------------------
(setq i 0
       floatTextHigh 3 )
(while (< i ListLength)
  (setq y1 (+ y (* -10 (+ i 2))))
  (setq ;pt1 (list x1 y1 0)
        pt2 (list x2 (+ y1 3) 0)
        pt3 (list x3 (+ y1 3) 0)
  pt4 (list x4 (+ y1 3) 0)
  pt5 (list x5 (+ y1 3) 0)
  )
  (setq strBlockName (car (nth i listResult))
        intNumberOfSSSingleBlockName (car (cddddr (nth i listResult)))
intNumberstrBlockNa (cadr (nth i listResult))
intNumberstrBlockgg (caddr (nth i listResult))
intNumberstrBlockdj (cadddr (nth i listResult))
  )
  (setq strNumberOfSSSingleBlockName (itoa intNumberOfSSSingleBlockName))
  (AddText_AlignmentMiddle pt2 floatTextHigh 0 intNumberstrBlockNa 0.8 "standard")
   (AddText_AlignmentMiddle pt3 floatTextHigh 0 intNumberstrBlockgg 0.8 "standard")
   ;(AddText_AlignmentMiddle pt4 floatTextHigh 0 intNumberstrBlockdj 0.8 "standard")
  (AddText_AlignmentMiddle pt4 floatTextHigh 0 strNumberOfSSSingleBlockName 0.8 "standard")
  
  (if (vl-catch-all-error-p (vl-catch-all-apply 'PrintBlockMiniature (list x y1 strBlockName)))
     (AddText_AlignmentLeft (list (+ x 1) (+ y1 2)) 3 0 "生成块缩略图时出错" 0.8 "standard")
   )
  (setq i (1+ i))
)
;;;打印表内容
)
;;;--------------------------------------------------------------------------------
(defun GetBlocksSelectionRange (/ strDCLFileName listInputDefinements listKeysAndValues listKeysAndActions listKeysToGetValue
                     listDCLReturn intButtonClick strSelectRange)
(setq strSelectRange  "UserSelection" )
(setq strDCLFileName "BlocksSelectionRange")
(setq listInputDefinements '(("dialog" "指定统计范围" "")
                               ("spacer")
                                ("radio_column" "进行块统计的范围:")
                                 ("btRadio" "手工选择" "brUserSelection")
                                 ("btRadio" "整个图形" "brDrawingFile")
                                ("end")
                                ("text" "注:不统计含无限长直线的块!")
                              ("spacer")
                              ("btOK")
                              ("end")
                             )
)
(setq listKeysAndValues '(("brUserSelection" "1")))
(setq listKeysAndActions '(("brUserSelection" "(setq strSelectRange \"UserSelection\")")
                            ("brDrawingFile" "(setq strSelectRange \"DrawingFile\")")) )
(setq listKeysToGetValue nil)
(setq listDCLReturn (listGenerateDCL strDCLFileName listInputDefinements listKeysAndValues listKeysAndActions listKeysToGetValue) )
(setq intButtonClick (car listDCLReturn )  )
strSelectRange
)
;;;--------------------------------------------------------------------------------
;;;块数量统计
(defun tktj (/                      ssObjects              strEntityName          listEntityDXF          strBlockName
                      listResult  intSingleBlockCount  listMinPoint listInsertPoint        floatBlockRotateAngle
                                             ;;listResult 用于记录统计结果，形式为((  块名  块数量  同名块中一个实体的对象名 )...)
                     )
; (initget "D S _DrawingFile UserSelection")
; (setq strSelectRange (getkword "\n统计块的范围[全图(D)/选择(S)]<S>:"))
(setq strSelectRange (GetBlocksSelectionRange))
(if (= strSelectRange "DrawingFile")
  (setq ssObjects  (ssget "X" '((0 . "insert")(100 . "AcDbBlockReference")))) ; 创建选择集 ssObjects
  (progn
   (princ "\n请选择需要统计的块:\n")
   (setq ssObjects (ssget '((0 . "INSERT")(100 . "AcDbBlockReference")))) ; 创建选择集 ssObjects
  )
)
(if ssObjects
  (progn
   (setq listResult nil)
   (while (> (sslength ssObjects) 0)
    (setq strEntityName (ssname ssObjects 0)) ; strEntityName，取得第1个对象名
    (setq listEntityDXF (entget strEntityName))
    (setq kobj (entnext strEntityName))
    (setq strBlockNa (cdr (assoc 1 (entget kobj))))
     (setq ggobj (entnext kobj))
     (setq strblockgg (cdr (assoc 1 (entget ggobj))))
     (setq djobj (entnext ggobj))
     (setq strblockdj (cdr (assoc 1 (entget djobj))))
     (setq strBlockName (cdr (assoc 2 listEntityDXF)))
    (setq intSingleBlockCount (intCountSingleBlock ssObjects strBlockName ) )
    (setq ssObjects (ssDelEntitysFromBlockSelectionSet ssObjects strBlockName))
    (setq listResult (append listResult
                             (list (list strBlockName strBlockNa strblockgg strblockdj intSingleBlockCount))
                     )
    )
   )
   (setq listResult (vl-sort listResult
        '(lambda (p1 p2)
    (cond ((< (car p1) (car p2)) T)
          (T nil)
    )
         )
      )
   )
   (setvar "dimzin" 8)
   (setvar "osmode" 0)
  (if  (tblsearch "style" "standard")
    ;;判断是否存在"standard"字体，有则设为当前，无则创建。
       (setvar "textstyle" "standard")
       (command "_style" "standard" "sceie.shx,sceic.shx" 0 0.8 0 "N" "N" "N")
   )
   (PrintCountResultList listResult)
   (setvar "osmode" 5375)
  )
)
(princ)
)

(defun c:ktj() (tktj))
;;;占个位哈

junkegg

刚发表的啊,没注意看.不好意思楼上的

自贡黄明儒

密秘在程序作者定义了块的产生如下:
(defun InsertBlock ( strBlockName listInsertPoint floatRotateAngle )
(entmake (list '(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
(cons 2 strBlockName)
(cons 10 listInsertPoint)
(cons 50 floatRotateAngle)))
)
;这样是很合理的。
如果用(command "I" ...)则要求你输入属性。如一个块有50个属性，产生一个块你要输入50下，另一块3个属性，你要输入3下，处理起来是不是很麻烦？

xskfq

自贡黄明儒 发表于 2014-2-12 15:01
密秘在程序作者定义了块的产生如下:
(defun InsertBlock ( strBlockName listInsertPoint floatRotateAngl ...

哦 原来如此  谢谢  那有什么好的办法没 生成属性块？

xskfq

;;;------------------------------------------------------------------------
;;;在当前图层、当前空间插入块
;;;调用形式 ( InsertBlock  块名  插入点  旋转角度 )
;;;成功时，返回dxf组码，否则返回nil
(defun InsertBlock ( strBlockName listInsertPoint floatRotateAngle )
(entmake (list '(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
(cons 2 strBlockName)
(cons 10 listInsertPoint)
(cons 50 floatRotateAngle)))
)

---------------------------------------
entmake做不了多属性块吗

hnfsf

遇到同样的问题，顶一个，寻找解决办法。。

伪书虫86

顶起来，材料表统计遇到同样的问题

鱼与熊掌

(vla-InsertBlock *MS* "block_name" 1.0 1.0 1.0 0.0)
模型空间. 块名 比例比例比例     旋转角度