Dear Experts,
I have a Lisp code that needs to be converted into Excel VBA code.
I have a Lisp code that needs to be converted into Excel VBA code.
Code:
(vl-load-com); load activex support
(defun C:CLabel (/ askString askReal initialize finish get_pline_vertices divide_selection get_crossing_points draw_text ; local functions
savDimzin savTextStyle savLayer ss ssAll ssH ssV dimscl gspace autoS)
(defun askString (msg def / ask)
(initget "Yes No")
(if (not (setq ask (getkword (strcat "\n" msg " <" def ">: "))) )
(setq ask def)
(setq def ask)
)
); askstring
(defun askReal (msg def / ask)
(initget (+ 2 4))
(if (not (setq ask (getreal (strcat "\n" msg " <" (rtos def 2) ">: "))))
(setq ask def)
(setq def ask)
)
); askreal
(defun initialize ()
(setvar "cmdecho" 0)
(command "._undo" "_begin")
(setq savDimzin (getvar "dimzin"))
(setvar "dimzin" 0)
(setq savTextStyle (getvar "textstyle"))
(if (not (tblsearch "style" "arial"))
(command "._style" "arial" "arial" 0 1 0 "n" "n")
(command "._textstyle" "arial")
)
(setq savLayer (getvar "clayer"))
(foreach lay '("grid" "grid-text")
(if (not (tblsearch "layer" lay))
(command "._layer" "_make" lay "")
)
)
(if (= (getvar "userr3") 0.0)
(setvar "userr3" 250.0)
)
(setq dimscl (getvar "dimscale"))
); initialize
(defun finish ()
; restore vars
(setvar "clayer" savLayer)
(command "._textstyle" savTextStyle)
(setvar "dimzin" savDimzin)
(command "._undo" "_end")
(setvar "cmdecho" 1)
); finish
(defun get_pline_vertices (ename / expand_pline ; local function
plineObj1 offset^ edata vertices^)
; expand pline outside more 10 units
; this would make sure all hatch lines would be auto selected
(defun expand_pline (/ offset_pline ; local function
plineObj0)
(defun offset_pline (dist)
(vlax-safearray->list
(vlax-variant-value
(vla-offset plineObj0 dist)
)
)
); setq
(setq plineObj0 (vlax-ename->vla-object ename))
(setq plineObj1 (car (setq offset^ (offset_pline 10))))
(if (< (vlax-curve-getArea plineObj1)
(vlax-curve-getArea plineObj0))
(progn
(foreach pl offset^
(vla-delete pl)
(vlax-release-object pl)
)
(setq plineObj1 (car (setq offset^ (offset_pline -10))))
); progn
); if
(vlax-release-object plineObj0)
); expand_pline
(expand_pline)
(setq edata (entget (vlax-vla-object->ename plineObj1)))
(setq vertices^
(vl-remove-if
'not
(mapcar
'(lambda (item)
(if (= (car item) 10)
(cdr item)
)
); lambda
edata
); mapcar
); vl-remove-if
)
(foreach pl offset^
(vla-delete pl)
(vlax-release-object pl)
)
vertices^
); get_pline_vertices
(defun divide_selection (/ is_ortho ; local function
ang)
(defun is_ortho (ent / elist p10 p11)
(setq elist (entget ent))
(setq p10 (cdr (assoc '10 elist)))
(setq p11 (cdr (assoc '11 elist)))
(cond
((equal (cadr p10) (cadr p11) 1e-9)
0.0
)
((equal (car p10) (car p11) 1e-9)
90.0
)
( t
nil
)
); cond
); is_ortho
(setq ssH (ssadd) ssV (ssadd))
(foreach ename0 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssAll)))
(if (setq ang (is_ortho ename0))
(if (= ang 0.0)
(ssadd ename0 ssH)
(ssadd ename0 ssV)
); if
); if
); foreach
); divide_selection
(defun get_crossing_points (/ AcDbLine1 AcDbLine2 lst)
(foreach ename1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssH)))
(setq AcDbLine1 (vlax-ename->vla-object ename1))
(foreach ename2 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssV)))
(setq AcDbLine2 (vlax-ename->vla-object ename2))
(if (setq c0 (vlax-invoke AcDbline1 'intersectwith AcDbLine2 acExtendNone))
(setq lst (cons c0 lst))
)
(vlax-release-object AcDbLine2)
); foreach
(vlax-release-object AcDbLine1)
); foreach
lst
); get_crossing_points
(defun draw_text (pt hgt ang text)
(entmake
(list
'(0 . "TEXT")
'(100 . "AcDbText")
'(71 . 0)
'(72 . 0)
'(73 . 0)
(cons '10 pt)
(cons '40 hgt)
(cons '50 ang)
(cons '1 text)
); list
); entmake
); draw_text
; here start command
(initialize)
(if (and
(setvar "users3" (setq autoS (askString "Auto select grid lines" "Yes")))
(setvar "userr3" (setq gspace (askReal "Specify spacing between grid lines" (getvar "userr3"))))
(setq ss (ssget "_:S:E+." '((0 . "lwpolyline"))))
)
(progn
(setq savSnapbase (getvar "snapbase"))
(command "._snapbase" '(0.0 0.0))
(setvar "clayer" "grid")
(command "._hatch" "_U" 0 gspace "_yes" "_si" "_None" (ssname ss 0))
(command "._explode" "_last")
(if (eq autoS "Yes")
(setq ssAll (ssget "_wp" (get_pline_vertices (ssname ss 0)) '((0 . "line") (8 . "grid"))))
(setq ssAll (ssget '((0 . "line") (8 . "grid"))))
); if
(if (and ssAll (> (sslength ssAll) 0))
(progn
(divide_selection)
(setvar "clayer" "grid-text")
(foreach c0 (get_crossing_points)
(draw_text (list (+ (car c0) (* 2.0 dimscl)) (+ (cadr c0) (* 0.5 dimscl)) 0.0) (* 2.5 dimscl) 0.0 (strcat "N" (rtos (cadr c0) 2 0)))
(draw_text (list (+ (car c0) (* 0.5 dimscl)) (- (cadr c0) (* 2.0 dimscl)) 0.0) (* 2.5 dimscl) (* pi 1.5) (strcat "E" (rtos (car c0) 2 0)))
); foreach
); progn
); progn
(command "._snapbase" savSnapbase)
); progn
); if
(finish)
(princ)
); C:Clabel