Routine Additin de Surfaces

[phil_vsd]

Re bonjour...

 

Voici ma deuxième routine que je vous propose. N'hésitez pas à l'améliorer car je ne maîtrise pas les loop et boucles en tous genre...

De plus si vous connaissez comment on fait une région sur une polyligne 2D... N'hésitez pas à poster des liens !

 

Pour cette routine nous sommes limités à douze pièces et que sur des polylignes de dimension d'une pièce. Je ne sais pas comment la modifier pour travailler sur des polyligne de la tailles de grands terrains... De plus le polylignes choisies doivent appartenir à un calque précis. Ici c'est le calque SHAB. Si l'on sélectionne une polyligne qui ne fait pas partie du calque on a un message d'erreur. C'est pour éviter de cliquer sur une surface et de fausser les calculs, mon boss ne me le pardonnerai pas...

 

A très bientôt !

 

 

Sub Areatotal()

Dim s1 As Double, s2 As Double, s3 As Double, s4 As Double, s5 As Double
Dim s6 As Double, s7 As Double, s8 As Double, s9 As Double, s10 As Double

Dim st As Single

Dim returns1 As AcadObject
Dim returns2 As AcadObject
Dim returns3 As AcadObject
Dim returns4 As AcadObject
Dim returns5 As AcadObject
Dim returns6 As AcadObject
Dim returns7 As AcadObject
Dim returns8 As AcadObject
Dim returns9 As AcadObject
Dim returns10 As AcadObject
Dim returns11 As AcadObject
Dim returns12 As AcadObject

Dim Calqueobjet As String

Dim Ptinsert As Variant

Dim textStyle1 As AcadTextStyle
Dim currFontFile As String
Dim newFontFile As String

Dim currLayerTetxteSurfacetot As AcadLayer
Dim newLayerTetxteSurfacetot As AcadLayer
   
Dim txtsurf As String
Dim txtsurf2 As String
Dim txtsurftot As String

Dim plineAreatot As Single
Dim plineAreabistot As Integer
Dim plineAreabisbistot As Single
Dim areaintegertot As Integer

s1 = 0
s2 = 0
s3 = 0
s4 = 0
s5 = 0
s6 = 0
s7 = 0
s8 = 0
s9 = 0
s10 = 0
s11 = 0
s12 = 0

Surface_totale_form.Show


'Fait que si l'on tappe dans le vide l'addition se fait,
'fait aussi qu si l'on tappe entree l'add se fait
On Error GoTo CALCUL


' Pour piquer l'objet Surface 1
   ThisDrawing.Utility.GetEntity returns1, basePnt, "Sélectionnez la pièce 1 SVP"
   
   Calqueobjet = returns1.Layer
   If Calqueobjet = "SHAB" Then GoTo Objet1 Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
   GoTo SCAPE
   
Objet1:
   If returns1.color = acGreen Then
   returns1.color = acYellow
   Else: returns1.color = acGreen
   End If
   s1 = returns1.Area

    
' Pour piquer l'objet Surface 2
   ThisDrawing.Utility.GetEntity returns2, basePnt, "Sélectionnez la pièce 2 SVP"
   
   Calqueobjet = returns2.Layer
   If Calqueobjet = "SHAB" Then GoTo Objet2 Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
   GoTo SCAPE
   
Objet2:
   If returns2.color = acGreen Then
   returns2.color = acYellow
   Else: returns2.color = acGreen
   End If
   s2 = returns2.Area
      
' Pour piquer l'objet Surface 3
   ThisDrawing.Utility.GetEntity returns3, basePnt, "Sélectionnez la pièce 3 SVP"
   
   Calqueobjet = returns3.Layer
   If Calqueobjet = "SHAB" Then GoTo Objet3 Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
   GoTo SCAPE
   
Objet3:
   If returns3.color = acGreen Then
   returns3.color = acYellow
   Else: returns3.color = acGreen
   End If
   s3 = returns3.Area
      
' Pour piquer l'objet Surface 4
   ThisDrawing.Utility.GetEntity returns4, basePnt, "Sélectionnez la pièce 4 SVP"
   
   Calqueobjet = returns4.Layer
   If Calqueobjet = "SHAB" Then GoTo Objet4 Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
   GoTo SCAPE
   
