[轉貼]：材料表計算

(DEFUN C:clb()
(PRINT "http://p4.xdcad.net/forum/showthread.php?s=&threadid=81603")
(PRINT "BY sdlp")
(PRINT "材料表計算")
(setq v1 (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "units" 2 1 "" "" "" "") 
(PROMPT "請選擇需改動的數字")
(setq s1 (ssget '((0 . "text")) ))
(setq n (sslength s1))
(SETQ SS (GETREAL "1:倍數,2:求總和,3:加和,4:條件加和,5:列相乘" ))
(WHILE (= SS 1) 
 (CHT1 S1 N)
 (SETQ SS 7)
)
(WHILE (= SS 2) 
 (CHT2 S1 N)
 (SETQ SS 7)
)
(WHILE (= SS 3) 
 (CHT3 S1 N)
 (SETQ SS 7)
)
(WHILE (= SS 4) 
 (CHT4 S1 N)
 (SETQ SS 7)
)
(WHILE (= SS 5) 
 (CHT5 S1 N)
 (SETQ SS 7)
)
(setvar "cmdecho" v1)
)

 

(defun CHT1(S1, N)
(setq wid1 (getreal "請輸入文字的倍數: " )) 
(setq i 0)
(repeat n
 (setq e (entget (ssname s1 i )))
 (setq tt1 (cdr (assoc 1 e)))
 (setq tt2 (atof tt1))
 (setq tt3 (* tt2 wid1))

 

 (setq tt4  tt3)
 (setq tt5 (RTOS tt4))
 (setq t5 (cons 1 tt5))
 (setq e1 (subst t5 (assoc 1 e) e))
 (entmod e1)
 (setq i (+ i 1))
)
)

 

 

 

(defun CHT2(S1, N)
;;(setq wid1 (getreal "請輸入文字的倍數: " )) 
(setq i 0)
(SETQ SS 0.00)
(repeat n
 (setq e (entget (ssname s1 i )))
 (setq tt1 (cdr (assoc 1 e)))
 (setq tt2 (atof tt1))
 (SETQ SS (+ SS TT2))
 (setq i (+ i 1))
)
(PRINT SS)
)

 

(defun CHT3(S1, N)
(setq wid1 (getreal "請輸入文字的加數: " )) 
(setq i 0)
(repeat n
 (setq e (entget (ssname s1 i )))
 (setq tt1 (cdr (assoc 1 e)))
 (setq tt2 (atof tt1))
 (setq tt3 (+ tt2 wid1))
 (setq tt4 (FIX tt3))
 (setq tt5 (itoa tt4))
 (setq t5 (cons 1 tt5))
 (setq e1 (subst t5 (assoc 1 e) e))
 (entmod e1)
 (setq i (+ i 1))
)
)

 

(defun CHT4(S1, N)
(setq wid1 (getreal "請輸入數字的加數: " ))
(setq wid2 (getreal "請輸入數字的起始數: " )) 
(setq i 0)
(repeat n
 (setq e (entget (ssname s1 i )))
 (setq tt1 (cdr (assoc 1 e)))
 (setq tt2 (atof tt1))
 (WHILE (>= TT2 35)
 (setq tt3 (+ tt2 wid1))
 (setq tt4 (FIX tt3))
 (setq tt5 (itoa tt4))
 (setq t5 (cons 1 tt5))
 (setq e1 (subst t5 (assoc 1 e) e))
 (entmod e1)
 (SETQ TT2 19)
 )
 (setq i (+ i 1))
)
)

 

 

 

(defun CHT5(S1, N)
;;(command "units" 2 1 "" "" "" "")
(PROMPT "請選擇需被乘的一列數字")
(setq s2 (ssget '((0 . "text")) )) 
(setq i 0)
(repeat n
 (setq e (entget (ssname s1 i )))
 (setq tt1 (cdr (assoc 1 e)))
 (setq tt2 (atof tt1))
 (setq xx1 (assoc 10 e))
 (setq xy1  (caddr xx1))
 (setq xx1  (cadr xx1))

 

(setq j 0)
(setq liang 1e1000)
(setq deltx 1e1000)
(setq delty 1e1000)
(repeat n
 (setq ee (entget (ssname s2 j )))
 (setq xy (assoc 10 ee))
 (setq xy2  (caddr xy))
 (setq xx2 (cadr xy))
(while (< (abs (- xy2 xy1)) delty)
 (setq delty (abs (- xy2 xy1)))
 (setq liang (ATOF (cdr (assoc 1 ee))))
 (setq deltx (abs (- xx1 xx2)))
 (setq xy2 (+ delty  xy1))
 )
(setq j (+ j 1))
)

 

 (setq tt3 (* tt2 liang))
 (setq tt4  tt3)
 (setq tt5 (rtos tt4))
 (setq t5 (cons 1 tt5))
 (setq e (subst t5 (assoc 1 e) e))
 (setq xx1 (+ (* 2 deltx) xx1))
 (setq xy1 (caddr (assoc 10 e)) )
 (setq xy (list 10 xx1 xy1 0 ))
 (setq e2 (subst xy (assoc 10 e) e))
 (entmake e2)
 (setq i (+ i 1))
)
)

 

(PRINT "執行命令: clb")

[轉貼]：DSX AutoLayer

;;*********************************************************
;;;*********************************************************
(vl-load-com)
(defun get-item (collection item / result)
(cond
((not
(vl-catch-all-error-p
(setq result
(vl-catch-all-apply 'vla-item (list collection item))
)
)
)
result
)
)
)
(setq oAcad (vlax-get-acad-object) ; acadapplication object
oDoc (vla-get-activedocument oAcad) ; activedocument object
oLay (vla-get-layers oDoc) ; layers collection of activedocument
)
(defun rCmdLayer (reactor data / cmd)
(setq cmd (strcase (car data))) ; get command name
(cond
((wcmatch cmd "*HATCH") ;is the command "*hatch"?
(rCmdLayer-Setlayer "HATCH")
)
)
)
(defun rCmdLayer-SetLayer (name / lay)
(cond
((setq lay (get-item oLay name))
(if (= :vlax-True (vla-get-lock lay))
(progn
(setq $laylock :vlax-True)
(vla-put-lock lay :vlax-False)
)
)
(if (= :vlax-False
(vla-get-layeron lay)
(progn
(setq $layon :vlax-false)
(vla-put-layeron lay :vlax-true)
)
)
(if (= :vlax-True (vla-get-Freeze lay))
(progn
(setq $layfrz :vlax-true)
(vla-put-Freeze layobj :vlax-false)
)
)
(vla-put-activelayer aDoc lay)
)
)
)
)
(defun rCmdLayer-Restore (reactor data / data lay)
(setq cmd (strcase (car data))) ; get command name
)
;;;upon completion of command restores *layers* to previous state
(defun al:restore (reactor info / cmd layobj)
(setq cmd (car info))
(if
(and
*capslock*
(or
(wcmatch (strcase cmd)
"*LEADER,*QLEADER,*MTEXT,*TEXT,*DDEDIT,*ATTEDIT"
)
(and
(wcmatch
(strcase cmd)
"*DIM,*DIMLINEAR,*DIMALIGNED,*DIMORDINATE,*DIMRADIUS,*DIMDIAMETER,*DIMANGULAR,*DIMBASELINE,*DIMCONTINUE,*QDIM,*LEADER,*QLEADER,*MTEXT,*TEXT,*DDEDIT"
)
(= (vlax-variant-value (vla-getvariable *adocobj* "dimaso"))
0
)
)
)
)
(dos_capslock)
)
(if (< (vlax-variant-value (vla-getvariable *adocobj* "cmdactive"))
2
) ;test for transparent commands
(progn
(setq layobj (vla-get-ActiveLayer *adocobj*))
;get ActiveLayer object
(if offlay ; "hidden" layer noted as off (offlay not nil)
(vlax-put-property
(vla-item *layers*
(if (wcmatch (strcase (car info)) "*HATCH")
"Hidden"
"Hatch"
)
)
"LayerOn"
1
) ;turn "hidden" layer back on
) ;end if
(if
(and
clobj ; clayer objobject assigned to clobj in al:laystate (clobj not nil)
(not (equal clobj layobj)) ;if clayer object (clobj set in al:laystate) layer object
) ;end and
(vla-put-ActiveLayer *adocobj* clobj) ;sets layer current
) ;end if
(if layoff ; if the layer (layoff set in al:laystate) was noted as off (layoff not nil)
(vla-put-LayerOn layoff 0) ;turn it off again
) ;end if
(if layfreeze ; if layer (layfreeze set in al:laystate) was frozen (layfreeze not nil)
(vla-put-Freeze layfreeze 1) ;freeze it again
) ;end if
(if laylock ; if layer (laylock set in al:laystate) was locked (laylock not nil)
(vla-put-Lock laylock 1) ;Lock it again
) ;end if
(setq clobj nil
offlay nil
layoff nil
layfreeze nil
laylock nil
) ;set global variables to nil
) ;end progn
) ;end if
) ;end defun

;;;======================================================================
;;;disables commandEnded reactor to avoid errors when using "new" and "open"
;;;in SDI mode. The error is merely annoying and only appears at the command
;;;line as "error: no function definition: al:restore" when opening or creating
;;;a new drawing. The cause of the error is commandEnded reactor present form
;;;last dwg but LISP has not yet loaded the called function in a new or opened
;;;dwg. Furthermore, the reactor cannot be removed because it has already been
;;;activated and is waiting for the command to end. Therefore, the reactor must
;;;be rendered non-functional by changing its call to the LISP command "LIST".
(defun al:disable (reactor info / tdat)
(if
(= (vlax-variant-value (vla-getvariable *adocobj* "sdi")) 1)
;in SDI mode?
(vlr-reaction-set
(car (vlr-object
'(VLR-Command-reactor
nil
'((:VLR-commandWillStart . al:autolay)
(:VLR-commandEnded . al:restore)
(:VLR-commandCancelled . al:restore)
)
)
)
)
:VLR-commandEnded
'list
)
) ;end if
) ;end defun

;;;======================================================================
;;;Here's where we set up the reactors to do all this cool stuff
(vlr-set-notification
(vlr-manager
'(VLR-DWG-reactor nil '((:VLR-beginClose . al:disable)))
3
)
'active-document-only
)
(vlr-set-notification
(vlr-manager
'(VLR-Command-reactor
nil
'((:VLR-commandWillStart . al:autolay)
(:VLR-commandEnded . al:restore)
(:VLR-commandCancelled . al:restore)
)
)
3
)
'active-document-only
)


;;;======================================================================
;;;get rid of old reactor if present. The reactor will be present, because in
;;;SDI mode, it's associated namespace is not destroyed, but has the new drawing
;;;loaded into it. At the time this file is loaded, this reactor is either not
;;;present or has been rendered useless (in SDI mode) at the closing of the last
;;;dwg and is excess loaded code bulk and should be removed. The VLR-MANAGER
;;;provides an easy means of doing this.
(vlr-manager
'(VLR-Command-reactor
nil
'((:VLR-commandWillStart . al:autolay)
(:VLR-commandEnded . list)
(:VLR-commandCancelled . al:restore)
)
)
1
)
;;;======================================================================
(princ
"\nAutoLay V2.2 loaded. Type \"autolay\" or \"capslock\" to enable/disable."
)
(princ)

