Création papier cadeau automatique [RESOLU]

C

christ-94

XLDnaute Occasionnel
Bonjour

Je cherche a crée mon propre papier cadeau, avec un texte en word art
avec une macro qui me fera apparaitre mon texte m'importe ou dans la feuille avec des polices de différente couleurs et différentes formes en VBA
J'ai bien réussi a crée mon premier texte , mais je n'arrive géré la police

exemple de papier

Merci de votre aide
 

Pièces jointes

  • Papier cadeau.jpg
    Papier cadeau.jpg
    72.4 KB · Affichages: 135
Dernière édition:
Trier par date Trier par votes
C

christ-94

XLDnaute Occasionnel
Re : Création papier cadeau automatique

Re-bonjour

J'ai bien reusi a faire 200 texte avec des tailles, couleur differentes mais je n'arrive pas a change la police du texte

Sub Macro7()
texte = "Christophe"
For F = 1 To 200
ActiveSheet.Select: Range("A" & F).Activate
ActiveSheet.Shapes.AddTextEffect(msoTextEffect1, texte, _
135, 10, msoTrue, msoFalse, Int((Rnd * 600) + 1), Int((Rnd * 900) + 1)).Select

'choix de la couleur
t = Int((Rnd * 10) + 1)
If t = 1 Then
Selection.Font.Color = -16777024
ElseIf t = 2 Then
Selection.Font.Color = -16776961
ElseIf t = 3 Then
Selection.Font.Color = -16727809
ElseIf t = 4 Then
Selection.Font.Color = -16711681
ElseIf t = 5 Then
Selection.Font.Color = -11480942
ElseIf t = 6 Then
Selection.Font.Color = -11489280
ElseIf t = 7 Then
Selection.Font.Color = -1003520
ElseIf t = 8 Then
Selection.Font.Color = -4165632
ElseIf t = 9 Then
Selection.Font.Color = -10477568
ElseIf t = 10 Then
Selection.Font.Color = -6279056
End If
'choix de la taille
t = Int((Rnd * 40) + 1)
If t < 10 Then
Selection.Font.Size = t + 10
ElseIf t > 10 Then
Selection.Font.Size = t
End If

'Rotation
Selection.ShapeRange.IncrementRotation Int((Rnd * 89) + 1)
Next F
End Sub
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
Pierrot93

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique

Bonjour,

un essai à adapter éventuellement à ton projet....
Code: 
Option Explicit
Sub test()
Dim t As String, i As Byte, s As Shape, p() As Variant
t = "Test"
p = Array("Arial", "Arial Black", "Courier", "Times New Roman")
Randomize
With ActiveSheet
    For i = 1 To 100
        Set s = .Shapes.AddTextEffect(msoTextEffect1, t, p(Int(4 * Rnd)), _
             Int((30 + 1) * Rnd + 10), msoTrue, msoFalse, .Range("A" & i).Left, .Range("A" & i).Top)
        With s
            .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
            .IncrementRotation Int((Rnd * 89) + 1)
        End With
    Next i
End With
End Sub

bon après midi
@+

Edition : manquait les points pour appli bloc "with"
 
Dernière édition:
Vote positif 0 Vote négatif
Pierrot93

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique

Bonjour,

une autre version qui gère le positionnement des formes sur la feuille... A adapter selon la longueur du prénom...

Code: 
Option Explicit
Sub test()
Dim t As String, i As Long, j As Long, s As Shape, p() As Variant
Application.ScreenUpdating = False
t = "Test"
p = Array("Arial", "Arial Black", "Courier New", "Times New Roman", "Comic Sans MS", "Lucida Console")
Randomize
With ActiveSheet
    With .Shapes
        If .Count > 0 Then .SelectAll: Selection.Delete
    End With
    For i = 1 To 100 Step 5
        For j = 1 To 20 Step 1
        Set s = .Shapes.AddTextEffect(msoTextEffect1, t, p(Int(6 * Rnd)), _
             Int((30 + 1) * Rnd + 10), msoTrue, msoFalse, .Cells(i, j).Left, .Cells(i, j).Top)
        With s
            .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
            .IncrementRotation Int(361 * Rnd)
        End With
        Next j
    Next i
