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

 

[Minick]

Re : placer et dimmensionner un rectangle automatiquement

Salut,

Essaie le piece jointe

 

[mromain]

Re : placer et dimmensionner un rectangle automatiquement

bonjour olhey, Minick,

Minick a été plus rapide, mais je poste quand même mon essai

a+

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

Bonjour, Je m'ecuse platement de ne pas avoir fait signe plus tôt mais jai toujours cru que mon message était rester sans réponse! je suis entrain de tester les deux variantes.

Ya t il une version plus légère que l'autre(j'aurait pas mal d'élément à faire déssiner)?

Merci en tous cas et encore dsl de ne pas avoir répondu plus tôt

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

Je suis en train d'adapter le script à mon projet et il m'affiche une erreur de type 13

pour cette ligne...

Call AfficheOuvrage(.Range("D" & Cpt).Value, Origine, .Range("G" & Cpt).Value, .Range("J" & Cpt).Value - .Range("G" & Cpt).Value, Couleur)

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

J'ai décider d'utiliser la version de minick, plus facile pour ajouter des types d'ouvrages.

J'ai un problème car jai des ouvrages sur plus de 21 km(donc pas assez de colonne j'ai modifié le script pour qu'il continur sur une autre feuil mais j'ai un problème de permission

Je joint un fichier pour que vous puissier voir vous même

ption Explicit

Sub AfficheOuvrage(Ouvrage As String, Origine As Range, posDeb As Double, Longueur As Double, Couleur As Integer)
    Dim Echelle As Double
    Dim posOuvrage As Integer
    
    Echelle = (Origine.Width / 100) * 1000
    
    If Not posDeb > 21 Then
        
    [COLOR="red"]With Feuil1[/COLOR].Shapes.AddShape(msoShapeRectangle, Origine.Left + (posDeb * Echelle), Origine.Top, Longueur * Echelle, 3)
        .Name = "Ouvrage_" & Ouvrage
        .Fill.ForeColor.SchemeColor = Couleur
        .Line.Visible = msoFalse
    End With
    
    Else
    [COLOR="red"]With Feuil3[/COLOR].Shapes.AddShape(msoShapeRectangle, Origine.Left + (posDeb * Echelle) - 210, Origine.Top, Longueur * Echelle, 3)
        .Name = "Ouvrage_" & Ouvrage
        .Fill.ForeColor.SchemeColor = Couleur
        .Line.Visible = msoFalse
    End With
    End If
    
    
    posOuvrage = ((posDeb + (Longueur / 2)) * Echelle) / Origine.Width

    Origine.Offset(, posOuvrage).Value = Ouvrage
End Sub

Sub CreationOuvrage()
    Dim Shp As Shape
    Dim Cpt As Integer, Couleur As Integer
    Dim Origine As Range
    Dim Ouvrage As String
    
    Application.ScreenUpdating = False
        For Each Shp In Feuil1.Shapes
            If Left(Shp.Name, 8) = "Ouvrage_" Then
                Shp.Delete
            End If
        Next Shp
        
        Feuil1.Range("F5:AN11").Clear
        With Feuil2
            For Cpt = 5 To Feuil2.Range("C65536").End(xlUp).Row
                If .Range("B" & Cpt).Value <> "" Then
                    Ouvrage = .Range("B" & Cpt).Value
                    Select Case Ouvrage
                        Case "ponts"
                            Couleur = 50
                            Set Origine = Feuil1.Range("F5")
                            
                        Case "tunels"
                            Couleur = 53
                            Set Origine = Feuil1.Range("F8")
                        
                        Case "galerie"
                            Couleur = 4
                            Set Origine = Feuil1.Range("F11")
                        
                        Case Else
                            Couleur = 0
                    End Select
                End If
                
                If Couleur <> 0 And .Range("C" & Cpt).Value <> "" And .Range("C" & Cpt).Value <> "no" Then
                    Call AfficheOuvrage(.Range("C" & Cpt).Value, Origine, .Range("F" & Cpt).Value, .Range("H" & Cpt).Value - .Range("F" & Cpt).Value, Couleur)
                End If
            Next Cpt
        End With
    Application.ScreenUpdating = True
End Sub

MERIC DE VOTRE AIDE PRECIEUSE.

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

Je me permet de up le topic

Mais je suis totallement bloqué est ça doit être un tout petit truc

 

[Minick]

Re : placer et dimmensionner un rectangle automatiquement

Salut,

Ci-joint la modif.

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

Merci Minick t'es un as!!! j'ai juste encore un petit problème...

J'ai juste adapter les références de cellules, colonnes etc... à mon projet, tout fonctionne sauf qu'il dessine les rectangles mais sans les remplir de couleur... j'arrive à les selectionner mais ils sont ''invisible''.

Voyez vous même le printscreen

Merci bcp de votre aide

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

Problème résolu en ajoutant:

[...] With Origine.Parent.Shapes.AddShape(msoShapeRectangle, Origine.Left + (posDeb * Echelle), Origine.Top, Longueur * Echelle, 3)
        .Name = "Ouvrage_" & Ouvrage
        .Fill.ForeColor.SchemeColor = Couleur
        [COLOR="Red"].Fill.Visible = msoTrue[/COLOR]
        .Line.Visible = msoFalse
    End With [...]

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

Encore une question..

Si j'ai deux ouvrages du même type (ex: 2 ponts) qui son très proche il affiche seulement P2, il faudrait que si il ya déjà qqch d'écrit dans la case il affiche le nom de l'ouvrage dans la case suivant ou précédante...

Merci

 

[Minick]

Re : placer et dimmensionner un rectangle automatiquement

Re,

Ajoute ceci

While Origine.Offset(, posOuvrage).Value <> ""
        posOuvrage = posOuvrage + 1
    Wend

avant

    Origine.Offset(, posOuvrage).Value = Ouvrage

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

MErci encore minick
fiouh.. j'ai encore un problème.

J'ai des types d'ouvrages (ex: parois anti bruit) qui si ils sont à gauche de la route devraient s'afficher en haut de la cellule et si ils sont à droite en bas.

J'ai penser rajouter un une colonne à ma "bd" avec des "g" et des "d" pour chauqe ouvrages qui ferais varier les paramètres du rectangle, au lieu d'avoir origine.top on aurait origine.bottom lorsque le contenu de cette colonne = d.

MERCI encore

 

[Minick]

Re : placer et dimmensionner un rectangle automatiquement

re,

zieute la piece jointe...

 

[olhey]

Re : placer et dimmensionner un rectangle automatiquement

C'est super j'avance hyper vite, MERCI!!