Jump to content
avagorn

AutoCAD VBA - count hatch areas

Recommended Posts

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.

Share this post


Link to post
Share on other sites
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

Share this post


Link to post
Share on other sites
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.

Share this post


Link to post
Share on other sites
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.

Share this post


Link to post
Share on other sites
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

Share this post


Link to post
Share on other sites
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

Share this post


Link to post
Share on other sites
avagorn

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

Share this post


Link to post
Share on other sites
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)

Share this post


Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now

×