probleme avec Shaperange.Group : Erreur 1004 au deuxième passage.

**Godzestla** · 02/10/2014, 13h01

Bonjour,

le code suivant fonctionnant sous Office 2003 plante sous Office 2010 sur la méthode .group .. lors du deuxième passage dans la boucle.

Le premier passage dans la boucle semble donner le résultat attendu, à savoir 1 Shape bien positionné en haut à gauche de l'écran avec un code actif quand on clique dessus.

Je n'ai pas écrit ce code mais je dois le faire tourner sous office 2010.

(Je n'ai jamais travaillé avec les Shapes).

J'ai fait toutes les vérifications d'usage : les shapes concernées existent bien tous, dans l'activesheet et les variables ar et PrArPgmInd sont bien initialisées.

L'erreur renseignée est la

Run-Time error 1004

je ne sais vraiment pas quoi faire.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
  
i = 1
  While I < AnzDaten + 1
    I = I + 1
    ar = F1.Fuenfstellig(Four.Cells(I, 4))
    PrArPgmInd = Four.Cells(I, 3) & "/" & ar & "/" & Four.Cells(I, 8) & "/" & Four.Cells(I, 9)
         Selection.Name = ar
        Selection.OnAction = "Macroaufruf"
       'Rahmenfarbe je nach Ofenzeit anbpassen
        With Selection.ShapeRange
          .Line.Weight = 2#
          .Line.Visible = msoTrue
          If Mat_auf_Pr = "X" Then .Line.DashStyle = msoLineDash
          Select Case Zeit
            Case Is < 400: .Line.ForeColor.SchemeColor = 12 'Blauer Ofen
            Case Is > 1000: .Line.ForeColor.SchemeColor = 10 'Roter Rahmen
          Case Else
            .Line.ForeColor.SchemeColor = 17 'Grüner Rahmen
          End Select
        End With
      
        Call Textbox1(ar, Exp, BolNr, AnzAusg, Korr, PS_ja) ' Ar/Exemplar-Bolsternr-Anz. Ausg. - Korrektor einfügen
        Call Textbox2(Leg, Blck_l, AnzBl, Kun_l)      ' Leg./Blocklänge/Anz. Blöcke/Kundenlänge) einfügen
        Call Textbox3(CodSurf, Anolaq, Traitfour)     ' CodSurf/Anolaq /Ofenbehandlung einfügen
        Call Textbox4(Pro_Ver)                        ' Proto,Relance oder Versuch ? einfügen
        Call Textbox5(ExtCor)                         ' mit Korrektor oä.einfügen
        Call Textbox6(Arbvor_ja)                      ' Arbeitsvorschrift ! einfügen
        Call Textbox7(Stunden, Minuten, Zeit)         ' Ofenzeit einfügen
        Call Textbox8(Zweiw_ja)                       ' Info ob Zweiwachs oder nicht einfügen
            
        H = H + 1
        If H > AnzBil_h - 1 Then
          H = 0: J = J + 1
        End If
     
With ActiveSheet.Shapes.Range(Array("Txt1", "Txt2", "Txt3", "Txt4", "Txt5", "Txt6", "Txt7", "Txt8", ar))
            .Select
            .Group
            .Name = PrArPgmInd
            .Top = Kv + J * 170
            .Left = Kh + H * 132
        End With
  Wend

Les modules Textboxn sont ici :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
Sub Textbox1(ar As String, Exp As String, BolNr As String, AnzAusg As Byte, Korr As String, PS_ja As Byte)
' Ziel: (Ar/Exemplar-Bolsternr-Anz. Ausg.) einfügen
 
  ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 0, 122, 13).Select
  Selection.Characters.Text = ar & "/" & Exp & "-" & BolNr & "-" & AnzAusg & " A.-" & Korr
  With Selection.Characters(Start:=1, Length:=30).Font
    .FontStyle = "Bold"
    .Size = 10
    .ColorIndex = 14
  End With
  If PS_ja = 1 Then
    With Selection.Characters(Start:=1, Length:=5).Font
      .ColorIndex = 1
    End With
  End If
  With Selection.ShapeRange.Fill
    .Visible = msoFalse
    .Solid
    .ForeColor.SchemeColor = 9
  End With
  Selection.ShapeRange.Line.Visible = msoFalse
  Selection.HorizontalAlignment = xlRight
  Selection.Name = "Txt1"
