Sujet Précédent Sujet Suivant

Recherche d'amélioration de code

Fermé
Matthieu - Modifié le 18 oct. 2022 à 09:05
cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 - 20 oct. 2022 à 16:09

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

A voir également:

2 réponses

Réponse 1 / 2
Matthieu
20 oct. 2022 à 09:04

J'ai vraiment besoin d'aide s'il vous plait ! 
Je suis dessus et je n'y arrive pas.
0
Réponse 2 / 2
cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
20 oct. 2022 à 11:46

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
0
Matthieu
20 oct. 2022 à 15:34

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 

0
cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728 > Matthieu
20 oct. 2022 à 16:09

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

0

Discussions similaires

[référencement] Ne pas être référencé
kij_82 -
Searaphina -

10 réponses
Code de renvoi d'appel : Ooredo, Mobilis...
midoou07 -
Camille -

13 réponses