 |
|
Exchange Forum >
AutoLISP and Visual LISP
Useful AutoLISP functions |
|
|
|
|
|
| Useful AutoLISP functions |
#31 |
|
|
s.wickel |
 |
|
Join Date: |
|
06-24-2008 | |
Searching in Google from ACAD:
Code:
;|Googlehupf - Suchen bei Google.de
-------------------------------------------------------------------------------
startet die Suche von Google.de
mit den eingegebenen Suchbegriffen oder öffnet Google wenn keine Suchbegriffe eingegeben wurden.
-------------------------------------------------------------------------------
Copyright (C) 2006 Markus Hoffmann
www.CADmaro.de
-------------------------------------------------------------------------------
FREEWARE:
Dieser Quellcode darf unbegrenzt und für jeden Zweck verwendet werden sofern
keine Gebühr erhoben wird. Der Quellcode darf weiterhin nach eigenen
Bedürfnissen anpasst, verbessert, kopiert und weitergegeben werden. Der
Urheberrechtshinweis darf nicht entfernt werden.
-------------------------------------------------------------------------------
|;
(defun C:Googlehupf (/ echo such suchliste)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(if (/= ""
(car (setq suchliste
(list
(getstring
"\nSuchbegriff eingeben oder [RETURN] um Google aufzurufen: "
)
)
)
)
)
(progn
(while
(/= ""
(setq such
(getstring
"\nweitere Suchbegriffe eingeben oder [RETURN] zum Beenden: "
)
)
)
(setq suchliste (cons such suchliste))
)
(Browse&Find
"http://www.google.de/search?hl=de&q"
(reverse suchliste)
"&btnG=Google-Suche&meta="
)
)
(startapp (GetBrowser)
"http://www.google.de"
)
)
(setvar "CMDECHO" echo)
)
(defun Browse&Find (url suchliste suf / suchtxt)
(foreach x suchliste
(setq suchtxt
(strcat (if suchtxt
(strcat suchtxt "+")
""
)
x
)
)
)
(startapp (GetBrowser) (strcat url suchtxt suf))
)
(defun GetBrowser (/ str)
(substr (setq str (vl-registry-read
"HKEY_CLASSES_ROOT\\htmlfile\\shell\\open\\command"
)
)
2
(1- (vl-string-search "\" " str))
)
)
(princ
"\n\"Googlehupf.lsp\" geladen. Zum Starten \"Googlehupf\" eingeben."
)
(princ)
This function searches in German. Try to Change it to your favourite language.
Seen first at: http://ww3.cad.de/foren/ubb/Forum54/HTML/008415.shtml#000017
Nice searching, Stefan
| |
|
| Useful AutoLISP functions |
#32 |
|
|
ASMI |
 |