End With
Application.ScreenUpdating = True
End Sub

bonne journée
@+
 
Vote positif 0 Vote négatif
Pierrot93

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique

Re,

un autre type de répartition...
Code: 
Option Explicit
Sub test()
Dim t As String, i As Long, j As Long, s As Shape, p() As Variant, k As Long
Application.ScreenUpdating = False
t = "Test"
p = Array("Arial", "Arial Black", "Courier New", "Times New Roman", "Comic Sans MS", "Lucida Console")
Randomize
With ActiveSheet
    With .Shapes
        If .Count > 0 Then .SelectAll: Selection.Delete
    End With
    For i = 1 To 100 Step 5
        'For j = 1 To 20 Step 1
        For j = 1 + (k Mod 2) To 20 - (k Mod 2) Step 2
        Set s = .Shapes.AddTextEffect(msoTextEffect1, t, p(Int(6 * Rnd)), _
             Int((30 + 1) * Rnd + 10), msoTrue, msoFalse, .Cells(i, j).Left, .Cells(i, j).Top)
        With s
            .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
            .IncrementRotation Int(361 * Rnd)
        End With
        Next j
        k = k + 1
    Next i
End With
Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
C

christ-94

XLDnaute Occasionnel
Re : Création papier cadeau automatique

Bonjour
Je viens de faire un test "super fonctionne parfaitement comme toujours"
Moi j'ai fait celui-ci, bien moins performent mais qui fonctionne
dans tous les cas le rendu est super

Sub Macro7()
texte = "Test"
Largeur = 900
Hauteur = 600

For F = 1 To 25
ActiveSheet.Select: Range("A" & F).Activate

'choix du type de police
t = Int((Rnd * 3) + 1)
If t = 1 Then
police = "Blackadder ITC"
ElseIf t = 2 Then
police = "Adobe Song Std L"
ElseIf t = 3 Then
police = "BankGothic Lt BT"
ElseIf t = 4 Then
police = "Verdana"
ElseIf t = 5 Then
police = "Times New Roman"
ElseIf t = 6 Then
police = "Shonar Bangla"
ElseIf t = 7 Then
police = "MS Serif"
ElseIf t = 8 Then
police = "Magneto"
ElseIf t = 9 Then
police = "Centaur"
ElseIf t = 10 Then
police = "Arial"
End If

