Routine Surface

[phil_vsd]

Bonjour à tous...

 

Je vous présente une petite routine qui permet en cliquant sur une polyligne d'insérer un texte contenant la surface arrondie. C'est un outil qui peut servir lors du calcul de surfaces d'appartements.

 

Si quelqu'in pouvait la corriger, notament lorsque je clique sur des surface trop grandes ça ne marche pas. De plus je ne maîtrise pas la fonction "round" alors j'ai rusé...

 

J'ai d'autres routines je vais les chercher et je reviens...

 

Merci d'avance pour vos conseils ! phil_vsd@yahoo.fr

 

 

 

Sub Area()

   ' Calcul de l'aire d'une polyligne et insère la surface dans un calque précis
       
line1:
       
   On Error GoTo line2
       
   Dim plineArea As Single
   Dim plineAreabis As Integer
   Dim plineAreabisbis As Single
   Dim areainteger As Integer
   Dim returnObj As AcadObject
   Dim Pt1 As Variant
   Dim Textesurf As String
   Dim Textem2 As String
   Dim Texttout As String
   Dim currLayerTetxteSurface As AcadLayer
   Dim newLayerTetxteSurface As AcadLayer
       
   Dim textStyle1 As AcadTextStyle
   Dim currFontFile As String
   Dim newFontFile As String
   
   Dim currLayer As AcadLayer 'Variable pour le Calque courant
   Dim newLayer As AcadLayer  ' Variable pour le calque Texte Surface
 
   Dim Calqueobjet As String
 
   ' Pour piquer l'objet
   ThisDrawing.Utility.GetEntity returnObj, basePnt, "Sélectionnez un objet SVP"
   
   ' Récupère le nom du calque de l'objet choisi, cela  permet de prendre un objet qui soit bien une surface
   Calqueobjet = returnObj.Layer
   If Calqueobjet = "SHAB" Then GoTo alpha Else
   MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "Preuve de votre manque d'attention... :) "
        
   GoTo line1
   
alpha:
   
   ' Pour calculer l'aire de l'objet piqué
   plineArea = returnObj.Area
   
   ' Met la surface en rouge pour ne pas se tromper lors du clik, 3000 euros le m² à Marseille...
   returnObj.color = acRed
      
   ' Pour insérer le texte
   Pt1 = ThisDrawing.Utility.GetPoint(, "Sélectionnez un Point SVP")
   
          
       
    ' 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-
   plineArea = Format(plineArea, "#0.00")
   
   
    ' Mémorise le calque courant, l'"active layer"
   Set currLayerTetxteSurface = ThisDrawing.ActiveLayer
    
    ' Créé le layer Texte Surface pour y insérer le texte de la superficie
   Set newLayerTetxteSurface = ThisDrawing.Layers.Add("Texte Surface Appartement")
   ThisDrawing.ActiveLayer = newLayerTetxteSurface
    
   ' insère le texte de l'aire
   Textesurf = "Surf. : "
   Textem2 = " m²"
   Texttout = plineArea & Textem2 ' Dans ce cas les mots "Surf = " ont été supprimés

    
   ThisDrawing.ModelSpace.AddText Texttout, Pt1, 0.14

   
' Retourne sur le calque d'avant l'insertion
   ThisDrawing.ActiveLayer = currLayerTetxteSurface
   
   GoTo line1
   
line2:
   
End Sub

 

 

[didier]

hello,

 

j'aime les gens qui se coltinent avec le logiciel...

 

touijours est il que la référence à Basic est par trop apparente...

il va falloir apprendre à éviter, à mon avis, les appels à GOTO line...

 

je regarde ça demain, car ce soir, je vous prie d'accepter mes excuses,

nous avons eu une inauguration d'ouvrage d'art,

ce qui signifie

 

Sub Apéro()

While LaTêteTourne

call EncoreUnVerre

if LeTempsPasse then

call UnDernierEt JyVais

Else UnJackSec

enf if

Wend

End sub

 

amicalement

 

[phil_vsd]

Didier,

 

Je préfère que tu regardes la routine une autre fois... Après les apéros on est pas toujours d'applomb Hé hé... Mon prog va ressembler à :

 

Dim les collants à qui y sont...

Goto on sait plus

Syntax error selectionset heu...

 

Blague à part je ne suis pas pressé tant j'ai a apprendre... Et puis ce soir y'a Numbers sur la six.

Aujourd'hui jai performé les selectionset, les hachures et tout la tralala. Je suis content de vous connaître, j'ai tant galéré tout seul. J'ai acheté le livre "Programmer Autocad", y'a du lisp (Comprend rien encore...) du DCL et un peu de VBA...

 

Le but final de la manip sera que d'un clik, toutes mes polylignes qui représentent des surfaces aient un texte contenant leurs surfaces en leur centre. De plus si les surfaces changent (comme c'est le cas lors de projets d'archi) il faudrait que d'un clik ces textes soient formatés et les calculs relancés et les textes réinsérés. Pour l'instant je sait faire une collections remplies avec toutes les polylignes mais je ne sais pas lancer un calcul du style For each object in ... j'ai hâte d'y être pour voir le résultat !

 

Allez bon vernissage !

:)

[didier]

hello,

 

je t'en prie, j'ai de la bouteille !!!

 

ce que tu veux faire n'a pas besoin de VBA,

 

il te suffira de créer un CHAMP,

tu vas sélectionner OBJET, puis Aire

et à chaque REGEN, (voir fieldeval)

tes surfaces se mettront à jour si la polyligne a été modifiée..

 

amicalement

[phil_vsd]

Salut Didier !

 

Effectivement avec les champs dynamiques et un bon réglages des variable ça roule. En plus j'ai découvert les champs dynamiques depuis hier grâce à Patrick pour une autre histoire de routine et je n'ai pas eu le temps de les essorer pour voir leur potentiel... Toute mes routines VBA deviennent obsolètes avec le temps... Et que de temps passé ! Je ne regrette rien cela m'a donné le goût pour le VBA.

Les champs dyn sont une pièce maîtresse pour la productivité. J'ai trouvé un autre truc pour le périmètre, on applique le Champ sur une région... Cela ouvre des horizons !

 

Merci encore mais ne t'en vas pas si vite on a besoin de toi dans :

 

"Accueil du Forum > VBA et VB > centroid d'une polyligne fermée" car même si cela résout une partie du problème, il faut créer automatiquement des régions dans une selectionset... on a pas envie de se les créer une par une à cliquer partout... (On est pas fainéants, on est rentables...)

 

Excuse nous si on t'a pourri ton week-end... :P