AutoCAD VBA - count hatch areas

[avagorn]

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.

[maratovich]

Try it

Public Sub HatchCount()
'On Error Resume Next
'-------------------+
Dim ObjSS
Dim SSitems
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
'----------------------------------------------------------------------------------+
Set ObjSS = ThisDrawing.SelectionSets
For Each SSitems In ObjSS
If SSitems.Name = "Nabor" Then
ThisDrawing.SelectionSets.Item("Nabor").Delete
Exit For
End If
Next
Set SSitems = ThisDrawing.SelectionSets.Add("Nabor")
'----------------------------------------------------------------------------------+
FilterType(0) = 0
FilterData(0) = "HATCH"
SSitems.Select acSelectionSetAll, , , FilterType, FilterData
'or
'SSitems.SelectOnScreen FilterType, FilterData
'----------------------------------------------------------------------------------+
If Err Then Err.Clear:  Exit Sub
If SSitems.Count - 1 = -1 Then
MsgBox "Selection empty !", vbExclamation
Exit Sub
End If
'----------------------------------------------------------------------------------+
MsgBox "HATCH - " & SSitems.Count, vbSystemModal + vbInformation
'----------------------------------------------------------------------------------+
End Sub

[avagorn]

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.

[maratovich]

Do you have any ideas how to improve this function?

No. Only individual hatching. Otherwise it does not work.

 

- make this function also let the user to change hatch pattern to solid with possibility to choose color.

It is necessary

- or know exactly what type of fill and color

- or make a form that will select the color you want.

[avagorn]

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

[maratovich]

Public Sub HatchCount()
'On Error Resume Next
'-------------------+
Dim ObjSS
Dim SSitems
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim HatchItem As AcadHatch
Dim color As AcadAcCmColor
Dim Version As String
'----------------------------------------------------------------------------------+
Set ObjSS = ThisDrawing.SelectionSets
For Each SSitems In ObjSS
If SSitems.Name = "Nabor" Then
ThisDrawing.SelectionSets.Item("Nabor").Delete
Exit For
End If
Next
Set SSitems = ThisDrawing.SelectionSets.Add("Nabor")
'----------------------------------------------------------------------------------+
FilterType(0) = 0
FilterData(0) = "HATCH"
SSitems.Select acSelectionSetAll, , , FilterType, FilterData
'or
'SSitems.SelectOnScreen FilterType, FilterData
'----------------------------------------------------------------------------------+
If Err Then Err.Clear:  Exit Sub
If SSitems.Count - 1 = -1 Then
MsgBox "Selection empty !", vbExclamation
Exit Sub
End 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.Evaluate
Next
'----------------------------------------------------------------------------------+
MsgBox "Ok!", vbSystemModal + vbInformation
'----------------------------------------------------------------------------------+
End Sub

[avagorn]

Sorry for late reply. The procedure works good. Thank you very much for help.

[BIGAL]

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)