AutoCAD VBA - count hatch area
Hello,I would like to write a procedure (function) which will show how many hatch areas are on the drawing. For example:
I have drawing which has 3 objects (2 rectangulars and 1 circle - all in layer 0.
1 rectangular and 1 circle is hatch. So when I will start the function it will show message about 2 hatch objects. Try it
Public Sub HatchCount()'On Error Resume Next'-------------------+Dim ObjSSDim SSitemsDim FilterType(0) As IntegerDim FilterData(0) As Variant'----------------------------------------------------------------------------------+Set ObjSS = ThisDrawing.SelectionSetsFor Each SSitems In ObjSSIf SSitems.Name = "Nabor" ThenThisDrawing.SelectionSets.Item("Nabor").DeleteExit ForEnd IfNextSet SSitems = ThisDrawing.SelectionSets.Add("Nabor")'----------------------------------------------------------------------------------+FilterType(0) = 0FilterData(0) = "HATCH"SSitems.Select acSelectionSetAll, , , FilterType, FilterData'or'SSitems.SelectOnScreen FilterType, FilterData'----------------------------------------------------------------------------------+If Err Then Err.Clear:Exit SubIf SSitems.Count - 1 = -1 ThenMsgBox "Selection empty !", vbExclamationExit SubEnd If'----------------------------------------------------------------------------------+MsgBox "HATCH - " & SSitems.Count, vbSystemModal + vbInformation'----------------------------------------------------------------------------------+End Sub Thank you. It works but I see some issues. For example:
1. I drew 3 circles
2. Next I went to Hatch Creation and made hatch in 2 circles
3. Finally I closed Hatch Creation
Then the function will say about 1 hatch object.
But if I change actions:
1. I drew 3 circles
2. Next I went to Hatch Creation and made hatch in first circle
3. I closed Hatch Creation
4. I went to Hatch Creation again and made hatch in second circle
5. I closed Hatch Creation
Then the function will say about 2 hatch objects and this is correct result.
Do you have any ideas how to improve this function?
Also if it is not a problem I would like to ask about help in:
- make this function also let the user to change hatch pattern to solid with possibility to choose color. No. Only individual hatching. Otherwise it does not work.
It is necessary
- or know exactly what type of fill and color
- or make a form that will select the color you want.
- pattern type: ANSI31, Hatch Pattern Scale 10
- form with colors will be great Public Sub HatchCount()'On Error Resume Next'-------------------+Dim ObjSSDim SSitemsDim FilterType(0) As IntegerDim FilterData(0) As VariantDim HatchItem As AcadHatchDim color As AcadAcCmColorDim Version As String'----------------------------------------------------------------------------------+Set ObjSS = ThisDrawing.SelectionSetsFor Each SSitems In ObjSSIf SSitems.Name = "Nabor" ThenThisDrawing.SelectionSets.Item("Nabor").DeleteExit ForEnd IfNextSet SSitems = ThisDrawing.SelectionSets.Add("Nabor")'----------------------------------------------------------------------------------+FilterType(0) = 0FilterData(0) = "HATCH"SSitems.Select acSelectionSetAll, , , FilterType, FilterData'or'SSitems.SelectOnScreen FilterType, FilterData'----------------------------------------------------------------------------------+If Err Then Err.Clear:Exit SubIf SSitems.Count - 1 = -1 ThenMsgBox "Selection empty !", vbExclamationExit SubEnd If'----------------------------------------------------------------------------------+MsgBox "HATCH - " & SSitems.Count, vbSystemModal + vbInformation'----------------------------------------------------------------------------------+Version = Left(ThisDrawing.GetVariable("ACADVER"), 2)Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor." & Version)color.SetRGB 80, 100, 244'----------------------------------------------------------------------------------+For Each HatchItem In SSitems HatchItem.SetPattern acHatchPatternTypePreDefined, "ANSI31" HatchItem.PatternScale = 10 HatchItem.TrueColor = color HatchItem.EvaluateNext'----------------------------------------------------------------------------------+MsgBox "Ok!", vbSystemModal + vbInformation'----------------------------------------------------------------------------------+End Sub Sorry for late reply. The procedure works good. Thank you very much for help. You can get at the number of individual hatches that make 1 bigger hatch pattern if you dump a hatch you will see the variable "numerof loops"
(vl-load-com)(defun hatchnum ( / x num ss tot)(setq ss (ssget (list (cons 0 "hatch"))))(setq num (sslength ss))(setq tot 0)(repeat (setq x (sslength ss))(setq obj (vlax-ename->vla-object (ssname ss (setq x (- x 1))))) (setq tot (+ (vla-get-numberofloops obj) tot )))(alert (strcat "There is " (rtos num 2 0) "hatches\n\nMade up of " (rtos tot 2 ) " sections")))(hatchnum)
页:
[1]