;;;======================================================================
;
Set up and installation instructions:
This is kind of an outline of the things you may need to edit to make this program work with your companies drafting standards.

The main body of autolay has the conditions that must be tested for to see if a layer needs to be switched to or created. It is also
where the layer name comes from. (al:laystate "Hatch" cmd) is the first such command (noted as cond 1) in the code to create or
switch to a layer, where "Hatch" is to be the actual name of the layer to be created. The conditions will probably be the most
difficult part to adapt to your companies drafting standards. Lets take a look at cond 6 for example:

(;cond 5
(wcmatch cmd "*TEXT");are you creating text?
(al:laystate "Text" cmd);make, thaw, turn on and make current "Text" layer as needed
);end cond 5

If the command (cmd) is "*text", then create or switch to a layer named "Text". You can have as many conds and *layers* as you
need. You can also add other parameters such as text style and/or size in different CONDS to put different text styles or sizes
on different *layers*. That would then look more like:

(;cond 6
(and
(wcmatch cmd "*TEXT");are you creating text?
(wcmatch tst "~SIMPLEX");is the current text style NOT "Simplex"*
(= tsz (* (getvar "dimscale") 0.0625));is this the current text size?
);end and
(al:laystate "Text" cmd);make, thaw, turn on and make current "Text" layer as needed
);end cond 6

