Eviter d'utiliser select
s
Bonjour,
J'ai ce code qui me permet de copier 1 image (plusieurs images groupées) dans la cellule D9
J'essaie d'utiliser dim et set ... pour éviter les select et rendre le code plus propre
J'ai cette ligne qui me dérange ou il y a 3 select:
Sh.Select: Selection.Cut: rngImageFin.Select: ws.Pictures.Paste.SelectJ'ai essayé avec cette ligne mais ca ne marche
Sh.Copy rngImageFinPourriez vous m'aider svp? est-ce possible et utile d'éviter les select ?
Voici une partie plus large du code
Dim ws As Worksheet: Set ws = Sheets("Feuil1"): Dim rngImageFin As Range: Set rngImageFin = Range("d9")
Set Sh = ws.Shapes.Range(Tableau).Group 'Regroupe les formes dont le nom se trouve dans le tableau
Sh.Select: Selection.Cut: rngImageFin.Select: ws.Pictures.Paste.Select
With Selection.ShapeRange
.Top = rngImageFin.Top + 20
.Left = rngImageFin.Left + Taille
.Line.Visible = msoTrue
.Line.ForeColor.ObjectThemeColor = msoThemeColorAccent2
.Line.ForeColor.TintAndShade = 0
.Line.ForeColor.Brightness = 0
.Line.Transparency = 0
.Line.Weight = 1.5
End WithJ'ai d'autres select dans mon code mais je pense que ces derniers ne peuvent pas être supprimés
Voici la totalité de mon code et ci-joint mon fichier
Private Sub InsereImage(Description As String, Taille As Integer)
Dim Fichier As String: Dim test1 As String: Dim i As Integer: Dim phrase As Range
Application.ScreenUpdating = True
Set phrase = Range("d2")
test1 = MajSansAccent$(Description): test1 = TexteEpure(test1): phrase = test1 'nettoie la chaine des accents et ponctuation
Mots = Split(phrase.Text, " ") 'On obtient donc n mots avec : Mots(1) = "LUCIE" , Mots(2) = "KAREN"... Donc on peux boucler :
Dim rngImageCell As Range: Set rngImageCell = Range("g7")
Dim rngImageInter As Range: Set rngImageInter = Range("g1")
Dim ws As Worksheet: Set ws = Sheets("Feuil1")
For Index = 1 To Len(phrase)
char = UCase(phrase.Characters(Index, 1).Text)
If char = "H" Then
If IsNumeric(phrase.Characters(Index - 1, 1).Text) And IsNumeric(phrase.Characters(Index - 2, 1).Text) And IsNumeric(phrase.Characters(Index + 1, 1).Text) And IsNumeric(phrase.Characters(Index + 2, 1).Text) Then
HH = phrase.Characters(Index - 2, 1).Text & phrase.Characters(Index - 1, 1).Text & char & phrase.Characters(Index + 1, 1).Text & phrase.Characters(Index + 2, 1).Text
ElseIf IsNumeric(phrase.Characters(Index - 1, 1).Text) And IsNumeric(phrase.Characters(Index + 1, 1).Text) And IsNumeric(phrase.Characters(Index + 2, 1).Text) Then
HH = phrase.Characters(Index - 1, 1).Text & char & phrase.Characters(Index + 1, 1).Text & phrase.Characters(Index + 2, 1).Text
ElseIf IsNumeric(phrase.Characters(Index - 1, 1).Text) And IsNumeric(phrase.Characters(Index - 2, 1).Text) Then
HH = phrase.Characters(Index - 2, 1).Text & phrase.Characters(Index - 1, 1).Text & char
ElseIf IsNumeric(phrase.Characters(Index - 1, 1).Text) Then
HH = phrase.Characters(Index - 1, 1).Text & char
End If
rngImageCell = HH
End If
Next Index
If HH <> "" Then 'Caractèristiques
Dim objChrt As Chart: Dim rngImage As Range: Dim strFile As String
On Error GoTo ErrExit 'Gestion erreur
With ws 'Nom de la feuille (à modifier, ici pour exemple) ou se trouve la zone de texte
Set rngImage = rngImageCell 'Choisir la cellule ou est positionnée la zone de texte selon fin de 1ière macro
rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap 'puis copie de la cellule contenant la zone de texte
strFile = "C:\Users\Sylvain Lucie\Pictures\CopieNote.jpg" 'Sous le dossier Images du disque C, Ici le dossier Images. Sinon changer par le chemin (Disque, dossier et sous-dossier) souhaité
Set objChrt = .ChartObjects.Add(rngImage.Left, rngImage.Top, rngImage.Width, rngImage.Height).Chart 'Selon taille de la zone de texte
With objChrt 'Réalise l'export avec l'objet Chart
.Parent.Activate: .ChartArea.Format.Line.Visible = msoFalse 'Ligne du cadre non visible
.Paste: .Export strFile: .Parent.Delete
End With
End With
ErrExit: 'Libère les objets
Set objChrt = Nothing: Set rngImage = Nothing
End If
rngImageInter.Select
For i = 0 To UBound(Mots)
If i <= UBound(Mots) Then ' boucle sur les mots
Fichier = Dir("C:\Users\Sylvain Lucie\Documents\images\" & Mots(i) & ".jpg") 'cherche image dans reprtoire
If Fichier <> "" Then 'si le fichier jpg existe
'rngImageInter.Select 'insertion de l'image dans la cellule "G"&b
Set MonImage = ws.Pictures.Insert("C:\Users\Sylvain Lucie\Documents\images\" & Mots(i) & ".jpg")
limage = MonImage.Width: MonImage.Left = rngImageInter.Left + l: l = l + limage: haut = MonImage.Height 'insertion image cote à cote selon la largeur de l'image précédente
'Else
' If Len(Mots(i)) > 1 Then MsgBox "Le fichier jpg de " & Mots(i) & " n'a pas été trouvé"
End If
End If
Next i
If HH <> "" Then
'rngImageInter.Select
Set MonImage = ws.Pictures.Insert("C:\Users\Sylvain Lucie\Pictures\CopieNote.jpg")
MonImage.Top = rngImageInter.Top + haut
End If
l = l + 10: B = 1
For J = 0 To UBound(Mots)
If J <= UBound(Mots) Then ' boucle sur les mots
Fichier = Dir("C:\Users\Sylvain Lucie\Documents\images2\" & Mots(J) & ".jpg") 'cherche image dans reprtoire
If Fichier <> "" Then 'si le fichier jpg existe
If B = 1 Then
'rngImageInter.Select 'insertion de l'image dans la cellule "G"&b
Set MonImage2 = ws.Pictures.Insert("C:\Users\Sylvain Lucie\Documents\images2\fl1.jpg")
limage2 = MonImage2.Width: MonImage2.Left = rngImageInter.Left + l: l = l + limage2 'insertion image cote à cote selon la largeur de l'image précédente
B = B + 1
End If
'rngImageInter.Select 'insertion de l'image dans la cellule "G"&b
Set MonImage = ws.Pictures.Insert("C:\Users\Sylvain Lucie\Documents\images2\" & Mots(J) & ".jpg")
limage = MonImage.Width: MonImage.Left = rngImageInter.Left + l: l = l + limage 'insertion image cote à cote selon la largeur de l'image précédente
'Else
' If Len(Mots(i)) > 1 Then MsgBox "Le fichier jpg de " & Mots(i) & " n'a pas été trouvé"
End If
End If
Next J
Dim xPicRg As Range: Dim k As Integer: Dim Tableau() As String: Dim xPic As Shape: Dim xRg As Range
Set xRg = Range("e1:x2") 'selection de la plage de cellules
For Each xPic In ws.Shapes 'recherche les images de la plage
Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
If Not Intersect(xRg, xPicRg) Is Nothing Then
k = k + 1: ReDim Preserve Tableau(1 To k) 'Redéfinit la taille du tableau et intègre le nom de la forme.
Tableau(k) = xPic.Name 'insére image dans le tableau
End If
Next
Dim rngImageFin As Range: Set rngImageFin = Range("d9")
If k = 0 Then Exit Sub
If k > 1 Then
Set Sh = ws.Shapes.Range(Tableau).Group 'Regroupe les formes dont le nom se trouve dans le tableau 'Sh.Name = "NomGroupe" 'Renomme le groupe. 'ActiveSheet.Shapes.Range(Array("NomGroupe")).Select
Sh.Select: Selection.Cut: rngImageFin.Select: ws.Pictures.Paste.Select
'Sh.Copy rngImageFin
With Selection.ShapeRange
.Top = rngImageFin.Top + 20
.Left = rngImageFin.Left + Taille
.Line.Visible = msoTrue
.Line.ForeColor.ObjectThemeColor = msoThemeColorAccent2
.Line.ForeColor.TintAndShade = 0
.Line.ForeColor.Brightness = 0
.Line.Transparency = 0
.Line.Weight = 1.5
End With
Else
Set Sh = ws.Shapes.Range(Tableau) 'Regroupe les formes dont le nom se trouve dans le tableau 'Sh.Name = "NomGroupe" 'Renomme le groupe. 'ActiveSheet.Shapes.Range(Array("NomGroupe")).Select
Sh.Select: Selection.Cut: rngImageFin.Select: ws.Pictures.Paste.Select
With Selection.ShapeRange
.Top = rngImageFin.Top + 20
.Left = rngImageFin.Left + Taille
.Line.Visible = msoTrue
.Line.ForeColor.ObjectThemeColor = msoThemeColorAccent2
.Line.ForeColor.TintAndShade = 0
.Line.ForeColor.Brightness = 0
.Line.Transparency = 0
.Line.Weight = 1.5
End With
End If
End Sub
Sub Ellipse1_Cliquer()
Dim T1 As Integer: T1 = 65
InsereImage Range("d1").Value, T1
End Sub
Function MajSansAccent$(ByVal Chaine$)
'Ti
Const VAccent = "àáâãäåéêëèìíîïðòóôõöùúûü", VSsAccent = "aaaaaaeeeeiiiioooooouuuu"
Dim Bcle&
For Bcle = 1 To Len(VAccent)
Chaine = Replace(Chaine, Mid(VAccent, Bcle, 1), Mid(VSsAccent, Bcle, 1))
Next Bcle
MajSansAccent = UCase(Chaine)
End Function
Function TexteEpure(Texte As String) As String
' supprime tous les caractères AUTRES
' que "a à z","A à Z" ou chiffre.
' voir aide sur ASC et table de caractères ASCII.
Dim tempmot As String, TempCar As String
For i = 1 To Len(Texte)
TempCar = Mid(Texte, i, 1)
Select Case Asc(TempCar)
Case 47 To 57 'chiffre
Case 65 To 90 'caractères A à Z
Case 97 To 122 'caractères a à z
Case Else
TempCar = " "
End Select
tempmot = tempmot + TempCar
Next i
TexteEpure = tempmot
End Function
Je vous remercie
Cordialement