www.pudn.com > CADtool.rar > sprayer.lsp, change:2009-12-06,size:9229b


;;;喷雾器,功能:在指定区域随机生成短线,模拟photoshop中的喷雾功能。 
;;;----------------------------------------------------------------------------- 
(defun c:sprayer 
                 (/                       floatRangeWidth ;单次生成对象的区域长及宽 
                  intSingleMakeEntityNumber ;每次生成的对象个数 
                  floatLineLength ;每段线的长度 
               ;   floatLineWidth ;每段线的宽度 
                  intTargetColor ;生成对象的颜色 
                  strTargetLayerName ;对象所在图层 
                  listExistedtLayerNames ;所有图层名称列表 
                  intDialogCloseType ;对话框的关闭类型,与done_dialog返回值相等 
                  dcl_id ;窗口id 
                  ;;以上所有变量均为程序的全局控制变量 
                 ) 
;;;----------------------------------------------------------------------------- 
;;;根据相应列表值,重新设置对话框中listbox/popuplist显示值 
;;;调用形式 ( 显示的内容列表 对话框中listbox/popuplist组件的名称 ) 
 (defun ListToPoPupList (listName strDCLPoPupListName) 
  (start_list strDCLPoPupListName 3 0) 
  (mapcar 'add_list listName) 
  (end_list) 
 ) 
;;;----------------------------------------------------------------------------- 
;;;搜索已有图层并加入到DCL中相应的List 
 (defun GetExistedLayerNames (/ LayerName LayerDXF) 
  (setq LayerDXF (tblnext "LAYER" T) 
        listExistedtLayerNames 
        nil 
  ) 
  (while LayerDXF 
   (setq LayerName (cdr (assoc 2 LayerDXF))) 
   ;;往表中加入已有图层名列表 
   (if (/= LayerName "") 
    (setq listExistedtLayerNames 
          (append listExistedtLayerNames 
                  (list LayerName) 
          ) 
    ) 
   ) 
   (setq LayerDXF (tblnext "LAYER")) 
  ) 
 
  (ListToPoPupList 
   listExistedtLayerNames 
   "plExistedlLayerNames" 
  ) 
 ) 
;;;----------------------------------------------------------------------------- 
;;;创建程序界面时,对大部分主要控制变量及界面进行初始化 
 (defun FormMainOnCreat () 
  (setq intDialogCloseType 0 ) 
 
  (GetExistedLayerNames) ;查询所有图层名并反映到界面中相关的组件值 
  (set_tile "plExistedlLayerNames" "0") 
  (setq strTargetLayerName (car listExistedtLayerNames)) 
          ;默认生成对象所在图层名为图层列表的第一个图层名 
 ) 
;;;----------------------------------------------------------------------------- 
;;;获取对话话上用户的输入 
 (defun GetDCLTiles (/ tmpFloat) 
  (setq tmpFloat (atof (get_tile "edfloatRangeWidth"))) 
  (if (and tmpFloat (> tmpFloat 0)) 
   (setq floatRangeWidth tmpFloat) 
   (setq floatRangeWidth 5) 
  ) 
  ;;获取用户输入的控制单次生成对象的区域长及宽,当输入错误时,取值为5 
 
  (setq tmpFloat (atoi (get_tile "edintSingleMakeEntityNumber"))) 
  (if (and tmpFloat (> tmpFloat 0)) 
   (setq intSingleMakeEntityNumber tmpFloat) 
   (setq intSingleMakeEntityNumber 50) 
  ) 
  ;;获取用户输入的每次生成的对象个数,当输入错误时,取值为50 
 
  (setq tmpFloat (atof (get_tile "edfloatLineLength"))) 
  (if (and tmpFloat (> tmpFloat 0)) 
   (setq floatLineLength tmpFloat) 
   (setq floatLineLength 0.2) 
  ) 
  ;;获取用户输入的每段线的长度,当输入错误时,取值为0.2 
 
;  (setq tmpFloat (atof (get_tile "edfloatLineWidth"))) 
 ; (if (and tmpFloat (> tmpFloat 0)) 
;   (setq floatLineWidth tmpFloat) 
 ;  (setq floatLineWidth 0.2) 
 ; ) 
  ;;获取用户输入的每段线的宽度,当输入错误时,取值为0.2 
 
  (setq tmpFloat (atoi (get_tile "edintTargetColor"))) 
  (if (and tmpFloat (> 256 tmpFloat 0)) 
   (setq intTargetColor tmpFloat) 
   (setq intTargetColor 256) 
  ) 
  ;;获取用户输入的每段线的宽度,当输入错误时,取值为256,即随层   
 ) 
;;;----------------------------------------------------------------------------- 
;;;点选颜色面板时 
 (defun ColorPaletteClick (intKeyValue) 
  (set_tile "edintTargetColor" (itoa intKeyValue)) 
 ) 
;;;----------------------------------------------------------------------------- 
;;;点选图层列表时 
 (defun plExistedlLayerNamesClick (strValue) 
  (setq strTargetLayerName 
        (nth (atoi strValue) listExistedtLayerNames) 
  ) 
 ) 
;;;----------------------------------------------------------------------------- 
;;;新建图层,重新搜索所有图层名,并添加到界面 
(defun LayerNewClick ( / strLayerName ) 
  (setq strLayerName 
        (car (InputBox "新建图层" 
                       (list (list "输入新建图层的名称:" "喷雾"  "20")) 
             ) 
        ) 
  ) 
   
  (if strLayerName     
     (if (member strLayerName listExistedtLayerNames) 
      (alert "已经存在同名图层!") 
       
      (progn 
       ;; 建立新的图层 
       (vla-add (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))) strLayerName) 
       (FormMainOnCreat)                
       )      
      ) 
     ) 
) 
;;;----------------------------------------------------------------------------- 
;;; 求随机数(-1~1) 
 (defun random () 
 ; (* (rem (getvar "cputicks") 1e3) 1e-3) 
 (sin (rem (getvar "cputicks") 1e3)) 
 ) 
