[编程交流] 错误：错误的参数类型：stri

; Legend - EMT Software Inc., by Scott Hull 04/18/01
;
(defun C:LEGEND (/ #ALERT #DCL-FILE #DCL-ID #DCL-LIST #GO #HELP #LEGEND-BLOCK
#LEGEND-LAYER #LINENO @ALERT @DWGLYRS @LAYER @LIST @LEGEND-DRAW
@LEGEND-READ @LEGEND-WRITE *error*)
(setq #DCL-LIST (list
"legend : dialog {"
" key = "title";"
" label = "Legend Generator";"
" : boxed_column {"
" label = "&Layers";"
" : concatenation {"
" : text_part {"
" label = "Name";"
" width = 19;"
" }"
" : text_part {"
" label = "Legend";"
" width = 9;"
" }"
" : text_part {"
" label = "Description";"
" }"
" }"
" : list_box {"
" height = 8;"
" key = "layer";"
" tabs = "19 28";"
" width = 70;"
" }"
" : row {"
" : edit_box {"
" edit_width = 60;"
" fixed_width = true;"
" key = "descp-layer";"
" label = "&Description:";"
" }"
" }"
" }"
" : boxed_column {"
" label = "&Blocks";"
" : concatenation {"
" : text_part {"
" label = "Name";"
" width = 19;"
" }"
" : text_part {"
" label = "Legend";"
" width = 9;"
" }"
" : text_part {"
" label = "Description";"
" }"
" }"
" : list_box {"
" height = 8;"
" key = "block";"
" tabs = "19 28";"
" width = 70;"
" }"
" : row {"
" : edit_box {"
" edit_width = 60;"
" fixed_width = true;"
" key = "descp-block";"
" label = "&Description:";"
" }"
" }"
" }"
" ok_cancel_help_cadalog_errtile;"
"}"
""
"cadalog_button : retirement_button {"
" key = "cadalog";"
" label = "&CADalog.com...";"
"}"
""
"ok_cancel_help_cadalog : column {"
" : row {"
" fixed_width = true;"
" alignment = centered;"
" ok_button;"
" : spacer {"
" width = 2;"
" }"
" cancel_button;"
" : spacer {"
" width = 2;"
" }"
" help_button;"
" : spacer {"
" width = 2;"
" }"
" cadalog_button;"
" }"
"}"
""
"ok_cancel_help_cadalog_errtile : column {"
" ok_cancel_help_cadalog;"
" errtile;"
"}"))
(setq #HELP (strcat
"Legend Generator\n\n"
"Allows you to add text descriptions to create a legend for blocks and \n"
"layers. The programs stores descriptions in two files, legend-block.tbl \n"
"and legend-layer.tbl so they can be reused later.\n\n"
"Blocks and layers that are present in the current drawing or in an XREF \n"
"can be used but XREF blocks and linetypes that cannot be found in the \n"
"current drawing table will not display in the legend. Instead, any blocks \n"
"that are not found will have a text marker placed in the legend, and any \n"
"linetypes that are not found will use the CONTINUOUS linetype.\n\n"
"The text for the legend is based on the current setting of the AutoCAD \n"
"TEXTSIZE system variable. Block scales are derived from existing blocks \n"
"used in the drawing.\n\n"
"You can enter different descriptions for blocks and layers in XREFs that \n"
"use the same name as the base drawing but the descriptions from the base \n"
"drawing will take precedence when the legend program writes the two tbl \n"
"files for later use."))
(if (not V:LEGEND_DIR)
(setq V:LEGEND_DIR
(strcat (vl-filename-directory (findfile "legend.lsp")) "\")))
(defun *error* (%A)
(if (= (type V:FILE) 'FILE) (close V:FILE))
(cond
((= %A "Function cancelled") nil)
((and V:FILENAME (= %A "malformed string"))
(princ (strcat "\nerror: check file - " V:FILENAME)))
(t (princ (strcat "\nerror: " %A "\007\n"))))
(princ))
(defun @ALERT0 (%STR)
(if (not #ALERT) (setq #ALERT ""))
(setq #ALERT
(strcat #ALERT "Linetype " %STR " is not loaded - used CONTINUOUS\n")))
(defun @ALERT1 (%STR)
(if (not #ALERT) (setq #ALERT ""))
(setq #ALERT
(strcat #ALERT "Block " %STR " is not loaded - used text w/block name\n")))
(defun @BASE (%A / #POS)
(setq #POS (vl-string-position 124 %A))
(if #POS (substr %A (+ #POS 2)) %A))
(defun @FORMAT (%A / #CHR #COUNT #LEN #STR)
(setq #COUNT 0 #LEN (strlen %A) #STR "")
(repeat #LEN
(setq #COUNT (1+ #COUNT) #CHR (substr %A #COUNT 1))
(if (= #CHR """) (setq #CHR "\\""))
(setq #STR (strcat #STR #CHR)))
(eval #STR))
(defun @DWGLYRS (/ #LINE #LYR #LYRNAME #X1 #X2)
(setq #LYR (tblnext "layer" 1))
(while #LYR
(setq #LYRNAME (strcase (cdr (assoc 2 #LYR))))
(if (setq #LINE (assoc (@BASE #LYRNAME) (cdr TBL:LEGEND-LAYER)))
(setq #LEGEND-LAYER (cons (list #LYRNAME (cadr #LINE) (caddr #LINE)) #LEGEND-LAYER))
(setq #LEGEND-LAYER (cons (list #LYRNAME 0 "") #LEGEND-LAYER)))
(setq #LYR (tblnext "layer")))
(setq #LEGEND-LAYER
(vl-sort #LEGEND-LAYER (function (lambda (#X1 #X2) (< (car #X1) (car #X2)))))))
(defun @DWGBLKS (/ #LINE #BLK #BLKNAME #X1 #X2)
(setq #BLK (tblnext "block" 1))
(while #BLK
(setq #BLKNAME (strcase (cdr (assoc 2 #BLK))))
(cond
((assoc 1 #BLK) nil)
((= (substr (@BASE #BLKNAME) 1 2) "*U") nil)
((setq #LINE (assoc (@BASE #BLKNAME) (cdr TBL:LEGEND-BLOCK)))
(setq #LEGEND-BLOCK (cons (list #BLKNAME (cadr #LINE) (caddr #LINE)) #LEGEND-BLOCK)))
(T (setq #LEGEND-BLOCK (cons (list #BLKNAME 0 "") #LEGEND-BLOCK))))
(setq #BLK (tblnext "block")))
(if #LEGEND-BLOCK (setq #LEGEND-BLOCK
(vl-sort #LEGEND-BLOCK (function (lambda (#X1 #X2) (< (car #X1) (car #X2))))))))
;draw legend
(defun @LEGEND-DRAW (/ #CLAYER #PT0 #PT1 #SCALE #TEXTSIZE #X
@DRAWBLK @DRAWLINE @DRAWTXT @INSERT)
(setvar "cmdecho" 0)
(setq #CLAYER (getvar "clayer")
#TEXTSIZE (getvar "textsize"))
;%A - block name
(defun @DRAWBLK (%BLKNAME / #0 #BLK #DATA #EXIST #LYR #SCALE #SIZE #SS #TMP @SIZE)
(defun @SIZE (%ENT / #MAXP #MINP)
(vla-getboundingbox (vlax-ename->vla-object %ENT) '#MINP '#MAXP)
(setq #MINP (vlax-safearray->list #MINP)
#MAXP (vlax-safearray->list #MAXP))
(- (cadr #MAXP) (cadr #MINP)))
(setq #BLK (@BASE %BLKNAME)
#EXIST (tblsearch "block" #BLK)
#SS (ssget "_X" (list (cons 2 #BLK))))
(if #SS
(setq #0 (ssname #SS 0)
#DATA (entget #0)
#LYR (cdr (assoc 8 #DATA))
#SCALE (cdr (assoc 41 #DATA))))
(cond
((not #EXIST)
(@ALERT1 #BLK)
(@DRAWTXT "m" (polar #PT1 0 (* #TEXTSIZE 6.5)) #BLK)
(@DRAWTXT "ml" (polar #PT1 0 (* #TEXTSIZE 15)) #TEXT)
(setq #PT1 (polar #PT1 (* 1.5 pi) (* #TEXTSIZE 4))))
((and #EXIST (not #0))
(setq #SCALE 1.0 #SIZE #TEXTSIZE #LYR (getvar "celayer"))
(@INSERT #BLK #PT1 #LYR #SCALE))
(#0
(if (not vla-getboundingbox) (vl-load-com))
(setq #SIZE (@SIZE #0))
(if (> #SIZE (setq #TMP (* 3 #TEXTSIZE)))
(setq #PT1 (polar #PT1 (* 1.5 pi) (setq #TMP (* 0.5 (- #SIZE #TMP)))))
(setq #TMP nil))
(@INSERT #BLK #PT1 #LYR #SCALE)
(@DRAWTXT "ml" (polar #PT1 0 (* #TEXTSIZE 15)) #TEXT)
(if #TMP
(setq #PT1 (polar #PT1 (* 1.5 pi) (+ (* #TEXTSIZE 4) #TMP)))
(setq #PT1 (polar #PT1 (* 1.5 pi) (* #TEXTSIZE 4)))))))
(defun @INSERT (%BLK %PT %LYR %SCALE / #CECOLOR #CELTYPE #COLOR #DATA
#LTYPE)
(setq #CECOLOR (getvar "cecolor")
#CELTYPE (getvar "celtype")
#DATA (tblsearch "layer" %LYR)
#COLOR (cdr (assoc 62 #DATA))
#LTYPE (@BASE (cdr (assoc 6 #DATA))))
(if (not (tblsearch "ltype" #LTYPE))
(progn
(@ALERT0 #LTYPE)
(setq #LTYPE "CONTINUOUS")))
(if (= (type #COLOR) 'INT) (setq #COLOR (itoa #COLOR)))
(setvar "cecolor" #COLOR)
(setvar "celtype" #LTYPE)
(command "_.insert" %BLK "_none" (polar %PT 0 (* #TEXTSIZE 6.5)) %SCALE %SCALE 0)
(setvar "cecolor" #CECOLOR)
(setvar "celtype" #CELTYPE))
;draw line
(defun @DRAWLINE (%LYR %PT / #CECOLOR #CELTYPE #COLOR #DATA #LTYPE)
(setq #CECOLOR (getvar "cecolor")
#CELTYPE (getvar "celtype")
#DATA (tblsearch "layer" %LYR)
#COLOR (cdr (assoc 62 #DATA))
#LTYPE (@BASE (cdr (assoc 6 #DATA))))
(if (not (tblsearch "ltype" #LTYPE))
(progn
(@ALERT0 #LTYPE)
(setq #LTYPE "CONTINUOUS")))
(if (= (type #COLOR) 'INT) (setq #COLOR (itoa #COLOR)))
(setvar "cecolor" #COLOR)
(setvar "celtype" #LTYPE)
(command "_.line" "_none" %PT "_none" (polar %PT 0 (* #TEXTSIZE 13)) "")
(setvar "cecolor" #CECOLOR)
(setvar "celtype" #CELTYPE))
;draw text
(defun @DRAWTXT (%JUST %PT %TXT)
(if (= (cdr (assoc 40 (tblsearch "style" (getvar "textstyle")))) 0.0)
(command "_.text" (strcat "_" %JUST) "_none" %PT "" 0 %TXT)
(command "_.text" (strcat "_" %JUST) "_none" %PT 0 %TXT)))
(initget 1)
(setq #PT0 (getpoint "\nLegend insert point: ")
#PT1 (polar #PT0 (* 1.5 pi) (* #TEXTSIZE 4)))
(@DRAWTXT "m" (polar #PT0 0 (* #TEXTSIZE 14)) "LEGEND")
(foreach #X #LEGEND-LAYER
(if (= (cadr #X) 1)
(progn
(if (= (setq #TEXT (caddr #X)) "") (setq #TEXT "???"))
(@DRAWLINE (car #X) #PT1)
(@DRAWTXT "ml" (polar #PT1 0 (* #TEXTSIZE 15)) #TEXT)
(setq #PT1 (polar #PT1 (* 1.5 pi) (* #TEXTSIZE 4))))))
(foreach #X #LEGEND-BLOCK
(if (= (cadr #X) 1)
(progn
(if (= (setq #TEXT (caddr #X)) "") (setq #TEXT "???"))
(@DRAWBLK (car #X))))))
;write legend table
(defun @LEGEND-WRITE-LAYER (%LGND / #BASE #LEGEND2 #X)
(setq #LEGEND2 %LGND
V:FILENAME (strcat V:LEGEND_DIR "legend-layer.tbl")
V:FILE (open V:FILENAME "w"))
(foreach #X (cdr TBL:LEGEND-LAYER)
(if (not (assoc (car #X) #LEGEND2))
(setq #LEGEND2 (append #LEGEND2 (list #X)))))
(write-line ""LAYER" "LEGEND" "DESCP"" V:FILE)
(foreach #X #LEGEND2
(setq #BASE (@BASE (car #X)))
(if (and
(/= (caddr #X) "")
(or (= #BASE (car #X)) (not (assoc #BASE #LEGEND2))))
(write-line
(strcat """ (@BASE (car #X)) "" "
(itoa (cadr #X)) " "" (@FORMAT (caddr #X)) """)
V:FILE)))
(close V:FILE))
(defun @LEGEND-WRITE-BLOCK (%LGND / #BASE #LEGEND2 #X)
(setq #LEGEND2 %LGND
V:FILENAME (strcat V:LEGEND_DIR "legend-block.tbl")
V:FILE (open V:FILENAME "w"))
(foreach #X (cdr TBL:LEGEND-BLOCK)
(if (not (assoc (car #X) #LEGEND2))
(setq #LEGEND2 (append #LEGEND2 (list #X)))))
(write-line ""BLOCK" "LEGEND" "DESCP"" V:FILE)
(foreach #X #LEGEND2
(setq #BASE (@BASE (car #X)))
(if (and
(/= (caddr #X) "")
(or (= #BASE (car #X)) (not (assoc #BASE #LEGEND2))))
(write-line
(strcat """ #BASE "" "
(itoa (cadr #X)) " "" (@FORMAT (caddr #X)) """)
V:FILE)))
(close V:FILE))
;sets table and returns current legend table as a list
(defun @LEGEND-GET-LAYER (/ @TABLE V:FILE V:FILENAME)
(defun @TABLE (/ #A #B #C #FILE)
(setq #A T
#FILE "legend-layer.tbl"
V:FILENAME (findfile #FILE)
V:FILE (open V:FILENAME "r"))
(while #A
(setq #A (read-line V:FILE))
(cond
((and #A (/= (substr #A 1 1) ";")
(setq #C (read (strcat "(" #A ")"))))
(setq #B (cons #C #B)))))
(close V:FILE)
(reverse #B))
(if (findfile "legend-layer.tbl")
(setq TBL:LEGEND-LAYER (@TABLE))
(setq TBL:LEGEND-LAYER (list (list "LAYER" "LEGEND" "DESCP")))))
;sets table and returns current legend table as a list
(defun @LEGEND-GET-BLOCK (/ @TABLE V:FILE V:FILENAME)
(defun @TABLE (/ #A #B #C #FILE)
(setq #A T
#FILE "legend-block.tbl"
V:FILENAME (findfile #FILE)
V:FILE (open V:FILENAME "r"))
(while #A
(setq #A (read-line V:FILE))
(cond
((and #A (/= (substr #A 1 1) ";")
(setq #C (read (strcat "(" #A ")"))))
(setq #B (cons #C #B)))))
(close V:FILE)
(reverse #B))
(if (findfile "legend-block.tbl")
(setq TBL:LEGEND-BLOCK (@TABLE))
(setq TBL:LEGEND-BLOCK (list (list "BLOCK" "LEGEND" "DESCP")))))
(defun @LIST-LAYER (/ #X)
(start_list "layer")
(foreach #X #LEGEND-LAYER
(add_list (strcat (car #X) "\t" (if (= (cadr #X) 1) "X" "")
"\t" (caddr #X))))
(end_list))
(defun @LIST-BLOCK (/ #X)
(start_list "block")
(foreach #X #LEGEND-BLOCK
(add_list (strcat (car #X) "\t" (if (= (cadr #X) 1) "X" "")
"\t" (caddr #X))))
(end_list))
(defun @LAYER (%A %B %C / #CASR #CADDR #CHECK #LINE0 #LINE1)
(setq #LINENO (atoi %A)
#LINE0 (nth #LINENO #LEGEND-LAYER)
#CHECK (cadr #LINE0))
(cond
(%B
(mode_tile "descp-layer" #CHECK)
(setq #CADR (abs (1- #CHECK)) #CADDR (caddr #LINE0)))
(%C
(setq #CADR (cadr #LINE0) #CADDR %C))
(T
(mode_tile "descp-layer" (abs (1- #CHECK)))
(setq #CADR (cadr #LINE0) #CADDR (caddr #LINE0))))
(setq #LINE1
(list (car #LINE0) #CADR #CADDR)
#LEGEND-LAYER (subst #LINE1 #LINE0 #LEGEND-LAYER))
(@LIST-LAYER)
(set_tile "layer" %A)
(set_tile "descp-layer" (caddr (nth #LINENO #LEGEND-LAYER)))
(if (and %A (= #CHECK 0)) (mode_tile "descp-layer" 2)))
(defun @BLOCK (%A %B %C / #CHECK #LINE0 #LINE1)
(setq #LINENO (atoi %A)
#LINE0 (nth #LINENO #LEGEND-BLOCK)
#CHECK (cadr #LINE0))
(cond
(%B
(mode_tile "descp-block" #CHECK)
(setq #CADR (abs (1- #CHECK)) #CADDR (caddr #LINE0)))
(%C
(setq #CADR (cadr #LINE0) #CADDR %C))
(T
(mode_tile "descp-block" (abs (1- #CHECK)))
(setq #CADR (cadr #LINE0) #CADDR (caddr #LINE0))))
(setq #LINE1
(list (car #LINE0) #CADR #CADDR)
#LEGEND-BLOCK (subst #LINE1 #LINE0 #LEGEND-BLOCK))
(@LIST-BLOCK)
(set_tile "block" %A)
(set_tile "descp-block" (caddr (nth #LINENO #LEGEND-BLOCK)))
(if (and %A (= #CHECK 0)) (mode_tile "descp-block" 2)))
(if (not (findfile (setq #DCL-FILE (strcat V:LEGEND_DIR "legend.dcl"))))
(progn
(setq #FILE (open #DCL-FILE "w"))
(foreach #X #DCL-LIST (write-line #X #FILE))
(close #FILE)
(alert #HELP)))
(if (< (setq #DCL-ID (load_dialog "legend")) 0) (quit))
(if (not (new_dialog "legend" #DCL-ID)) (quit))
(@LEGEND-GET-LAYER)
(@LEGEND-GET-BLOCK)
(@DWGLYRS)
(@DWGBLKS)
(@LIST-LAYER)
(@LIST-BLOCK)
(@LAYER "0" nil nil)
(if #LEGEND-BLOCK
(@BLOCK "0" nil nil)
(progn (mode_tile "block" 1) (mode_tile "descp-block" 1)))
(set_tile "layer" "0")
(action_tile "accept" (strcat
"(@LEGEND-WRITE-LAYER #LEGEND-LAYER)"
"(@LEGEND-WRITE-BLOCK #LEGEND-BLOCK)"
"(done_dialog 1)"))
(action_tile "cadalog" "(done_dialog 2)")
(action_tile "descp-layer" "(@LAYER (itoa #LINENO) nil $value)")
(action_tile "descp-block" "(@BLOCK (itoa #LINENO) nil $value)")
(action_tile "help" "(alert #HELP)")
(action_tile "layer" "(@LAYER $value T nil)")
(action_tile "block" "(@BLOCK $value T nil)")
(setq #GO (start_dialog))
(cond
((= #GO 1)
(@LEGEND-DRAW)
(if #ALERT (alert #ALERT)))
((= #GO 2) (command "_.browser" "www.cadalog.com")))
(princ))
**************************************************************************
Legend.dcl
legend : dialog {
key = "title";
label = "Legend Generator";
: boxed_column {
label = "&Layers";
: concatenation {
: text_part {
label = "Name";
width = 19;
}
: text_part {
label = "Legend";
width = 9;
}
: text_part {
label = "Description";
}
}
: list_box {
height = 8;
key = "layer";
tabs = "19 28";
width = 70;
}
: row {
: edit_box {
edit_width = 60;
fixed_width = true;
key = "descp-layer";
label = "&Description:";
}
}
}
: boxed_column {
label = "&Blocks";
: concatenation {
: text_part {
label = "Name";
width = 19;
}
: text_part {
label = "Legend";
width = 9;
}
: text_part {
label = "Description";
}
}
: list_box {
height = 8;
key = "block";
tabs = "19 28";
width = 70;
}
: row {
: edit_box {
edit_width = 60;
fixed_width = true;
key = "descp-block";
label = "&Description:";
}
}
}
ok_cancel_help_cadalog_errtile;
}
cadalog_button : retirement_button {
key = "cadalog";
label = "&CADalog.com...";
}
ok_cancel_help_cadalog : column {
: row {
fixed_width = true;
alignment = centered;
ok_button;
: spacer {
width = 2;
}
cancel_button;
: spacer {
width = 2;
}
help_button;
: spacer {
width = 2;
}
cadalog_button;
}
}
ok_cancel_help_cadalog_errtile : column {
ok_cancel_help_cadalog;
errtile;
}