The routine al:ltype is the one that decides what linetype is assigned to a layer (name). Similar is true for al:lweight and al:color.
Edit these to suit your companies drafting standards.

One more thing. If you use a different linetype source file (.lin file format) other than acad.lin or acadiso.lin, you will
have to edit in the name of the linetype file name in the al:mkLay routine.

To disable AutoLay[2.2].lsp, type "autolay" at the commond prompt.

This should be enough to get you going. Pick away, play around with it and learn from it until you get it to do what you want. I
already did the hard part of coding and testing.

Best Regards
Eric Schneider;

轉貼:http://publishblog.blogchina.com/blog/tb.b?diaryID=5753822

[轉貼]：兩個矢量的點積

 

;; ! Function : Computes the dot products of two vectors
;; !
;; ! Arguments: 'v1' - First vector
;; !            'v2' - Second Vector
;; !
;; ! Returns  : 'scl'  - The dot product of the two vectors which is a scalar
;; !                     value
;; ! Theory:    Say you have two vectors
;; !            A= ax i +  ay j + az k
;; !            B= bx i +  by j + bz k
;; !
;; ! then A . B = ax.bx + ay.by + az.bz
;; ! (C) 1999-2004, Four Dimension Technologies, Bangalore
;; ! e-mail   : rakesh.rao@4d-technologies.com
;; ! Web      : www.4d-technologies.com
;; ! ****************************************************************************
;; 兩個矢量的點積
(defun GE_VecDotProduct (v1 v2)
  (apply '+ (mapcar '* v1 v2))
)

 