Objet4:
   If returns4.color = acGreen Then
   returns4.color = acYellow
   Else: returns4.color = acGreen
   End If
   s4 = returns4.Area
  
' Pour piquer l'objet Surface 5
   ThisDrawing.Utility.GetEntity returns5, basePnt, "Sélectionnez la pièce 5 SVP"
   
   Calqueobjet = returns5.Layer
   If Calqueobjet = "SHAB" Then GoTo Objet5 Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
   GoTo SCAPE
   
Objet5:
   If returns5.color = acGreen Then
   returns5.color = acYellow
   Else: returns5.color = acGreen
   End If
   s5 = returns5.Area
    
' Pour piquer l'objet Surface 6
   ThisDrawing.Utility.GetEntity returns6, basePnt, "Sélectionnez la pièce 6 SVP"
   
   Calqueobjet = returns6.Layer
   If Calqueobjet = "SHAB" Then GoTo Objet6 Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
   GoTo SCAPE
   
Objet6:
   If returns6.color = acGreen Then
   returns6.color = acYellow
   Else: returns6.color = acGreen
   End If
   s6 = returns6.Area
  
' Pour piquer l'objet Surface 7
   ThisDrawing.Utility.GetEntity returns7, basePnt, "Sélectionnez la pièce 7 SVP"
   
   Calqueobjet = returns7.Layer
   If Calqueobjet = "SHAB" Then GoTo Objet7 Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
   GoTo SCAPE
   
Objet7:
   If returns7.color = acGreen Then
   returns7.color = acYellow
   Else: returns7.color = acGreen
   End If
   s7 = returns7.Area
   
' Pour piquer l'objet Surface 8
   ThisDrawing.Utility.GetEntity returns8, basePnt, "Sélectionnez la pièce 8 SVP"
   
   Calqueobjet = returns8.Layer
   If Calqueobjet = "SHAB" Then GoTo Objet8 Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
   GoTo SCAPE
   
Objet8:
   If returns8.color = acGreen Then
   returns8.color = acYellow
   Else: returns8.color = acGreen
   End If
   s8 = returns8.Area
  
' Pour piquer l'objet Surface 9
   ThisDrawing.Utility.GetEntity returns9, basePnt, "Sélectionnez la pièce 9 SVP"
   
   Calqueobjet = returns9.Layer
   If Calqueobjet = "SHAB" Then GoTo Objet9 Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
   GoTo SCAPE
   
Objet9:
   If returns9.color = acGreen Then
   returns9.color = acYellow
   Else: returns9.color = acGreen
   End If
   s9 = returns9.Area
   
' Pour piquer l'objet Surface 10
   ThisDrawing.Utility.GetEntity returns10, basePnt, "Sélectionnez la pièce 10 SVP"
   
   Calqueobjet = returns10.Layer
   If Calqueobjet = "SHAB" Then GoTo Objet10 Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
   GoTo SCAPE
   
Objet10:
   If returns10.color = acGreen Then
   returns10.color = acYellow
   Else: returns10.color = acGreen
   End If
   s10 = returns1.Area
  
  ' Pour piquer l'objet Surface 11
   ThisDrawing.Utility.GetEntity returns11, basePnt, "Sélectionnez la pièce 11 SVP"
   
   Calqueobjet = returns11.Layer
   If Calqueobjet = "SHAB" Then GoTo Objet11 Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
   GoTo SCAPE
   
Objet11:
   If returns11.color = acGreen Then
   returns11.color = acYellow
   Else: returns11.color = acGreen
   End If
   s11 = returns11.Area
  
  ' Pour piquer l'objet Surface 12
   ThisDrawing.Utility.GetEntity returns12, basePnt, "Sélectionnez la pièce 12 SVP"
   
   Calqueobjet = returns12.Layer
   If Calqueobjet = "SHAB" Then GoTo Objet12 Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
   GoTo SCAPE
   
Objet12:
   If returns12.color = acGreen Then
   returns12.color = acYellow
   Else: returns12.color = acGreen
   End If
   s12 = returns12.Area
  
  
  
   
   
   
