hachure grace a une macro

[timhothels]

bonjour, je dois faire une hachure depuis mon programme vb.

Mais il faut ke je la fasse en selection un point et non en selectionnant un objet et je ne trouve pas la solution..

Si quelqu'un trouve....

Merci :D

[timhothels]

est ce ke kelkun connait la commande -bhatch

car il faudrait ke je la tape avec ts les parametres nécéssaires en une ligne!!!!

 

merci

 

[timhothels]

OK je sais comment faire

 

Voici deux méthodes différentes:

 

la il va prendre en compte si il y a autre chose dans le rectangle et hachurer que la zone souhaité comme si on fait pickpoint dans autocad

'*****************************************************************************************

'*Fonction permettant de Dessiner un rectangle et de l'hachurer grace a la commande batch*

'*****************************************************************************************

Public Sub DessinerHachureDessin1(x As Double, y As Double, TypeHachure As Long, NomHachure As String, H As Double, Larg As Double, EchelleHachure As Double, PointXHachure As Double, PointYHachure As Double)

Dim objHachure As AcadHatch, PointHachure(0 To 2) As Double

Dim Rectangle(0 To 3) As AcadLine, PickPoint(0 To 1) As Double

Dim Point1(0 To 2) As Double, Point2(0 To 2) As Double, Point3(0 To 2) As Double, Point4(0 To 2) As Double

'création des différents points

Point1(0) = x: Point1(1) = y: Point1(2) = 0

Point2(0) = x: Point2(1) = y + H: Point2(2) = 0

Point3(0) = Larg: Point3(1) = y + H: Point3(2) = 0

Point4(0) = Larg: Point4(1) = y: Point4(2) = 0

'*Creation des lignes*

Set Rectangle(0) = Feuille.ModelSpace.AddLine(Point1, Point2)

Set Rectangle(1) = Feuille.ModelSpace.AddLine(Point2, Point3)

Set Rectangle(2) = Feuille.ModelSpace.AddLine(Point3, Point4)

Set Rectangle(3) = Feuille.ModelSpace.AddLine(Point4, Point1)

'création des hachures

Set objHachure = Feuille.ModelSpace.AddHatch(TypeHachure, NomHachure, True)

Feuille.SendCommand ("-bhatch p ar-conc 0.25 0 " & PointXHachure & "," & PointYHachure & vbCrLf)

'on efface les lignes que l'on doit pas voir

Rectangle(0).delete

Rectangle(2).delete

Rectangle(3).delete

End Sub

 

 

 

'***************************************************************

'*Fonction permettant de Dessiner un rectangle et de l'hachurer*

'***************************************************************

Public Sub DessinerHachureDessin2(x As Double, y As Double, TypeHachure As Long, NomHachure As String, H As Double, Larg As Double, EchelleHachure As Double)

Dim objHachure As AcadHatch, PointHachure(0 To 2) As Double

Dim Rectangle(0 To 3) As AcadLine, PickPoint(0 To 1) As Double

Dim Point1(0 To 2) As Double, Point2(0 To 2) As Double, Point3(0 To 2) As Double, Point4(0 To 2) As Double

'création des différents points

Point1(0) = x: Point1(1) = y: Point1(2) = 0

Point2(0) = x: Point2(1) = y + H: Point2(2) = 0

Point3(0) = Larg: Point3(1) = y + H: Point3(2) = 0

Point4(0) = Larg: Point4(1) = y: Point4(2) = 0

'*Creation des lignes*

Set Rectangle(0) = Feuille.ModelSpace.AddLine(Point1, Point2)

Set Rectangle(1) = Feuille.ModelSpace.AddLine(Point2, Point3)

Set Rectangle(2) = Feuille.ModelSpace.AddLine(Point3, Point4)

Set Rectangle(3) = Feuille.ModelSpace.AddLine(Point4, Point1)

' PickPoint(0) = 499

'PickPoint(1) = 1240

'création des hachures

Set objHachure = Feuille.ModelSpace.AddHatch(TypeHachure, NomHachure, True)

objHachure.AppendOuterLoop (Rectangle)

objHachure.PatternScale = EchelleHachure

objHachure.Evaluate

'on efface les lignes que l'on doit pas voir

Rectangle(0).delete

Rectangle(2).delete

Rectangle(3).delete

End Sub

[NANARD]

L'échelle des hachures en vba ne peut pas être apparemment, aussi petite que dans la fonction hachure autocad; pourquoi ? :casstet:

[timhothels]

je crois que si....

Regarde ici j'emploie une echelle à 0.25 mais tu peux mettre tous ce ke tu veux.

:D