placer et dimmensionner un rectangle automatiquement

[olhey]

Bonjour,

J'ai un défi assez intéressant:

Comme vous allez le voir dans le fichier j'ai des ouvrages(ponts, tunnels, galerieS) qu'il faudrait placer dans un tableau par vba.

Le programme devrait:
1. calculer la longueur de l'ouvrage(km fin-km début)(=longeur du rectangle)
2. Calculer sa position par rapport à la ligne métrique(avec km début )(=position du rectangle)
3. puis en fonction de l'ouvrage lui attribuer la couleur adéquate

il s'agit de rectangle très très fin en fait. Il faudrait encore que le vba le place en au de la cellule, en fait comme dans l'exemple.

est ce que c'est possible à réaliser? Ca serait vraiment super

MERCI les as

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

hello!

J'ai décidé de mettre mes ouvrages gauche/droite sur 2 ligne:

les ouvrages g serais sur la première ligne en haut et les ouvrages d sur la deuxième ligne en bas.

Sub AfficheOuvrage(Ouvrage As String, Origine As Range, posDeb As Double, Longueur As Double, Couleur As Integer, Direction As String)
    Dim Echelle As Double
    Dim poshOuvrage As Integer, Hauteur As Integer, posvOuvrage As Integer
    [COLOR="red"]Dim origineV As Range[/COLOR]
     
    
    
    Echelle = (Origine.Width / 100) * 1000
    
    If Direction = "G" Then
       Hauteur = Origine.Top
       posvOuvrage = 0
       [COLOR="Red"]origineV = Origine.Left + (posDeb * Echelle)[/COLOR]
    Else
        Hauteur = Origine.Top + Origine.Height - 1
        posvOuvrage = 1
        [COLOR="red"]origineV = Origine.Offset(1, 0).Left + (posDeb * Echelle)[/COLOR]
    End If
    
    With Origine.Parent.Shapes.AddShape(msoShapeRectangle, [COLOR="red"]origineV[/COLOR], Hauteur, Longueur * Echelle, 2)
        .Name = "Ouvrage_" & Ouvrage
        .Fill.Visible = msoTrue
        .Fill.ForeColor.SchemeColor = Couleur
        .Line.Visible = msoFalse
    End With

mais il me dit que la variable objet ou variable de bloc with n'est pas définie...


MERCI!

 

[mutzik]

Re : placer et dimmensionner un rectangle automatiquement

bonjour,

à mon avis, il faut d'abord que tu crée ton objet (.add ... + paramètres)
et ensuite que tu fasses ton bloc with ...

 

[Minick]

Re : placer et dimmensionner un rectangle automatiquement

Salut,

originev ne sert a rien, tu fais un offset pour voir la position (gauche).
Mais comme tu changes seulement de ligne origine.left et origine.offset(1,0).left sont identique.
En plus tu as definis originev en range alors que tu veux lui affecter un entier.
Le plantage vient de la, comme tu as declare originev comme un objet
tu devrais utiliser Set originev=....
Mais bon la ca servira a rien.

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

hum...

ouais ya encore du travail, c'est vrai que j'ai pas très bien saisi le but de Left.
pour le offset, je comprends pas pourquoi si je déplace l'origine de mon ouvrage d'une ligne ça ne fonctionne pas étant donnée que ouvrageV et le paramètre de mon recrangle...

Merci de ta persévérance

EDIT: héhé I've found myself

if Direction = "D" Then
       Hauteur = Origine.[COLOR="Red"]Offset(1, 0).[/COLOR]Top + Origine.Height - 1
        posvOuvrage = 1
    Else
        Hauteur = Origine.Top
       posvOuvrage = 0
    End If

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

re, Est ce que ça serait possible que les paramètres de addshape soient entièrement paramètrables sous forme de variables.

[...]
 [COLOR="red"]With Origine.Parent.Shapes.AddShape(forme, Origine.Left + (posDeb * Echelle), Hauteur, Longueur * Echelle, taille)[/COLOR]
[...]
With ShtDest
                    Select Case Ouvrage
                        Case "Viaducs"
                            [COLOR="Red"]forme=trapezoide
                            taille= 3
                             ... autres paramètres[/COLOR] 
                            Couleur = 60                           
                             Set Origine = .Range("G54")
                            
                        Case "Ponts"
                            Couleur = 53
                            Set Origine = .Range("G55")
                        
                        Case "Ponceaux"
                            Couleur = 52
                            Set Origine = .Range("G56")
                            
                        Case "Voûtages"
                            Couleur = 51
                            Set Origine = .Range("G57")
                            
                        Case "Galeries"
                            Couleur = 61
                            Set Origine = .Range("G59")
                        
                        Case "Tunnels creusés"
                            Couleur = 54
                            Set Origine = .Range("G60")
                            
                        Case "Murs de soutènement"
                            Couleur = 46
                            Set Origine = .Range("G61")
                            
                        Case "Passages inférieurs"
                            Couleur = 57
                            Set Origine = .Range("G63")
                        
                        Case "Passages supérieurs"
                            Couleur = 57
                            Set Origine = .Range("G64")
                            
                         Case "Protections anti-bruit"
                            Couleur = 11
                            Set Origine = .Range("G74")
                        
                        Case Else
                            Couleur = 0
                    End Select
                End With