End Sub
Sub Textbox2(Leg As String, Blck_l As Single, AnzBl As Byte, Kun_l As Single)
' Ziel:(Leg./Blocklänge/Anz. Blöcke/Kundenlänge) einfügen
 
  ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 105, 130, 13).Select
  Selection.Characters.Text = Leg & "/" & Blck_l & "/" & AnzBl & " Bl. / " & Kun_l & " m"
  With Selection.Characters(Start:=1, Length:=30).Font
    .FontStyle = "Bold"
    .Size = 10
    .ColorIndex = 1
  End With
  With Selection.ShapeRange.Fill
    .Visible = msoFalse
    .Solid
    .ForeColor.SchemeColor = 9
  End With
  Selection.ShapeRange.Line.Visible = msoFalse
  Selection.Name = "Txt2"
End Sub
Sub Textbox3(CodSurf As String, Anolaq As String, Traitfour As String)
' Ziel:(CodSurf/Anolaq)einfügen
  ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 90, 120, 17).Select
  With Selection
    With .Characters
      .Text = CodSurf & "/" & Traitfour & "/" & Anolaq
      .Font.FontStyle = "Bold"
      .Font.Size = 10
    End With
    .Font.ColorIndex = 5
    .ShapeRange.ZOrder msoBringToFront
    .Name = "Txt3"
  End With
  Selection.ShapeRange.Fill.Visible = msoFalse
  Selection.ShapeRange.Line.Visible = msoFalse