[轉貼]：兩個矢量的點積

http://publishblog.blogchina.com/blog/tb.b?diaryID=5754891

張貼和修改

可以在張貼時使用快速鍵嗎？
Blogger 提供幾個用來編輯文章的快速鍵。
它們一定可以在 Internet Explorer 5.5+/Windows 和 Mozilla 系列
(1.6+ 及 Firefox0.9+) 上使用，而其他瀏覽器可能也適用。 這些快速鍵包括：

Ctrl + B = 粗體
Ctrl + I = 斜體
Ctrl + l = 引用文字 (Blockquote，僅限 HTML 模式)
Ctrl + Z = 復原
Ctrl + Y = 取消復原
Ctrl + Shift + A = 連結
Ctrl + Shift + P = 預覽
Ctrl + D = 儲存為草稿
Ctrl + S = 發佈文章

精采網址

Windows工具箱
http://www.wells.hk/ws_toolsneg.php

微軟-搜尋知識庫
http://support.microsoft.com/search/default.aspx?query=%E6%A9%8B%E6%8E%A5%E5%99%A8&catalog=LCID%3D1028&spi

d=&amp;qryWt=&mode=r&cus=False&x=6&y=9

BT之家-BT文化
http://bbs.btbbt.com/

線上檔存儲，擁有25G免費線上空間
http://amd.streamload.com/

免費上傳空間網址:
http://up-file.com/index.php
http://www.rapidupload.com/
http://shareit.ws/?page=upload
http://www.badongo.com/application/windows

[60G,只能上傳圖檔類型]
http://picsplace.to/upload.php
http://sv1.letmehost.com/

verycd互聯網
http://www.verycd.com/

貪婪大陸
http://share.greedland.net/cache_html/2/seeds/DESC/1.htm
http://share.greedland.net/cache_html/0/seeds/DESC/1.htm