Recherche d'amélioration de code
Bonjour,
J'ai créé un code qui crée sous Excel des QR-codes, cependant, je voudrais l'améliorer.
J'aimerais pouvoir créer 4 QR-codes d'un coup, tous dans un carré de 10X10cm de côté.
De plus, j'aimerais que le fond derrière les QR-codes soit uni et qu'il y ait des délimitations entre chaque QR-code.
Enfin, j'aimerais que la chaine de caractères entrée dans la case "A2" qui génère les QR-codes, soit affichée sous chaque QR-code.
Je vous met ci-joint le code actuel en italique pour faciliter la visibilité.
Sub Zebra()
Dim enregistrement As Range
Dim donnee As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set x = Worksheets("Qr-Code")
Set newfeuille = Worksheets("Qr-Code")
'Selectionne les données d'entrées pour les QR-codes
Worksheets("Qr-Code").Activate
I = Range("A2")
V = "%09"
L = "%0D"
'1er QR-code sur la feuille
Set cellule = newfeuille.Range("C1")
donnee = "http://api.qrserver.com/v1/create-qr-code/?data=" & I & V & L & "&size=250x250"
Set newforme = x.Shapes.AddShape(msoShapeRectangle, cellule.Left, cellule.Top, 94, 94) '94, 94 indique la taille de la forme'1 pixel = 0.0264583333 cm donc 94 pixels = 5cm)
newforme.Line.Visible = False 'enlève la ligne de contour
newforme.Fill.UserPicture (donnee) 'insère l'image dans la forme
'Affiche le nom du QR-code
I = newforme.Name
Range("J1") = I
Range("J1").Select 'Police blanche
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
End Sub
Merci d'avance et bonne journée.
Matthieu
Windows / Edge 106.0.1370.47
2 réponses
-
J'ai vraiment besoin d'aide s'il vous plait !
Je suis dessus et je n'y arrive pas. -
Contributeur
Bonjour,
essaie ceci:
Sub Zebra() Dim enregistrement As Range Dim donnee As String Application.ScreenUpdating = False Application.DisplayAlerts = False Set x = Worksheets("Qr-Code") Set newfeuille = Worksheets("Qr-Code") 'Selectionne les données d'entrées pour les QR-codes Worksheets("Qr-Code").Activate i = Range("A2") V = "%09" L = "%0D" For j = 3 To 12 Step 2 '1er QR-code sur la feuille Set cellule = newfeuille.Cells(1, j) donnee = "http://api.qrserver.com/v1/create-qr-code/?data=" & i & V & L & "&size=250x250" Set newforme = x.Shapes.AddShape(msoShapeRectangle, cellule.Left, cellule.Top, 94, 94) '94, 94 indique la taille de la forme'1 pixel = 0.0264583333 cm donc 94 pixels = 5cm) newforme.Line.Visible = False 'enlève la ligne de contour newforme.Fill.UserPicture (donnee) 'insère l'image dans la forme 'Affiche le nom du QR-code ' newforme.Name = i Cells(8, j) = Range("A2") 'newforme.Name Cells(8, j).Select 'Police noire With Selection.Font .ColorIndex = 1 'xlThemeColorDark1 .TintAndShade = 0 End With Next j End Sub
-
Bonjour, merci pour votre réponse et désolé pour le doublon, je n'avais pas vu que vous m'aviez déjà répondu.
Cependant, si j'ai ouvert une nouvelle discussion, c'était pour montrer que le code avait changé et que je recherchais pas la même chose du coup.
J'ai essayé ce code et j'avoue que cela n'a pas fonctionné cependant, étant assez mauvais en VBA, je n'ai pas vraiment compris pourquoi.
Merci d'avance pour toute autre réponse (si possible concernant le deuxième sujet de discussion).
Cordialement
-
Contributeur@Matthieu
Voilà une macro diminuée de moitié:
Sub Zebra() Dim enregistrement As Range Dim donnee As String Dim newforme As Shape Application.ScreenUpdating = False Application.DisplayAlerts = False Set x = Worksheets("Qr-Code") Set newfeuille = Worksheets("Qr-Code") 'Selectionne les données d'entrées pour les QR-codes Worksheets("Qr-Code").Activate i = Range("A2") V = "%09" L = "%0D" c = 3 For j = 1 To 2 '1er QR-code sur la feuille Set cellule = newfeuille.Cells(1, c) donnee = "http://api.qrserver.com/v1/create-qr-code/?data=" & i & V & L & "&size=250x250" Set newforme = x.Shapes.AddShape(msoShapeRectangle, cellule.Left, cellule.Top, 55, 55) newforme.Name = "QR" & j newforme.Line.Visible = False 'enlève la ligne de contour newforme.Fill.UserPicture (donnee) 'insère l'image dans la forme Cells(5, c) = i c = c + 1 Next j c = 3 For j = 1 To 2 Set cellule = newfeuille.Cells(7, c) donnee = "http://api.qrserver.com/v1/create-qr-code/?data=" & i & V & L & "&size=250x250" Set newforme = x.Shapes.AddShape(msoShapeRectangle, cellule.Left, cellule.Top, 55, 55) newforme.Name = "QR" & j + 2 newforme.Line.Visible = False 'enlève la ligne de contour newforme.Fill.UserPicture (donnee) 'insère l'image dans la forme Cells(11, c) = i c = c + 1 Next j End Sub Sub EffaceShapesSaufBoutons() For Each i In ActiveSheet.Shapes If i.Type <> 8 And i.Type <> 12 Then ActiveSheet.Shapes(i.Name).Delete End If Next i End Subj'ai ajouté l'effacement des Qrcodes:
Sub EffaceShapesSaufBoutons()
Voilà
@+ Le Pivert
-