'choix du type word
t = Int((Rnd * 10) + 1)
If t = 1 Then
ActiveSheet.Shapes.AddTextEffect(msoTextEffect1, texte, _
police, 10, msoTrue, msoFalse, Int((Rnd * Largeur) + 1), Int((Rnd * Hauteur) + 1)).Select
ElseIf t = 2 Then
ActiveSheet.Shapes.AddTextEffect(msoTextEffect3, texte, _
police, 10, msoTrue, msoFalse, Int((Rnd * Largeur) + 1), Int((Rnd * Hauteur) + 1)).Select
ElseIf t = 3 Then
ActiveSheet.Shapes.AddTextEffect(msoTextEffect5, texte, _
police, 10, msoTrue, msoFalse, Int((Rnd * Largeur) + 1), Int((Rnd * Hauteur) + 1)).Select
ElseIf t = 4 Then
ActiveSheet.Shapes.AddTextEffect(msoTextEffect6, texte, _
police, 10, msoTrue, msoFalse, Int((Rnd * Largeur) + 1), Int((Rnd * Hauteur) + 1)).Select
ElseIf t = 5 Then
ActiveSheet.Shapes.AddTextEffect(msoTextEffect11, texte, _
police, 10, msoTrue, msoFalse, Int((Rnd * Largeur) + 1), Int((Rnd * Hauteur) + 1)).Select
ElseIf t = 6 Then
ActiveSheet.Shapes.AddTextEffect(msoTextEffect14, texte, _
police, 10, msoTrue, msoFalse, Int((Rnd * Largeur) + 1), Int((Rnd * Hauteur) + 1)).Select
ElseIf t = 7 Then
ActiveSheet.Shapes.AddTextEffect(msoTextEffect19, texte, _
police, 10, msoTrue, msoFalse, Int((Rnd * Largeur) + 1), Int((Rnd * Hauteur) + 1)).Select
ElseIf t = 8 Then
ActiveSheet.Shapes.AddTextEffect(msoTextEffect30, texte, _
police, 10, msoTrue, msoFalse, Int((Rnd * Largeur) + 1), Int((Rnd * Hauteur) + 1)).Select
ElseIf t = 9 Then
ActiveSheet.Shapes.AddTextEffect(msoTextEffect25, texte, _
police, 10, msoTrue, msoFalse, Int((Rnd * Largeur) + 1), Int((Rnd * Hauteur) + 1)).Select
ElseIf t = 10 Then
ActiveSheet.Shapes.AddTextEffect(msoTextEffect17, texte, _
police, 10, msoTrue, msoFalse, Int((Rnd * Largeur) + 1), Int((Rnd * Hauteur) + 1)).Select
End If

'choix de la couleur
t = Int((Rnd * 10) + 1)
If t = 1 Then
Selection.Font.Color = -16777024
ElseIf t = 2 Then
Selection.Font.Color = -16776961
ElseIf t = 3 Then
Selection.Font.Color = -16727809
ElseIf t = 4 Then
Selection.Font.Color = -1990422
ElseIf t = 5 Then
Selection.Font.Color = -11480942
ElseIf t = 6 Then
Selection.Font.Color = -11489280
ElseIf t = 7 Then
Selection.Font.Color = -1003520
ElseIf t = 8 Then
Selection.Font.Color = -4165632
ElseIf t = 9 Then
Selection.Font.Color = -10477568
ElseIf t = 10 Then
Selection.Font.Color = -6279056
End If

'choix de la taille
t = Int((Rnd * 40) + 1)
If t < 20 Then
Selection.Font.Size = t + 15
ElseIf t > 21 Then
Selection.Font.Size = t
End If

'Rotation
Selection.ShapeRange.IncrementRotation Int((Rnd * 89) + 1)
Next F
End Sub
Cliquez pour agrandir...

Encore un grand merci a toi pour cette super MACRO
 
Vote positif 0 Vote négatif
Pierrot93

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique [RESOLU]

Re,

en variant les effets...
Code: 
Option Explicit
Sub test()
Dim t As String, i As Long, j As Long, s As Shape, p() As Variant, f() As Variant, k As Long
Application.ScreenUpdating = False
t = "Test"
p = Array("Arial", "Arial Black", "Courier New", "Times New Roman", "Comic Sans MS", "Lucida Console")
f = Array(0, 2, 4, 5, 10, 13, 16, 18, 24, 29)
Randomize
With ActiveSheet
    With .Shapes
        If .Count > 0 Then .SelectAll: Selection.Delete
    End With
    For i = 1 To 100 Step 5
        'For j = 1 To 20 Step 1
        For j = 1 + (k Mod 2) To 20 - (k Mod 2) Step 2
        Set s = .Shapes.AddTextEffect(f(Int(10 * Rnd)), t, p(Int(6 * Rnd)), _
             Int((30 + 1) * Rnd + 10), msoTrue, msoFalse, .Cells(i, j).Left, .Cells(i, j).Top)
        With s
            .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
            .IncrementRotation Int(361 * Rnd)
        End With
        Next j
        k = k + 1
    Next i
End With
Application.ScreenUpdating = True
End Sub

A noter, sont utilisées les valeurs se rapportant aux différentes constantes(exemple msoTextEffect1 = 0) ....
 
