18.01.2025 11:34    

baha07
$TEXTSIZE buradan yuksekligi istedigim yukseklik ile degistirdim . duzeldi .


Alıntı
baha07 :
merhabalar
elimde iki text arasindaki farki cikarip aradaki farki istedigim yere ekranda text olarak yazdiran bir lisp var . isimi goruyor .
sormak istedigim bu farki yeni text olarak yazdirirken ,bazi calistigim projelerde text yuksekligini farkli yapiyor .
bu fark hangi ayardan kaynaklaniyor buladim . hangi ayar oldugu konusunda bana yardimci olabilecek var mi ?
ornek dosyalari ekledim
Kod:

; secilen textler arasinda 4 islem yapip  ekrana yeni text olarak yazdirir
; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-to-subtract-2-given-mtexts/td-p/5131450
(defun c:AV (/) (c:CombineValues))
(defun c:CombineValues (/ *error* AT:ExtractNumbers AT:Str2Lst AT:MText AT:Entsel AT:ListSelect
                        CV:StripFormat _sel dZin f i obj num nStr final pt
                       )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SUBROUTINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; error handler
  (defun *error* (msg)
    (and dZin (setvar 'dimzin dZin))
    (and msg
         (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*"))
         (princ (strcat "\nError: " msg))
    )
  )
;;; Extract numbers from string
;;; #String - String to extract numbers from
;;; Required Subroutines: AT:Str2Lst
;;; Alan J. Thompson, 11.13.09 / 04.08.10
  (defun AT:ExtractNumbers (Str / i l)
    (setq i -1)
    (mapcar
      (function atof)
      (AT:Str2Lst
        (vl-list->string
          (mapcar
            (function (lambda (x)
                        (setq i (1+ i))
                        (cond ;; number
                              ((< 47 x 58) x)
                              ;; - and number following
                              ((and (eq x 45) (< 47 (nth (1+ i) l) 58)) x)
                              ;; . and follows a number
                              ((and (eq x 46) (not (minusp (1- i))) (< 47 (nth (1- i) l) 58)) x)
                              (t 32)
                        )
                      )
            )
            (setq l (vl-string->list (vl-princ-to-string Str)))
          )
        )
        " "
      )
    )
  )
;;; Convert string to list, based on separator
;;; #Str - String to convert
;;; #Sep - Separator to break string into items
;;; Ex. - (AT:Str2Lst "1,2,3" ",") -> '("1" "2" "3")
;;; Alan J. Thompson, 11.11.09
  (defun AT:Str2Lst (#Str #Sep / #Inc #List #Str)
    (while (setq #Inc (vl-string-search #Sep #Str))
      (setq #List (cons (substr #Str 1 #Inc) #List))
      (setq #Str (substr #Str (+ 2 #Inc)))
    ) ;_ while
    (vl-remove "" (append (reverse #List) (list #Str)))
  ) ;_ defun
;;; Add MText to drawing
;;; Pt - MText insertion point
;;; Str - String to place in created MText object
;;; Wd - Width of MText object (if nil, will be 0 width)
;;; Lay - Layer to place Mtext object on (nil for current)
;;; Jus - Justification # for Mtext object
;;;       1 or nil= TopLeft
;;;       2= TopCenter
;;;       3= TopRight
;;;       4= MiddleLeft
;;;       5= MiddleCenter
;;;       6= MiddleRight
;;;       7= BottomLeft
;;;       8= BottomCenter
;;;       9= BottomRight
;;; Alan J. Thompson, 05.23.09 / 04.09.10
  (defun AT:MText (Pt Str Wd Lay Jus / Wd s o)
    (or Wd (setq Wd 0.))
    (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
    (setq s  (if (or (eq acmodelspace (vla-get-activespace *AcadDoc*))
                     (eq :vlax-true (vla-get-mspace *AcadDoc*))
                 )
               (vla-get-modelspace *AcadDoc*)
               (vla-get-paperspace *AcadDoc*)
             )
          Pt (cond ((vl-consp Pt) (vlax-3d-point Pt))
                   ((eq (type Pt) 'variant) Pt)
             )
    )
    (vla-put-lock (vlax-ename->vla-object (tblobjname "layer" (getvar 'clayer))) :vlax-false)
    (setq o (vla-addMText s Pt Wd (vl-princ-to-string Str)))
    (and Lay (tblsearch "layer" Lay) (vla-put-layer o Lay))
    (cond ((vl-position Jus '(1 2 3 4 5 6 7 8 9))
           (vla-put-AttachmentPoint o Jus)
           (vla-put-InsertionPoint o Pt)
          )
    )
    o
  )
;;; Entsel or NEntsel with options
;;; #Nested - Entsel or Nentsel (T for Nentsel, nil for Entsel)
;;; #Message - Selection message (if nil, "\nSelect object: " is used)
;;; #FilterList - DXF ssget style filtering (nil if not required)
;;;               "V" as first item in list to convert object to VLA-OBJECT (must be in list if no DXF filtering)
;;;               "L" as first item in list to ignore locked layers (must be in list if no DXF filtering)
;;; #Keywords - Keywords to match instead of object selection (nil if not required)
;;; Example: (AT:Entsel nil "\nSelect MText not on 0 layer [Settings]: " '("LV" (0 . "MTEXT")(8 . "~0")) "Settings")
;;; Example: (AT:Entsel T "\nSelect object [Settings]: " '("LV") "Settings")
;;; Alan J. Thompson, 04.16.09
;;; Updated: Alan J. Thompson, 06.04.09 (changed filter coding to work as ssget style dxf filtering)
;;; Updated: Alan J. Thompson, 09.07.09 (added option to ignore locked layers and convert object to VLA-OBJECT
;;; Updated: Alan J. Thompson, 09.18.09 (fixed 'missed pick' alert)
  (defun AT:Entsel (#Nested #Message #FilterList #Keywords / #Count #Message #Choice #Ent
                    #VLA&Locked #FilterList
                   )
    (vl-load-com)
    (setvar "errno" 0)
    (setq #Count 0)
    ;; fix message
    (or #Message (setq #Message "\nSelect object: "))
    ;; set entsel/nentsel
    (if #Nested
      (setq #Choice nentsel)
      (setq #Choice entsel)
    ) ;_ if
    ;; check if option to convert to vla-object or ignore locked layers in #FilterList variable
    (and (vl-consp #FilterList)
         (eq (type (car #FilterList)) 'STR)
         (setq #VLA&Locked (car #FilterList)
               #FilterList (cdr #FilterList)
         ) ;_ setq
    ) ;_ and
    ;; select object
    (while (and (not #Ent) (/= (getvar "errno") 52))
      ;; if keywords
      (and #Keywords (initget #Keywords))
      (cond
        ((setq #Ent (#Choice #Message))
         ;; if ignore locked layers
         (and
           #VLA&Locked
           (vl-consp #Ent)
           (wcmatch (strcase #VLA&Locked) "*L*")
           (not (zerop (cdr (assoc 70
                                   (entget (tblobjname "layer" (cdr (assoc 8 (entget (car #Ent))))) ;_ tblobjname
                                   ) ;_ entget
                            ) ;_ assoc
                       ) ;_ cdr
                ) ;_ zerop
           ) ;_ not
           (setq #Ent nil
                 #Flag T
           ) ;_ setq
         ) ;_ and
         ;; #FilterList check
         (if (and #FilterList (vl-consp #Ent))
           ;; process filtering from #FilterList
           (or
             (not
               (member
                 nil
                 (mapcar '(lambda (x)
                            (wcmatch
                              (strcase (vl-princ-to-string (cdr (assoc (car x) (entget (car #Ent))))) ;_ vl-princ-to-string
                              ) ;_ strcase
                              (strcase (vl-princ-to-string (cdr x)))
                            ) ;_ wcmatch
                          ) ;_ lambda
                         #FilterList
                 ) ;_ mapcar
               ) ;_ member
             ) ;_ not
             (setq #Ent nil
                   #Flag T
             ) ;_ setq
           ) ;_ or
         ) ;_ if
        )
      ) ;_ cond
      (and (or (= (getvar "errno") 7) #Flag)
           (/= (getvar "errno") 52)
           (not #Ent)
           (setq #Count (1+ #Count))
           (prompt (strcat "\nNope, keep trying!  " (itoa #Count) " missed pick(s).") ;_ strcat
           ) ;_ prompt
      ) ;_ and
    ) ;_ while
    (if (and (vl-consp #Ent) #VLA&Locked (wcmatch (strcase #VLA&Locked) "*V*")) ;_ and
      (vlax-ename->vla-object (car #Ent))
      #Ent
    ) ;_ if
  ) ;_ defun
;list select dialog
;create a temp DCL multi-select list dialog from provided list
;value is returned in list form, DCL file is deleted when finished
;example: (setq the_list (AT:listselect "This is my list title" "Select items to make a list" "25" "30" "true" (list "object 1" "object 2" "object 3"))
;if mytitle is longer than defined width, the width will be ignored and it will fit to title string
;if mylabel is longer than defined width, mylabel will be truncated
;myheight and mywidth must be strings, not numbers
;mymultiselect must either be "true" or "false" (true for multi, false for single)
;created by: alan thompson, 9.23.08
;some coding borrowed from http://www.jefferypsanders.com (thanks for the DCL examples)
  (defun AT:ListSelect (mytitle ;title for dialog box
                        mylabel ;label right above list box
                        myheight ;height of dialog box !!*MUST BE STRING*!!
                        mywidth ;width of dialog box !!*MUST BE STRING*!!
                        mymultiselect ;"true" for multiselect, "false" for single select
                        mylist ;list to display in list box
                        / retlist readlist count item savevars fn fo valuestr dcl_id
                       )
    (defun saveVars (/ readlist count item)
      (setq retList (list))
      (setq readlist (get_tile "mylist"))
      (setq count 1)
      (while (setq item (read readlist))
        (setq retlist (append retList (list (nth item myList))))
        (while
          (and
            (/= " " (substr readlist count 1))
            (/= "" (substr readlist count 1))
          )
           (setq count (1+ count))
        )
        (setq readlist (substr readlist count))
      )
    ) ;defun
    (setq fn (vl-filename-mktemp "" "" ".dcl"))
    (setq fo (open fn "w"))
    (setq valuestr (strcat "value = "" mytitle "";"))
    (write-line (strcat "list_select : dialog {
            label = "" mytitle "";") fo)
    (write-line
      (strcat
        "          : column {
            : row {
              : boxed_column {
               : list_box {
                  label ="" mylabel
        "";
                  key = "mylist";
                  allow_accept = true;
                  height = " myheight ";
                  width = " mywidth ";
                  multiple_select = " mymultiselect
        ";
                  fixed_width_font = false;
                  value = "0";
                }
              }
            }
            : row {
              : boxed_row {
                : button {
                  key = "accept";
                  label = " Okay ";
                  is_default = true;
                }
                : button {
                  key = "cancel";
                  label = " Cancel ";
                  is_default = false;
                  is_cancel = true;
                }
              }
            }
          }
}"     )
      fo
    )
    (close fo)
    (setq dcl_id (load_dialog fn))
    (new_dialog "list_select" dcl_id)
    (start_list "mylist" 3)
    (mapcar 'add_list myList)
    (end_list)
    (action_tile "cancel" "(setq ddiag 1)(done_dialog)")
    (action_tile "accept" "(setq ddiag 2)(saveVars)(done_dialog)")
    (start_dialog)
    (if (= ddiag 1)
      (setq retlist nil)
    )
    (unload_dialog dcl_id)
    (vl-file-delete fn)
    retlist
  ) ;defun
  ;;  StripFormat as taken (with permission) from the following:
  ;;  StripMtext Version 5.0b for AutoCAD 2000 and above
  ;;  Copyright© Steve Doman and Joe Burke 2010
  ;; Location: http://www.theswamp.org/index.php?topic=31584.0
  ;; Arguments:
  ;; str - an mtext string.
  ;; formats - a list of format code strings or a string.
  ;; Format code arguments are not case sensitive.
  ;; Examples:
  ;; Remove Font, Overline and Underline formatting.
  ;; (StripFormat <mtext string> (list "f" "O" "U"))
  ;; Or a quoted list:
  ;; (StripFormat <mtext string> '("f" "O" "U"))
  ;; Or a string:
  ;; (StripFormat <mtext string> "fOU")
  ;; Remove all formatting except Overline and Underline.
  ;; (StripFormat <mtext string> (list "*" "^O" "^U"))
  ;; Or a quoted list:
  ;; (StripFormat <mtext string> '("*" "^O" "^U"))
  ;; Or a string:
  ;; (StripFormat <mtext string> "*^O^U")
  ;; Available codes:
  ;; A (^A) - Alignment
  ;; B (^B) - taBs
  ;; C (^C) - Color
  ;; F (^F) - Font
  ;; H (^H) - Height
  ;; L (^L) - Linefeed (newline, line break, carriage return)
  ;; O (^O) - Overline
  ;; Q (^Q) - obliQuing
  ;; P (^P) - Paragraph (embedded justification, line spacing and indents)
  ;; S (^S) - Stacking
  ;; T (^T) - Tracking
  ;; U (^U) - Underline
  ;; W (^W) - Width
  ;; ~ (^~) - non-breaking space
  ;; * - all formats
  (defun CV:StripFormat (str formats / FormatsToList text slashflag lbrace rbrace RE:Replace
                         RE:Execute Alignment Tab Color Font Height Linefeed Overline Paragraph
                         Oblique Stacking Tracking Underline Width Braces HardSpace
                        )
    ;; Argument: either a list of strings or a string.
    ;; Given a list, ensure formats are uppercase.
    ;; Given a formats string, convert it to a list of uppercase strings.
    ;; Examples: (FormatsToList "fOU") > ("F" "O" "U")
    ;;           (FormatsToList "f^OU") > ("F" "^O" "U")
    (defun FormatsToList (arg / lst)
      (cond ((= (type arg) 'LIST) (mapcar 'strcase arg))
            ((= (type arg) 'STR)
             (while (not (eq "" (substr arg 1)))
               (if (eq "^" (substr arg 1 1))
                 (setq lst (cons (strcat "^" (substr arg 2 1)) lst)
                       arg (substr arg 3)
                 )
                 (setq lst (cons (substr arg 1 1) lst)
                       arg (substr arg 2)
                 )
               )
             )
             (mapcar 'strcase (reverse lst))
            )
      )
    ) ; end FormatsToList
    (setq formats (FormatsToList formats))
    ;; Access the RegExp object from the blackboard.
    ;; Thanks to Steve for this idea.
    (or (vl-bb-ref '*REX*) (vl-bb-set '*REX* (vlax-create-object "VBScript.RegExp")))
    (defun RE:Replace (newstr pat string)
      (vlax-put (vl-bb-ref '*REX*) 'Pattern pat)
      (vlax-put (vl-bb-ref '*REX*) 'Global actrue)
      (vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse)
      (vlax-invoke (vl-bb-ref '*REX*) 'Replace string newstr)
    ) ;end
    (defun RE:Execute (pat string / result match idx lst)
      (vlax-put (vl-bb-ref '*REX*) 'Pattern pat)
      (vlax-put (vl-bb-ref '*REX*) 'Global actrue)
      (vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse)
      (setq result (vlax-invoke (vl-bb-ref '*REX*) 'Execute string))
      (vlax-for x result
        (setq match (vlax-get x 'Value)
              idx   (vlax-get x 'FirstIndex)
              ;; position within string - zero based - first position is zero
              lst   (cons (list match idx) lst)
        )
      )
      lst
    ) ;end
    ;; Replace linefeeds using this format "\n" with the AutoCAD
    ;; standard format "\P". The "\n" format occurs when text is
    ;; copied to ACAD from some other application.
    (setq str (RE:Replace "\\P" "\\n" str))
;;;;; Start remove formatting sub-functions ;;;;;
    ;; A format
    (defun Alignment (str) (RE:Replace "" "\\\\A[012];" str))
    ;; B format (tabs)
    (defun Tab (str / lst origstr tempstr)
      (setq lst (RE:Execute "\\\\P\\t|[0-9]+;\\t" str))
      (foreach x lst
        (setq origstr (car x)
              tempstr (RE:Replace "" "\\t" origstr)
              str     (vl-string-subst tempstr origstr str)
        )
      )
      (RE:Replace " " "\\t" str)
    )
    ;; C format
    (defun Color (str)
      ;; True color and color book integers are preceded
      ;; by a lower case "c". Standard colors use upper case "C".
      (RE:Replace "" "\\\\[Cc][0-9]?[.]?[0-9]+;" str)
    )
    ;; F format
    (defun Font (str) (RE:Replace "" "\\\\[Ff].*?;" str))
    ;; H format
    (defun Height (str)
      (RE:Replace "" "\\\\H[0-9]?[.]?[0-9]+x;" str)
      ;; This also works, but it's not as clear as the above.
      ;; (RE:Replace "" "\\\\H\\d\\.?\\d*x;" str)
    )
    ;; L format
    ;; Leading linefeeds are not converted to spaces.
    (defun Linefeed (str / teststr)
      ;; Remove formatting from test string other than linefeeds.
      ;; Seems there's no need to check for stacking
      ;; because a linefeed will always come before stack formatting.
      (setq teststr (Alignment str)
            teststr (Color teststr)
            teststr (Font teststr)
            teststr (Height teststr)
            teststr (Overline teststr)
            teststr (Paragraph teststr)
            teststr (Oblique teststr)
            teststr (Tracking teststr)
            teststr (Underline teststr)
            teststr (Width teststr)
            teststr (Braces teststr)
      )
      ;; Remove leading linefeeds.
      (while (eq "\\P" (substr teststr 1 2))
        (setq teststr (substr teststr 3)
              str     (vl-string-subst "" "\\P" str)
        )
      )
      (RE:Replace " " " \\\\P|\\\\P |\\\\P" str)
    )
    ;; O format
    (defun Overline (str) (RE:Replace "" "\\\\[Oo]" str))
    ;; This option is effectively the same as the Remove Formatting >
    ;; Remove Paragraph Formatting option avaiable in the 2008 Mtext editor.
    (defun Paragraph (str) (RE:Replace "" "\\\\p.*?;" str))
    ;; Q format - numeric value may be negative.
    (defun Oblique (str)
      ;; Any real number including negative values.
      (RE:Replace "" "\\\\Q[-]?[0-9]*?[.]?[0-9]+;" str)
    )
    ;; S format
    (defun Stacking (str / lst tempstr pos origstr teststr testpos numcheck)
      (setq lst (RE:Execute "\\\\S(.*?)(\\;)" str))
      (foreach x lst
        (setq tempstr (car x)
              pos     (cadr x)
              origstr tempstr
        )
        ;; Remove formatting from test string other than stacking.
        (setq teststr (Alignment str)
              teststr (Color teststr)
              teststr (Font teststr)
              teststr (Height teststr)
              teststr (Linefeed teststr)
              teststr (Overline teststr)
              teststr (Paragraph teststr)
              teststr (Oblique teststr)
              teststr (Tracking teststr)
              teststr (Underline teststr)
              teststr (Width teststr)
              teststr (Braces teststr)
        )
        ;; Remove all "{" characters if present. Added JB 2/1/2010.
        (setq teststr (RE:Replace "" "[{]" teststr))
        ;; Get the stacked position within test string.
        (setq testpos (cadar (RE:Execute "\\\\S(.*?)(\\;)" teststr)))
        ;; Avoid an error with substr if testpos is zero.
        ;; A space should not be added given a stacked
        ;; fraction string which is simply like this 1/2" anyway.
        (if (/= 0 testpos)
          (setq numcheck (substr teststr testpos 1))
        )
        ;; Check whether the character before a stacked string/fraction
        ;; is a number. Add a space if it is.
        (if (and numcheck (<= 48 (ascii numcheck) 57))
          (setq tempstr (RE:Replace " " "\\\\S" tempstr))
          (setq tempstr (RE:Replace "" "\\\\S" tempstr))
        )
        (setq tempstr (RE:Replace "/" "[#]" tempstr)
              tempstr (RE:Replace "" "[;]" tempstr)
              tempstr (RE:Replace "" "\\\\A(.*?)[;]" tempstr)
              tempstr (RE:Replace "" "\\^" tempstr)
              str     (vl-string-subst tempstr origstr str pos)
        )
      )
      str
    )
    ;; T format
    (defun Tracking (str) (RE:Replace "" "\\\\T[0-9]?[.]?[0-9]+;" str))
    ;; U format
    (defun Underline (str) (RE:Replace "" "\\\\[Ll]" str))
    ;; W format
    (defun Width (str) (RE:Replace "" "\\\\W[0-9]?[.]?[0-9]+;" str))
    ;; ~ format
    ;; In 2008 a hard space includes font formatting.
    ;; In 2004 it does not, simply this \\~.
    (defun HardSpace (str) (RE:Replace " " "{\\\\[Ff](.*?)\\\\~}|\\\\~" str))
    ;; Remove curly braces. Called after other formatting is removed.
    (defun Braces (str / lst origstr tempstr len teststr)
      (setq lst (RE:Execute "{[^\\\\]+}" str))
      (foreach x lst
        (setq origstr (car x)
              tempstr (RE:Replace "" "[{}]" origstr)
              str     (vl-string-subst tempstr origstr str)
        )
      )
      ;; Added JB 12/20/2009
      ;; Last ditch attempt at remove braces from start and end of string.
      (setq len (strlen str))
      (if (and (= 123 (ascii (substr str 1 1)))
               (= 125 (ascii (substr str len 1)))
               (setq teststr (substr str 2))
               (setq teststr (substr teststr 1 (1- (strlen teststr))))
               (not (vl-string-search "{" teststr))
               (not (vl-string-search "}" teststr))
          )
        (setq str teststr)
      )
      str
    )
;;;;; End remove formatting sub-functions ;;;;;
;;;;; Start primary function ;;;;;
    ;; Temporarily replace literal backslashes with a unique string.
    ;; Literal backslashes are restored at end of function. By Steve Doman.
    (setq slashflag (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) ">"))
    (setq text (RE:Replace slashflag "\\\\" str))
    ;; Temporarily replace literal left curly brace.
    (setq lbrace (strcat "<L" (substr (rtos (getvar "CDATE") 2 8) 14) ">"))
    (setq text (RE:Replace lbrace "\\\\{" text))
    ;; Temporarily replace literal right curly brace.
    (setq rbrace (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) "R>"))
    (setq text (RE:Replace rbrace "\\\\}" text))
    (if (or (vl-position "A" formats)
            (and (vl-position "*" formats) (not (vl-position "^A" formats)))
        )
      (setq text (Alignment text))
    )
    (if (or (vl-position "B" formats)
            (and (vl-position "*" formats) (not (vl-position "^B" formats)))
        )
      (setq text (Tab text))
    )
    (if (or (vl-position "C" formats)
            (and (vl-position "*" formats) (not (vl-position "^C" formats)))
        )
      (setq text (Color text))
    )
    (if (or (vl-position "F" formats)
            (and (vl-position "*" formats) (not (vl-position "^F" formats)))
        )
      (setq text (Font text))
    )
    (if (or (vl-position "H" formats)
            (and (vl-position "*" formats) (not (vl-position "^H" formats)))
        )
      (setq text (Height text))
    )
    (if (or (vl-position "L" formats)
            (and (vl-position "*" formats) (not (vl-position "^L" formats)))
        )
      (setq text (Linefeed text))
    )
    (if (or (vl-position "O" formats)
            (and (vl-position "*" formats) (not (vl-position "^O" formats)))
        )
      (setq text (Overline text))
    )
    (if (or (vl-position "P" formats)
            (and (vl-position "*" formats) (not (vl-position "^P" formats)))
        )
      (setq text (Paragraph text))
    )
    (if (or (vl-position "Q" formats)
            (and (vl-position "*" formats) (not (vl-position "^Q" formats)))
        )
      (setq text (Oblique text))
    )
    (if (or (vl-position "S" formats)
            (and (vl-position "*" formats) (not (vl-position "^S" formats)))
        )
      (setq text (Stacking text))
    )
    (if (or (vl-position "T" formats)
            (and (vl-position "*" formats) (not (vl-position "^T" formats)))
        )
      (setq text (Tracking text))
    )
    (if (or (vl-position "U" formats)
            (and (vl-position "*" formats) (not (vl-position "^U" formats)))
        )
      (setq text (Underline text))
    )
    (if (or (vl-position "W" formats)
            (and (vl-position "*" formats) (not (vl-position "^W" formats)))
        )
      (setq text (Width text))
    )
    (if (or (vl-position "~" formats)
            (and (vl-position "*" formats) (not (vl-position "^~" formats)))
        )
      (setq text (HardSpace text))
    )
    (setq text (Braces (RE:Replace "" slashflag text))
          text (RE:Replace "\\{" lbrace text)
          text (RE:Replace "\\}" rbrace text)
    )
    text
  ) ; end StripFormat
  (defun _sel (/ o)
    (if (setq o
               (AT:Entsel t
                          (strcat "\nSelect text object to "
                                  *AV:Fnc*
                                  " or "
                                  (if final
                                    "[Add/Divide/Multiply/Subtract/Type]: "
                                    "[Type]: "
                                  )
                          )
                          '("V" (0 . "AECC_COGO_POINT,AECC_POINT,ATTDEF,ATTRIB,MULTILEADER,MTEXT,TEXT"))
                          (if final
                            "Add Divide Multiply Subtract Type"
                            "Type"
                          )
               )
        )
      (cond ((eq o "Add") (setq f "+") (setq *AV:Fnc* "Add") (_sel))
            ((eq o "Divide") (setq f "/") (setq *AV:Fnc* "Divide") (_sel))
            ((eq o "Multiply") (setq f "*") (setq *AV:Fnc* "Multiply") (_sel))
            ((eq o "Subtract") (setq f "-") (setq *AV:Fnc* "Subtract") (_sel))
            ((eq o "Type") (initget 6) (setq o (getreal (strcat "\nNumber to " *AV:Fnc* ": "))))
            (T o)
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (vl-load-com)
  (or *AV:Fnc* (setq *AV:Fnc* "Add"))
  (and (setq dZin (getvar 'dimzin)) (setvar 'dimzin 0))
  (initget 0 "Add Divide Multiply Subtract")
  (setq
    *AV:Fnc* (cond ((getkword
                      (strcat "\nChoose function [Add/Divide/Multiply/Subtract] <" *AV:Fnc* ">: ")
                    )
                   )
                   (*AV:Fnc*)
             )
  )
  (setq f (cond ((eq *AV:Fnc* "Add") "+")
                ((eq *AV:Fnc* "Divide") "/")
                ((eq *AV:Fnc* "Multiply") "*")
                ((eq *AV:Fnc* "Subtract") "-")
          )
        i 0.
  )
  (while (setq obj (_sel))
    (if
      (cond
        ;; real value
        ((eq (type obj) 'REAL) (setq num obj))
        ;; LDD point
        ((and (eq (vla-get-objectname obj) "AeccDbPoint")
              (not (vl-catch-all-error-p
                     (setq num (vl-catch-all-apply
                                 (function
                                   (lambda () (cadddr (assoc 11 (entget (vlax-vla-object->ename obj)))))
                                 )
                               )
                     )
                   )
              )
         )
         num
        )
        ;; C3D point
        ((and
           (eq (vla-get-objectname obj) "AeccDbCogoPoint")
           (not (vl-catch-all-error-p
                  (setq num (vl-catch-all-apply (function vlax-get-property) (list obj 'Elevation)))
                )
           )
         )
         (setq num (car (AT:ExtractNumbers num)))
        )
        ;; attribute, multileader, mtext, text
        (T
         ;;(T (setq num (apply (function (eval (read f))) (AT:ExtractNumbers (vla-get-textstring obj)))))
         ;;(T (setq num (car (AT:ExtractNumbers (vla-get-textstring obj)))))
         ;|
         (setq num ((lambda (n)
                      (foreach x (AT:ExtractNumbers (StripFormat (vla-get-textstring obj) "*"))
                        (setq n ((eval (read f)) x n))
                      )
                    )
                     0.
                   )
         )
         |;
         (if
           (> (length (setq num (AT:ExtractNumbers (CV:StripFormat (vla-get-textstring obj) "*"))))
              1
           )
            (if (setq num (AT:ListSelect
                            (strcat "Multiple numbers to: " *AV:Fnc*)
                            "Choose numbers:"
                            "10"
                            "5"
                            "true"
                            (mapcar (function vl-princ-to-string) num)
                          )
                )
              (setq i   (+ i (1- (length num)))
                    num ((lambda (n)
                           (foreach x (mapcar (function atof) num)
                             (setq n ((eval (read f)) x n))
                           )
                         )
                          0.
                        )
              )
            )
            (setq num (car num))
         )
        )
      )
       (if final
         (progn (setq final ((eval (read f)) final num)
                      nStr  (strcat nStr " " f " " (vl-princ-to-string num))
                      i     (1+ i)
                )
                (princ (strcat nStr " = " (vl-princ-to-string final)))
         )
         (progn (setq final num
                      nStr  (strcat "\n" (vl-princ-to-string num))
                      i     (1+ i)
                )
                (princ (strcat nStr " " f))
         )
       )
       (princ "\nValue does not contain number!")
    )
  )
  (and nStr
       (> i 1)
       (if (and (eq *AV:Fnc* "Add") (not (wcmatch nStr "*/*,*`**,*-*")))
         (setq pt (initget 0 "Average")
               pt (getpoint (strcat nStr
                                    " = "
                                    (vl-princ-to-string final)
                                    "\nSpecify text placement or [Average]: "
                            )
                  )
         )
         (setq
           pt (getpoint (strcat nStr " = " (vl-princ-to-string final) "\nSpecify text placement: "))
         )
       )
       (if (vl-consp pt)
         (AT:MText (trans pt 1 0) (rtos final) nil nil 5)
         (if (setq pt (getpoint (strcat nStr
                                        " = "
                                        (vl-princ-to-string final)
                                        " / "
                                        (vl-princ-to-string (fix i))
                                        " = "
                                        (vl-princ-to-string (/ final i))
                                        "\nSpecify text placement point: "
                                )
                      )
             )
           (AT:MText (trans pt 1 0) (rtos (/ final i)) nil nil 5)
         )
       )
  )
  (*error* nil)
  (princ)
)

276810-deneme1.dwg
276810-deneme2.dwg

20.01.2025 05:51    

Travaci
Dwg içinde Textsize değerini değiştirin.

20.01.2025 12:38    

BLack|E
Herkese Merhaba,
Aşağıda iki adet lisp paylaşacağım.
Birinci orjinal olan ikincisi ise benim yapmaya çalıştığım
Birinci lisp "M" yazan yazıları algılayıp toplamını alıyor.
ikinci lisp'de "M" yazısından farklı string değeri için kullanıcıdan input istetip yeni string değerine göre toplatmak.
nerede hata yapıyorum yardımcı olursanız sevinirim.



önce

sonra



önce

sonra



Birinci Orjinal Lisp
Kod:

(defun c:eed (/ *error* sl s pn tx ls n tp nn gr st ly vt yy)
   (defun *error* (et)
   (command "_.undo" "e")
   (command "_.u")
   (setvar "cmdecho" 1))
   (vl-load-com)
   (setvar "cmdecho" 0)
   (command "_.undo" "be")
   (setq n -1 s -1 pn '(0.0 0.0 0.0) gr (ssadd)
     sl (ssget (list (cons 0 "text"))))
   (if sl
     (progn
       (while (< (setq s (1+ s)) (sslength sl))
         (if (vl-string-search "M"
           (setq tx (cdr (assoc 1 (entget (ssname sl s))))))
           (setq ls (append ls (list (substr tx
             (+ 1 (vl-string-position (ascii "M") tx))))))))
       (while (< (setq n (1+ n)) (length ls))
         (setq ls (append (list (nth n ls)) (vl-remove (nth n ls) ls))))
       (setq ls (vl-sort ls '<) n -1 s 0 tp 0
             ly (cdr (assoc 8 (entget (ssname sl 0))))
             st (cdr (assoc 7 (entget (ssname sl 0))))
             vt (cdr (assoc 41 (entget (ssname sl 0))))
             yy (cdr (assoc 40 (entget (ssname sl 0)))))
       (repeat (length ls) (setq n (1+ n) s 0 tp 0
         pn (polar pn 4.71239 (* 1.5 yy)))
         (while (< s (sslength sl))
           (if (vl-string-search "M"
             (setq tx (cdr (assoc 1 (entget (ssname sl s))))))
             (if (= (nth n ls) (substr tx
               (+ 1 (vl-string-position (ascii "M") tx))))
               (progn (entdel (ssname sl s))
                 (setq tp (+ tp (atof (substr tx 1
                   (vl-string-position (ascii "M") tx))))
                   sl (ssdel (ssname sl s) sl) s (1- s)))))
         (setq s (1+ s)))
       (entmake (list (cons 0 "text") (cons 10 pn) (cons 11 pn)(cons 41 vt)
         (cons 40 yy) (cons 72 2) (cons 73 0) (cons 8 ly) (cons 7 st)
         (cons 1 (strcat (rtos tp 2 0) (nth n ls))))) (ssadd (entlast) gr))
       (while (/= 3 (car (setq nn (grread T 14 0))))
         (setq nn (trans (cadr nn) 1 0 nil) n -1)
         (while (< (setq n (1+ n)) (sslength gr))
           (vla-transformby (vlax-ename->vla-object (ssname gr n))
           (vlax-tmatrix
             (list (list 1 0 0 (- (car nn) (car pn)))
             (list 0 1 0 (- (cadr nn) (cadr pn)))
             (list 0 0 1 (- (caddr nn) (caddr pn))) (list 0 0 0 1)))))
         (setq pn nn))))
   (command "._undo" "e") (setvar "cmdecho" 1) (princ))



İkinci lisp
Kod:

(defun c:eed (/ *error* sl s pn tx ls n tp nn gr st ly vt yy last-value user-input)
   (defun *error* (et)
   (command "_.undo" "e")
   (command "_.u")
   (setvar "cmdecho" 1))
  (if (not user-input) (setq last-value "M"))
  (if (setq last-value (getstring (strcat "\nYazi Degerini Giriniz...: <" user-input ">")))
  (setq user-input last-value) (setq last-value user-input))
   (vl-load-com)
   (setvar "cmdecho" 0)
   (command "_.undo" "be")
   (setq n -1 s -1 pn '(0.0 0.0 0.0) gr (ssadd)
     sl (ssget (list (cons 0 "text"))))
   (if sl
     (progn
       (while (< (setq s (1+ s)) (sslength sl))
         (if (vl-string-search last-value
           (setq tx (cdr (assoc 1 (entget (ssname sl s))))))
           (setq ls (append ls (list (substr tx
             (+ 1 (vl-string-position (ascii last-value) tx))))))))
       (while (< (setq n (1+ n)) (length ls))
         (setq ls (append (list (nth n ls)) (vl-remove (nth n ls) ls))))
       (setq ls (vl-sort ls '<) n -1 s 0 tp 0
             ly (cdr (assoc 8 (entget (ssname sl 0))))
             st (cdr (assoc 7 (entget (ssname sl 0))))
             vt (cdr (assoc 41 (entget (ssname sl 0))))
             yy (cdr (assoc 40 (entget (ssname sl 0)))))
       (repeat (length ls) (setq n (1+ n) s 0 tp 0
         pn (polar pn 4.71239 (* 1.5 yy)))
         (while (< s (sslength sl))
           (if (vl-string-search last-value
             (setq tx (cdr (assoc 1 (entget (ssname sl s))))))
             (if (= (nth n ls) (substr tx
               (+ 1 (vl-string-position (ascii last-value) tx))))
               (progn (entdel (ssname sl s))
                 (setq tp (+ tp (atof (substr tx 1
                   (vl-string-position (ascii last-value) tx))))
                   sl (ssdel (ssname sl s) sl) s (1- s)))))
         (setq s (1+ s)))
       (entmake (list (cons 0 "text") (cons 10 pn) (cons 11 pn)(cons 41 vt)
         (cons 40 yy) (cons 72 2) (cons 73 0) (cons 8 ly) (cons 7 st)
         (cons 1 (strcat (rtos tp 2 0) (nth n ls))))) (ssadd (entlast) gr))
       (while (/= 3 (car (setq nn (grread T 14 0))))
         (setq nn (trans (cadr nn) 1 0 nil) n -1)
         (while (< (setq n (1+ n)) (sslength gr))
           (vla-transformby (vlax-ename->vla-object (ssname gr n))
           (vlax-tmatrix
             (list (list 1 0 0 (- (car nn) (car pn)))
             (list 0 1 0 (- (cadr nn) (cadr pn)))
             (list 0 0 1 (- (caddr nn) (caddr pn))) (list 0 0 0 1)))))
         (setq pn nn))))
   (command "._undo" "e")
   (setvar "cmdecho" 1)
   (princ))

21.01.2025 05:32    

Travaci
Kod:

  (if (= user-input nil) (setq user-input "M"))
  (setq last-value (getstring (strcat "\nYazi Degerini Giriniz...: < "user-input" > :")))
  (if (/= last-value "") (setq user-input last-value))

23.01.2025 12:21    

BLack|E
Erkan hocam teşekkür ederim yardımınız için. Son bir konu hakkında tecrübenize ihtiyacım var.
Excel ile AutoCAD arasında ilişki kurmak ile ilgili çok kaynak var sitede. Fakat benim ihtiyacıma karşılık vermiyor ya da ben bulamadım.
Elimde excel .xlsx uzantılı bir dosya var ve içeriğin nasıl göründüğünü aşağıda gösterdim.
Excelde sadece aktif olan sayfa1 kullanılacak


AutoCAD'deki text'ler seçilecek,
Excel seçilecek,
AutoCAD'de seçilen textlerin içeriği excel'de A sütununda aratılıp varsa, B sütununda yazan değer ile değiştirilecek.





Sonuç




belli bir yere kadar getiriyorum.
Kod:

  (if (setq n 0 r 0 ss (ssget (list (cons 0 "TEXT,MTEXT"))))
    (if (setq fl (getfiled "\nEXCEL DOSTAYISIN SECINIZ..." "" "xlsx;xls;csv;*" 16))
      (progn
        (setq fl (open fl "r"))
        (command "_.undo" "be")
        (repeat (sslength ss)
          (setq en (entget (ssname ss n)))
.................
.................
        (close fl)
      )
    )
  ) (princ)
)

Önceki Sayfa [1] [2] [3] [4] [5] [6] [7] [8] [9] [10] [15] [20] [25] [30] [35] [40] [45] [50] [55] [60] [65] [70] [75] [80] [85] [90] [95] [100] > 101 <
Copyright © 2004-2022 SQL: 0.638 saniye - Sorgu: 57 - Ortalama: 0.0112 saniye