|
Join Date: |
|
07-03-2008 | |
Set or renew list of global variables:
Code:
;;; *
;;; Sets list of user variables *
;;; *
;;; Arguments: *
;;; Renew - If NIL sets only new variables, if T sets new and renew *
;;; old variables valies *
;;; *
;;; *
;;; Var_Lst - list of variables name and values *
;;; (list '(var1 val1) ... '(varN valN)) *
;;; Output: *
;;; None *
;;; *
(defun #Asmi_Var_Set(Renew Var_Lst)
(foreach #i Var_Lst
(if Renew
(set(car #i)(eval(cadr #i)))
(if(not(eval(car #i)))
(set(car #i)(eval(cadr #i)))
); end if
); end if
); end foreach
(princ)
); end of #Asmi_Var_Set
I use it to fill initial values of OpenDCL dialogs by global variables to use it next session.
| |
|
| Useful AutoLISP functions |
#33 |
|
|
ASMI |
|
|
|
Join Date: |
|
07-03-2008 | |
Hard drive serial:
Code:
;;; *
;;; Retrieves Hard Drive serial number *
;;; *
;;; Arguments: *
;;; Path - Path of Hard Drive, for example "C:" (string) *
;;; *
;;; Output: *
;;; Hard Drive serial number (integer) or NIL in case of error. *
;;; *
(defun #Asmi_Get_Drive_Serial(Path / fsObj hSn abPth cDrv)
(vl-load-com)
(if
(and
(setq fsObj(vlax-create-object "Scripting.FileSystemObject"))
(not
(vl-catch-all-error-p
(setq abPth(vl-catch-all-apply 'vlax-invoke-method
(list fsObj 'GetAbsolutePathName Path))
); end setq
); end vl-catch-all-error-p
); end not
); end and
(progn
(setq cDrv(vlax-invoke-method fsObj 'GetDrive
(vlax-invoke-method fsObj 'GetDriveName abPth
); end vlax-invoke-method
);end vlax-invoke-method
); end setq
(if
(vl-catch-all-error-p
(setq hSn(vl-catch-all-apply 'vlax-get-property
(list cDrv 'SerialNumber))))
(progn
(vlax-release-object cDrv)
(setq hSn nil)
); end progn
); end if
(vlax-release-object fsObj)
); end progn
); end if
hSn
); end of #Asmi_Get_Drive_Serial
| |
|
| Useful AutoLISP functions |
#34 |
|
|
ASMI |
|
|
|
Join Date: |
|
07-03-2008 | |
Extracts single or all DXF-group value(s) with given code.
Code:
;;; *
;;; Retrievs single or all DXF-group value with corresponding Code *
;;; *
;;; Arguments: *
;;; Entity - Entity or list '(Entity (Point)) *
;;; Code - DXF-Code *
;;; All - If NIL first DXF code extracts, if T list of all *
;;; corresponding codes extracts *
;;; *
;;; Output: *
;;; Single (first) DXF-group value if argument All=NIL *
;;; List of DXF-group(s) values if argument All=T *
;;; NIL if such DXF-group(s) missed *
;;; *
(defun #Asmi_Get_DXF_Value(Entity Code All)
(if(= 'LIST(type Entity))
(setq Entity(car Entity))
); end if
(if All
(mapcar 'cdr
(vl-remove-if
(function
(lambda(x)(/= Code(car x))))
(entget Entity)))
(cdr(assoc Code(entget Entity)))
); end if
); end of #Asmi_Get_DXF_Value
| |
|
| Useful AutoLISP functions |
#35 |
|
|
Alumni |
 |
|
Join Date: |
|
08-22-2008 | |
I really like this thread. I've added several new functions from this thread to my own library of AutoLISP functions. Here's one that I'd like to share that I found on my computer that I downloaded somewhere. I first posted it in another thread, but I think it really belongs here.
It returns the midpoint between two points.
Code:
(defun midpt (p1 p2 / a b)
(mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2)
)
| |
|
| Useful AutoLISP functions |
#36 |
|
|
Terry Cadd |
 |
|
Join Date: |
|
09-10-2007 | |
Hi Alumni,
Your MidPt function got me thinking about how to improve on one of my functions. I use the polar function a lot to locate one point relative to another. Sometimes it's easier to use the polar function twice if you know the X and Y difference between the starting point instead of adding in the math every time. I wrote Coords to save time with less code.
As you are entering in the arguments for Horizontal and Vertical, think about the starting point Pt as if were 0,0. Right from 0,0 is a positive distance. Left from 0,0 would be a negative distance. Up from 0,0 would be a positive distance. Down from 0,0 would be a negative distance.
Terry Cadd
Code:
;-------------------------------------------------------------------------------
; Coords - Returns new point relative to starting point Pt
; Arguments: 3
; Pt = Starting point
; Horizontal = Positive distance for right, or negative distance for left
; Vertical = Positive distance for up, or negative distance for down
; Syntax Example: (setq Pt2 (Coords Pt1 (- DistX) DistY))
; = From Pt1 left DistX and up DistY
;-------------------------------------------------------------------------------
(defun Coords (Pt Horizontal Vertical)
(list (+ (car Pt) Horizontal) (+ (cadr Pt) Vertical))
);defun Coords
| |
|
| Useful AutoLISP functions |
#37 |
|
|
alanjt |
 |
|
Join Date: |
|
04-05-2008 | |
Terry, that's awesome. I was coding something the other day that would place text, this would have been perfect. I went about it in such a backwards way. I will def. be borrowing this and rewriting that portion of the code.
Here's a sub that will get the project path for land desktop drawings.
Code:
;get project path for Land Desktop
;example: (setq project_path (AT:ProjectPath))
;returns: "X:\\Land Projects Folder\\Active Project Name\\"
(defun AT:ProjectPath ( / *aeccApp* *aeccProj*)
(defun GetProperty (lst / result returnProperty)
(and (setq result (vl-catch-all-apply 'vlax-get-property lst))
(or (not (vl-catch-all-error-p result))
(prompt (vl-catch-all-error-message result))
); or
(setq returnProperty result)
); and
returnProperty
); defun
(setq *aeccApp* (vl-catch-all-apply
'vla-getinterfaceobject
(list (vlax-get-acad-object) "aecc.application.7");;LDD2008 (prior to 2004 = 2, 2004-2006 =4, 2007 = 6, 2008 = 7)
) ;_ end of vl-catch-all-apply
)
(setq *aeccProj* (GetProperty (list *aeccApp* "ActiveProject")))
(strcat (vlax-get *aeccProj* "Path") "\\" (vlax-get *aeccProj* "Name") "\\")
)
I wish I could figure out how to set the project, so I could:
(if (equal AT:ProjectPath nil) (SetProject "any existing project name"))
| |
|
| Useful AutoLISP functions |
#38 |
|
|
Terry Cadd |
|
|
|
Join Date: |
|
09-10-2007 | |
alanjt,
Thanks for the compliment for my Coords function. I can't believe I hadn't thought of this idea before. It's such an easy method to use and understand. I just wrote it, and now I'm using it every chance it applies.
Here's a 3D version for those who might want to try it out. The syntax is very much the same as the Coords function. I just changed the argument names to X, Y, and Z.
Code:
;-------------------------------------------------------------------------------
; Coords3D - Returns new 3D point relative to starting 3D point Pt
; Arguments: 4
; Pt = Starting 3D point
; X = Positive distance for right, or negative distance for left
; Y = Positive distance for up, or negative distance for down
; Z = Positive distance for higher, or negative distance for lower
; Syntax Example: (setq Pt2 (Coords3D Pt1 (- DistX) DistY DistZ))
; = From Pt left DistX and up DistY and higher DistZ
;-------------------------------------------------------------------------------
(defun Coords3D (Pt X Y Z)
(list (+ (car Pt) X) (+ (cadr Pt) Y) (+ (caddr Pt) Z))
);defun Coords3D
| |
|
| Useful AutoLISP functions |
#39 |
|
|
Some Buddy |
 |
|
Join Date: |
|
02-25-2009 | |
Here is another one for extracting the entity names from the selection sets:
Code:
(defun sset->list(sset)
(vl-remove-if 'listp (mapcar 'cadr (ssnamex sset)))
)
Here is an example on the command line.
Quote:
Command: (setq SS (ssget)) Select objects: Specify opposite corner: 3 found
Select objects: <Selection set: c>
Command: (sset->list SS)
(<Entity name: 7ef530a0> <Entity name: 7ef53098> <Entity name: 7ef53090>)
Regards,
Some Buddy
| |
|
| Useful AutoLISP functions |
#40 |
|
|
Chandler |
 |
|
Join Date: |
|
09-04-2007 | |
The sameitems function checks if a list has all the same items.
Here are a few examples:
Quote:
(sameitems (list 12.5 12.50 12.500)) = T
(sameitems (list "Case" "case" "casE")) = T
(sameitems (list '("A" 1) '("A" 1) '("A" 1))) = T
Code:
(defun sameitems (lst / diff item)
(foreach item lst
(cond
((and (numberp (car lst)) (numberp item))
(if (not (equal (car lst) item 0.000000001))
(setq diff t)
)
)
((and (listp (car lst)) (listp item))
(if (not (equal (car lst) item))
(setq diff t)
)
)
((and (= (type (car lst)) 'STR) (= (type item) 'STR))
(if (/= (strcase (car lst)) (strcase item))
(setq diff t)
)
)
((setq diff t))
)
)
(not diff)
)
| |
|
|
|
|
|