Vote positif 0 Vote négatif
Pierrot93

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique [RESOLU]

Re, bonjour Michel:)

un dernier pour la route... tirages aléatoires sur toutes les polices installées sur l'ordi et sur tous les effets disponible + texte gras et italique...
Code: 
Sub test2()
Dim t As String, i As Long, j As Long, s As Shape, p() As Variant, k As Long
Application.ScreenUpdating = False
t = "Test"
With CommandBars.FindControl(ID:=1728)
    ReDim p(.ListCount - 1)
    For i = LBound(p) To UBound(p)
        p(i) = .List(i + 1)
    Next i
End With
Randomize
With ActiveSheet
    With .Shapes
        If .Count > 0 Then .SelectAll: Selection.Delete
    End With
    For i = 1 To 100 Step 5
        'For j = 1 To 20 Step 1
        For j = 1 + (k Mod 2) To 20 - (k Mod 2) Step 2
        Set s = .Shapes.AddTextEffect(Int(29 * Rnd), t, p(Int((UBound(p) + 1) * Rnd)), _
             Int((30 + 1) * Rnd + 10), Int((0 - -1 + 1) * Rnd + -1), Int((0 - -1 + 1) * Rnd + -1), _
             .Cells(i, j).Left, .Cells(i, j).Top)
        With s
            .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
            .IncrementRotation Int(361 * Rnd)
        End With
        Next j
        k = k + 1
    Next i
End With
Application.ScreenUpdating = True
End Sub

tous les arguments sont maintenant aléatoires....
 
Vote positif 0 Vote négatif
C

christ-94

XLDnaute Occasionnel
Re : Création papier cadeau automatique [RESOLU]

Merci pour cette dernier version

par contre cette ligne
.Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
Cliquez pour agrandir...
active le contour comment le faire aleatoirement

J'ai envelloppe un cadeau avec " un CD " super resultat il faut essayer

Merci encore , mes cadeaux son super
 
Dernière édition:
Vote positif 0 Vote négatif
Pierrot93

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique [RESOLU]

Re,

peut être en modifiant cette partie comme suit, enfin si j'ai bien compris... doit dépendre de l'effet tiré aléatoirement lors de la création....
Code: 
        With s
            .Fill.Visible = Int((0 - -1 + 1) * Rnd + -1)
            .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
            .IncrementRotation Int(361 * Rnd)
        End With
 
Vote positif 0 Vote négatif
C

christ-94

XLDnaute Occasionnel
Re : Création papier cadeau automatique [RESOLU]

Merci pour cette modification
hélas cela ne n'a pas fonctionne
J'ai toujours le contour sur tous les textes je souhaite que cela soit aléatoire
en tout cas merci pour ta patience et ton travail
j'espere que ce code donnera des idées, le résultat est superbe , je me répète

Sub test2()
Dim t As String, i As Long, j As Long, s As Shape, p() As Variant, k As Long
Application.ScreenUpdating = False
t = "Test"
With CommandBars.FindControl(ID:=1728)
ReDim p(.ListCount - 1)
For i = LBound(p) To UBound(p)
p(i) = .List(i + 1)
Next i
End With
Randomize
With ActiveSheet
With .Shapes
If .Count > 0 Then .SelectAll: Selection.Delete
End With
For i = 1 To 100 Step 5
'For j = 1 To 20 Step 1
For j = 1 + (k Mod 2) To 20 - (k Mod 2) Step 2
Set s = .Shapes.AddTextEffect(Int(29 * Rnd), t, p(Int((UBound(p) + 1) * Rnd)), _
Int((30 + 1) * Rnd + 10), Int((0 - -1 + 1) * Rnd + -1), Int((0 - -1 + 1) * Rnd + -1), _
.Cells(i, j).Left, .Cells(i, j).Top)

