Want Lisp For Input Data In Cad

October 29, 2007

HI ALL

WANT LISP FOR INPUT DATA IN CAD

i have a ground level

sample

x y z

17 20 2.5

21 24 3.4

25 28 4.3

29 32 5.2

33 36 2.5

37 40 3.4

of plot i have x,y & z corrdinate i havve to plot this in autocad

but plotting z valu shown on display point and text is one block

after that when i ckeck list of that it is on same x,y&z cordinate.

please refer sample attached:)

thanks

harshad:)

SAMPLE.pdf

October 29, 2007

Try this one

;; local defun
;; entmake block
(defun makepoint  ()
 (if (not (tblsearch "BLOCK" "POINT_ELEV"))
   (progn
     (initget 6)
     (setq hgt (getreal "\n  Enter text height of attribute <2.5>: "))
     (if (not hgt)
(setq hgt 2.5))
     (entmake
(mapcar	'cons
	(list 0 8 2 70 10 3)
	(list "BLOCK" "0" "POINT_ELEV" 2 '(0 0 0) "POINT_ELEV")))
     (entmake
(mapcar	'cons
	(list 0 8 62 10 210 50)
	(list "POINT" "0" 0 (list 0 0 0) '(0 0 1) 0.0)))
     (entmake
(mapcar	'cons
	(list 0 8 62 10 40 70 1 210 3 2)
	(list "ATTDEF"
	      "0"
	      0
	      (list (/ hgt 2) (* hgt 2.5) 0)
	      2.5
	      9
	      "x"
	      '(0 0 1)
	      "Topo point X coordinate"
	      "XCOORD")))
     (entmake
(mapcar	'cons
	(list 0 8 62 10 40 70 1 210 3 2)
	(list "ATTDEF"
	      "0"
	      0
	      (list (/ hgt 2) (* hgt 1.5) 0)
	      2.5
	      9
	      "y"
	      '(0 0 1)
	      "Topo point Y coordinate"
	      "YCOORD")))
     (entmake
(mapcar	'cons
	(list 0 8 62 10 40 70 1 210 3 2)
	(list "ATTDEF"
	      "0"
	      6
	      (list (/ hgt 2) (/ hgt 2) 0)
	      2.5
	      8
	      "z"
	      '(0 0 1)
	      "Topo point Z coordinate"
	      "ZCOORD")))
     (entmake
(mapcar	'cons
	(list 0 
	(list "ENDBLK" "0"))))))

;; main programm
(defun C:PP  (/ att_tag ent new_value next next_data osm point_list)

 (makepoint)
 (if (not (tblsearch "BLOCK" "POINT_ELEV"))
   (progn
     (alert "Something wrong\nprogramm stopped")
     (exit)
     (princ)))
 (setq osm (getvar "osmode"))
 (setvar "cmdecho" 0)
 (setvar "osmode" 0)
 (setq	point_list
 (list
   '(17 20 2.5)	'(21 24 3.4) '(25 28 4.3) '(29 32 5.2) '(33 36 2.5) '(37 40 3.4)))
 (foreach point  point_list
   (command "._-insert" "POINT_ELEV" point 1 1 0)

   (setq ent (entlast))
   (setq next ent)
   (while (setq next (entnext next))
     (setq next_data (entget next))
     (setq att_tag (cdr (assoc 2 next_data)))
     (cond
((eq (strcase "XCOORD") att_tag)
 (setq new_value (rtos (car point) 2 1)))
((eq (strcase "YCOORD") att_tag)
 (setq new_value (rtos (cadr point) 2 1)))
((eq (strcase "ZCOORD") att_tag)
 (setq new_value (rtos (caddr point) 2 1))))
     (entmod
(subst (cons 1 new_value) (assoc 1 next_data) next_data))
     (entupd ent)
     )
   )
 (command "._zoom" "_e");by suit
 (setvar "osmode" osm)
 (setvar "cmdecho" 1)
 (princ)
 )
;; TesT : (C:PP)
(prompt "\n====================================\n")
(prompt "\n\t>>>\tType PP to execute ... \t>>>\n")
(prompt "\n====================================\n")
(prin1)

~'J'~

October 31, 2007

thanks fatty but i have lots of ground levels

witch i send u is a sample i have more than 10,000

x,y,z cordinate let"s try u r best

thanks

harshad

October 31, 2007

Do you have a file of the XYZ coords, and is the file "space" delimited?

October 31, 2007

i hope u know about the ground improvements

from site i got x,y,z data i want to import it into the cad

but z valu i want in display thats all our douctment is

Confidential if any idia about to makeing script or lisp of that x,y,z points

and done this input in one time

thanks for reply

harshad

October 31, 2007

See This Sample

Cordinate .exel File

Thanks

Harshad

SAMPLE.zip

October 31, 2007

you got me, I've never used excell files before. But there are many threads here about it. Do a search and find the answer.

October 31, 2007

See This Sample
Cordinate .exel File

Thanks

Harshad

Keep watching this thread

~'J'~

October 31, 2007

See how it will work for you

;; PP.lsp

;; read Excel, draw points in Acad as blocks with attributes
;; local defun
;; entmake block
(defun makepoint  ()
 (if (not (tblsearch "BLOCK" "POINT_ELEV"))
   (progn
     (initget 6)
     (setq hgt (getreal "\n  Enter text height of attribute <2.5>: "))
     (if (not hgt)
(setq hgt 2.5))
     (entmake
(mapcar	'cons
	(list 0 8 2 70 10 3)
	(list "BLOCK" "0" "POINT_ELEV" 2 '(0 0 0) "POINT_ELEV")))
     (entmake
(mapcar	'cons
	(list 0 8 62 10 210 50)
	(list "POINT" "0" 0 (list 0 0 0) '(0 0 1) 0.0)))
     (entmake
(mapcar	'cons
	(list 0 8 62 10 40 70 1 210 3 2)
	(list "ATTDEF"
	      "0"
	      0
	      (list (/ hgt 2) (* hgt 2.5) 0)
	      2.5
	      9
	      "x"
	      '(0 0 1)
	      "Topo point X coordinate"
	      "XCOORD")))
     (entmake
(mapcar	'cons
	(list 0 8 62 10 40 70 1 210 3 2)
	(list "ATTDEF"
	      "0"
	      0
	      (list (/ hgt 2) (* hgt 1.5) 0)
	      2.5
	      9
	      "y"
	      '(0 0 1)
	      "Topo point Y coordinate"
	      "YCOORD")))
     (entmake
(mapcar	'cons
	(list 0 8 62 10 40 70 1 210 3 2)
	(list "ATTDEF"
	      "0"
	      6
	      (list (/ hgt 2) (/ hgt 2) 0)
	      2.5
	      8
	      "z"
	      '(0 0 1)
	      "Topo point Z coordinate"
	      "ZCOORD")))
     (entmake
(mapcar	'cons
	(list 0 
	(list "ENDBLK" "0"))))))

;; local defun
;; to read the Excel range


(defun EXR  (FilePath ShtNum StrRange /	ExcelApp ExcData Sht UsdRange Wbk)
;; based on function "EXD" from this page:
;; http://www.cadforyou.spb.ru/index.php?current_section=section_functions_page
 (vl-load-com)


 (setq ExcelApp (vlax-get-or-create-object "Excel.Application"))
 (vla-put-visible ExcelApp :vlax-true)		  ; or :vlax-false if you want
 (vlax-put-property ExcelApp 'DisplayAlerts :vlax-false)
 (setq	Wbk (vl-catch-all-apply
      'vla-open
      (list (vlax-get-property ExcelApp "WorkBooks") FilePath)
      )
)
 (setq	Sht (vl-catch-all-apply
      'vlax-get-property
      (list (vlax-get-property Wbk "Sheets")
	    "Item"
	    ShtNum
	    )
      )
)
 (vlax-invoke-method Sht "Activate")
 
 (setq	UsdRange (vlax-get-property
	   (vlax-get-property Sht 'Cells)
	   "Range"
	   StrRange)
ExcData	 (vlax-safearray->list
	   (vlax-variant-value
	     (vlax-get-property UsdRange 'Value2)
	     )
	   )
)
 (setq
   ExcData (mapcar
      (function (lambda (x) (mapcar 'vlax-variant-value x)))
      ExcData
      )
   )

 (vl-catch-all-apply
   'vlax-invoke-method
   (list Wbk "Close")
   )

 (vl-catch-all-apply
   'vlax-invoke-method
   (list ExcelApp "Quit")
   )

 (mapcar
   (function
     (lambda (x)
(vl-catch-all-apply
  (function (lambda ()
	      (progn
		(if (not (vlax-object-released-p x))
		  (progn
		    (vlax-release-object x)
		    (setq x nil)
		    )
		  )
		)
	      )
	    )
  )
)
     )

   (list UsdRange Sht Wbk ExcelApp)
   )

 (gc)
 (gc)
 ExcData

 )

;;      main part       ;;
(defun C:PP  (/	Att_Tag	Ent Filepath Headflag New_Value	Next Next_Data
      Osm Poinlist Response Shtnum Strrange)

 (or (vl-load-com))
 (setq	FilePath (getfiled "Select Excel file to read :"
		   (getvar "dwgprefix")
		   "xls"
		   16
		   )
)
 (initget 6)
 (setq ShtNum (getint "\nEnter the sheet number <1> : "))
 (if (not ShtNum)
   (setq ShtNum 1))
 (setq	strRange (strcase
	   (getstring "\n  Enter address of used range <A1:C99>: ")))
 (if (eq "" strRange)
   (setq strRange "A1:C99"))
 (initget "Yes No")
 (setq	Response (getkword
	   "\n   Is the Excel table has the headers? (Y/N) <Y>: "))
 (if (not Response)
   (setq Response "Yes"))
 (if (eq "Yes" Response)
   (setq HeadFlag T)
   (setq HeadFlag nil))
 
 (setq PoinList (EXR FilePath ShtNum strRange))
 (if HeadFlag
   (setq PoinList (cdr PoinList)))
 
 (if PoinList
   (progn
     (makepoint)
     (if (not (tblsearch "BLOCK" "POINT_ELEV"))
(progn
  (alert "Something wrong\nprogramm stopped")
  (exit)
  (princ)))
     (setq osm (getvar "osmode"))
     (setvar "cmdecho" 0)
     (setvar "osmode" 0)

     (foreach point  PoinList
(command "._-insert" "POINT_ELEV" point 1 1 0)

(setq ent (entlast))
(setq next ent)
(while (setq next (entnext next))
  (setq next_data (entget next))
  (setq att_tag (cdr (assoc 2 next_data)))
  (cond
    ((eq (strcase "XCOORD") att_tag)
     (setq new_value (rtos (car point) 2 1)))
    ((eq (strcase "YCOORD") att_tag)
     (setq new_value (rtos (cadr point) 2 1)))
    ((eq (strcase "ZCOORD") att_tag)
     (setq new_value (rtos (caddr point) 2 1))))
  (entmod
    (subst (cons 1 new_value) (assoc 1 next_data) next_data))
  (entupd ent)
  )
)
     (command "._zoom" "_e");by suit
     )
   (alert "Trouble with reading Excel data")
   )

 (setvar "osmode" osm)
 (setvar "cmdecho" 1)
 (princ)
 )

;; TesT : (C:PP)
(prompt "\n====================================\n")
(prompt "\n\t>>>\tType PP to execute ... \t>>>\n")
(prompt "\n====================================\n")
(prin1)

~'J'~

October 31, 2007

ok fatty try u r best

best of luck!

thanks

harshad

October 31, 2007

See how it will work for you

;; PP.lsp

;; read Excel, draw points in Acad as blocks with attributes
;; local defun
;; entmake block
(defun makepoint  ()
 (if (not (tblsearch "BLOCK" "POINT_ELEV"))
   (progn
     (initget 6)
     (setq hgt (getreal "\n  Enter text height of attribute <2.5>: "))
     (if (not hgt)
   (setq hgt 2.5))
     (entmake
   (mapcar    'cons
       (list 0 8 2 70 10 3)
       (list "BLOCK" "0" "POINT_ELEV" 2 '(0 0 0) "POINT_ELEV")))
     (entmake
   (mapcar    'cons
       (list 0 8 62 10 210 50)
       (list "POINT" "0" 0 (list 0 0 0) '(0 0 1) 0.0)))
     (entmake
   (mapcar    'cons
       (list 0 8 62 10 40 70 1 210 3 2)
       (list "ATTDEF"
             "0"
             0
             (list (/ hgt 2) (* hgt 2.5) 0)
             2.5
             9
             "x"
             '(0 0 1)
             "Topo point X coordinate"
             "XCOORD")))
     (entmake
   (mapcar    'cons
       (list 0 8 62 10 40 70 1 210 3 2)
       (list "ATTDEF"
             "0"
             0
             (list (/ hgt 2) (* hgt 1.5) 0)
             2.5
             9
             "y"
             '(0 0 1)
             "Topo point Y coordinate"
             "YCOORD")))
     (entmake
   (mapcar    'cons
       (list 0 8 62 10 40 70 1 210 3 2)
       (list "ATTDEF"
             "0"
             6
             (list (/ hgt 2) (/ hgt 2) 0)
             2.5
             8
             "z"
             '(0 0 1)
             "Topo point Z coordinate"
             "ZCOORD")))
     (entmake
   (mapcar    'cons
       (list 0 
       (list "ENDBLK" "0"))))))

;; local defun
;; to read the Excel range


(defun EXR  (FilePath ShtNum StrRange /    ExcelApp ExcData Sht UsdRange Wbk)
;; based on function "EXD" from this page:
;; http://www.cadforyou.spb.ru/index.php?current_section=section_functions_page
 (vl-load-com)


 (setq ExcelApp (vlax-get-or-create-object "Excel.Application"))
 (vla-put-visible ExcelApp :vlax-true)          ; or :vlax-false if you want
 (vlax-put-property ExcelApp 'DisplayAlerts :vlax-false)
 (setq    Wbk (vl-catch-all-apply
         'vla-open
         (list (vlax-get-property ExcelApp "WorkBooks") FilePath)
         )
   )
 (setq    Sht (vl-catch-all-apply
         'vlax-get-property
         (list (vlax-get-property Wbk "Sheets")
           "Item"
           ShtNum
           )
         )
   )
 (vlax-invoke-method Sht "Activate")

 (setq    UsdRange (vlax-get-property
          (vlax-get-property Sht 'Cells)
          "Range"
          StrRange)
   ExcData     (vlax-safearray->list
          (vlax-variant-value
            (vlax-get-property UsdRange 'Value2)
            )
          )
   )
 (setq
   ExcData (mapcar
         (function (lambda (x) (mapcar 'vlax-variant-value x)))
         ExcData
         )
   )

 (vl-catch-all-apply
   'vlax-invoke-method
   (list Wbk "Close")
   )

 (vl-catch-all-apply
   'vlax-invoke-method
   (list ExcelApp "Quit")
   )

 (mapcar
   (function
     (lambda (x)
   (vl-catch-all-apply
     (function (lambda ()
             (progn
           (if (not (vlax-object-released-p x))
             (progn
               (vlax-release-object x)
               (setq x nil)
               )
             )
           )
             )
           )
     )
   )
     )

   (list UsdRange Sht Wbk ExcelApp)
   )

 (gc)
 (gc)
 ExcData

 )

;;      main part       ;;
(defun C:PP  (/    Att_Tag    Ent Filepath Headflag New_Value    Next Next_Data
         Osm Poinlist Response Shtnum Strrange)

 (or (vl-load-com))
 (setq    FilePath (getfiled "Select Excel file to read :"
              (getvar "dwgprefix")
              "xls"
              16
              )
   )
 (initget 6)
 (setq ShtNum (getint "\nEnter the sheet number <1> : "))
 (if (not ShtNum)
   (setq ShtNum 1))
 (setq    strRange (strcase
          (getstring "\n  Enter address of used range <A1:C99>: ")))
 (if (eq "" strRange)
   (setq strRange "A1:C99"))
 (initget "Yes No")
 (setq    Response (getkword
          "\n   Is the Excel table has the headers? (Y/N) <Y>: "))
 (if (not Response)
   (setq Response "Yes"))
 (if (eq "Yes" Response)
   (setq HeadFlag T)
   (setq HeadFlag nil))

 (setq PoinList (EXR FilePath ShtNum strRange))
 (if HeadFlag
   (setq PoinList (cdr PoinList)))

 (if PoinList
   (progn
     (makepoint)
     (if (not (tblsearch "BLOCK" "POINT_ELEV"))
   (progn
     (alert "Something wrong\nprogramm stopped")
     (exit)
     (princ)))
     (setq osm (getvar "osmode"))
     (setvar "cmdecho" 0)
     (setvar "osmode" 0)

     (foreach point  PoinList
   (command "._-insert" "POINT_ELEV" point 1 1 0)

   (setq ent (entlast))
   (setq next ent)
   (while (setq next (entnext next))
     (setq next_data (entget next))
     (setq att_tag (cdr (assoc 2 next_data)))
     (cond
       ((eq (strcase "XCOORD") att_tag)
        (setq new_value (rtos (car point) 2 1)))
       ((eq (strcase "YCOORD") att_tag)
        (setq new_value (rtos (cadr point) 2 1)))
       ((eq (strcase "ZCOORD") att_tag)
        (setq new_value (rtos (caddr point) 2 1))))
     (entmod
       (subst (cons 1 new_value) (assoc 1 next_data) next_data))
     (entupd ent)
     )
   )
     (command "._zoom" "_e");by suit
     )
   (alert "Trouble with reading Excel data")
   )

 (setvar "osmode" osm)
 (setvar "cmdecho" 1)
 (princ)
 )

;; TesT : (C:PP)
(prompt "\n====================================\n")
(prompt "\n\t>>>\tType PP to execute ... \t>>>\n")
(prompt "\n====================================\n")
(prin1)

~'J'~

fatty u r done very good job but 1 probleam z valu takes one diget after point for that its take maxzimum 3 diget after point

October 31, 2007

Take a look at RTOS function in the Help file

~'J'~

October 31, 2007

Cheers, Fatty,

Just trying to boost my post count here:

rtos ......... Converts a number into a string

(rtos number [mode [precision]]) mode = 2 (decimal) precision = ?

October 31, 2007

Alan, sorry for the late

(rtos number [mode [precision]]) mode = 2 (decimal) precision = number of digits

say to display 3 digits it should :

(rtos SomeNumericVariable 2 3)

Thanks

~'J'~

November 1, 2007

thank u very much fatty u solve my problem once again

thanks

harshad:) :)

November 1, 2007

You're welcome

Cheers

~'J'~

March 22, 2009

thank...very useful to my part..

cheers

oliver

;; PP.lsp

;; read Excel, draw points in Acad as blocks with attributes

;; local defun

;; entmake block

(defun makepoint ()

(if (not (tblsearch "BLOCK" "POINT_ELEV"))

(progn

(initget 6)

(setq hgt (getreal "\n Enter text height of attribute : "))

(if (not hgt)

(setq hgt 2.5))

(entmake

(mapcar 'cons

(list 0 8 2 70 10 3)

(list "BLOCK" "0" "POINT_ELEV" 2 '(0 0 0) "POINT_ELEV")))

(entmake

(mapcar 'cons

(list 0 8 62 10 210 50)

(list "POINT" "0" 0 (list 0 0 0) '(0 0 1) 0.0)))

(entmake

(mapcar 'cons

(list 0 8 62 10 40 70 1 210 3 2)

(list "ATTDEF"

"0"

0

(list (/ hgt 2) (* hgt 2.5) 0)

2.5

9

"x"

'(0 0 1)

"Topo point X coordinate"

"XCOORD")))

(entmake

(mapcar 'cons

(list 0 8 62 10 40 70 1 210 3 2)

(list "ATTDEF"

"0"

0

(list (/ hgt 2) (* hgt 1.5) 0)

2.5

9

"y"

'(0 0 1)

"Topo point Y coordinate"

"YCOORD")))

(entmake

(mapcar 'cons

(list 0 8 62 10 40 70 1 210 3 2)

(list "ATTDEF"

"0"

6

(list (/ hgt 2) (/ hgt 2) 0)

2.5

8

"z"

'(0 0 1)

"Topo point Z coordinate"

"ZCOORD")))

(entmake

(mapcar 'cons

(list 0

(list "ENDBLK" "0"))))))

;; local defun

;; to read the Excel range

(defun EXR (FilePath ShtNum StrRange / ExcelApp ExcData Sht UsdRange Wbk)

;; based on function "EXD" from this page:

;; http://www.cadforyou.spb.ru/index.php?current_section=section_functions_page

(vl-load-com)

(setq ExcelApp (vlax-get-or-create-object "Excel.Application"))

(vla-put-visible ExcelApp :vlax-true) ; or :vlax-false if you want

(vlax-put-property ExcelApp 'DisplayAlerts :vlax-false)

(setq Wbk (vl-catch-all-apply

'vla-open

(list (vlax-get-property ExcelApp "WorkBooks") FilePath)

)

)

(setq Sht (vl-catch-all-apply

'vlax-get-property

(list (vlax-get-property Wbk "Sheets")

"Item"

ShtNum

)

)

)

(vlax-invoke-method Sht "Activate")

(setq UsdRange (vlax-get-property

(vlax-get-property Sht 'Cells)

"Range"

StrRange)

ExcData (vlax-safearray->list

(vlax-variant-value

(vlax-get-property UsdRange 'Value2)

)

)

)

(setq

ExcData (mapcar

(function (lambda (x) (mapcar 'vlax-variant-value x)))

ExcData

)

)

(vl-catch-all-apply

'vlax-invoke-method

(list Wbk "Close")

)

(vl-catch-all-apply

'vlax-invoke-method

(list ExcelApp "Quit")

)

(mapcar

(function

(lambda (x)

(vl-catch-all-apply

(function (lambda ()

(progn

(if (not (vlax-object-released-p x))

(progn

(vlax-release-object x)

(setq x nil)

)

)

)

)

)

)

)

)

(list UsdRange Sht Wbk ExcelApp)

)

(gc)

(gc)

ExcData

)

;; main part ;;

(defun C:PP (/ Att_Tag Ent Filepath Headflag New_Value Next Next_Data

Osm Poinlist Response Shtnum Strrange)

(or (vl-load-com))

(setq FilePath (getfiled "Select Excel file to read :"

(getvar "dwgprefix")

"xls"

16

)

)

(initget 6)

(setq ShtNum (getint "\nEnter the sheet number : "))

(if (not ShtNum)

(setq ShtNum 1))

(setq strRange (strcase

(getstring "\n Enter address of used range : ")))

(if (eq "" strRange)

(setq strRange "A1:C99"))

(initget "Yes No")

(setq Response (getkword

"\n Is the Excel table has the headers? (Y/N) : "))

(if (not Response)

(setq Response "Yes"))

(if (eq "Yes" Response)

(setq HeadFlag T)

(setq HeadFlag nil))

(setq PoinList (EXR FilePath ShtNum strRange))

(if HeadFlag

(setq PoinList (cdr PoinList)))

(if PoinList

(progn

(makepoint)

(if (not (tblsearch "BLOCK" "POINT_ELEV"))

(progn

(alert "Something wrong\nprogramm stopped")

(exit)

(princ)))

(setq osm (getvar "osmode"))

(setvar "cmdecho" 0)

(setvar "osmode" 0)

(foreach point PoinList

(command "._-insert" "POINT_ELEV" point 1 1 0)

(setq ent (entlast))

(setq next ent)

(while (setq next (entnext next))

(setq next_data (entget next))

(setq att_tag (cdr (assoc 2 next_data)))

(cond

((eq (strcase "XCOORD") att_tag)

(setq new_value (rtos (car point) 2 1)))

((eq (strcase "YCOORD") att_tag)

(setq new_value (rtos (cadr point) 2 1)))

((eq (strcase "ZCOORD") att_tag)

(setq new_value (rtos (caddr point) 2 1))))

(entmod

(subst (cons 1 new_value) (assoc 1 next_data) next_data))

(entupd ent)

)

)

(command "._zoom" "_e");by suit

)

(alert "Trouble with reading Excel data")

)

(setvar "osmode" osm)

(setvar "cmdecho" 1)

(princ)

)

;; TesT : (C:PP)

(prompt "\n====================================\n")

(prompt "\n\t>>>\tType PP to execute ... \t>>>\n")

(prompt "\n====================================\n")

(prin1)

any update instead of Z or elev..change into point labels or point numbering.

March 22, 2009

Are you sure you're not looking for something like this thread?

http://www.cadtutor.net/forum/showthread.php?t=34092

March 22, 2009

no its not...seems as what he did of "fixo" for harshad export from excel.

will i just found out another routine...try to found out what is this..but they are looking another files..

  ;; Internal error handler defined locally
 ;;
 (defun al_err (s)                   ; If an error (such as CTRL-C) occurs
                                     ; while this command is active...
   (if (/= s "Function cancelled")
     (princ (strcat "\nError: " s))
   )
   (if al_oe                         ; If an old error routine exists
     (setq *error* al_oe)            ; then, reset it 
   )
   (setq aliasi (close aliasi))
   (setvar "cmdecho" al_oce)         ; Reset command echoing on error
   (princ)
 )
 ;;
 ;; Body of alias function
 ;;
 (if *error*                         ; Set our new error handler
   (setq al_oe *error* *error* al_err) 
   (setq *error* al_err) 
 )

(DEFUN C:TOPO ()

(COMMAND "LAYER" "N" "SIGN" "C" "1" "SIGN" "")
(COMMAND "LAYER" "N" "LEVEL" "C" "7" "LEVEL" "")
(COMMAND "LAYER" "N" "PNT_CEN" "C" "7" "PNT_CEN" "")
(COMMAND "LAYER" "N" "PNT_NUM" "C" "2" "PNT_NUM" "")

(initget (+ 1 2 4))
(setq raz (getreal "Imenitelj razmere .........: "))
(initget (+ 1 2 4))
(setq fnt (getreal "Visina ispisa [mm] .........: "))
(setq oang (getreal "Zakosenje ispisa [dec. step.] ...: "))
(setq fnt (* fnt (/ raz 1000)))
;(setq dia (* fnt 1.25))
(setq dia (* fnt 0.)
;(setq dia fnt) ############## TP
;(setq dis (/ fnt 5))
(setq dis (/ fnt 4))
(setq dpn (/ fnt 4))
(setq imefnt "1")
(setq ffile "ROMANS")
(setq wfac 0.75)
(setq non "N")

(COMMAND "PDMODE" "32")
(COMMAND "PDSIZE" "0.125")

(COMMAND "STYLE")
(COMMAND imefnt)
(COMMAND ffile)
(COMMAND fnt)
(COMMAND wfac)
(COMMAND oang)
(COMMAND non)
(COMMAND non)
(COMMAND non)

 (setvar "CMDECHO" 0)
 (setq f (getfiled "Fajla tacaka" "" "*" 4))
 (setq fr (open f "r"))
 (setq k 0 Cr " " Row " ")

 (while (/= Row nil)
   (setq Row (read-line fr))
   (if (/= Row nil)
     (progn

       (SPC)

       (if (> k 1)
         (TRIMS)
       )

       (VALU)
       (setq Pn (substr Row 1 (- k 1)))
       (TRIMS)

       (SPC)
       (TRIMS)

       (VALU)
       (setq y (atof (substr Row 1 (- k 1))))
       (TRIMS)

       (SPC)
       (TRIMS)

       (VALU)
       (setq x (atof (substr Row 1 (- k 1))))
       (TRIMS)

       (if (= Cr " ")
         (progn
           (SPC)
           (TRIMS)
         )
       )

       (setq h nil s nil)
       (VALU)

       (if (> k 1)
         (progn
           (if (< (ascii (substr Row 1 1)) 58)
             (setq h (atof (substr Row 1 (- k 1))))
             (setq h nil s (substr Row 1 (- k 1)))
           )
         )
       )

       (TRIMS)

       (if (= Cr " ")
         (progn
           (SPC)
           (TRIMS)
         )
       )

       (if (and (= s nil) (/= (substr Row 1 1) ""))
         (progn
           (VALU)
           (setq s (substr Row 1 (- k 1)))
         )
       )

       (setq tc (list y x))
       (WRT)

       (if (/= h nil)
           (WRTH)
       )
       (if (/= s nil)
            (WRTS)
       )
     )
     (progn
       (COMMAND "LAYER" "S" "0" "")
       (COMMAND "ZOOM" "E" "")
       (prin1)
     )
   )
 )
 (close fr)
;  (close m)
)

(DEFUN SPC ()
 (setq k 0 Cr " ")
 (while (= Cr " ")
   (setq k (+ k 1))
   (setq Cr (substr Row k 1))
 )
)

(DEFUN VALU ()
 (setq k 0 Cr "&")
 (while (and (/= Cr " ") (/= Cr ""))
   (setq k (+ k 1))
   (setq Cr (substr Row k 1))
 )
)

(DEFUN TRIMS ()
 (setq tmp (substr Row k))
 (setq Row tmp)
)

(DEFUN WRT ()
 (if (/= s nil)
   (progn
     (if (or (= (strcase s) "P") (= (strcase s) "T"))
       (setq tn (list y (+ x fnt)))
       (setq tn (list y (+ x dpn)))
     )
   )
   (setq tn (list y (+ x dpn)))
 )
 (COMMAND "LAYER" "S" "PNT_CEN" "")
 (COMMAND "POINT" tc)
 (COMMAND "LAYER" "S" "PNT_NUM" "")
 (COMMAND "TEXT" "S" "1" "BC" tn "0" Pn)
)

(DEFUN WRTH ()
 (if (/= s nil)
   (progn
     (if (or (= (strcase s) "P") (= (strcase s) "T"))
       (setq tl (list (+ y fnt) x))
       (setq tl (list (+ y dis) x))
     )
   )
   (setq tl (list (+ y dis) x))
 )
 (setq hs (rtos h 2 2))
 (setq l (strlen hs))
 (setq hs (substr hs 1 l))

 (DEC)

 (setq p (- l k))
;  (cond ((= k l) (setq hs (strcat hs ".00")))
;        ((= (- l 1)) (setq hs (strcat hs "0")))
;  (progn
   (cond ((= p 0) (setq hs (strcat hs ".00")))
         ((= p 1) (setq hs (strcat hs "0")))
   )
;  )

 (COMMAND "LAYER" "S" "LEVEL" "")
 (COMMAND "TEXT" "S" "1" "TL" tl "0" hs)
)

(DEFUN WRTS ()
 (setq ts (list (- y (/ fnt 1.625)) x))
;  (setq ts (list (- y dis) x))
 (COMMAND "LAYER" "S" "SIGN" "")
 (if (= (strcase s) "T" )
   (TRG)
 )
 (if (= (strcase s) "P" )
   (TRP)
 )
 (if (and (/= (strcase s) "P") (/= (strcase s) "T"))
   (COMMAND "TEXT" "S" "1" "MR" ts "0" s)
 )
)

(DEFUN DEC ()
 (setq k 0 Cr "&" l (strlen hs))
 (while (and (< k l) (/= Cr "."))
   (setq k (+ k 1))
   (setq Cr (substr hs k 1))
 )
)

(DEFUN TRG ()
;  (setq a (/ (sqrt (/ (expt dia 2) 3)) 2))
 (setq a (sqrt (/ (expt dia 2) 3)))
 (setq b (* a (/ (sin 0.5236) (cos 0.5236))))
;  (setq b (* a (/ (sin 30) (cos 30))))
;  (setq b (* a (/ 1 (atan 0.5236))))
 (setq c (- dia b))
 (setq t1 (list (+ y a) (- x b)))
 (setq t2 (list (- y a) (- x b)))
 (setq t3 (list y (+ x c)))
 (COMMAND "LINE" t1 t2 t3 t1 "")
)

(DEFUN TRP ()
 (COMMAND "LAYER" "S" "SIGN" "")
 (COMMAND "CIRCLE" tc (/ dia 2))
)
(princ "..!")
(prompt "\rProgram se startuje sa TOPO\007")
(prin1)

Want Lisp For Input Data In Cad

Recommended Posts

harshad

Link to comment

Share on other sites

fixo

Link to comment

Share on other sites

harshad

Link to comment

Share on other sites

Guest Alan Cullen

Link to comment

Share on other sites

harshad

Link to comment

Share on other sites

harshad

Link to comment

Share on other sites

Guest Alan Cullen

Link to comment

Share on other sites

fixo

Link to comment

Share on other sites

fixo

Link to comment

Share on other sites

harshad

Link to comment

Share on other sites

harshad

Link to comment

Share on other sites

fixo

Link to comment

Share on other sites

Guest Alan Cullen

Link to comment

Share on other sites

fixo

Link to comment

Share on other sites

harshad

Link to comment

Share on other sites

fixo

Link to comment

Share on other sites

oliver

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

oliver

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity