Leaderboard

@Mesut Your lisp computes all distances but because mes keeps getting reset it will only have the distance of the last two points. You can get dist from 3d points. your two points dist = 30.67 The error you getting is due to a bad while lets say you have 3 points in your noks selection set ssname noks 0 ssname noks 1 ssname noks 2 first pass counter = 0 dist noks 0 & noks 1 counter = 1 dist noks 1 & noks 2 counter = 2 dist noks 2 & noks 3 error because noks 3 doesn't exist update while to (while (< counter (- len 1)) or (repeat (- len 1) -edit- (defun c:ucg (/ noks kord1 kord2 mes c len) (setq noks (ssget '((0 . "POINT")))) (if (<= (setq len (sslength noks)) 1) ;need a minimum of two points (prompt "\nNot Enought Points Selected") (progn (setq c 0) (repeat (- len 1) (setq txtdata (entget (ssname noks c)) txtdata1 (entget (ssname noks (setq c (+ c 1)))) kord1 (cdr (assoc 10 txtdata)) kord2 (cdr (assoc 10 txtdata1)) mes (distance kord1 kord2) ) (prompt (strcat "\nDistance : " (rtos mes 2))) ;don't know what your doing with mes but this will display it. ) ) ) (princ) )

(defun c:hsel ( / ss obj hlinks str n k en txt txten txtelist) (prompt "\n Select Object to Add Hyperlinks ") (setq ss (ssget ":L")) (terpri) (setq txten (car (entsel "\n Pick Text :"))) (if txten (progn (setq txtelist (entget txten)) (setq txt (cdr (assoc 1 txtelist))) ); progn ); if (setq n (sslength ss)) (setq k 0) (while (<= 1 n) (setq en (ssname ss k)) (vlax-for x (vla-get-hyperlinks (vlax-ename->vla-object en)) (vla-delete x)) (setq n (- n 1)) (setq k (+ k 1)) ) (setq n (sslength ss)) (setq k 0) (while (<= 1 n) (setq obj (vlax-ename->vla-object (ssname ss k))) (setq hlinks (vlax-get-property obj 'Hyperlinks)) (vla-add hlinks txt) (setq obj 0) (setq n (- n 1)) (setq k (+ k 1)) ) (princ) ) (defun c:htxt ( / ss obj hlinks str n k en ) (prompt "\n Select Object to Add Hyperlinks ") (setq ss (ssget ":L")) (terpri) (setq str (getstring "\n Input Text : ")) (setq n (sslength ss)) (setq k 0) (while (<= 1 n) (setq en (ssname ss k)) (vlax-for x (vla-get-hyperlinks (vlax-ename->vla-object en)) (vla-delete x)) (setq n (- n 1)) (setq k (+ k 1)) ) (setq n (sslength ss)) (setq k 0) (while (<= 1 n) (setq obj (vlax-ename->vla-object (ssname ss k))) (setq hlinks (vlax-get-property obj 'Hyperlinks)) ;(setq str (getstring "\nEnter Hyperlink: ")) (vla-add hlinks str) (setq obj 0) (setq n (- n 1)) (setq k (+ k 1)) ) (princ) ) (defun c:hdel (/ ss n k en ) (prompt "\n Select Object to delete Hyperlinks : ") (setq ss (ssget)) (terpri) (setq n (sslength ss)) (setq k 0) (while (<= 1 n) (setq en (ssname ss k)) (vlax-for x (vla-get-hyperlinks (vlax-ename->vla-object en)) (vla-delete x)) (setq n (- n 1)) (setq k (+ k 1)) ) (princ) ) (defun C:TAG ( / ss_dtl dtl_export dtl_export_open dtl_count dtl_obj dtl_hyp each hyp_txt r textsize linkUrl) (setq r (getpoint "\nPick Point")) (setvar 'CMDECHO 0) (setq textsize (getvar 'textsize)) (if (and (LM:ssget "\nSelect details in order for export or [Fence]: " (list "_:L" (append '((0 . "INSERT,LWPOLYLINE,POLYLINE")) ( (lambda ( / def lst ) (while (setq def (tblnext "INSERT,LWPOLYLINE,POLYLINE" (null def))) (if (= 4 (logand 4 (cdr (assoc 70 def)))) (setq lst (vl-list* "," (cdr (assoc 2 def)) lst))) ) (if lst (list '(-4 . "<NOT") (cons 2 (apply 'strcat (cdr lst))) '(-4 . "NOT>"))) ) ) (if (= 1 (getvar 'cvport)) (list (cons 410 (getvar 'ctab))) '((410 . "Model"))) ) ) ) (setq ss_dtl (ssget "_P" '((0 . "INSERT,LWPOLYLINE,POLYLINE") (-3 ("PE_URL")) ))) ) (progn (setq dtl_count 0) (repeat (sslength ss_dtl) (setq r (polar r (dtr 90) (* textsize 1.4))) (setq hyt_txt 0) (setq dtl_obj (vlax-ename->vla-object (ssname ss_dtl dtl_count))) (setq dtl_hyp (vlax-get-property dtl_obj 'Hyperlinks)) (vlax-for each dtl_hyp (setq hyp_txt (strcat (vla-get-url each))) ) ;(setq linkUrl (cdr (assoc 2 (entget (ssname ss_dtl dtl_count))))) ;(setq linkUrl (vlax-vla-object->ename (vla-item dtl_hyp 0))) (command "text" r textsize "0" hyp_txt ) ;(princ (vl-princ-to-string linkUrl)) (setq dtl_count (1+ dtl_count)) ) ;(princ (vl-princ-to-string hyp_txt)) (princ (strcat "\nHyperlink Count : " (vl-princ-to-string dtl_count) " EA\n")) ) ) (setvar 'CMDECHO 1) (princ) ) (defun C:TAGL ( / ss_dtl dtl_export dtl_export_open dtl_count dtl_obj dtl_hyp each hyp_txt r textsize len_txt ) (vl-load-com) (setvar 'CMDECHO 0) (setq r (getpoint "\nPick Point")) (setq textsize (getvar 'textsize)) (if (and (LM:ssget "\nSelect details in order for export or [Fence]: " (list "_:L" (append '((0 . "LWPOLYLINE,POLYLINE")) ( (lambda ( / def lst ) (while (setq def (tblnext "LWPOLYLINE,POLYLINE" (null def))) (if (= 4 (logand 4 (cdr (assoc 70 def)))) (setq lst (vl-list* "," (cdr (assoc 2 def)) lst))) ) (if lst (list '(-4 . "<NOT") (cons 2 (apply 'strcat (cdr lst))) '(-4 . "NOT>"))) ) ) (if (= 1 (getvar 'cvport)) (list (cons 410 (getvar 'ctab))) '((410 . "Model"))) ) ) ) (setq ss_dtl (ssget "_P" '((0 . "INSERT,LWPOLYLINE,POLYLINE") (-3 ("PE_URL")) ))) ) (progn (setq dtl_count 0) (repeat (sslength ss_dtl) (setq r (polar r (dtr 90) (* textsize 1.4))) (setq dtl_obj (vlax-ename->vla-object (ssname ss_dtl dtl_count))) (setq dtl_hyp (vlax-get-property dtl_obj 'Hyperlinks)) (vlax-for each dtl_hyp (setq hyp_txt (strcat (vla-get-url each))) ) (setq len_txt (rtos (vla-get-length dtl_obj) ) ) (command "text" r textsize "0" (strcat hyp_txt " / Length = " len_txt )) (setq dtl_count (1+ dtl_count)) ) (princ (strcat "\nHyperlink Count : " (vl-princ-to-string dtl_count) " EA\n")) ) ) (setvar 'CMDECHO 1) (princ) ) (defun C:TAGLL ( / ss_dtl dtl_export dtl_export_open dtl_count dtl_obj dtl_hyp each hyp_txt r textsize len_txt lay_txt ) (vl-load-com) (setvar 'CMDECHO 0) (setq r (getpoint "\nPick Point")) (setq textsize (getvar 'textsize)) (if (and (LM:ssget "\nSelect details in order for export or [Fence]: " (list "_:L" (append '((0 . "LWPOLYLINE,POLYLINE")) ( (lambda ( / def lst ) (while (setq def (tblnext "LWPOLYLINE,POLYLINE" (null def))) (if (= 4 (logand 4 (cdr (assoc 70 def)))) (setq lst (vl-list* "," (cdr (assoc 2 def)) lst))) ) (if lst (list '(-4 . "<NOT") (cons 2 (apply 'strcat (cdr lst))) '(-4 . "NOT>"))) ) ) (if (= 1 (getvar 'cvport)) (list (cons 410 (getvar 'ctab))) '((410 . "Model"))) ) ) ) (setq ss_dtl (ssget "_P" '((0 . "INSERT,LWPOLYLINE,POLYLINE") (-3 ("PE_URL")) ))) ) (progn (setq dtl_count 0) (repeat (sslength ss_dtl) (setq r (polar r (dtr 90) (* textsize 1.4))) (setq dtl_obj (vlax-ename->vla-object (ssname ss_dtl dtl_count))) (setq dtl_hyp (vlax-get-property dtl_obj 'Hyperlinks)) (vlax-for each dtl_hyp (setq hyp_txt (strcat (vla-get-url each))) ) (setq len_txt (rtos (vla-get-length dtl_obj) ) ) (setq lay_txt (vla-get-layer dtl_obj) ) (command "text" r textsize "0" (strcat hyp_txt " / Length = " len_txt " / Layer = " lay_txt )) (setq dtl_count (1+ dtl_count)) ) (princ (strcat "\nHyperlink Count : " (vl-princ-to-string dtl_count) " EA\n")) ) ) (setvar 'CMDECHO 1) (princ) ) (defun C:TAGXYZ ( / ss_dtl dtl_export dtl_export_open dtl_count dtl_obj dtl_hyp each hyp_txt r textsize xyz_txt lay_txt) (setq r (getpoint "\nPick Point")) (setvar 'CMDECHO 0) (setq textsize (getvar 'textsize)) (if (and (LM:ssget "\nSelect details in order for export or [Fence]: " (list "_:L" (append '((0 . "INSERT,LWPOLYLINE,POLYLINE")) ( (lambda ( / def lst ) (while (setq def (tblnext "INSERT,LWPOLYLINE,POLYLINE" (null def))) (if (= 4 (logand 4 (cdr (assoc 70 def)))) (setq lst (vl-list* "," (cdr (assoc 2 def)) lst))) ) (if lst (list '(-4 . "<NOT") (cons 2 (apply 'strcat (cdr lst))) '(-4 . "NOT>"))) ) ) (if (= 1 (getvar 'cvport)) (list (cons 410 (getvar 'ctab))) '((410 . "Model"))) ) ) ) (setq ss_dtl (ssget "_P" '((0 . "INSERT,LWPOLYLINE,POLYLINE") (-3 ("PE_URL")) ))) ) (progn (setq dtl_count 0) (repeat (sslength ss_dtl) (setq r (polar r (dtr 90) (* textsize 1.4))) (setq dtl_obj (vlax-ename->vla-object (ssname ss_dtl dtl_count))) (setq dtl_hyp (vlax-get-property dtl_obj 'Hyperlinks)) (vlax-for each dtl_hyp (setq hyp_txt (strcat (vla-get-url each))) (setq xyz_txt (vl-princ-to-string (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint dtl_obj))))) ) (command "text" r textsize "0" (strcat hyp_txt " / Coord = " xyz_txt) ) (setq dtl_count (1+ dtl_count)) ) (princ (strcat "\nHyperlink Count : " (vl-princ-to-string dtl_count) " EA\n")) ) ) (setvar 'CMDECHO 1) (princ) ) (defun C:TAGXYZL ( / ss_dtl dtl_export dtl_export_open dtl_count dtl_obj dtl_hyp each hyp_txt r textsize xyz_txt) (setq r (getpoint "\nPick Point")) (setvar 'CMDECHO 0) (setq textsize (getvar 'textsize)) (if (and (LM:ssget "\nSelect details in order for export or [Fence]: " (list "_:L" (append '((0 . "INSERT,LWPOLYLINE,POLYLINE")) ( (lambda ( / def lst ) (while (setq def (tblnext "INSERT,LWPOLYLINE,POLYLINE" (null def))) (if (= 4 (logand 4 (cdr (assoc 70 def)))) (setq lst (vl-list* "," (cdr (assoc 2 def)) lst))) ) (if lst (list '(-4 . "<NOT") (cons 2 (apply 'strcat (cdr lst))) '(-4 . "NOT>"))) ) ) (if (= 1 (getvar 'cvport)) (list (cons 410 (getvar 'ctab))) '((410 . "Model"))) ) ) ) (setq ss_dtl (ssget "_P" '((0 . "INSERT,LWPOLYLINE,POLYLINE") (-3 ("PE_URL")) ))) ) (progn (setq dtl_count 0) (repeat (sslength ss_dtl) (setq r (polar r (dtr 90) (* textsize 1.4))) (setq dtl_obj (vlax-ename->vla-object (ssname ss_dtl dtl_count))) (setq dtl_hyp (vlax-get-property dtl_obj 'Hyperlinks)) (vlax-for each dtl_hyp (setq hyp_txt (strcat (vla-get-url each))) (setq xyz_txt (vl-princ-to-string (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint dtl_obj))))) (setq lay_txt (vla-get-layer dtl_obj) ) ) (command "text" r textsize "0" (strcat hyp_txt " / Coord = " xyz_txt " / Layer = " lay_txt)) (setq dtl_count (1+ dtl_count)) ) (princ (strcat "\nHyperlink Count : " (vl-princ-to-string dtl_count) " EA\n")) ) ) (setvar 'CMDECHO 1) (princ) ) (defun C:TAGXYZLN ( / ss_dtl dtl_export dtl_export_open dtl_count dtl_obj dtl_hyp each hyp_txt r textsize xyz_txt blkname_txt) (setq r (getpoint "\nPick Point")) (setvar 'CMDECHO 0) (setq textsize (getvar 'textsize)) (if (and (LM:ssget "\nSelect details in order for export or [Fence]: " (list "_:L" (append '((0 . "INSERT,LWPOLYLINE,POLYLINE")) ( (lambda ( / def lst ) (while (setq def (tblnext "INSERT,LWPOLYLINE,POLYLINE" (null def))) (if (= 4 (logand 4 (cdr (assoc 70 def)))) (setq lst (vl-list* "," (cdr (assoc 2 def)) lst))) ) (if lst (list '(-4 . "<NOT") (cons 2 (apply 'strcat (cdr lst))) '(-4 . "NOT>"))) ) ) (if (= 1 (getvar 'cvport)) (list (cons 410 (getvar 'ctab))) '((410 . "Model"))) ) ) ) (setq ss_dtl (ssget "_P" '((0 . "INSERT,LWPOLYLINE,POLYLINE") (-3 ("PE_URL")) ))) ) (progn (setq dtl_count 0) (repeat (sslength ss_dtl) (setq r (polar r (dtr 90) (* textsize 1.4))) (setq dtl_obj (vlax-ename->vla-object (ssname ss_dtl dtl_count))) (setq dtl_hyp (vlax-get-property dtl_obj 'Hyperlinks)) (vlax-for each dtl_hyp (setq hyp_txt (strcat (vla-get-url each))) (setq xyz_txt (vl-princ-to-string (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint dtl_obj))))) (setq lay_txt (vla-get-layer dtl_obj)) (setq blkname_txt (vla-get-effectivename dtl_obj)) ) (command "text" r textsize "0" (strcat hyp_txt " / Coord = " xyz_txt " / Layer = " lay_txt " / BlockName = " blkname_txt )) (setq dtl_count (1+ dtl_count)) ) (princ (strcat "\nHyperlink Count : " (vl-princ-to-string dtl_count) " EA\n")) ) ) (setvar 'CMDECHO 1) (princ) ) (defun c:HMAT ( / ss obj hlinks str n k en ss1 ss1_obj ss1_hyp ss1_txt) (prompt "\n Select original to copy Hyperlink (single selection) ") (setq ss1 (ssget ":S")) (terpri) (setq ss1_obj (vlax-ename->vla-object (ssname ss1 0))) (setq ss1_hyp (vlax-get-property ss1_obj 'Hyperlinks)) (vlax-for each ss1_hyp (setq ss1_txt (strcat (vla-get-url each))) ) (prompt "\n Select object to paste Hyperlink ") (setq ss (ssget ":L")) (terpri) (setq str ss1_txt) (setq n (sslength ss)) (setq k 0) (while (<= 1 n) (setq en (ssname ss k)) (vlax-for x (vla-get-hyperlinks (vlax-ename->vla-object en)) (vla-delete x)) (setq n (- n 1)) (setq k (+ k 1)) ) (setq n (sslength ss)) (setq k 0) (while (<= 1 n) (setq obj (vlax-ename->vla-object (ssname ss k))) (setq hlinks (vlax-get-property obj 'Hyperlinks)) ;(setq str (getstring "\nEnter Hyperlink: ")) (vla-add hlinks str) (setq obj 0) (setq n (- n 1)) (setq k (+ k 1)) ) (princ) ) (defun c:FH( / *error* old_osmode fhclayer ob count inputtext bas name xxlist enti1 enti2 dxy x xx y yy finded num hyp_obj hyp_hyp text2 ) (command "ucs" "w") (command "_undo" "_be") (defun *error*(e) (setvar "osmode" old_osmode) (command "_undo" "_e") (princ) ) (setvar "cmdecho" 0) (setq old_osmode 0) (setq fhclayer 0) (setq ob 0) (setq count 0) (setq inputtext 0) (setq bas 0) (setq name 0) (setq xxlist 0) (setq enti1 0) (setq enti2 0) (setq dxy 0) (setq x 0) (setq xx 0) (setq y 0) (setq yy 0) (setq xy 0) (setq finded 0) (setq num 0) (setq old_osmode (getvar "osmode")) (setq fhclayer (getvar "clayer")) (setq ob (ssget "x" '((0 . "INSERT,LWPOLYLINE,POLYLINE") (-3 ("PE_URL")) ))) (setq count (sslength ob)) (setq inputtext (getstring T "\n Input Hyperlink to Find ")) (setq bas (getpoint "\n Pick point to set origin ")) (setq num 0) (setq finded 0) (setvar "osmode" 0) (if (= bas nil) (setq bas "0, 0")) (repeat count (setq name (ssname ob num)) (setq xxlist (entget name)) (progn (setq enti1 (cdr (assoc -1 xxlist))) ;(setq text2 (cdr (assoc 1 xxlist))) (setq hyp_obj (vlax-ename->vla-object name)) (setq hyp_hyp (vlax-get-property hyp_obj 'Hyperlinks)) (vlax-for each hyp_hyp (setq text2 (strcat (vla-get-url each))) ) (setq dxy (assoc 10 xxlist)) (setq x (nth 1 dxy)) (setq xx (rtos x 2 4)) (setq y (nth 2 dxy)) (setq yy (rtos y 2 4)) (setq xy (strcat xx "," yy)) (if (wcmatch (strcase text2) (strcat "*" (strcase inputtext) "*")) (progn (command "pline" bas xy "") (setq finded (+ finded 1)) );progn );if );progn (setq num (+ num 1)) );repeat (prompt (strcat "\n Hyperlink Total = "(rtos finded) " ea")) (if ( = finded 0 ) (alert " There's no Hyperlink")) (command "_undo" "_e") (setvar "osmode" old_osmode) (princ) (command "ucs" "p") (princ) );end_defun ;; ssget - Lee Mac ;; A wrapper for the ssget function to permit the use of a custom selection prompt ;; msg - [str] selection prompt ;; arg - [lst] list of ssget arguments (defun LM:ssget ( msg arg / sel ) (princ msg) (setvar 'nomutt 1) (setq sel (vl-catch-all-apply 'ssget arg)) (setvar 'nomutt 0) (if (not (vl-catch-all-error-p sel)) sel) ) add Hyperlink Match ( HMAT ) add Find Hyperlink Function for block, polyline only ( FH ) use old find text and draw lines lisp (allow space bar, and use both side wildcard)

Yes, add your code after the "; Routine continues if not expired" comment. See modified version with following changes - CheckProgramExpire has been modified to include the test date as input - wraps the error trap 'setup' and 'cancel' into separate functions (or could build these into the 'CheckProgramExpire' routine, but this wouldn't give you the chance to add additional program-specific comments before you exit). The updated example should make it easier to drop a generic block of code into an existing routine. ; Sample timebomb application - Verion 2 ; KJM - Dec 2009, Mod Aug 2018 ; Used to stop a routine from running if date has been exceeded ; Global variables (setq ProgramExpiryDate "20180827") ; change this date before or after current date to test (setq ProgramContact "Contact XYZZY for renewal at xyzzy@nospam.net or xxx.xxx.xxxx") (setq *error* nil) (setq OldErrorTrap nil) ; ------------------- Main Program (defun C:Test1 ( / *error* ) ; Test function for 'CheckProgramExpire' timebomb ; KJM - Dec 2009 ; ------------------ Begin expiry date check ; Start error trap (SetProgramExitErrorTrap) ; Check Expiry Date using custom function (setq MyCode (CheckProgramExpire2 nil (atoi ProgramExpiryDate) ProgramContact)) ;(prompt "\nReturned Code: ")(princ MyCode) ;(princ) ; Terminate routine if expired (if (eq MyCode 0) (progn (prompt "\n ") ; add additional error messages here (princ) (exit) ) ) ; Cancel error trap, reset back to original (CancelProgramExitErrorTrap) ; ------------------- End expiry date check ; Routine continues if not expired (setq a (getstring 1 "\nEnter something...")) (prompt "\n You entered '")(princ a)(prompt "' ") (princ) ) (prompt "\nTest1 - test program Ver 1.")(princ) ; ------------------ Support functions (defun SetProgramExitErrorTrap ( / msg) ; Specify special error trap to capture (exit) ; KJM - Aug 2018 ; Input: ; nothing ; ; Uses Global variables 'OldErrorTrap' and '*error*' (setq OldErrorTrap *error*) (defun *error* (msg) (if (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (progn ; add error message here ;(princ (strcat "\n *** Error: " msg " **")) (princ) ) ) (princ) ) (princ) ) (defun CancelProgramExitErrorTrap () ; Cancel special error trap, reset to previous ; KJM - Aug 2018 (setq *error* OldErrorTrap) (princ) ) (defun CheckProgramExpire2 (TestDate ExpiryDate RenewString / CurrentDate OutCode) ; Expiration date check ver 2 ; KJM - Dec 2009, based on code by Irne Barnard, Mod KJM Aug 2018 ; http://forums.augi.com/showthread.php?80070-Code-help&p=842603&viewfull=1#post842603 ; Input: ; TestDate - (integer) format YYYYMODD, nil to use current data ; ExpiryDate - (integer) format YYYYMODD ; RenewString - (string) info for contact info on timer failure, nil to omit displaying renewal string ; Returns: ; 0 if failed ; 1 if passed ; prints 'Program Expiry' message to command line ; ; Example Use: ; (setq MyCode (CheckProgramExpire2 nil (atoi MyTestDate) "Contact XYZZY for renewal at xyzzy@nospam.net or xxx.xxx.xxxx")) (if (eq TestDate nil) (progn ; Add expiry data in YYYYMODD format and contact info message here (setq TestDate (atoi (LM:InternetTime "YYYYMODD"))) ; Mod KJM Jan 2012 ;(setq TestDate (getvar "CDATE")) ; Orig version ) ) (if (> TestDate ExpiryDate) (progn (prompt "\n *** Program Expired ***")(princ) (if RenewString (progn (prompt (strcat "\n " RenewString)) (princ) ) ) (setq OutCode 0) ) (progn (princ (strcat "\n *** Program active for " (itoa (fix (- ExpiryDate TestDate))) " more day(s) *** ")) (princ) (setq OutCode 1) ) ) OutCode ) ;;---------------------=={ Internet Time }==------------------;; ;; ;; ;; Returns the date and/or UTC time as a string in the ;; ;; format specified. Data is sourced from a NIST server. ;; ;;------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; format - string specifying format of returned information ;; ;; using the following identifiers to represent ;; ;; date & time quantities: ;; ;; YYYY = 4-digit year ;; ;; YY = Year, MO = Month, DD = Day ;; ;; HH = Hour, MM = Minutes, SS = Seconds ;; ;;------------------------------------------------------------;; ;; Returns: String containing formatted date/time data ;; ;;------------------------------------------------------------;; ; All users should ensure that their software NEVER queries a server more frequently than once every 4 seconds. ; Systems that exceed this rate will be refused service. ; http://www.theswamp.org/index.php?topic=39491.msg447974#msg447974 (defun LM:InternetTime ( format / result rgx server xml ) (setq server "http://time.nist.gov:13") (setq result (vl-catch-all-apply (function (lambda ( / str ) (setq xml (vlax-create-object "MSXML2.XMLHTTP.3.0")) (setq rgx (vlax-create-object "VBScript.RegExp")) (vlax-invoke-method xml 'open "POST" server :vlax-false) (vlax-invoke-method xml 'send) (if (setq str (vlax-get-property xml 'responsetext)) (progn (vlax-put-property rgx 'global actrue) (vlax-put-property rgx 'ignorecase actrue) (vlax-put-property rgx 'multiline actrue) (setq str (strcat " " (itoa (jtoy (+ (atoi (substr str 2 5)) 2400000.5))) (substr str 7))) (mapcar (function (lambda ( a b ) (vlax-put-property rgx 'pattern a) (setq format (vlax-invoke rgx 'replace format b)) ) ) '("YYYY" "YY" "MO" "DD" "HH" "MM" "SS") '( "$1" "$2" "$3" "$4" "$5" "$6" "$7") ) (vlax-put-property rgx 'pattern (strcat "(?:[^\\d]+)([\\d]+)(?:[^\\d]+)([\\d]+)" "(?:[^\\d]+)([\\d]+)(?:[^\\d]+)([\\d]+)" "(?:[^\\d]+)([\\d]+)(?:[^\\d]+)([\\d]+)" "(?:[^\\d]+)([\\d]+)(?:.+)\\n" ) ) (vlax-invoke-method rgx 'replace str format) ) ) ) ) ) ) (if xml (vlax-release-object xml)) (if rgx (vlax-release-object rgx)) (if (not (vl-catch-all-error-p result)) result ) ) ;; Julian Date to Calendar Year - Lee Mac ;; Algorithm from: Meeus, Jean. Astronomical Algorithms. (defun jtoy ( j / a b c d ) (setq j (fix j) a (fix (/ (- j 1867216.25) 36524.25)) b (+ (- (+ j 1 a) (fix (/ a 4))) 1524) c (fix (/ (- b 122.1) 365.25)) d (fix (/ (- b (fix (* 365.25 c))) 30.6001)) ) (fix (- c (if (< 2 (fix (if (< d 14) (1- d) (- d 13)))) 4716 4715))) )