Jump to content

Create Multileader with Arrowhead?

Dien nguyen

By Dien nguyen
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Dien nguyen Apprentice

Dien nguyen

Posted
Posted

I'm searching the forums for how to create multileader, I found the following lisp to create it but they don't have Arrowhead installed, I tried with parameter: '("ArrowSymbol"            . "LA-ARRW") , but it don't work. Can it be fixed? 

(defun CreateMLeaderStyle (CMS_NewName CMS_Config / CMS_TextStyle CMS_MLeaderStyles CMS_NewMLeaderStyle CMS_Property CMS_ColorObject)   
   (if
      (or
         (and
            (setq CMS_TextStyle (cdr (assoc "TextStyle" CMS_Config)))
            (tblsearch "STYLE" CMS_TextStyle)
         )
         (not (cdr (assoc "TextStyle" CMS_Config)))
      )
      (progn
         (setq CMS_MLeaderStyles (vla-item (vla-get-Dictionaries (vla-get-ActiveDocument (vlax-get-acad-object))) "ACAD_MLEADERSTYLE"))
         (if
            (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list CMS_MLeaderStyles CMS_NewName)))
            (progn
               (setq CMS_NewMLeaderStyle (vla-AddObject CMS_MLeaderStyles CMS_NewName "AcDbMLeaderStyle"))
               (if
                  (not (cdr (assoc "TextStyle" CMS_Config)))
                  (vla-put-TextStyle CMS_NewMLeaderStyle (getvar "TEXTSTYLE"))
               )
               (foreach CMS_Item CMS_Config
                  (if
                     (and
                        (vl-consp CMS_Item)
                        (= (type (setq CMS_Property (car CMS_Item))) 'STR)
                        (not (listp (cdr CMS_Item)))
                        (vlax-property-available-p CMS_NewMLeaderStyle CMS_Property)
                     )
                     (cond
                        (
                           (wcmatch (strcase CMS_Property) "*COLOR*")
                           (setq CMS_ColorObject  (vlax-get-property CMS_NewMLeaderStyle CMS_Property))
                           (vla-put-ColorIndex CMS_ColorObject (cdr CMS_Item))
                           (vl-catch-all-apply 'vlax-put-property (list CMS_NewMLeaderStyle CMS_Property CMS_ColorObject))
                        )
                        (
                           T
                           (vl-catch-all-apply 'vlax-put-property (list CMS_NewMLeaderStyle CMS_Property (cdr CMS_Item)))
                        )
                     )
                  )
               )
               (princ (strcat "\n ** Created " CMS_NewName " MLeader style"))
            )
             (princ "\n ** Error: MLeader style already exists")
         )
      )
      (princ "\n ** Error: textstyle does not exist")
   )
   (princ)
)

;MLeaderLandingDistance
(defun MLeaderLandingDistance ( sty flg / dic )
   (and (setq dic (dictsearch (namedobjdict) "acad_mleaderstyle"))
        (setq dic (dictsearch (cdr (assoc -1 dic)) sty))
        (entmod (subst (cons 43 ((if flg + -) (abs (cdr (assoc 43 dic))))) (assoc 43 dic) dic))
   )
)

(defun c:MMN ()

    (setq  txt 	  (tblsearch "style" "L-ARIAL")
    )
	(if (null txt)
	      (progn
		  (command "_-style"	"L-ARIAL"	"Arial.ttf"	"0.0"	"1.0"	"0"	""	"")
	      )
	  )


   (CreateMLeaderStyle "L-TAG-TEXT"
      (list 
         '("ArrowSize"               . 2)
         '("ArrowSymbol"            . "Dot")
         '("DoglegLength"            . 3)
         '("LandingGap"              . 1)
         '("LeaderLineColor"         . 256)
         (cons "ScaleFactor"         1)
         '("TextColor"               . 256)
         '("TextHeight"              . 2)
         '("TextLeftAttachmentType"  . 1)
         '("TextRightAttachmentType" . 1)
         '("TextStyle"               . "L-ARIAL")
      )
   )

   (princ)
(command "cmleaderstyle" "L-TAG-TEXT")
;;;;;;====================================

(MLeaderLandingDistance (getvar 'cmleaderstyle) nil)
)

 

Dien nguyen Apprentice

Dien nguyen

Posted
  • Author
Posted (edited)

I find another way to create multileader in lisp below, but how find another properties in multileader such as landing distance, color?
  

(defun c:MM ()
	(style "L-TAG-SHRUBS" 2)	  
	(MLeaderLandingDistance (getvar 'cmleaderstyle) t)
)

(defun style (styleName asize)

	(setq txt (tblsearch "style" "L-ARIAL"))
	(if (null txt)
	  (progn
		(command "_-style" "L-ARIAL" "Arial.ttf" "0.0" "1.0" "0" "" "")
	  )
	)

	(setq newleaderstyle (vla-AddObject (vla-item (vla-get-Dictionaries (vla-get-ActiveDocument (vlax-get-acad-object))) "ACAD_MLEADERSTYLE") stylename "AcDbMLeaderStyle"))
		(vla-put-ArrowSymbol newleaderstyle "KL-ARRW")
		(vla-put-ArrowSize newleaderstyle asize)
		(vla-put-TextLeftAttachmentType newleaderstyle "1")
		(vla-put-TextRightAttachmentType newleaderstyle "1")
		(vla-put-TextStyle newleaderstyle "L-ARIAL")
		(vla-put-TextHeight newleaderstyle "2")
	(command "cmleaderstyle" styleName)
)

 

Edited by Dien nguyen
lido Enthusiast

lido

Posted
Posted

Try this: 

;;Draw leader and text inside circle
(DEFUN C:LEADBBL  (/ 
                    *error*
                    _Common
                    _Getkword
                    ACD
                    BOX
                    C67 CLA CTB
                    DIA DIC DIS DMC DMH DMS DMY DSO
                    FDS FIL
                    LDI
                    POS PT1 PT2 PT3 PTE PTW
                    RAD RGT
                    SRT
                    TXT
                  )

  (defun *error* (s)
    (if (and PT2 (not PT3)) (redraw))
    (if (and ACD DSO DMS) (vla-put-activedimstyle ACD (vla-item DIC DMS)))
    (if DIC (vlax-release-object DIC))
    (if ACD (vlax-release-object ACD))
    (or (wcmatch (strcase s) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\nError: " s)))
    (princ)
  )

  (defun _Common (nume)
    (mapcar
      (function cons)
      (quote (0      100      67  410  8))
      (list nume "AcDbEntity" C67 CTB CLA)
    )
  )

  (defun _Getkword (Ini Def Esc Msg / lies lopt noli stop)
    (prompt Msg)
    (setq   lies  (list (quote (2 13)) (quote (2 32)))
            Ini   (mapcar (function (lambda (x) (list 2 (ascii x)))) Ini)
    )
    (while (not stop)
      (setq   noli  (vl-catch-all-error-p (setq lopt (vl-catch-all-apply (function grread) (list nil 8))))
              stop  (cond
                      ( noli Esc)
                      ( (or (= (car lopt) 25) (vl-position lopt lies)) Def)
                      ( (vl-position lopt Ini) (princ (chr (cadr lopt))))
                      ( T (if (= (car lopt) 2) (princ (chr (cadr lopt)))) (prompt (strcat "\nInvalid option." Msg)))
                    )
      )
    )
    (strcase stop)
  )

  (setq   CTB (if (= (getvar "CVPORT") 1) (getvar "CTAB") "Model")
          C67 (if (= CTB "Model") 0 1)
          CLA (getvar "CLAYER")
          DMS (getvar "DIMSTYLE")
          ACD (vla-get-activedocument (vlax-get-acad-object))
          DIC (vla-get-dimstyles ACD)
          FIL (vl-filename-mktemp (substr (rtos (getvar "CDATE") 2 8) 10) nil ".tmp")
  )
  (vlax-for itm DIC (setq LDI (cons (vla-get-name itm) LDI)))
  (setq LDI (acad_strlsort LDI))

  (if
    (= (_Getkword (quote ("n" "N" "y" "Y")) "N" "N" (strcat "\nCurrent Dimension Style \"" DMS "\" settings will be used. Select another Dimension Style [Yes/No] <No>: ")) "Y")
    (if (setq FDS (open FIL "w"))
      (progn
        (write-line
          (strcat
            "DimStyle:dialog{label=\"Dimension Style selection\";initial_focus=\"Dims\";:row{:boxed_row{label=\"Available Dimension Styles\";:list_box{key=\"Dims\";height=8;width="
            (itoa (+ (apply (function max) (mapcar (function strlen) LDI)) 2))
            ";}}:column{alignment=bottom;fixed_height=true;:button{label=\"&OK\";key=\"DoIt\";is_default=true;width=14;fixed_width=true;height=2;}:spacer{height=0.25;}:button{label=\"&Cancel\";key=\"Cancel\";is_cancel=true;width=14;fixed_width=true;height=2;}}}}"
          )
          FDS
        )
        (setq   FDS (close FDS)
                DIA (load_dialog FIL)
                POS (itoa (vl-position DMS LDI))
        )
        (new_dialog "DimStyle" DIA)
        (start_list "Dims")
        (foreach el LDI (add_list el))
        (end_list)
        (set_tile "Dims" POS)
        (action_tile "Dims"   "(setq POS $value)")
        (action_tile "DoIt"   "(done_dialog 1)")
        (action_tile "Cancel" "(done_dialog 0)")
        (setq SRT (start_dialog))
        (unload_dialog DIA)
        (vl-file-delete FIL)
        (if (and (= SRT 1) (/= (vl-position DMS LDI) (atoi POS)))
          (progn
            (setq DSO (nth (atoi POS) LDI))
            (vla-put-activedimstyle ACD (vla-item DIC DSO))
          )
        )
      )
      (alert (strcat "Unable to write data to folder \"" (vl-filename-directory FIL)  "\". Current Dimension Style \""  DMS "\" settings will be used."))
    )
  )

  (setq   DMC (getvar "DIMCLRD")
          DMH (getvar "DIMTXT")
          DMY (getvar "DIMTXSTY")
  )
  (initget 1)
  (setq PT1 (getpoint "\nLeader start  point: "))
  (initget 1)
  (setq PT2 (getpoint PT1 "\nLeader second point: "))
  (grdraw PT1 PT2 (if (vl-position DMC (quote (0 256))) (vla-get-color (vla-item (vla-get-layers ACD) CLA)) DMC))
  (initget 1)
  (setq   PT3 (getpoint PT2 "\nX coordinate of the Leader last point: ")
          DIS (distance PT2 (list (car PT3) (cadr PT2) (caddr PT2)))
          PTE (polar PT2 0  DIS)
          PTW (polar PT2 pi DIS)
          RGT (< (car PT2) (car PT3))
  )
  (redraw)

  (entmake
    (append
      (_Common "LEADER")
      (list
        (cons 62 DMC)
        (quote (100 . "AcDbLeader"))
        (cons 3  (cond (DSO) (DMS)))
        (cons 10 PT1)
        (cons 10 PT2)
        (cons 10 (if RGT PTE PTW))
      )
    )
  )

  (if
    (and
      (setq TXT (getstring T "\nAnnotation text: "))
      (vl-remove 32 (vl-string->list TXT))
    )
    (progn
      (setq   BOX (textbox (list (cons 1 TXT) (cons 7 DMY) (cons 40 DMH)))
              RAD (fix (+ 0.5 (max 0.5 (* 0.9 DMH) (* 0.525 (distance (car BOX) (cadr BOX))))))
              PT1 (if RGT (polar PTE 0 RAD) (polar PTW pi RAD))
      )
      (entmake
        (append
          (_Common "CIRCLE")
          (list
            (cons 62 DMC)
            (quote (100 . "AcDbCircle"))
            (cons 10 PT1)
            (cons 40 RAD)
          )
        )
      )
      (entmake
        (append
          (_Common "TEXT")
          (list
            (cons 62 (getvar "DIMCLRT"))
            (quote (100 . "AcDbText"))                                    
            (cons 10 PT1)
            (cons 40 DMH)
            (cons 1 TXT)
            (quote (50 . 0.))
            (cons 41 (vla-get-width (vla-item (vla-get-textstyles ACD) DMY)))
            (quote (51 . 0.))
            (cons 7 DMY)
            (quote (71 . 0))
            (quote (72 . 1))
            (cons 11 PT1)
            (quote (73 . 2))
          )
        )
      )
    )
  )

  (if DSO (vla-put-activedimstyle ACD (vla-item DIC DMS)))
  (vlax-release-object DIC)
  (vlax-release-object ACD)
  (princ)
) ;;C:LEADBBL

 

  • Like 2

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...