Mauvais placement de SHAPE selon pc

Bonjour,

je viens à vous car je suis à bout d'idée!!!!!

Grâce à ce code, je crée une SHAPE dans un onglet.

Pour des raisons que je ne comprend pas, selon un à un autre la SHAPE n'a pas tout à fait la même taille, ni le même emplacement.

Le dérèglement se situe au niveau de l'horizontal!

Si quelqu'un à une idée, je suis preneur, sinon je cherche à créer la SHAPE mais non pas en avec des dimensions mais dans une RANGE.

Voici le code (proc d'appel et code):

Sub draw_b()
DrawImage "dessin_b", "294", "68", "251", "168"
End Sub

Sub DrawImage(Nom As String, gauche As String, haut As String, largeur As String, hauteur As String)
Dim protec As Integer

On Error GoTo ErrorHandler

Application.ScreenUpdating = False

If ActiveSheet.ProtectContents = True Then
protec = 1
Else
protec = 0
End If

Call Module1.unprotect_hide

On Error Resume Next

fichetech.Shapes(Nom).Delete

If Nom = "dessin_a" Then
fichetech.Shapes("Cible_a").Delete
ElseIf Nom = "dessin_b" Then
fichetech.Shapes("Cible_b").Delete
End If

On Error GoTo ErrorHandler

With ActiveSheet.Shapes.AddShape(msoShapeRectangle, gauche, haut, largeur, hauteur)
    .Name = Nom
    .Fill.ForeColor.RGB = RGB(255, 255, 255)
    .Line.ForeColor.RGB = RGB(255, 0, 0)
    .TextFrame2.TextRange.Characters(-1, -1).Font.Fill.ForeColor.RGB = RGB(100, 0, 0)
    .Line.Weight = 0.5
    .Line.Style = msoLineSingle
End With

'mettre en background
ActiveSheet.Shapes.Range(Array(Nom)).Select
Selection.ShapeRange.ZOrder msoSendToBack
SendKeys "{ESC}"

End_ErrorHandler:
If protec = 1 Then
Call Module1.protect_hide
End If

Application.ScreenUpdating = True

Exit Sub

ErrorHandler:
MsgBox Err.Number & vbLf & Err.Description
GoTo End_ErrorHandler
End Sub

bonjour,

si tu veux placer un shape par rapport à une cellule déterminée, regarde le code ci-après

alignement du shape nommé "rectangle 1" sur D2

Sub test()
With ActiveSheet.Shapes("rectangle 1")
.Top = Range("D2").Top
.Left = Range("D2").Left
End With
End Sub

Bonjour le forum,

Pour inspiration,

Crdt

merci pour votre aide,

en travaillant, j'ai pondu ça, vous en pensez quoi?

Set position = Range(placement)

With ActiveSheet.Shapes.AddShape(msoShapeRectangle, position.Left, position.Top, position.Width, position.Height)
    .Name = Nom
    .Fill.ForeColor.RGB = RGB(255, 255, 255)
    .Line.ForeColor.RGB = RGB(255, 0, 0)
    .TextFrame2.TextRange.Characters(-1, -1).Font.Fill.ForeColor.RGB = RGB(100, 0, 0)
    .Line.Weight = 0.5
    .Line.Style = msoLineSingle
End With