End Sub
Sub Textbox4(Pro_Ver As String)
' Ziel:(Proto,Relance oder Versuch ?)einfügen
  If Pro_Ver = vbNullString Then Pro_Ver = "kein"
    ActiveSheet.Shapes.AddTextEffect(msoTextEffect8, Pro_Ver, "Arial Black", 10#, msoFalse, msoFalse, 2, 12).Select
    Selection.ShapeRange.Fill.Visible = msoTrue
  With Selection.ShapeRange.Fill
    .Visible = msoTrue
    .ForeColor.SchemeColor = 10
    .BackColor.SchemeColor = 10
  End With
  Selection.Name = "Txt4"
  If Pro_Ver = "kein" Then Selection.ShapeRange.Fill.Visible = msoFalse
End Sub
Sub Textbox5(ExtCor As String)
' Ziel:(mit Korrektor oä.)einfügen
  If ExtCor = vbNullString Then ExtCor = "ohne"
  ActiveSheet.Shapes.AddTextEffect(msoTextEffect2, ExtCor, "Arial Black", 16#, msoFalse, msoFalse, 30, 20).Select
  With Selection.ShapeRange.Fill
    .Visible = msoTrue
    .ForeColor.RGB = RGB(255, 231, 1)
    .BackColor.SchemeColor = 10
    .Transparency = 0#
    .TwoColorGradient msoGradientHorizontal, 1
  End With
  Selection.Name = "Txt5"
  If ExtCor = "ohne" Then
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Line.Visible = msoFalse
  End If
End Sub
Sub Textbox6(Arbvor_ja As Byte)
Dim ArbFarbe As Byte
' Ziel:(Arbeitsvorschrift !) einfügen
  Select Case Arbvor_ja
    Case Is = 1
     ActiveSheet.Shapes.AddTextEffect(msoTextEffect8, "Arbeitsvorschrift !", "Arial Black", 8#, msoFalse, msoFalse, 38, 12).Select
     Selection.ShapeRange.Fill.Visible = msoTrue
     If ArbTage > 90 Then ArbFarbe = 57 Else ArbFarbe = 12
     With Selection.ShapeRange.Fill
      .Visible = msoTrue
      .ForeColor.SchemeColor = ArbFarbe
      .BackColor.SchemeColor = ArbFarbe
     End With
    Case Is = 2
     ActiveSheet.Shapes.AddTextEffect(msoTextEffect8, "Allg. Vorschrift !!", "Arial Black", 8#, msoFalse, msoFalse, 38, 12).Select
     Selection.ShapeRange.Fill.Visible = msoTrue
     If ArbTage > 90 Then ArbFarbe = 57 Else ArbFarbe = 10
     With Selection.ShapeRange.Fill
      .Visible = msoTrue
      .ForeColor.SchemeColor = ArbFarbe
      .BackColor.SchemeColor = ArbFarbe
     End With
  Case Else
    ActiveSheet.Shapes.AddTextEffect(msoTextEffect8, "keine !", "Arial Black", 8#, msoFalse, msoFalse, 38, 12).Select
  End Select
  Selection.Name = "Txt6"
  If Arbvor_ja = 0 Then Selection.ShapeRange.Fill.Visible = msoFalse
End Sub
Sub Textbox7(Stunden As Integer, Minuten As Integer, Zeit As Integer)
' Ziel: OFenzeiten anzeigen
  ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 85, 87, 40, 17).Select
  Selection.Characters.Text = Stunden & "h" & Minuten
  With Selection.Characters(Start:=1, Length:=6).Font
    .FontStyle = "Bold"
    .Size = 13
  End With
  Selection.Font.ColorIndex = 5
  Selection.HorizontalAlignment = xlRight
  Selection.ShapeRange.ZOrder msoBringToFront
 
 'Textfarbe je nach Ofenzeit anbpassen
  Select Case Zeit
    Case Is < 300: Selection.Font.ColorIndex = 5 'Blau
    Case Is > 800: Selection.Font.ColorIndex = 3 'Rot
  Case Else
    Selection.Font.ColorIndex = 10 'Grün
  End Select
  Selection.Name = "Txt7"
  Selection.ShapeRange.Fill.Visible = msoFalse
  Selection.ShapeRange.Line.Visible = msoFalse
End Sub
Sub Textbox8(Zweiw_ja As String)
' Ziel:(Z für Zweiwachshprofil einfügen)
  If Zweiw_ja = vbNullString Then Zweiw_ja = "kein" Else Zweiw_ja = "Z"
    ActiveSheet.Shapes.AddTextEffect(msoTextEffect8, Zweiw_ja, "Arial Black", 10#, msoFalse, msoFalse, 2, 36).Select
    Selection.ShapeRange.Fill.Visible = msoTrue
  With Selection.ShapeRange.Fill
    .Visible = msoTrue
    .ForeColor.SchemeColor = 51
    .BackColor.SchemeColor = 51
  End With
  Selection.Name = "Txt8"
  If Zweiw_ja = "kein" Then Selection.ShapeRange.Fill.Visible = msoFalse
End Sub
Sub Textbox9(Pgm As String, TRec As Single)
' Ziel: (Pgm) einfügen
 
'Dafür sorgen, daß Pgm dreistelllig ist
 Select Case Len(Pgm)
  Case Is = 1: Pgm = "00" & Pgm
  Case Is = 2: Pgm = "0" & Pgm
 End Select
 
 
  ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 70, 92, 40, 9).Select
  Selection.Characters.Text = Pgm & "/" & TRec
  With Selection.Characters(Start:=1, Length:=11).Font
    .FontStyle = "Bold"
    .Size = 8
    .ColorIndex = 14
  End With
  With Selection.ShapeRange.Fill
    .Visible = msoFalse
    .Solid
    .ForeColor.SchemeColor = 9
  End With
  Selection.ShapeRange.Line.Visible = msoFalse
  Selection.HorizontalAlignment = xlRight
  Selection.Name = "Txt9"
End Sub

Invité · 04/10/2014, 11h26

Bonjour,

Une piste avec ce bout de code à adapter à votre programme. Le principe est de dupliquer les objets et de grouper les copies :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Essai1()
 
Dim NbPasses As Long
Dim ShapeRecherche As Shape
 
    NbPasses = ActiveSheet.Shapes.Count
 
    For Each ShapeRecherche In ActiveSheet.Shapes
      Select Case ShapeRecherche.Name
        Case "Txt1", "Txt2" ' "Txt3",....
             ShapeRecherche.Copy
             ActiveSheet.Paste
             Selection.Name = ShapeRecherche.Name & NbPasses
      End Select
    Next ShapeRecherche
 
 
    With ActiveSheet.Shapes.Range(Array("Txt1" & NbPasses, "Txt2" & NbPasses))
            .Select
            .Group
            .Name = "PrArPgmInd" '& NbPasses
            .Top = 170
            .Left = 132
    End With
End Sub

Cordialement.

**Godzestla** · 07/10/2014, 08h52

Merci Eric,
c'est exactement vers cela que je me dirigeais.
Ca fonctionne parfaitement.

probleme avec Shaperange.Group : Erreur 1004 au deuxième passage. [XL-2010]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager