Jump to content

AutoCAD VBA - count hatch areas


avagorn

Recommended Posts

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.

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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.

Link to comment
Share on other sites

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.

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

  • 3 weeks later...

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)

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...