' Pour calculer le total des surfaces
CALCUL:
   st = s1 + s2 + s3 + s4 + s5 + s6 + s7 + s8 + s9 + s10 + s11 + s12
   
' Create new text style
   Set textStyle1 = ThisDrawing.ActiveTextStyle
   newFontFile = "C:\WINDOWS\Fonts\arialni.ttf"
   textStyle1.fontFile = newFontFile

' Arrondit le chiffre de l'aire -en cours de travail-
   plineAreabistot = st * 100
   areaintegertot = plineAreabistot * 1
   plineAreabisbistot = plineAreabistot / 100


' Mémorise le calque courant, l'"active layer"
   Set currLayerTetxteSurfacetot = ThisDrawing.ActiveLayer

 ' Créé le layer Texte Surface pour y insérer le texte de la superficie
   Set newLayerTetxteSurfacetot = ThisDrawing.Layers.Add("Texte Surface Totale")
   ThisDrawing.ActiveLayer = newLayerTetxteSurfacetot


' Pour insérer le texte
   Ptinsert = ThisDrawing.Utility.GetPoint(, "Sélectionnez un Point SVP")
   

   
' insère le texte de l'aire totale
   txtsurf = "Surf. Totale = "
   txtsurf2 = " m²"
   txtsurftot = plineAreabisbistot & txtsurf2
   ThisDrawing.ModelSpace.AddText txtsurftot, Ptinsert, 0.2
   
    
' Retourne sur le calque d'avant l'insertion
   ThisDrawing.ActiveLayer = currLayerTetxteSurfacetot
   

   
SCAPE:
End Sub

[sechanbask]

Salut, j'ai survolé tout code et plusierus chose peut être améliorées:

 

Lorsque tu declares comme ça:

Dim s1 as double
Dim s2 As double

 

tu peux opérer une simplifiaction en déclarant s(i) en tant que tableau car on va boucler la somme

dim s(i) as double

 

 

pour les initialiser tes surfaces, tu peux faire :

 

s(i) = 0

 

et ça suffit car la somme sera boucler dans la partie suivante:

 

ensuite pour remplacer toutes les parties de ton programme, tu peux faire une boucle:

 

for i = 0 to 11
' Pour piquer l'objet Surface (i)
ThisDrawing.Utility.GetEntity returns(i), basePnt(i), "Sélectionnez la pièce (i) SVP"

Calqueobjet = returns(i).Layer
If Calqueobjet = "SHAB" Then GoTo Objet(i) Else
MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION"
GoTo SCAPE

Objet(i) :
If returns(i).color = acGreen Then
returns (i).color = acYellow
Else: returns(i).color = acGreen
End If
s(i) = returns(i).Area+ s
next i

 

 

Après pour afficher la somme tu peux afficher s(i)

 

ça permet d'alléger le code et de rendre l'application plus fluide et ton travail aussi car en épargnant le temps CPU de ton PC en mettant 12 pièces en 1, tu peux agrandir et mettre 40 par exemple pièces juste en mettant

 

dim returns(39) as AcadObject

 

 

j'ai parcouru le code assez rapidement si tu as des problème sur ton code avec les modifications, je pourrais t'aider..

 

tu peux aussi aller voir :

http:// http://www.vbfrance.com/tutoriaux/OPTIMISER-PROGRAMME-VISUAL-BASIC_519.aspx

c'est plutôt bien fait.

[Edité le 16/12/2006 par sechanbask]

 

[Edité le 16/12/2006 par sechanbask]

[phil_vsd]

Bonjour tous,

 

J'ai été un peu (beaucoup...) absent ces derniers temps pour cause de big virus et surtout de tracas professionnels. Je reviens donc un peu pour recoller à la vie !

 

Merci sechanbask, tes conseils me seront très utiles. Je n'ai pas eu l'occasion de travailler le VB depuis quelques mois et j'aimerai bien m'y remettre.

 

J'analyse tout cela et je tâcherai d'être plus dispo à l'avenir.

[sechanbask]

je serai là pour te filer un coup de main si tu en as besoin et si je suis capable de te répondre...

bonne fin de journée