Insertion d'un texte sur une image insérée dans un Range

Version imprimable

Bonjour à tous
Je galère depuis de nombreuses heures, cherchant en vain dans l'aide en ligne, avec l'enregistreur de macros, sur Internet pour trouver la bonne syntaxe qui fonctionne pour réaliser mon projet:
j'ai inséré une image dans un range de quelques cellules qui s'appelle "LunZone".
Je souhaiterais insérer sur cette image un texte verticalement.
Pour cela j'essaie de mettre un textbox de nom "TexteLunZone" transparent dans lequel j'écris par exemple "Journée italienne".
Si je fais la manip avec l'enregistreur de macro, tout est correct, mais lorsque je l'intègre dans mon prog cela ne donne plus le résultat escompté.
J'ai fais un petit programme test pour faire mes essais:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
Sub ToucheF9()
    Dim i As Long
    Dim RepertoirePhoto As String
    RepertoirePhoto = "C:\Documents and Settings\Michel\Mes documents\Mes Images\"
    Dim Nom As String
    Nom = "PhotoTest"
    Dim cel As Range
    Dim sh As Shape
    Set cel = Range("LunZone")
    With ActiveSheet
        .Pictures.Insert(RepertoirePhoto & Nom & ".jpg").Name = Nom
        .Shapes(Nom).Left = cel.Left
        .Shapes(Nom).Top = cel.Top
        .Shapes(Nom).LockAspectRatio = msoFalse
        .Shapes(Nom).Height = cel.Height
        .Shapes(Nom).Width = cel.Width
        .Shapes.AddTextbox(msoTextOrientationVertical, _
                           cel.Left, cel.Top, cel.Width, cel.Height).Select
        Selection.Name = "TexteLunZone"
        Set sh = .Shapes("TexteLunZone")
        With sh
            .Fill.Visible = msoFalse
            .Fill.Solid
            .Flip msoFlipVertical
            .Fill.Transparency = 0#
            .Line.Weight = 0.75
            .Line.DashStyle = msoLineSolid
            .Line.Style = msoLineSingle
            .Line.Transparency = 0#
            .Line.Visible = msoFalse
            With .TextFrame
                .Characters.Text = "Journée italienne"
                .Characters(Start:=1, Length:=17).Font.Color = vbBlack
                .Characters.Font.Name = "Monotype Corsiva"
                .Characters.Font.Size = 36
                .Characters.Font.Underline = xlUnderlineStyleNone
                .Characters.Font.ColorIndex = xlAutomatic
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .ReadingOrder = xlContext
                .Orientation = msoTextOrientationVertical
                .AutoSize = False
                MsgBox .Characters.Font.Name
            End With
        End With
    End With
    Set sh = Nothing
    Set cel = Nothing
End Sub

Si quelqu'un pouvait me dire où cela cloche

Merci
Michel

Bonjour,

Utilise plutôt un Label pour la transparence :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
 
Sub ToucheF9()
 
    Dim i As Long
    Dim RepertoirePhoto As String
    Dim Nom As String
    Dim cel As Range
    Dim sh As Shape
 
    RepertoirePhoto = "C:\Documents and Settings\Michel\Mes documents\Mes Images\"
 
    Nom = "PhotoTest"
 
    Set cel = Range("LunZone")
 
    With ActiveSheet
 
        .Pictures.Insert(RepertoirePhoto & Nom & ".jpg").Name = Nom
 
        With .Shapes(Nom)
 
            .Left = cel.Left
            .Top = cel.Top
            .LockAspectRatio = msoFalse
            .Height = cel.Height
            .Width = cel.Width
 
        End With
 
        Set sh = .Shapes.AddLabel(msoTextOrientationVertical, cel.Left, cel.Top, cel.Width, cel.Height)
 
        With sh
 
            .Name = "TexteLunZone"
            .Fill.Visible = msoFalse
            .Fill.Solid
            .Flip msoFlipVertical
            .Fill.Transparency = 1#
            .Line.Weight = 0.75
            .Line.DashStyle = msoLineSolid
            .Line.Style = msoLineSingle
            .Line.Transparency = 1#
            .Line.Visible = msoFalse
 
            With .TextFrame
 
                .Characters.Text = "Journée italienne"
                .Characters(1, Len(.Characters.Text)).Font.Color = vbBlack
                .Characters.Font.Name = "Monotype Corsiva"
                .Characters.Font.Size = 36 '<-- une telle taille de fonte risque de modifier la taille d'origine de l'objet
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Orientation = msoTextOrientationVertical
                .AutoSize = False
 
            End With
 
        End With
 
    End With
 
    Set sh = Nothing
    Set cel = Nothing
 
End Sub

Hervé.

10/10/2014, 18h26
mormic

Réponse à Hervé

Hervé

mais pourquoi la zone du label ne s'incorpore pas dans zone définie par "cel.Left, cel.Top, cel.Width, cel.Height"

De plus j'ai essayé d'utiliser orientation = vbUpward <-- erreur: la valeur est en dehors des limites ??

Quelle galère !

Merci tout de même
11/10/2014, 12h04
Theze
Bonjour,

Comme je l'ai précisé en commentaire dans le code :
Code:

1 2 .Characters.Font.Size = 36 '<-- une telle taille de fonte risque de modifier la taille d'origine de l'objet
la définition d'une fonte trop grande redimensionne le Label !
Mets cette commande en commentaire afin que la taille de la fonte soit celle par défaut et regarde le résultat ensuite, trouve la taille de la fonte qui entre dans le Label sans en modifier les dimensions.

Hervé.

Bonjour
Je viens enfin de voir le bout du tunnel. En fait mon code n'était pas si mauvais que je le pensais: au cours je mes multiples manœuvres, j'avais sauvegardé dans ma feuille de test un shape "TexteLunZone" que je ne voyais pas car il était transparent. Alors, lorsque je lançais mon prog il se plantait lorsque j'essayais de créer un shape du même nom!! Bon grâce aussi à l'aide l'Hervé voilà le code qui va bien:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Sub ToucheF9()
    Dim i As Long
    Dim RepertoirePhoto As String
    RepertoirePhoto = "C:\Documents and Settings\Michel\Mes documents\Mes Images\"
    Dim Nom As String
    Nom = "PhotoTest"
    Dim cel As Range
    Dim sh As Shape
    Set cel = Range("LunZone")
    With ActiveSheet
        .Pictures.Insert(RepertoirePhoto & Nom & ".jpg").Name = Nom
        .Shapes(Nom).Left = cel.Left
        .Shapes(Nom).Top = cel.Top
        .Shapes(Nom).LockAspectRatio = msoFalse
        .Shapes(Nom).Height = cel.Height
        .Shapes(Nom).Width = cel.Width
        .Shapes.AddTextbox(msoTextOrientationUpward, _
                           cel.Left, cel.Top, cel.Width, cel.Height).Name = "TexteLunZone"
        Set sh = .Shapes("TexteLunZone")
        With sh
            .Fill.Visible = msoFalse
            .Line.Visible = msoFalse
            With .TextFrame
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                With .Characters
                    .Font.Name = "Monotype Corsiva"
                    .Font.Size = 36
                    .Font.Color = vbBlue
                    .Text = "Journée italienne"
                End With
            End With
        End With
    End With
End Sub

Et là mon textbox s'intègre parfaitement dans ma photo, la taille de la police n'influant pas la taille de la zone

Merci encore

Michel