qqch comme ça qui me permettrai en fonction des ouvrages d'afficher différents types de forme, car par exemple j'ai des places d'évitement qui seraient représentées par des trapèzes.

Bon une difficulté supplémentaire c'est qu'entre les places d'évitements gauches et droites il y a 4 ligne(shématisant les voies)... donc faut aussi voir pour paramètré le positionnement.

MERCI bein

 

[Minick]

Re : placer et dimmensionner un rectangle automatiquement

Salut,

C'est certainement possible mais il va surement falloir revoir un peu la facon de faire.

Un classeur avec tous les types d'ouvrages serait le bienvenu...

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

okay, voilà une liste avec leur moyen de représentation, je rajouterai peut être d'autres types, c'ets pour ça que ça serait pas mal de rendre ceci assez simple.

A+
EDIT: une petite image d'illustration

 

[Minick]

Re : placer et dimmensionner un rectangle automatiquement

Re,

Tu trouveras ci-joint le programme modifie (sur l'exemple initial).
J'ai utilise une structure pour definir les infos de l'ouvrage a dessiner.
Donc pour chaque type d'ouvrage tu pourras definir ses parametres.

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

Non mais c'est top! je viens de jeter un coup d'oeil ça à l'air nickel, ça sera parfait pour mon projet! je me réjouis de fouiner dedans!

Je te redonnerai des nouvelles en tous cas merci!

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

J'ai adapter le script à mon projet, c'est vraiment nickel. ça laisse une liberté totale dans la gestion de l'affichage des ouvrages!

Il faudarait juste que je puisse paramétrer la visibilité des l'encadrement des formes(line.visible)(je sais pas dans quel type déclarer la variable: Etat as Mso...??)
et que si certaines formes sont à droite qu'elles se retournent de 180°, par exemple pour les trapèzes..) je crois que après je serais gentilement au bout!
Merci encore mille fois!!

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

minick as tu eu le temps de jeter un coup d'oeil au modifications?

merci

 

[Minick]

Re : placer et dimmensionner un rectangle automatiquement

Salut,

Zieute la piece jointe, j'ai simplement ajoute 2 elements dans la structure.

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

that's great! maintenant je crois que j'ai compris comment ça fonctionne!

Merci bcp!

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

hello, en contrôlant mon tableau je me suis rendu compte qu'à des endroits les ouvrage sne s'affichent pas, j'ai essayé de régler le problème en bidouillant, mais je n'arrive pas à régler le problème.

regarde la ligne des Brücken, B11, B12 ne s'affichent pas par exemple...

voilà le fichier:

Cijoint.fr - Service gratuit de dépôt de fichiers

Merci beaucoup

 

[Minick]

Re : placer et dimmensionner un rectangle automatiquement

Salut,

Le prob vient de InfoSup qui efface le nom de l'ouvrage.

Remplace AfficheOuvrage comme ceci:

Sub AfficheOuvrage(infOuvrage As infosOuvrage)
    With Sheets(infOuvrage.Feuille).Shapes.AddShape(infOuvrage.Forme, infOuvrage.X, infOuvrage.Y, infOuvrage.Longueur, infOuvrage.Hauteur)
        .Name = "Ouvrage_" & infOuvrage.Nom
        .Fill.ForeColor.SchemeColor = infOuvrage.Couleur
        .Line.ForeColor.SchemeColor = infOuvrage.CouleurBordure
        .Fill.Visible = infOuvrage.Fond
        .Line.Visible = infOuvrage.Bordure
        .Rotation = infOuvrage.Rotation
    End With

    While infOuvrage.Origine.Offset(infOuvrage.posyNom, infOuvrage.posxNom).Value <> ""   'affichage du nom si il y en a déjà 1 dans la cellule
        infOuvrage.posxNom = infOuvrage.posxNom + 1
    Wend
    
    
    infOuvrage.Origine.Offset(infOuvrage.posyNom, infOuvrage.posxNom).Value = infOuvrage.Nom    'affichage du nom
    
    'affichage des infos supplémentaires
    If infOuvrage.InfoSup <> "" Then
        While infOuvrage.Origine.Offset(, infOuvrage.posxInfoSup - 1).Value <> ""   'affichage du nom si il y en a déjà 1 dans la cellule
            infOuvrage.posxInfoSup = infOuvrage.posxInfoSup + 1
        Wend
        
        With infOuvrage.Origine.Offset(, infOuvrage.posxInfoSup - 1)
            .Value = infOuvrage.InfoSup
            .Font.Size = 5
            .MergeCells = True
        End With 'affichage des infos supplémentaires
    End If
End Sub