Recherche d'amélioration de code
cs_Le Pivert Messages postés 8437 Statut Contributeur -
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
- Recherche d'amélioration de code
- Code ascii - Guide
- Recherche automatique des chaînes ne fonctionne pas - Guide
- Code puk bloqué - Guide
- Code de déverrouillage oublié - Guide
- Code activation windows 10 - Guide
2 réponses
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
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 Sub
j'ai ajouté l'effacement des Qrcodes:
Sub EffaceShapesSaufBoutons()
Voilà
@+ Le Pivert