;;;----------------------------------------------------------------------------- 
;;;动态、随机生成短线,模拟喷雾效果 
 (defun Main (/            kw           i ;控制循环变量 
              tmp          tmppt        TempPLineName             floatHalfRangeWidth ;临时变量 
              x0           y0           x1           x2           y1           y2           ptList 
          ;用于记录填充区域四角坐标 
              listStartPoint            listEndPoint ;填充对象的起终点坐标 
              floatLineX   floatLineY ;填充线的x,y                 
             ) 
;;;------------------------------------------------------------- 
;;;若已绘临时多义线,则删除 
  (defun ClearTempLine () 
   (if TempPLineName 
    (progn 
     (entdel TempPLineName) 
     (setq TempPLineName nil) 
    ) 
   ) 
  ) 
;;;------------------------------------------------------------- 
;;;出错时清除临时内容 
  (defun *error* (msg) 
   (ClearTempLine) 
   (EndUndoGroup) 
   (setvar "osmode" 431) 
   (princ) 
  ) 
;;;------------------------------------------------------------- 
  (setq TempPLineName nil) ;变量初始化 
  (BeginUndoGroup) 
   
  (setq kw t) 
  (while kw 
   (setq tmp (grread t 4 1)) 
   (cond 
    ((= (car tmp) 5) ;移动了光标,动态绘箭头 
     (setq tmppt (cadr tmp)) 
 
     (setq x0                  (car tmppt) 
           y0                  (cadr tmppt) 
           floatHalfRangeWidth (* floatRangeWidth 0.5) 
     ) 
 
     (setq x1 (- x0 floatHalfRangeWidth) 
           x2 (+ x0 floatHalfRangeWidth) 
           y1 (- y0 floatHalfRangeWidth) 
           y2 (+ y0 floatHalfRangeWidth) 
     ) 
     ;;计算填充区域的四个角点坐标 
     (setq ptList (list (list x1 y1) (list x2 y1) (list x2 y2) (list x1 y2))) 
     ;;以上计算并生成箭头多段线的顶点坐标表 
 
     (if TempPLineName 
      (ClearTempLine) 
     ) 
 
     (setvar "osmode" 0) 
     (command "pline") 
     (foreach i ptList 
      (command i) 
     ) 
     (command (nth 0 ptList) "") 
 
     (setq TempPLineName (entlast)) 
    ) 
 
    ((= (car tmp) 3) ;按下了鼠标左键,绘箭头 
     (repeat intSingleMakeEntityNumber 
      (setq tmppt (cadr tmp)) ;当前鼠标的坐标 
 
      (setq x0                  (car tmppt) 
            y0                  (cadr tmppt) 
            floatHalfRangeWidth (* floatRangeWidth 0.5) 
      ) 
 
      (setq floatLineX (+ x0  
                          (* (random) floatHalfRangeWidth) 
                       ) 
      ) 
      (setq floatLineY (+ y0 
                          (* (random) floatHalfRangeWidth) 
                       ) 
      ) 
      (setq listStartPoint (list floatLineX floatLineY)) 
      ;;计算短线起点坐标 
 
      (setq floatLineX (+ floatLineX floatLineLength)) 
      (setq listEndPoint (list floatLineX floatLineY)) 
      ;;计算短线终点坐标 
      (entmake (list '(0 . "LINE") 
                     (cons 8 strTargetLayerName) 
                     (cons 62 intTargetColor) 
                     (cons 10 listStartPoint) 
                     (cons 11 listEndPoint) 
               ) 
      )   ;生成短线       
     ) 
    ) 
 
    (T    ;其它情况,退出程序 
     (ClearTempLine) 
     (setq kw nil) 
    ) 
   ) 
  ) 
 
  (setvar "osmode" 431) 
  (EndUndoGroup) 
  (princ) 
 ) 
;;;----------------------------------------------------------------------------- 
;;;主函数内容,设置、调用DCL 
 (if (setq dcl_id (load_dialog "sprayer.dcl")) 
  (if (new_dialog "sprayer" dcl_id) 
   (progn 
    (action_tile "plColorNames" "(plColorNamesClick $value)") 
    (action_tile "001" "(ColorPaletteClick 1)") 
    (action_tile "002" "(ColorPaletteClick 2)") 
 
    (action_tile "003" "(ColorPaletteClick 3)") 
    (action_tile "004" "(ColorPaletteClick 4)") 
 
    (action_tile "005" "(ColorPaletteClick 5)") 
    (action_tile "006" "(ColorPaletteClick 6)") 
    (action_tile "007" "(ColorPaletteClick 7)") 
 
    (action_tile 
     "plExistedlLayerNames" 
     "(plExistedlLayerNamesClick $value)" 
    ) 
    (action_tile "btLayerNew" "(LayerNewClick)") 
     
    (action_tile "accept" "(GetDCLTiles) (done_dialog 1) ") 
 
    (FormMainOnCreat) 
 
    (setq intDialogCloseType (start_dialog)) 
    (unload_dialog dcl_id) 
 
    (if (= intDialogCloseType 1) 
     (Main) 
    ) 
   ) 
 
   (princ "无法创建对话框!") 
  ) 
 
  (princ "对话框定义文件有错!") 
 ) 
 (princ) 
) 
;;;-----------------------------------------------------------------------------