Jump to content

Hatch pattern to layername


halam

Recommended Posts

Hi, I am looking for a lisp that will put all used hatches in a dwg file layers according to their pattern name. Have you seen something than can do this? Would be most welcome to clean up my act.

Link to comment
Share on other sites

  • Replies 21
  • Created
  • Last Reply

Top Posters In This Topic

  • halam

    10

  • Grrr

    6

  • ronjonp

    4

  • Tharwat

    1

Top Posters In This Topic

Posted Images

Hi,

 

Its simple enough. ;)

Have you written any codes for this task?

 

Sorry for my lazyness. I thought I'd better ask for a good starting point..

Link to comment
Share on other sites

heres a bit of practice (activex approach) :

 

(defun C:test ( / pref suf *error* SS acDoc Lyrs acSS pat )
 
 (setq ; Adjust to suit
   pref ""
   suf ""
 ); setq 
 
 (defun *error* (m)
   (and acSS (vla-Delete acSS))
   (and m (princ m)) (princ)
 ); defun *error*
 
 (cond 
   ( (setq SS (ssget "_X" '((0 . "HATCH")))) (setq Lyrs (vla-get-Layers (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))))
     (vlax-for o (setq acSS (vla-get-ActiveSelectionSet acDoc))
       (setq pat (strcat pref (vla-get-PatternName o) suf))
       (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-Item (list Lyrs pat))) (vla-Add Lyrs pat) )
       (vla-put-Layer o pat)
     ); vlax-for
     
   )
 ); cond
 (*error* nil) (princ)
); defun C:test
(vl-load-com) (princ)

 

...untested.

Link to comment
Share on other sites

This is quite easy to create. But what are the names of the layers? Do they have to match the hatch patterns name?

 

yes, with a prefix like XX_

Link to comment
Share on other sites

Vanilla version:

(defun c:foo (/ s)
 (if (setq s (ssget "_x" '((0 . "hatch"))))
   (foreach h (mapcar 'cadr (ssnamex s))
     (entmod (append (entget h) (list (cons 8 (strcat "XX_" (cdr (assoc 2 (entget h))))))))
   )
 )
 (princ)
)

Link to comment
Share on other sites

Pretty fantastic to clean up some DWG exports

How can i made to work all hatch layers now get color 253 and transparancy 50% by default.

 

 

..(vla-put-layercolor..

..(vla-put-layertransparancy..

 

 

?

Knipsel.jpg

Link to comment
Share on other sites

Pretty fantastic to clean up some DWG exports

How can i made to work all hatch layers now get color 253 and transparancy 50% by default.

 

 

..(vla-put-layercolor..

..(vla-put-layertransparancy..

 

 

?

 

(defun c:foo (/ l s)
 (regapp "AcCmTransparency")
 (if (setq s (ssget "_x" '((0 . "hatch"))))
   (foreach h (mapcar 'cadr (ssnamex s))
     (entmod (append (entget h) (list (cons 8 (setq l (strcat "XX_" (cdr (assoc 2 (entget h))))))))
     )
     (entmod (append (entget (tblobjname "layer" l))
	      '((62 . 253))
	      '((-3 ("AcCmTransparency" (1071 . 33554559))))
      )
     )
   )
 )
 (princ)
)

Link to comment
Share on other sites

And modification on my code (again - not tested) :

 

(defun C:test ( / pref suf LM:SetLayerTransparency *error* SS oCol acDoc Lyrs acSS pat lyr )
 
 (setq ; Adjust to suit
   pref ""
   suf ""
 ); setq 
 
 ; https://www.theswamp.org/index.php?topic=52473.msg574082#msg574082
 (defun LM:SetLayerTransparency ( lay trn / ent ) ; Lee Mac
   (defun LM:trans->dxf ( x ) (logior (fix (* 2.55 (- 100 x))) 33554432) )
   (cond 
     ( (not  (<= 0 trn 90)) nil)
     ( (if (setq ent (tblobjname "layer" lay)) (progn (regapp "accmtransparency") (entmod (append (entget ent) (list (list -3 (list "accmtransparency" (cons 1071 (LM:trans->dxf trn))))))))) )
   )
 ); defun LM:SetLayerTransparency
 
 (defun *error* (m)
   (and acSS (vla-Delete acSS))
   (and (eq 'VLA-OBJECT (type oCol)) (not (vlax-object-released-p oCol)) (vlax-release-object oCol))
   (and acDoc (vla-EndUndoMark acDoc))
   (and m (princ m)) (princ)
 ); defun *error*
 
 (cond 
   ( 
     (and 
       (setq SS (ssget "_X" '((0 . "HATCH")))) 
       (setq oCol (vla-GetInterfaceObject (vlax-get-acad-object) (strcat "AutoCAD.AcCmColor." (substr (getvar 'acadver) 1 2))))
       (setq Lyrs (vla-get-Layers (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))))
     ); and 
     (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc)
     (vla-put-ColorMethod oCol acColorMethodByACI)
     (vla-put-ColorIndex oCol 253)
     (vlax-for o (setq acSS (vla-get-ActiveSelectionSet acDoc))
       (setq pat (strcat pref (vla-get-PatternName o) suf))
       (if (vl-catch-all-error-p (setq lyr (vl-catch-all-apply 'vla-Item (list Lyrs pat)))) (setq lyr (vla-Add Lyrs pat)) )
       (vla-put-TrueColor lyr oCol)
       (LM:SetLayerTransparency (vla-get-Name lyr) 50)
       (vla-put-Layer o pat)
     ); vlax-for
   )
 ); cond
 (*error* nil) (princ)
); defun C:test
(vl-load-com) (princ)

 

Still couldn't figure out how to assign layer transparency with activex.

Link to comment
Share on other sites

@Grrr, you don't have to use the color object (AutoCAD.AcCmColor.XX) when assigning index colors.

Try:

(vla-put-color (vlax-ename->vla-object (tblobjname "layer" "0")) 5)

:)

Link to comment
Share on other sites

@Ron, thanks - I've forgot that there was a Color property.. :ouch:

Once I started mixing up true and index colors, I got used to obtain the color object like that (TrueColor property). For this case I thought it would be faster to obtain and manipulate just once the interface color object, and just apply it to each layer (rather than obtaining TrueColor property for each layer).

Link to comment
Share on other sites

This works just fine allready!

 

 

One further wish.. it would be most useful to have a part in which user can filter it based on the name to assign both color and transparency seperate.

In my case i want to be able to color all hatches translated from Revit Fill Patterns into purple, and the rest 253 or other. Also, if there is a way to filter AutoCAD custom hatches, this would be very welcome to.

 

I think this start with something like this beneith. Hope you get the picture. I don't know to use wildcards searches and to make this good into this fine piece of code is also beyond my skills.

 

(vlax-for o (setq acSS (vla-get-ActiveSelectionSet acDoc))
   (setq pat_eval (vla-get-PatternName o))
)
(if (= pat_eval
      (_PF)                                      ; filter Pattern Fill, how to use wildcard in name ?
      (setq                                      ; Adjust to suit in the case _PF
          pref "x-Revit-PF-"
          suf  " to be fixed"
      )                                          ; 
   )
   ()
)
(if (= pat_eval
      (_Solid)                                   ; filter Regular AutoCAD hatch 
      (setq                                      ; Adjust to suit in the 
          pref "x-AC-"
          suf  " is ok"
      )                                          ; 
   )
   ()
)

Link to comment
Share on other sites

What you want is a conditional statement:

(setq patname (strcase patname))
(cond ((wcmatch patname "*_PF*")
      (setq pref "x-Revit-PF-"
     suf  " to be fixed"
      )
     )
     ((= patname "SOLID")
      (setq pref "x-AC-"
     suf  " is ok"
      )
     )
)

Link to comment
Share on other sites

UPDATED

 

 




(defun C:getpatlayer (/           pref
                     suf         LM:SetLayerTransparency
                     *error*     SS
                     oCol        acDoc
                     Lyrs        acSS
                     pat         lyr
                     pref_eval
                     lcol
                    )                            ; https://www.theswamp.org/index.php?topic=52473.msg574082#msg574082
   (defun LM:SetLayerTransparency (lay trn / ent) ; Lee Mac
       (defun LM:trans->dxf (x) (logior (fix (* 2.55 (- 100 x))) 33554432))
       (cond
           ((not (<= 0 trn 90)) nil)
           ((if (setq ent (tblobjname "layer" lay))
                (progn (regapp "accmtransparency")
                       (entmod
                           (append
                               (entget ent)
                               (list (list -3
                                           (list "accmtransparency"
                                                 (cons 1071 (LM:trans->dxf trn))
                                           )
                                     )
                               )
                           )
                       )
                )
            )
           )
       )
   )                                             ; defun LM:SetLayerTransparency
   (defun *error* (m)
       (and acSS (vla-Delete acSS))
       (and (eq 'VLA-OBJECT (type oCol))
            (not (vlax-object-released-p oCol))
            (vlax-release-object oCol)
       )
       (and acDoc (vla-EndUndoMark acDoc))
       (and m (princ m))
       (princ)
   )                                             ; defun *error*
   (cond ((and (setq SS (ssget "_X" '((0 . "HATCH"))))
               (setq oCol (vla-GetInterfaceObject
                              (vlax-get-acad-object)
                              (strcat "AutoCAD.AcCmColor."
                                      (substr (getvar 'acadver) 1 2)
                              )
                          )
               )
               (setq Lyrs (vla-get-Layers (setq acDoc (vla-get-ActiveDocument
                                                          (vlax-get-acad-object)
                                                      )
                                          )
                          )
               )
          )                                      ; and 
          (vla-EndUndoMark acDoc)
          (vla-StartUndoMark acDoc)
          (vlax-for o (setq acSS (vla-get-ActiveSelectionSet acDoc))
              (setq pat (vla-get-PatternName o))
              (if (cond ((wcmatch (vla-get-PatternName o) "FP_*")
                         (setq pref "x-hatch-pat-Revit-"
                               suf  ""
                               lcol 6
                         )
                        )
                        ((wcmatch (vla-get-PatternName o) "SOLID")
                         (setq pref "x-hatch-pat-"
                               suf  ""
                               lcol 253
                         )
                        )
                        ((wcmatch (vla-get-PatternName o) "DOTS")
                         (setq pref "x-hatch-pat-"
                               suf  ""
                               lcol 253
                         )
                        )
                        ((wcmatch (vla-get-PatternName o) "ANGLE")
                         (setq pref "x-hatch-pat-"
                               suf  ""
                               lcol 254
                         )
                        )
                        ((wcmatch (vla-get-PatternName o) "JIS_*")
                         (setq pref "x-hatch-pat-"
                               suf  ""
                               lcol 4
                         )
                        )
                        ((wcmatch (vla-get-PatternName o) "ACAD_*")
                         (setq pref "x-hatch-pat-"
                               suf  ""
                               lcol 3
                         )
                        )
                        ((wcmatch (vla-get-PatternName o) "ISO_*")
                         (setq pref "x-hatch-pat-"
                               suf  ""
                               lcol 7
                         )
                        )
                        ((wcmatch (vla-get-PatternName o) "AR-*")
                         (setq pref "x-hatch-pat-"
                               suf  ""
                               lcol 5
                         )
                        )
                        )


                  (progn 
                    (vla-put-ColorMethod oCol acColorMethodByACI)
                    (vla-put-ColorIndex oCol lcol)
                         (setq pat (strcat pref pat suf))
                         (if (vl-catch-all-error-p
                                 (setq lyr (vl-catch-all-apply 'vla-Item
                                                               (list Lyrs pat)
                                           )
                                 )
                             )
                             (setq lyr (vla-Add Lyrs pat))
                         )
                         (vla-put-TrueColor lyr oCol)
                         (LM:SetLayerTransparency (vla-get-Name lyr) 50)
                         (vla-put-Layer o pat)
                  )                              ; progn
              )                                  ; if
          )                                      ; vlax-for

   ))                                             ; cond
   (*error* nil)
   (princ)
)                                                 ; defun C:test
(vl-load-com)
(princ)


Edited by halam
UPDATED
Link to comment
Share on other sites

Hans, try with:

 

(vlax-for o (setq acSS (vla-get-ActiveSelectionSet acDoc))
 (setq pat (vla-get-PatternName o))
 (if
   (cond 
     ( (wcmatch (strcase pat) "*_PF*")
       (setq 
         pref "x-Revit-PF-"
         suf  " to be fixed"
       )
     )
     ( (= (strcase pat) "SOLID")
       (setq 
         pref "x-AC-"
         suf  " is ok"
       )
     )
   )
   (progn
     (setq pat (strcat pref pat suf))
     (if (vl-catch-all-error-p (setq lyr (vl-catch-all-apply 'vla-Item (list Lyrs pat))))
       (setq lyr (vla-Add Lyrs pat))
     )
     (vla-put-TrueColor lyr oCol)
     (LM:SetLayerTransparency (vla-get-Name lyr) 50)
     (vla-put-Layer o pat)
   ); progn
 ); if
); vlax-for

 

It could be shortened a bit, but I don't have time to revise further.

Link to comment
Share on other sites

Thanks. That works!!!! :)

Update the code above.

 

 

I have two statements in mind.

The first is ((wcmatch (strcase pat) "FP_*") to filter the Revit Fill patterns

The other one should be the opposite of that for other hatches not coming from Revit exports.

something like (=/ "FP_*")

Link to comment
Share on other sites

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.


×
×
  • Create New...