halam Posted October 17, 2017 Share Posted October 17, 2017 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. Quote Link to comment Share on other sites More sharing options...
Tharwat Posted October 17, 2017 Share Posted October 17, 2017 Hi, Its simple enough. Have you written any codes for this task? Quote Link to comment Share on other sites More sharing options...
Aftertouch Posted October 17, 2017 Share Posted October 17, 2017 This is quite easy to create. But what are the names of the layers? Do they have to match the hatch patterns name? Quote Link to comment Share on other sites More sharing options...
halam Posted October 17, 2017 Author Share Posted October 17, 2017 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.. Quote Link to comment Share on other sites More sharing options...
Grrr Posted October 17, 2017 Share Posted October 17, 2017 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. Quote Link to comment Share on other sites More sharing options...
halam Posted October 17, 2017 Author Share Posted October 17, 2017 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_ Quote Link to comment Share on other sites More sharing options...
halam Posted October 17, 2017 Author Share Posted October 17, 2017 Thanks! Great,... Will test and get to work with it.. Quote Link to comment Share on other sites More sharing options...
ronjonp Posted October 17, 2017 Share Posted October 17, 2017 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) ) Quote Link to comment Share on other sites More sharing options...
halam Posted October 24, 2017 Author Share Posted October 24, 2017 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.. ? Quote Link to comment Share on other sites More sharing options...
ronjonp Posted October 25, 2017 Share Posted October 25, 2017 Pretty fantastic to clean up some DWG exportsHow 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) ) Quote Link to comment Share on other sites More sharing options...
Grrr Posted October 25, 2017 Share Posted October 25, 2017 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. Quote Link to comment Share on other sites More sharing options...
ronjonp Posted October 25, 2017 Share Posted October 25, 2017 @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) Quote Link to comment Share on other sites More sharing options...
Grrr Posted October 25, 2017 Share Posted October 25, 2017 @Ron, thanks - I've forgot that there was a Color property.. 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). Quote Link to comment Share on other sites More sharing options...
halam Posted October 26, 2017 Author Share Posted October 26, 2017 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" ) ; ) () ) Quote Link to comment Share on other sites More sharing options...
ronjonp Posted October 27, 2017 Share Posted October 27, 2017 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" ) ) ) Quote Link to comment Share on other sites More sharing options...
halam Posted October 29, 2017 Author Share Posted October 29, 2017 (edited) 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 October 30, 2017 by halam UPDATED Quote Link to comment Share on other sites More sharing options...
Grrr Posted October 29, 2017 Share Posted October 29, 2017 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. Quote Link to comment Share on other sites More sharing options...
halam Posted October 29, 2017 Author Share Posted October 29, 2017 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_*") Quote Link to comment Share on other sites More sharing options...
Grrr Posted October 29, 2017 Share Posted October 29, 2017 for the opposite: ([color="red"]not [/color](wcmatch (strcase pat) "FP_*")) Quote Link to comment Share on other sites More sharing options...
halam Posted October 29, 2017 Author Share Posted October 29, 2017 Doooo..... Quote Link to comment Share on other sites More sharing options...
Recommended Posts
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.