With s
.Fill.Visible = Int((0 - -1 + 1) * Rnd + -1)
.Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
.IncrementRotation Int(361 * Rnd) End With
Next j
k = k + 1
Next i
End With
Application.ScreenUpdating = True
End Sub
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
G

Guest

Guest
Re : Création papier cadeau automatique [RESOLU]

Bonjour, Chris,
Pierrot:D:D:D
MJ:D:D:D

si je peux me permettre, proposition:
Code: 
         With s
             .Fill.Visible = Round(Rnd, 0) * -1
             If .Fill.Visible Then .Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
             .IncrementRotation Int(361 * Rnd)
         End With

[Edit]

Et en déplaçant le Randomize juste en dessous du premier For cela sera mieux réparti:

Code: 
For i = 1 To 100 Step 5
Randomize
'......


A+
 
Dernière modification par un modérateur:
Vote positif 0 Vote négatif
Pierrot93

Pierrot93

XLDnaute Barbatruc
Re : Création papier cadeau automatique [RESOLU]

Re,

si je peux me permettre, proposition:
Cliquez pour agrandir...
bien sur Hasco:):), toujours un plaisir. Bien vu le "Round", bravo:) ... Avec tes indications, cela devrait donner ceci :
Code: 
Option Explicit
Sub test()
Dim t As String, i As Long, j As Long, s As Shape, p() As Variant, k As Long
Application.ScreenUpdating = False
t = "Test"
With CommandBars.FindControl(ID:=1728)
    ReDim p(.ListCount - 1)
    For i = LBound(p) To UBound(p)
        p(i) = .List(i + 1)
    Next i
End With
With ActiveSheet
    With .Shapes
        If .Count > 0 Then .SelectAll: Selection.Delete
    End With
    For i = 1 To 100 Step 5
        Randomize
        'For j = 1 To 20 Step 1
        For j = 1 + (k Mod 2) To 20 - (k Mod 2) Step 2
            Set s = .Shapes.AddTextEffect(Int(29 * Rnd), t, p(Int((UBound(p) + 1) * Rnd)), _
                Int((30 + 1) * Rnd + 10), Round(Rnd, 0) * -1, Round(Rnd, 0) * -1, _
                .Cells(i, j).Left, .Cells(i, j).Top)
            With s
                With .Fill
                    .Visible = Round(Rnd, 0) * -1
                    If .Visible Then .ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
                End With
                .IncrementRotation Int(361 * Rnd)
            End With
        Next j
        k = k + 1
    Next i
End With
Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

Simbaa
  • Question
Microsoft 365 Création d'un fichier entier par rapport à des entrées via UserForm
Réponses
1
Affichages
364
job75
job75
D
  • Question
XL 2013 Graphique comparatif par fournisseur
Réponses
2
Affichages
2 K
Decouverte Excel
D
R
  • Question
Autres Sheets - updater les valeurs d'un formulaire
Réponses
4
Affichages
640
Raka
R
E
  • Question
Microsoft 365 Calendrier automatique personnalisé
2
Réponses
21
Affichages
4 K
Eric&
E
Nyxi
  • Question
XL 2016 Tableau de bord "Suivis des Evènements Indésirables" ?
2
Réponses
21
Affichages
8 K
ChTi160
ChTi160
N
  • Question
Commander Word à partir d'Excel
Réponses
0
Affichages
2 K
nak
N
T
  • Question
base salarié pour création de contrat
Réponses
7
Affichages
6 K
tchock
T
K
  • Question
[RESOLU] Cerveau 1 - Ordinateur 0! Tableau et tri automatique
Réponses
7
Affichages
2 K
kabol
K
S
  • Question
amélioration & création macro (tournée transport)
Réponses
10
Affichages
2 K
skun
S
S
  • Question
changment couleur selon texte automatique
Réponses
9
Affichages
2 K
silver74
S

Membres actuellement en ligne

19 membres et 298 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 231
Messages
2 086 438
Membres
103 209
dernier inscrit
MIKA33260